Page MenuHomeDevCentral
Files F11724581

No OneTemporary
Actions

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 "*sql*connect*" $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 (3 h, 24 m)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
2991069
Default Alt Text
(19 KB)

Event Timeline

Nasqueron DevCentral · If it had been much bigger the moon would have had a core of ice. · Powered by Phabricator