No OneTemporary
Actions

Size

19 KB

Referenced Files

None

Subscribers

None

View Options

	diff --git a/Core.tcl b/Core.tcl
	index 3e51189..2d2a924 100644
	--- a/Core.tcl
	+++ b/Core.tcl
	@@ -1,237 +1,288 @@
	#
	# TCL helpers
	#

	#Determines if $proc exists
	proc proc_exists {proc} {
	expr {[info procs $proc] == $proc}
	}

	#
	# Trivial procs
	#

	#Determines if $v is a number
	proc isnumber {v} {
	return [expr {! [catch {expr {int($v)}}]}]
	}

	#Returns "s" if $count implies a plural
	#TODO: keep this method for French (ie NOT adjusting values for English)
	# and grab the plural proc from wiki.tcl.tk for English.
	proc s {count} {
	if {$count >= 2 \|\| $count <= 2} {return "s"}
	}

	#
	# Strings
	#

	#Completes $text by spaces or $char so the returned text length is $len
	proc completestring {text len {char " "}} {
	set curlen [string length $text]
	if {$curlen >= $len} {
	return $text
	}
	if {[string length $char] < 2} {
	append text [string repeat $char [expr $len - $curlen]]
	} {
	while {[string length $text] < $len} {
	append text $char
	}
	string range $text 0 $len+1
	}
	}

	proc completestringright {text len {char " "}} {
	set curlen [string length $text]
	if {$curlen >= $len} {
	return $text
	}
	set completedtext [string range [completestring $text $len $char] $curlen end]
	append completedtext $text
	}

	## Prepends 0s to a number
	##
	## @param $number The number to zerofill
	## @param $digits The number length
	## @return The zerofilled number
	proc zerofill {number digits} {
	format "%0${digits}d" $number
	}

	#
	# SQL
	#

	#Reconnects to the sql & sql2 server
	proc sqlrehash {} {
	global sql
	catch {
	sql disconnect
	sql2 disconnect
	}
	sql connect $sql(host) $sql(user) $sql(pass)
	sql2 connect $sql(host) $sql(user) $sql(pass)
	sql selectdb $sql(database)
	sql2 selectdb $sql(database)
	}

	#Escape a string to use as sql query parameter
	proc sqlescape {data} {
	#\ -> \\
	#' -> \'
	string map {"\\" "\\\\" "'" "\\'"} $data

	}

	#Gets the first item of the first row of a sql query (scalar results)
	proc sqlscalar {sql} {
	lindex [lindex [sql $sql] 0] 0
	}

	#Adds specified data to specified SQL table
	proc sqladd {table {data1 ""} {data2 ""}} {
	if {$data1 == ""} {
	set fields ""
	#Prints field to fill
	foreach row [sql "SHOW COLUMNS FROM $table"] {
	lappend fields [lindex $row 0]
	}
	return $fields
	}

	if {$data2 == ""} {
	set sql "INSERT INTO $table VALUES ("
	set data $data1
	} {
	set sql "INSERT INTO $table (`[join $data1 "`, `"]`) VALUES ("
	set data $data2
	}
	set first 1
	foreach value $data {
	if {$first == 1} {set first 0} {append sql ", "}
	append sql "'[sqlescape $value]'"
	}
	append sql ")"
	sql $sql
	}

	# Gets the value of the AUTOINCREMENT column for the last INSERT
	#
	# @return the last value of the primary key
	proc sqllastinsertid {} {
	sql "SELECT LAST_INSERT_ID()"
	}

	#
	# Registry
	#

	#Gets, sets, deletes or increments a registry value
	proc registry {command key {value ""}} {
	switch -- $command {
	"add" {
	sqladd registry "data value" [list $key $value]
	}

	"get" {
	sqlscalar "SELECT value FROM registry WHERE `data` = '$key'"
	}

	"set" {
	sqlreplace registry "data value" [list $key $value]
	}

	"del" {
	registry delete $key $value
	}

	"delete" {
	set sql "DELETE FROM registry WHERE `data` = '$key'"
	putdebug $sql
	sql $sql
	}

	"incr" {
	set current [registry get $key]
	if {$value == ""} {set term 1}
	if {$current == ""} {
	registry set $key $term
	} {
	registry set $key [incr current $term]
	}
	}

	default {
	error "unknown subcommand: must be add, get, set, incr or delete"
	}
	}
	}

	#
	# Users information
	#

	#Gets user_id from a username, idx or user_id
	proc getuserid {data} {
	if {$data == ""} {
	return
	} elseif {![isnumber $data]} {
	#username -> user_id
	sql "SELECT user_id FROM users WHERE username = '[sqlescape $data]'"
	} elseif {$data < 1000} {
	#idx -> user_id
	getuserid [idx2hand $data]
	} else {
	#user_id -> user_id (or "" if not existing)
	sql "SELECT user_id FROM users WHERE user_id = $data"
	}
	}

	#
	# Text parsing
	#

	proc geturls {text} {
	#Finds the first url position
	set pos -1
	foreach needle "http:// https:// www. youtu.be" {
	set pos1 [string first $needle $text]
	if {$pos1 != -1 && ($pos == -1 \|\| $pos1 < $pos)} {
	set pos $pos1
	}
	}

	#No URL found
	if {$pos == -1} {return}

	#URL found
	set pos2 [string first " " $text $pos]
	if {$pos2 == -1} {
	#Last URL to be found
	string range $text $pos end
	} {
	#Recursive call to get other URLs
	concat [string range $text $pos $pos2-1] [geturls [string range $text $pos2+1 end]]
	}
	}

	#Reads specified URL and returns content
	proc geturltext {url {trim 1}} {
	package require http
	if {[string range [string tolower $url] 0 5] == "https:"} {
	package require tls
	http::register https 443 tls::socket
	}

	set fd [http::geturl $url]
	set text [http::data $fd]
	http::cleanup $fd
	if $trim {
	string trim $text
	} {
	return $text
	}
	}
	+
	+proc numeric2ordinal {n} {
	+ switch $n {
	+ 1 { return first }
	+ 2 { return second }
	+ 3 { return third }
	+ 5 { return fifth }
	+ 8 { return eight }
	+ 9 { return ninth }
	+ #todo: ve -> f / y -> ie
	+ 12 { return twelfth }
	+ default {
	+ set ordinal "[numeric2en $n]th"
	+ set m [expr $n % 10]
	+ if {$m == 0} {
	+ return [string map "yth ieth" $ordinal]
	+ }
	+ if {$n < 20} { return $ordinal }
	+ if {$n > 100} { return "${n}th" }
	+ return "[numeric2en [expr $n - $m]]-[numeric2ordinal $m]"
	+ }
	+ }
	+}
	+
	+proc numeric2en {n {optional 0}} {
	+ #---------------- English spelling for integer numbers
	+ if {[catch {set n [expr $n]}]} {return $n}
	+ if {$optional && $n==0} {return ""}
	+ array set dic {
	+ 0 zero 1 one 2 two 3 three 4 four 5 five 6 six 7 seven
	+ 8 eight 9 nine 10 ten 11 eleven 12 twelve
	+ }
	+ if [info exists dic($n)] {return $dic($n)}
	+ foreach {value word} {1000000 million 1000 thousand 100 hundred} {
	+ if {$n>=$value} {
	+ return "[numeric2en $n/$value] $word [numeric2en $n%$value 1]"
	+ }
	+ } ;#--------------- composing between 13 and 99...
	+ if $n>=20 {
	+ set res $dic([expr $n/10])ty
	+ if $n%10 {append res -$dic([expr $n%10])}
	+ } else {
	+ set res $dic([expr $n-10])teen
	+ } ;#----------- fix over-regular compositions
	+ regsub "twoty" $res "twenty" res
	+ regsub "threet" $res "thirt" res
	+ regsub "fourty" $res "forty" res
	+ regsub "fivet" $res "fift" res
	+ regsub "eightt" $res "eight" res
	+ set res
	+} ;#RS
	\ No newline at end of file
	diff --git a/Nasqueron/Gerrit.tcl b/Nasqueron/Gerrit.tcl
	index a3ff2e3..25d980c 100644
	--- a/Nasqueron/Gerrit.tcl
	+++ b/Nasqueron/Gerrit.tcl
	@@ -1,145 +1,292 @@
	# .tcl source scripts/Nasqueron/Gerrit.tcl

	+package require json
	+
	bind dcc - gerrit dcc:gerrit

	+# Gerrit eventss are at the bottom of the file
	+
	#
	# Gerrit helper methods
	#

	namespace eval ::ssh:: {
	proc set_agent {{tryToStartAgent 1}} {
	global env
	set file $env(HOME)/bin/ssh-agent-session

	if {![file exists $file]} {
	putcmdlog "Can't find SSH agent information - $file doesn't exist."
	}

	#TCSH rules -> set through env array
	set fp [open $file]
	fconfigure $fp -buffering line
	gets $fp line
	while {$line != ""} {
	foreach "command variable value" [split $line] {}
	if {$command == "setenv"} {
	set env($variable) [string range $value 0 end-1]
	}
	gets $fp line
	}
	close $fp

	#Checks if agent exists
	- if {[string first ssh-agent [get_pid $env(SSH_AGENT_PID)]] == -1} {
	+ if {[string first ssh-agent [get_processname $env(SSH_AGENT_PID)]] == -1} {
	putcmdlog "SSH agent isn't running"
	if {$tryToStartAgent} {
	putdebug "Trying to launch SSH agent..."
	exec -- ssh-agent -c \| grep -v echo > $env(HOME)/bin/ssh-agent-session
	if {![add_key]} {
	# TODO: send a note to relevant people key should manually added
	# something like sendNoteToGroup $username T "Key sould be manually added"
	}
	set_agent 0
	}
	}
	}

	proc add_key {{key ""}} {
	if {$key == ""} { set key [registry get ssh.key] }
	if {$key != ""} {
	catch { exec -- ssh-add $key } result
	putdebug "Adding SSH key: $result"
	expr [string first "Identity added" $result] > -1
	} {
	return 0
	}

	}

	- proc get_pid {pid} {
	+ proc get_processname {pid} {
	set processes [exec ps xw]
	foreach process [split $processes \n] {
	set current_pid [lindex $process 0]
	set command [lrange $process 4 end]
	if {$pid == $current_pid} { return $command }
	}
	}

	# Gets appropriate connection parameter
	#
	# @param $server The server to connect
	# @return The server domain name, prepent by SSH options
	proc get_connection_parameter {server} {
	#TODO: return -p 29418 username@review.anothersite.com when appropriate instead to create SSH config alias
	return $server
	}
	}

	namespace eval ::gerrit:: {
	## Queries a Gerrit server
	##
	## @param $query The query to send
	## @seealso http://gerrit-documentation.googlecode.com/svn/Documentation/2.5/cmd-query.html
	proc query {server query} {
	exec -- ssh [ssh::get_connection_parameter $server] gerrit query $query
	}

	## Launches a socket to monitor Gerrit events in real time and initializes events.
	## This uses a node gateway.
	##
	## @seealso http://gerrit-documentation.googlecode.com/svn/Documentation/2.5/cmd-stream-events.html
	proc setup_stream_events {server} {
	control [connect [registry get gerrit.$server.streamevents.host] [registry get gerrit.$server.streamevents.port]] gerrit::listen:stream_event
	}

	proc listen:stream_event {idx text} {
	global buffers

	if {$text == ""} {
	putdebug "Connection to Gerrit stream-events gateway closed."
	if [info exists buffers($idx)] { unset buffers($idx) }
	} elseif {$text == "--"} {
	# Process gerrit event
	set event [json::json2dict $buffers($idx)]
	set buffers($idx) ""
	- registry incr gerrit.stats.type.[dict get $event type]
	+ set type [dict get $event type]
	+ #todo: handle here multiservers
	+ callevent wmreview $type $event
	} {
	append buffers($idx) $text
	}
	return 0
	}
	+
	+ # Registers a new event
	+ #
	+ proc event {type callback} {
	+ dict lappend gerrit::events $type $callback
	+ }
	+
	+ # Calls an event proc
	+ #
	+ # @param $type the Gerrit type
	+ # @param $message a dict representation of the JSON message sent by Gerrit
	+ proc callevent {server type message} {
	+ if [dict exists $gerrit::events all] {
	+ foreach procname [dict get $gerrit::events all] {
	+ $procname $server $type $message
	+ }
	+ }
	+
	+ if [dict exists $gerrit::events $type] {
	+ # Determines the proc arguments from the Gerrit message type
	+ switch $type {
	+ "patchset-created" { set params "change patchSet uploader" }
	+ "change-abandoned" { set params "change patchSet abandoner" }
	+ "change-restored" { set params "change patchSet restorer" }
	+ "change-merged" { set params "change patchSet submitter" }
	+ "comment-added" { set params "change patchSet author approvals comment" }
	+ "ref-updated" { set params "submitter refUpdate" }
	+
	+ default {
	+ putdebug "Unknown Gerrit type in gerrit::callevent: $type"
	+ return
	+ }
	+ }
	+
	+ # Gets the values of the proc arguments
	+ set args $server
	+ foreach param $params {
	+ if [dict exists $message $param] {
	+ lappend args [dict get $message $param]
	+ } {
	+ lappend args ""
	+ }
	+ }
	+
	+ # Calls callbacks procs
	+ foreach procname [dict get $gerrit::events $type] {
	+ $procname {*}$args
	+ }
	+ }
	+ }
	+
	+ # The events callback methods
	+ set events {}
	+
	+ # # # # # # # # # # # # # # #
	+
	+ # Handles statistics
	+ proc stats {server type message} {
	+ registry incr gerrit.stats.type.$type
	+ }
	+
	+ # Announces a call
	+ proc debug {server type message} {
	+ putdebug "$server -> $type +1"
	+ }
	+
	+ proc onNewPatchset {server change patchset uploader} {
	+ # Gets relevant variables from change, patchset & uploader
	+ set who [dict get $uploader name]
	+ foreach var "project branch topic subject url" {
	+ if [dict exists $change $var] {
	+ set $var [dict get $change $var]
	+ } {
	+ set $var ""
	+ }
	+ }
	+ set patchsetNumber [dict get $patchset number]
	+
	+ #IRC notification
	+ if {$server == "wmreview" && $who != "L10n-bot"} {
	+ set message "\[$project] $who uploaded a [numeric2ordinal $patchsetNumber] patchset to change '$subject'"
	+ if {$branch != "master"} { append message " in branch $branch" }
	+ append message " - $url"
	+ }
	+ #if {[string range $project 0 9] == "mediawiki/"} {
	+ # puthelp "PRIVMSG #mediawiki :$message"
	+ #}
	+ }
	+
	+ proc onCommentAdded {server change patchset author approvals comment} {
	+ # Gets relevant variables from change, patchset & uploader
	+ set who [dict get $author name]
	+ foreach var "project branch topic subject url" {
	+ if [dict exists $change $var] {
	+ set $var [dict get $change $var]
	+ } {
	+ set $var ""
	+ }
	+ }
	+
	+ #IRC notification
	+ if {$server == "wmreview" && $who != "jenkins-bot"} {
	+ set verbs {
	+ "\0034puts a veto on\003"
	+ "\0034suggests improvement on\003"
	+ "comments"
	+ "\0033approves\003"
	+ "\0033definitely approves\003"
	+ }
	+ set CR 0
	+ if {$approvals != ""} {
	+ foreach approval $approvals {
	+ if {[dict get $approval type] == "CRVW"} {
	+ set CR [dict get $approval value]
	+ break
	+ }
	+ }
	+ }
	+ set verb [lindex $verbs [expr $CR + 2]]
	+ set message "\[$project] $who $verb change '$subject'"
	+ if {$comment != ""} {
	+ if {[strlen $message] > 160} {
	+ append message ": '[string range $comment 0 158]...'"
	+ } {
	+ append message ": '$comment'"
	+ }
	+ }
	+ append message " - $url"
	+ if {[string range $project 0 9] == "mediawiki/" && ($comment != "" \|\| $CR < 0)} {
	+ #putdebug "OK -> $message"
	+ puthelp "PRIVMSG #mediawiki :$message"
	+ } {
	+ putdebug "Not on IRC -> $message"
	+ }
	+ }
	+ }
	}

	#
	# Gerrit binds
	#

	proc dcc:gerrit {handle idx arg} {
	switch $arg {
	"" {
	putdcc $idx "Usage: .gerrit <query>"
	putdcc $idx "Cmds: .gerrit stats"
	return 0
	}

	"stats" {
	foreach row [sql "SELECT SUBSTRING(data, 19), value FROM registry WHERE LEFT(data, 18) = 'gerrit.stats.type.'"] {
	putdcc $idx $row
	}
	return 1
	}

	default {
	# TODO: support several Gerrit servers
	set server [registry get gerrit.defaultserver]
	putdcc $idx [gerrit::query $server $arg]
	putcmdlog "#$handle# gerrit ..."
	return 0
	}
	}
	}

	#
	# Initialization code
	#

	-ssh::set_agent
	\ No newline at end of file
	+ssh::set_agent
	+
	+gerrit::event all gerrit::stats
	+gerrit::event all gerrit::debug
	+gerrit::event patchset-created gerrit::onNewPatchset
	+gerrit::event comment-added gerrit::onCommentAdded
	diff --git a/Tech.tcl b/Tech.tcl
	index ffeceb3..44888aa 100644
	--- a/Tech.tcl
	+++ b/Tech.tcl
	@@ -1,181 +1,181 @@
	unbind dcc n rehash *dcc:rehash
	bind dcc T rehash dcc:rehash
	bind dcc T s dcc:source
	unbind dcc n tcl *dcc:tcl
	bind dcc T tcl dcc:tcl

	bind dcc T sql dcc:sql
	bind dcc T sql? dcc:sql?
	bind dcc T sql! dcc:sql!
	bind dcc T sql1 dcc:sql1
	bind dcc T sql1? dcc:sql1?
	bind dcc T sql1! dcc:sql1!
	bind dcc T sqlrehash dcc:sqlrehash

	bind dcc T tcldoc dcc:tcldoc

	#
	# Helpers methods
	#

	#Logs a timestamped message to the specified file
	proc log {logfile handle message} {
	global username
	set fd [open "logs/$username/$logfile.log" a]
	puts $fd "\[[unixtime]\] <$handle> $message"
	close $fd
	}

	#Prints a message to all the techs
	-proc putdebug {{message ""}} {
	- if {$message == ""} {
	+proc putdebug {{message d41d8cd98f00b204e98}} {
	+ if {$message == "d41d8cd98f00b204e98"} {
	global errorInfo
	set message $errorInfo
	}
	foreach conn [dcclist CHAT] {
	foreach "idx handle uhost type flags idle" $conn {}
	#dccputchan 0 "(debug) $conn"
	if [matchattr $handle T] {
	putdcc $idx "\[DEBUG\] $message"
	}
	}
	}

	#
	# Tech commands
	#

	#Disconnect SQL, then rehash (to prevent sql connect fatal errors)
	proc dcc:rehash {handle idx arg} {
	catch {
	sql disconnect
	sql2 disconnect
	}
	*dcc:rehash $handle $idx $arg
	}

	#Loads a script
	proc dcc:source {handle idx arg} {
	if {$arg == ""} {
	putdcc $idx "Usage: .s <script> [script2 ...]"
	return
	}
	foreach file $arg {
	if ![sourcetry $file] {
	putdcc $idx "Can't find script $file"
	}
	}
	}

	#Tries to load a script
	proc sourcetry {file} {
	global username
	set scriptlist "$file $file.tcl scripts/$file scripts/$file.tcl scripts/$username/$file scripts/$username/$file.tcl"
	foreach script $scriptlist {
	if [file exists $script] {
	source $script
	return 1
	}
	}
	return 0
	}

	#.tcl with tech.log logging
	proc dcc:tcl {handle idx arg} {
	#Logs every .tcl commands, except sql connect
	#You should add here any line with password.
	catch {
	if ![string match "sqlconnect*" $arg] {
	log tech $handle $arg
	}
	}
	*dcc:tcl $handle $idx $arg
	}

	#
	# SQL
	#

	#Reconnects to the MySQL main server (sql and sql2)
	proc dcc:sqlrehash {handle idx arg} {
	sqlrehash
	return 1
	}

	#
	# dcc:sql1 dcc:sql1? and dcc:sql1! are the main procedures
	# They will be cloned for the 9 other connections command
	#

	#Executes a query
	proc dcc:sql1 {handle idx arg} {
	if {$arg == ""} {
	putdcc $idx "Usage: .sql1 <query>"
	return
	}

	#Executes the query and prints the query one row per line
	set t1 [clock milliseconds]
	if [catch {
	foreach row [sql1 $arg] {
	putdcc $idx $row
	}
	} err] {
	putdcc $idx $err
	}

	#Warns after a long query
	set delta_t [expr [clock milliseconds] - $t1]
	if {$delta_t > 1999} {
	putcmdlog "Fin de la requête SQL ($delta_t ms)."
	}

	#Logs the query
	log sql $handle "sql1\t$arg"
	}

	#Dumps (SELECT * FROM <table>) a table
	proc dcc:sql1! {handle idx arg} {
	if {$arg == ""} {
	putdcc $idx "Usage: .sql1! <table>"
	return
	}
	dcc:sql1 $handle $idx "SELECT * FROM $arg"
	}

	#Without parameters, list the tables (SHOW TABLES)
	#With a parameter, dump tables info (SHOW CREATE TABLE)
	proc dcc:sql1? {handle idx arg} {
	if {$arg == ""} {
	dcc:sql1 $handle $idx "SHOW TABLES"
	}
	foreach table $arg {
	dcc:sql1 $handle $idx "SHOW CREATE TABLE $table"
	}
	}

	#Clones .sql1, .sql1? and .sql1! commands into .sql, .sql? and .sql!
	proc dcc:sql {handle idx arg} [string map "sql1 sql" [info body dcc:sql1]]
	proc dcc:sql? {handle idx arg} [string map "sql1 sql" [info body dcc:sql1?]]
	proc dcc:sql! {handle idx arg} [string map "sql1 sql" [info body dcc:sql1!]]

	proc sqlreplace {table {data1 ""} {data2 ""}} [string map {"INSERT INTO" "REPLACE INTO"} [info body sqladd]]

	#Clones .sql1, .sql1? and .sql1! commands into .sql2, .sql3, ..., .sql10.
	for {set i 2} {$i < 11} {incr i} {
	bind dcc T sql$i dcc:sql$i
	bind dcc T sql$i? dcc:sql$i?
	bind dcc T sql$i! dcc:sql$i!
	proc dcc:sql$i {handle idx arg} [string map "sql1 sql$i" [info body dcc:sql1]]
	proc dcc:sql$i! {handle idx arg} [string map "sql1 sql$i" [info body dcc:sql1!]]
	proc dcc:sql$i? {handle idx arg} [string map "sql1 sql$i" [info body dcc:sql1?]]
	}

	#
	# Reference documentation
	#

	proc dcc:tcldoc {handle idx arg} {
	putdcc $idx [exec -- grep $arg doc/tcl-commands.doc]
	return 1
	}

File Metadata

Mime Type: text/x-diff
Expires: Thu, Sep 18, 16:20 (12 h, 9 m)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 2991069
Default Alt Text: (19 KB)

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions