No OneTemporary
Actions

Size

58 KB

Referenced Files

None

Subscribers

None

View Options

	diff --git a/BBS/vt100.tcl b/BBS/vt100.tcl
	index d6edf48..59d0cc8 100644
	--- a/BBS/vt100.tcl
	+++ b/BBS/vt100.tcl
	@@ -1,90 +1,91 @@
	#
	# VT100 server
	#

	listen [registry get bbs.vt100.port] script listen:vt100
	+set protect-telnet 0

	proc listen:vt100 {newidx} {
	putcmdlog "Serving vt100 for idx $newidx."
	listen:vt100:welcome $newidx
	control $newidx control:vt100
	}

	proc listen:vt100:welcome {idx} {
	#Menu files in 3 cols
	set txtroot [registry get bbs.vt100.txtroot]
	set files [split [glob $txtroot/*.vt]]
	set pos [strlen $txtroot]
	set cols 3
	set rows [expr [llength $files].0 / $cols]
	set rowsc [expr ceil($rows)]
	set rows [expr floor($rows)]
	for {set i 0} {$i < $rowsc} {incr i} {
	set line ""
	for {set j 0} {$j < $cols} {incr j} {
	set item [string range [lindex $files [expr int ($i + $j * $rows)]] $pos+1 end-3]
	append line [completestring $item 24]
	}
	putdcc $idx $line
	}
	putdcc $idx [string repeat _ 72]
	putdcc $idx "Text to read: "
	return 1
	}

	#Plays the relevant file to $idx, cleans and exit
	proc vt100:play {idx} {
	putcmdlog "(vt100) Playing file for idx $idx"
	global vt100
	set txtroot [registry get bbs.vt100.txtroot]

	set fd [open $txtroot/[dict get $vt100($idx) file].vt r]
	set i 0
	while {![eof $fd] && $i < 1000} {
	#Wait time: 0.0005s
	putdcc $idx [gets $fd]
	after 3
	incr i
	}
	if {$i == 5000} {
	putdcc $idx "Stop at 5000th line."
	putcmdlog "(vt100) Stopping at 5000th line for idx $idx"
	}
	close $fd
	putcmdlog "(vt100) End play file for idx $idx"

	#Cleans and exit
	unset vt100($idx)
	killdcc $idx
	}

	#Controls the telnet connection
	proc control:vt100 {idx text} {
	global vt100
	set txtroot [registry get bbs.vt100.txtroot]
	if ![info exists vt100($idx)] {
	if [file exists $txtroot/$text.vt] {
	#Reads file
	set vt100($idx) [dict create file $text]

	#Prints file
	vt100:play $idx
	} {
	putdcc $idx "Not a valid file"
	}
	} {
	switch $text {
	exit {
	putdcc $idx "Ja mata!"

	#Cleans and exit
	unset vt100($idx)
	return 1
	}
	default {
	putdcc $idx "Unknown command: $text"
	}
	}
	}
	return 0
	}
	diff --git a/Core.tcl b/Core.tcl
	index 26c246d..8faf28f 100644
	--- a/Core.tcl
	+++ b/Core.tcl
	@@ -1,417 +1,434 @@
	#
	# 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 +-<number>
	proc numberSign {number} {
	if {$number > 0} {
	return "+$number"
	} {
	return $number
	}
	}

	#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"}
	+ if {$count >= 2 \|\| $count <= -2} {return "s"}
	}

	#
	# Dictionaries
	#

	# Gets recursively a value in a dictionary
	#
	# @param $dict the dictionary (without any dots in keys)
	# @param $key the value's key; if dict are nested, succesive keys are separated by dots (e.g. change.owner.name)
	# @param $throwErrorIfKeyDoesNotExist when the key doesn't exist: if true, throws an error; otherwise, returns an empty string
	# @return the dictionary value at the specified key, or an empty string if the key doesn't exist
	proc dg {dict key {throwErrorIfKeyDoesNotExist 0}} {
	set keys [split $key .]
	if {[llength $keys] > 1} {
	# Recursive call
	# dg $dict a.b = dict get [dict get $dict a] b
	dg [dg $dict [lindex $keys 0] $throwErrorIfKeyDoesNotExist] [join [lrange $keys 1 end] .] $throwErrorIfKeyDoesNotExist
	} elseif {([llength $dict] % 2 == 0) && [dict exists $dict $key]} {
	# This is a dict and we have a key
	dict get $dict $key
	} elseif {$throwErrorIfKeyDoesNotExist > 0} {
	error "Key not found: $key"
	}
	}

	#
	# 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 {who} {
	if {$who == ""} {
	return
	} elseif {![isnumber $who]} {
	#username -> user_id
	sql "SELECT user_id FROM users WHERE username = '[sqlescape $who]'"
	} elseif {$who < 1000} {
	#idx -> user_id
	getuserid [idx2hand $who]
	} else {
	#user_id -> user_id (or "" if not existing)
	sql "SELECT user_id FROM users WHERE user_id = $who"
	}
	}

	# Gets user info
	#
	# @param who The user
	# @param what The information to get
	proc getuserinfo {who what} {
	sqlscalar "SELECT $what FROM users WHERE user_id = [getuserid $who]"
	}

	#
	# 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

	# Truncates the first word
	#
	# @param string the string to truncate
	# @return the truncated string
	proc truncate_first_word {string} {
	set pos [string first " " $string]
	if {$pos == -1} return
	string range $string $pos+1 end
	}

	+proc xmlescape {text} {
	+ #Determines if we should use <![CDATA[]]>
	+ set useCDATA 0
	+ if {[string first < $text] > -1 \|\| [string first > $text] > -1} {
	+ set useCDATA 1
	+ }
	+ #TODO: check if there is no other case for CDATA
	+ # check when to use CDATA instead < >
	+
	+ #Output
	+ set text [string map {& {&} ' {'} {"} {"}} $text]
	+ if {$useCDATA} {
	+ return "<!\[CDATA\[$text]]>"
	+ }
	+ return $text
	+}
	+
	#
	# URLs
	#

	namespace eval url {
	variable map
	variable alphanumeric a-zA-Z0-9._~-
	namespace export encode decode
	namespace ensemble create
	}
	proc url::init {} {
	variable map
	variable alphanumeric a-zA-Z0-9._~-

	for {set i 0} {$i <= 256} {incr i} {
	set c [format %c $i]
	if {![string match \[$alphanumeric\] $c]} {
	set map($c) %[format %.2x $i]
	}
	}
	# These are handled specially
	array set map { " " + \n %0d%0a }
	}
	url::init
	proc url::encode {str} {
	variable map
	variable alphanumeric

	# The spec says: "non-alphanumeric characters are replaced by '%HH'"
	# 1 leave alphanumerics characters alone
	# 2 Convert every other character to an array lookup
	# 3 Escape constructs that are "special" to the tcl parser
	# 4 "subst" the result, doing all the array substitutions

	regsub -all \[^$alphanumeric\] $str {$map(&)} str
	# This quotes cases like $map([) or $map($) => $map(\[) ...
	regsub -all {[][{})\\]\)} $str {\\&} str
	return [subst -nocommand $str]
	}

	# Decodes an URL
	#
	# @param $str The URL to decode
	# @return The decoded URL
	proc url::decode {str} {
	# rewrite "+" back to space
	# protect \ from quoting another '\'
	set str [string map [list + { } "\\" "\\\\"] $str]

	# prepare to process all %-escapes
	regsub -all -- {%([A-Fa-f0-9][A-Fa-f0-9])} $str {\\u00\1} str

	# process \u unicode mapped chars
	return [subst -novar -nocommand $str]
	}

	#
	# GUID
	#

	# Gets the MD5 of a string, and returns it following the GUID format
	#
	# @param $str The string to compute the hash
	# @return The MD5, formatted as a GUID
	proc guidmd5 {str} {
	set md5 [md5 $str]
	set output ""
	for {set i 0} {$i < 32} {incr i} {
	if {$i == 8 \|\| $i == 12 \|\| $i == 16 \|\| $i == 20} {
	append output "-"
	}
	append output [string index $md5 $i]
	}
	return $output
	}
	\ No newline at end of file
	diff --git a/Nasqueron/Bugzilla.tcl b/Nasqueron/Bugzilla.tcl
	index 4dc554f..6c405fd 100644
	--- a/Nasqueron/Bugzilla.tcl
	+++ b/Nasqueron/Bugzilla.tcl
	@@ -1,66 +1,66 @@
	# .tcl source scripts/Nasqueron/Bugzilla.tcl

	+package require XMLRPC
	package require SOAP
	package require rpcvar
	-
	package require http
	package require tls
	http::register https 443 ::tls::socket

	bind dcc - bug dcc:bug

	#
	# Bugzilla structures
	#

	namespace import -force rpcvar::typedef

	typedef {
	login string
	password string
	remember boolean
	} userLoginRequest

	#
	# Bugzilla libraries
	#

	namespace eval ::Bugzilla:: {
	proc endpoint {server} {
	return [registry get bugzilla.$server.url]/xmlrpc.cgi
	}

	proc login {server} {
	global errorInfo
	if [catch { ::Bugzilla::${server}::UserLogin [list \
	login [registry get bugzilla.$server.username] \
	password [registry get bugzilla.$server.password] \
	remember 1 \
	] } reply] {
	error [lindex [split $errorInfo \n] 0]
	}
	return $reply
	}

	proc version {server} {
	::Bugzilla::${server}::BugzillaVersion
	}
	}

	#
	# XML-RPC procedures
	#

	foreach bzServer [registry get bugzilla.servers] {
	namespace eval ::Bugzilla::${bzServer} { }
	XMLRPC::create ::Bugzilla::${bzServer}::UserLogin -name "User.login" -proxy [Bugzilla::endpoint $bzServer] -params {login userLoginRequest}
	XMLRPC::create ::Bugzilla::${bzServer}::BugzillaVersion -name "Bugzilla.version" -proxy [Bugzilla::endpoint $bzServer]
	}

	#
	# Userland
	#

	proc dcc:bug {handle idx arg} {

	}
	\ No newline at end of file
	diff --git a/Nasqueron/Bureautique.tcl b/Nasqueron/Bureautique.tcl
	index 1aca2c6..7ade1a2 100644
	--- a/Nasqueron/Bureautique.tcl
	+++ b/Nasqueron/Bureautique.tcl
	@@ -1,181 +1,199 @@
	bind dcc - antidater dcc:antidater
	bind dcc - postdater dcc:postdater
	bind dcc - days dcc:days
	bind dcc - quux dcc:quux
	+bind dcc - paypal dcc:paypal

	#
	# Dates calculation
	#

	#Removes $days from $date or if unspecified, current unixtime
	proc antidater {days {date ""}} {
	postdater [expr $days * -1] $date
	}

	#Adds $days from $date or if unspecified, current unixtime
	proc postdater {days {date ""}} {
	if {$date == ""} {
	set date [unixtime]
	}
	incr date [expr 86400 * $days]
	}

	#.antidater 15
	#.antidater 2011-01-29 4
	proc dcc:antidater {handle idx arg} {
	set argc [llength $arg]
	if {$argc == 0} {
	putdcc $idx "De combien de jours dois-je antidater ?"
	return
	}
	if {$argc == 1} {
	set date ""
	set days $arg
	} {
	if [catch {set date [clock scan [lindex $arg 0]]} err] {
	putdcc $idx $err
	return
	}
	set days [lindex $arg 1]
	}
	if ![isnumber $days] {
	putdcc $idx "$days n'est pas un nombre de jours"
	return
	}
	putdcc $idx [clock format [antidater $days $date] -format "%Y-%m-%d"]
	return 1
	}

	#.postdater 15
	#.postdater 2011-01-29 4
	proc dcc:postdater {handle idx arg} {
	set argc [llength $arg]
	if {$argc == 0} {
	putdcc $idx "De combien de jours dois-je postdater ?"
	return
	}
	if {$argc == 1} {
	set date ""
	set days $arg
	} {
	if [catch {set date [clock scan [lindex $arg 0]]} err] {
	putdcc $idx $err
	return
	}
	set days [lindex $arg 1]
	}
	if ![isnumber $days] {
	putdcc $idx "$days n'est pas un nombre de jours"
	return
	}
	putdcc $idx [clock format [postdater $days $date] -format "%Y-%m-%d"]
	return 1
	}

	namespace eval ::quux:: {
	## Adds a quux
	##
	## @param $userid The user id
	## @param $category The quux category
	## @param $content The quux content
	## @param $tags The quux tags [optional]
	proc add {userid category content {tags ""}} {
	global username
	lappend tags client:$username
	sqladd quux "user_id quux_date quux_category quux_content quux_tags" [list $userid [unixtime] $category $content $tags]
	sqllastinsertid
	}

	## Tags a quux
	##
	## @param $id The quux id
	## @param $tags The tags to add
	proc tag {id tags} {
	if {![isnumber $id]} { error "bad id \"$id\": must be integer" }
	switch [sql "SELECT LENGTH(quux_tags) FROM quux WHERE quux_id = $id"] {
	"" { error "Not existing quux: $id" }
	0 { set value '[sqlescape $tags]' }
	default { set value "CONCAT(quux_tags, ' ', '[sqlescape $tags]')" }
	}
	sql "UPDATE quux SET quux_tags = $value WHERE quux_id = $id"
	}

	## Determines if the specified user is the quux's owner
	##
	## @param $id The quux id
	## @param $userid The user id
	## @return 1 if the quux exists and added by the specified user; otherwise, 0
	proc isauthor {id userid} {
	if {![isnumber $id]} { error "bad id \"$id\": must be integer" }
	if {![isnumber $userid]} { error "bad userid \"$userid\": must be integer" }
	sql "SELECT count(*) FROM quux WHERE quux_id = $id AND user_id = $userid"
	}
	}

	proc dcc:quux {handle idx arg} {
	#.quux
	if {[llength $arg] == 0} {
	#Prints categories
	putdcc $idx [sql "SELECT DISTINCT quux_category FROM quux WHERE user_id = [getuserid $idx] AND quux_deleted = 0"]
	return 1
	}

	#.quux <command>
	set command [lindex $arg 0]
	switch $command {
	"tag" {
	#.quux tag <quux id> <tag to add>

	set id [lindex $arg 1]
	set content [string range $arg [string length $id]+5 end]

	if {![isnumber $id]} {
	putdcc $idx "Not a number."
	} elseif {![quux::isauthor $id [getuserid $idx]]} {
	putdcc $idx "Not your quux."
	} {
	quux::tag $id $content
	putcmdlog "#$handle# quux tag ..."
	}
	return 0
	}
	}

	#.quux <category>
	if {[llength $arg] == 1} {
	global username
	set category $arg
	set i 0
	set dateformat [registry get date.formats.long]
	set sql "SELECT quux_id, quux_date, quux_category, quux_content, quux_tags FROM quux WHERE user_id = [getuserid $idx] AND quux_deleted = 0"
	if { $category != "*" } { append sql " AND quux_category = '[sqlescape $category]'" }
	append sql " ORDER BY quux_date DESC LIMIT 20"
	foreach row [sql $sql] {
	foreach "id date cat content tags" $row {}
	set text "[completestringright $id 3]. "
	if { $category == "*" } { append text "$cat - " }
	append text $content

	#Tags
	set tags [string trim [string map [list "client:$username" ""] $tags]]
	if {$tags != ""} {
	append text " \00314$tags\003"
	}

	putdcc $idx $text
	incr i
	}
	if {$i == 0} {
	putdcc $idx "$arg xuuQ."
	return 0
	}
	return 1
	}

	#.quux <category> <text to add>
	set category [lindex $arg 0]
	set content [string range $arg [string length $category]+1 end]
	putdcc $idx "Published under QX[quux::add [getuserid $idx] $category $content]"
	putcmdlog "#$handle# quux ..."
	return 0
	+}
	+
	+#
	+# Paypal calculation
	+#
	+
	+namespace eval ::paypal {
	+ # -rate% - 0.35 €
	+ # Default rate: 3.4% for EU
	+ proc gross2net {net {rate 3.4}} {
	+ format %0.2f [expr ($net - 0.35) / (100 + $rate) * 100]
	+ }
	+
	+ # +rate% + 0.35 €
	+ proc net2gross {gross {rate 3.4}} {
	+ format %0.2f [expr $gross * (100 + $rate) / 100 + 0.35]
	+ }
	}
	\ No newline at end of file
	diff --git a/Nasqueron/Communication.tcl b/Nasqueron/Communication.tcl
	index f8bae03..d8e3329 100644
	--- a/Nasqueron/Communication.tcl
	+++ b/Nasqueron/Communication.tcl
	@@ -1,406 +1,413 @@
	package require http

	bind dcc - sms dcc:sms
	bind dcc - mail dcc:mail
	bind dcc - twitter dcc:twitter
	bind pub - !sms pub:sms
	bind pub - !identica pub:identica
	bind pub - !pub pub:twitter
	bind pub - !twit pub:twitter
	bind pub - !tweet pub:twitter
	bind pub - !idee pub:idee
	bind pub - !idees pub:idee
	+bind pub - !idée pub:idee

	#
	# SMS
	#

	#Sends a SMS to $to with $message as text and $from as source
	#Returns "" if SMS were sent, the error message otherwise
	proc sendsms {from to message} {
	switch [set mode [registry get sms.$to.mode]] {
	1 {
	#Triskel/Wolfplex form
	set url [registry get sms.$to.url]
	set pass [registry get sms.$to.pass]
	set xtra [registry get sms.$to.xtra]
	if {$url == ""} {return "URL inconnue pour $to"}

	#Check length
	set len [string length $from$message]
	if {$len > 113} {
	return "Message trop long, réduisez-le de [expr $len-113] caractère[s $len-113]."
	}

	#Posts form
	package require http
	set query [::http::formatQuery m $from p $message v $pass envoi Envoyer]
	if {$xtra != ""} {append query &$xtra}
	set tok [::http::geturl $url -query $query]
	set result [::http::data $tok]
	::http::cleanup $tok

	#Parses reply
	if {[string first "Impossible d'envoyer" $result] != -1} {
	return "Le formulaire web indique qu'il est immpossible d'envoyer le message."
	} elseif {[string first "Tu as subtilement" $result] != -1} {
	return "Pass incorrect : $pass, regardez sur $url si la question antibot n'a pas été modifiée."
	} elseif {[string first "envoi \[ Ok \]" $result] != -1} {
	return ""
	} {
	putdebug $result
	return "D'après la réponse du formulaire, il n'est pas possible de déterminer si oui ou non il a été envoyé."
	}
	}

	"" {
	return "$to n'a pas activé la fonction SMS."
	}

	default {
	return "Unknown sms mode: $mode."
	}
	}
	}

	#.sms
	proc dcc:sms {handle idx arg} {
	# The SMS configuration is stored in the following registry variables:
	# sms.$destinataire.mode 1 Triskel or Wolfplex form
	#
	# For mode 1:
	# sms.$destinataire.url form URL
	# sms.$destinataire.pass e.g. rose
	# sms.$destinataire.xtra not needed for triskel forms, who=Darkknow needed for Wolfplex form

	if {$arg == "" \|\| $arg == "config"} {
	#Prints config
	switch [set mode [registry get sms.$handle.mode]] {
	1 {
	putdcc $idx "URL ..... [registry get sms.$handle.url]"
	if {[set pass [registry get sms.$handle.pass]] != ""]} {
	putdcc $idx "Pass .... $pass"
	}
	if {[set xtra [registry get sms.$handle.xtra]] != ""} {
	putdcc $idx "Extra ... $xtra"
	}
	}
	"" {
	putdcc $idx "Vous n'avez pas encore configuré votre fonctionnalité SMS."
	}
	default {
	putdcc $idx "Unknown sms mode: $mode"
	}
	}
	return 1
	} elseif {[string range $arg 0 6] == "config "} {
	putdcc $idx "Le script interactif de configuration n'est pas encore prêt."
	putcmdlog "#$handle# sms config ..."
	return 0
	} else {
	#Sends a SMS
	set to [lindex $arg 0]
	#TODO: use a proc to remove the first word instead and keep $arg as string
	set message [lrange $arg 1 end]
	if {[set result [sendsms $handle $to $message]] == ""} {
	putdcc $idx "Envoyé."
	putcmdlog "#$handle# sms ..."
	} {
	putdcc $idx $result
	}
	}
	return 0
	}

	#!sms
	proc pub:sms {nick uhost handle chan text} {
	#Sends a SMS
	if {$handle == "" \|\| $handle == "*"} {
	set from $nick
	} {
	set from $handle
	}
	set to [lindex $text 0]
	#TODO: use a proc to remove the first word instead and keep $arg as string
	set message [lrange $text 1 end]
	if {[set result [sendsms $from $to $message]] == ""} {
	putquick "PRIVMSG $chan :$nick, c'est envoyé."
	putcmdlog "!$nick! sms ..."
	} {
	putquick "PRIVMSG $chan :$nick, $result."
	}
	return 0
	}

	#
	# Identi.ca and Twitter
	#

	#Posts $message on the identi.ca $account account
	proc identicapost {account message} {
	package require http
	package require base64
	set row [lindex [sql "SELECT account_username, account_password FROM identica_accounts WHERE account_code = '$account'"] 0]
	set auth "Basic [base64::encode [join $row :]]"
	set tok [::http::geturl http://identi.ca/api/statuses/update.xml -headers [list Authorization $auth] -query [::http::formatQuery status $message]]
	#putdebug [::http::data $tok]
	::http::cleanup $tok
	}

	#Posts $message on the Twitter $account account
	proc twitterpost {account message} {
	set status_url "https://api.twitter.com/1.1/statuses/update.json"
	if {[catch {twitter_query $status_url $account [list status $message]} error]} {
	putdebug "Twitter error: $error"
	return 0
	}
	return 1
	}

	#Gets the Twitter OAuth token
	proc twitter_token {account} {
	registry get twitter.oauth.tokens.$account
	}

	proc dcc:twitter {handle idx arg} {
	set command [lindex $arg 0]
	switch $command {
	"setup" {
	set account [lindex $arg 1]
	if {$account == ""} {
	putdcc $idx "What account to setup?"
	return 0
	}
	if {[twitter_token $account] != ""} {
	switch [lindex $arg 2] {
	"--force" { registry del twitter.oauth.tokens.$account }
	"" {
	putdcc $idx "There is already a token set for this account. Please use '.twitter setup $account --force' to erase it."
	return 0
	}
	}
	}
	set pin [lindex $arg 2]
	if {$pin == "" \|\| $pin == "--force"} {
	#Initializes requests
	if {[catch {oauth::get_request_token {*}[registry get twitter.oauth.consumer]} data]} {
	putdebug "Can't request OAuth token for Twitter $account account: $data"
	putdcc $idx "An error occured, I can't request an OAuth token for you account."
	return 0
	} {
	registry set twitter.oauth.tokens.$account "[dict get $data oauth_token] [dict get $data oauth_token_secret]"
	putdcc $idx "Step 1 — Go to [dict get $data auth_url]"
	putdcc $idx "Step 2 — .twitter setup $account <the PIN code>"
	return 1
	}
	} {
	#Saves token
	if {[catch {oauth::get_access_token {}[registry get twitter.oauth.consumer] {}[twitter_token $account] $pin} data]} {
	putdebug "Can't confirm OAuth token for Twitter $account account: $data"
	putdcc $idx "An error occured, I can't confirm an OAuth token for you account."
	return 0
	} {
	registry set twitter.oauth.tokens.$account "[dict get $data oauth_token] [dict get $data oauth_token_secret]"
	putdcc $idx "Ok, I've now access to account [dict get $data screen_name]."
	putcmdlog "#$handle# twitter setup $account ..."
	return 0
	}
	}
	}

	default { putdcc $idx "Unknown Twitter command: $arg"}
	}
	}

	#Sends a query
	proc twitter_query {url account {query_list {}} {method {}}} {
	# Uses POST for any query
	if {$method == ""} {
	if {$query_list == ""} {
	set method GET
	} {
	set method POST
	}
	}
	if {$method == "GET" && $query_list == ""} {
	append url ?
	append url [http::formatQuery {*}$query_list]
	}

	# Requests
	set token [twitter_token $account]
	if {$token == ""} {
	error "Unidentified Twitter account: $account"
	} {
	set reply [oauth::query_api $url {}[registry get twitter.oauth.consumer] $method {}$token $query_list]
	json::json2dict $reply
	}
	}

	#.identica
	proc dcc:identica {handle idx arg} {

	}

	#!idee
	proc pub:idee {nick uhost handle chan text} {
	+ set who [whois $nick]
	+ if {$who == ""} {
	+ append text " — via IRC."
	+ } {
	+ append text " — $who, via IRC."
	+ }
	twitterpublish ideedarticles $nick $text
	}

	#!identica
	proc pub:identica {nick uhost handle chan text} {
	putquick "NOTICE $nick :!identica is currently disabled. Is identi.ca still usable since pump.io migration? If so, please request the command."
	}

	proc whois {nickname} {
	# By handle
	set result [nick2hand $nickname]
	if {$result != "*"} {
	#Will return "", when nick doesn't exist to avoid further processing.
	return $result
	}

	#Gets user@host
	set uhost [getchanhost $nickname]
	set host [lindex [split $uhost @] 1]

	# By Cloak
	if {[regexp / $host]} {
	set cloak [split $host /]
	- set group [lindex $host 0]
	+ set group [lindex $cloak 0]

	if {$group != "gateway" && $group != "nat"} {
	# @freenode/staff/ubuntu.member.niko → niko
	# @wikipedia/pdpc.21for7.elfix → elfix
	# @wikipedia/poulpy → poulpy
	return [lindex [split [lindex $cloak end] .] end]
	}
	}

	# By NickServ
	# TODO: code with callback

	# By user@host, when the host doesn't contain any digit
	if {[regexp {^[^0-9]*$} $host]} {
	return "$nickname!$uhost"
	}

	# Can't identify
	return ""
	}

	#!pub or !twit or !tweet
	#The account is channel dependant
	proc pub:twitter {nick uhost handle chan text} {
	if {$chan == "#wikipedia-fr"} {
	set account wikipediafr
	set who [whois $nick]
	if {$who == ""} {
	putquick "NOTICE $nick :Pour utiliser !pub sur $chan, vous devez disposer d'un cloak projet ou unaffiliated, être connecté depuis un host sans chiffre ou encore avoir votre user@host reconnu par mes soins."
	return 0
	} {
	append text " —$who"
	}
	} elseif {$chan == "#wolfplex"} {
	set account wolfplex
	} {
	putquick "NOTICE $nick :!pub n'est pas activé sur le canal $chan"
	return
	}
	twitterpublish $account $nick $text
	}

	proc twitterpublish {account nick text} {
	if {$text == ""} {
	putquick "NOTICE $nick :Syntaxe : !pub <texte à publier sur identi.ca et Twitter>"
	return
	}
	set len [string length $text]
	if {$len > 140} {
	putquick "NOTICE $nick :140 caractères max, là il y en a $len."
	return
	}
	if [twitterpost $account $text] {
	putquick "NOTICE $nick :Publié sur Twitter"
	return 1
	} {
	putquick "NOTICE $nick :Non publié, une erreur a eu lieu."
	}
	}

	#
	# Mail
	#

	# .mail
	proc dcc:mail {handle idx arg} {
	global mail special
	if {$arg == ""} {
	putdcc $idx "## Syntaxe : .mail <destinataire> \[objet\]"
	return
	} elseif {[validuser [lindex $arg 0]]} {
	set mail($idx-to) [getuserinfo [lindex $arg 0] user_email]
	} elseif {[regexp {^[A-Za-z0-9._-]+@[[A-Za-z0-9.-]+$} [lindex $arg 0]]} {
	set mail($idx-to) [lindex $arg 0]
	} else {
	putdcc $idx "Destinataire invalide : [lindex $arg 0]"
	return
	}
	set mail($idx) ""
	putdcc $idx "\002Alors, que désires tu envoyer comme mail ?\002"
	putdcc $idx "Pour envoyer l'e-mail, entre une ligne ne contenant que ceci: \002+\002"
	putdcc $idx "Pour annuler l'e-mail, entre une ligne ne contenant que ceci: \002-\002"

	set mail($idx-subject) [truncate_first_word $arg]
	if {$mail($idx-subject) == ""} {
	putdcc $idx "\002Objet :\002"
	} else {
	putdcc $idx "\002Message :\002"
	}

	control $idx control:mail
	dccbroadcast "Tiens, $handle est parti rédiger un mail ..."
	}

	# Controls mail encoding processus
	proc control:mail {idx text} {
	global mail
	if {$text == "+"} {
	mail.send $mail($idx-to) $mail($idx-subject) $mail($idx) [getuserinfo $idx user_email]
	unset mail($idx)
	putdcc $idx "Envoyé :-)"
	dccbroadcast "Et, hop, un mail d'envoyé pour [idx2hand $idx] :)"
	return 1
	} elseif {$text == "-"} {
	unset mail($idx)
	dccbroadcast "[idx2hand $idx] vient de changer d'avis et revient."
	putdcc $idx "Ok, le mail a été annulé: retour au party line !"
	return 1
	} elseif {$mail($idx-subject) == ""} {
	set mail($idx-subject) $text
	putdcc $idx "\002Message :\002"
	} else {
	regsub -all {\\} $text "\\\\\\" text
	regsub -all "'" $text "\\'" text
	append mail($idx) "\n$text"
	}
	}

	# Sends a mail
	#
	# @param to The recipient
	# @param subject The mail subject
	# @param message The message to send
	# @param from The mail author (optional)
	proc mail.send {to subject message {from {}}} {
	set fd [open "\|sendmail -t" w]
	if {$from != ""} {
	puts $fd "From: $from"
	}
	puts $fd "To: $to"
	puts $fd "Subject: $subject"
	puts $fd
	puts $fd "$message"
	flush $fd
	close $fd
	}
	\ No newline at end of file
	diff --git a/Nasqueron/GIS.tcl b/Nasqueron/GIS.tcl
	index 8be7521..8541ffc 100644
	--- a/Nasqueron/GIS.tcl
	+++ b/Nasqueron/GIS.tcl
	@@ -1,67 +1,67 @@
	# Geographical data procs

	bind pub - !fantoir pub:fantoir
	bind dcc - fantoir dcc:fantoir

	namespace eval fantoir {
	#Path to the FANTOIR file
	variable file_all [registry get fantoir.files.all]

	#Path to the FANTOIR file, containing only streets
	variable file_streets [registry get fantoir.files.streets]

	# Performs a search
	#
	# @param text The text to search
	# @return the number of lines in the file matching the expression
	proc search {text} {
	variable file_all
	variable file_streets

	if {[catch {set count_all [exec -- grep -a -c "$text" $file_all]}]} {
	set count_all 0
	}
	set count_all [string trim $count_all]
	set reply "$count_all occurrence[s $count_all]"
	if {$count_all > 0} {
	if {[catch {set count_voies [exec -- grep -a -c "$text" $file_streets]}]} {
	set count_voies 0
	}
	set count_voies [string trim $count_voies]
	- append reply "(dont $count_voies voie[s $count_voies])"
	+ append reply " (dont $count_voies voie[s $count_voies])"
	} {
	return $reply
	}
	}

	# Determines if a search expression is valid
	#
	# @param $expression The expression to check
	# @return 1 if the expression is valid; otherwise, 0
	proc is_valid_search_expression {expression} {
	#TODO: allow some regexp
	expr [regexp "^\[A-Z0-9 ]*\$" $expression] && [string length $expression] < 100
	}
	}

	# Handles fantoir dcc bind
	proc dcc:fantoir {handle idx arg} {
	set text [string toupper $arg]
	if {![::fantoir::is_valid_search_expression $text]} {
	putdcc $idx "Format incorrect, !fantoir <chaîne de texte à rechercher, sans accent>"
	return 0
	}
	putdcc $idx [::fantoir::search $text]
	return 1
	}

	# Handles !fantoir pub bind
	proc pub:fantoir {nick uhost handle chan text} {
	set text [string toupper $text]
	if {![::fantoir::is_valid_search_expression $text]} {
	puthelp "NOTICE $nick :Format incorrect, !fantoir <chaîne de texte à rechercher, sans accent>"
	return 0
	}
	putserv "PRIVMSG $chan :$nick: [::fantoir::search $text]"
	return 1
	}
	diff --git a/Nasqueron/Gerrit.tcl b/Nasqueron/Gerrit.tcl
	index 87da1d8..d2637f7 100644
	--- a/Nasqueron/Gerrit.tcl
	+++ b/Nasqueron/Gerrit.tcl
	@@ -1,554 +1,586 @@
	# .tcl source scripts/Nasqueron/Gerrit.tcl

	package require json

	bind dcc - gerrit dcc:gerrit

	# Gerrit events 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_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_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 $server The 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
	}

	## Queries a Gerrit server, searching changes with an expression
	##
	## @param $server The Gerrit server
	## @param $project The project
	## @param $query The query
	proc search {server project query} {
	set query "message:$query"
	if {$project != "*" } {
	append query " project:$project"
	}
	set results ""
	putdebug $query
	foreach line [split [query $server "--format json $query"] "\n"] {
	set c [json::json2dict $line]
	if {![dict exists $c type]} {
	lappend results "\[[dg $c project]\] <[dg $c owner.name]> [dg $c subject] ([status [dg $c status]]) - [dg $c number]"
	}
	}
	return $results
	}

	# Gets the approvals for a specified change
	proc approvals {server change} {
	set change [query $server "--format JSON --all-approvals $change"]
	#We exploit here a bug: parsing stops after correct item closure, so \n new json message is ignored
	set change [json::json2dict $change]
	set lastPatchset [lindex [dg $change patchSets] end]
	dg $lastPatchset approvals
	}

	proc approvals2xml {approvals {indentLevel 0} {ignoreSubmit 1}} {
	set indent [string repeat "\t" $indentLevel]
	append xml "$indent<approvals>\n"
	foreach approval $approvals {
	set type [dg $approval type]
	if {$type == "SUBM" && $ignoreSubmit} { continue }
	append xml "$indent\t<approval type=\"$type\">
	$indent<user email=\"[dg $approval by.email]\">[dg $approval by.name]</user>
	$indent<date>[dg $approval grantedOn]</date>
	$indent<value>[numberSign [dg $approval value]]</value>
	$indent</approval>\n"
	}
	append xml "$indent</approvals>"
	}

	# Gets a string representation of the API status
	#
	# @param $status the API status string code
	# @return the textual representation of the status
	proc status {status} {
	switch $status {
	"NEW" { return "Review in progress" }
	default { return $status }
	}
	}

	## 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} {
	set idx [connect [registry get gerrit.$server.streamevents.host] [registry get gerrit.$server.streamevents.port]]
	control $idx gerrit::listen:stream_event
	}

	# Listens to a Gerrit stream event
	#
	# @param $idx The connection idx
	# @param $text The message received
	# @return 0 if we continue to control this connection; otherwise, 1
	proc listen:stream_event {idx text} {
	# To ensure a better system stability, we don't directly handle
	# a processus calling the 'ssh' command, but use a lightweight
	# non blocking socket connection:
	#
	# This script <--socket--> Node proxy <--SSH--> Gerrit server
	#
	# We receive line of texts from the proxy. There are chunks of a
	# JSON message (we convert it to a dictionary, to be used here).
	#
	# As the json objects are rather long, it is generally truncated
	# in several lines. Immediately after, a line with "--" is sent:
	#
	# 1. {"type":"comment-added","change":......................
	# 2. ................,"comment":"Dark could be the night."}
	# 3. --
	# 4. {"type":"patchset-created",...........................}
	# 5. --
	# 6. ........
	#
	# Text is stored in a global array, shared with others control
	# procs, called $buffers. The message is to add in the idx key.
	# It should be cleared after, as the idx could be reassigned.
	#
	# When a message is received, we sent the decoded json message
	# to gerrit::callevent, which has the job to fire events and
	# to call event callback procedures.

	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) ""
	set type [dict get $event type]
	#todo: handle here multiservers
	if { [catch { callevent wmreview $type $event } err] } {
	+ global errorInfo
	putdebug "A general error occured during the Gerrit event processing."
	putdebug $errorInfo
	}
	} {
	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} {
	# Gerrit events could be from two types:
	#
	# (1) Generic events
	# ------------------
	# They are created with "gerrit::event all callbackproc".
	# The callback procedure args are server, type & message.
	#
	# Every Gerrit event is sent to them.
	#
	# (2) Specific events
	# -------------------
	# Similar create way: "gerrit::event type callbackproc".
	#
	# Only Gerrit events of matching type are sent to them.
	# The callback procedure arguments varie with the type.
	#
	# patchset-created ... server change patchSet uploader
	- # change-abandoned ... server change patchSet abandoner
	+ # change-abandoned ... server change patchSet abandoner reason
	# change-restored .... server change patchSet restorer
	# change-merged ...... server change patchSet submitter
	# comment-added ...... server change patchSet author approvals comment
	# ref-updated ........ server submitter refUpdate
	#
	# The documentation of these structures can be found at this URL:
	# http://gerrit-documentation.googlecode.com/svn/Documentation/2.5.1/json.html
	#
	# The callback procedures are all stored in the global ditionary
	# $gerrit::events.
	#
	# Generic events are fired before specific ones. They can't edit
	# the message. They can't say "no more processing".
	#

	if [dict exists $gerrit::events all] {
	foreach procname [dict get $gerrit::events all] {
	if [catch {$procname $server $type $message} err] {
	putdebug "An error occured in $procname (called by a $type event):"
	+ global errorInfo
	putdebug $errorInfo
	+ putdebug $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-abandoned" { set params "change patchSet abandoner reason" }
	"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] {
	if [catch {$procname {*}$args} err] {
	+ global errorInfo
	putdebug "An error occured in $procname (called by a $type event):"
	putdebug $errorInfo
	+ putdebug $message
	}
	}
	}
	}

	# 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 topic id" {
	set $var [dg $change $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"
	#}

	# Activity feed
	set email [dict get $uploader email]
	set item " <item type=\"patchset\">
	+ <date>[unixtime]</date>
	<user email=\"$email\">$who</user>
	<project>$project</project>
	<branch>$branch</branch>
	<topic>$topic</topic>
	- <change id=\"$id\">$subject</change>
	+ <change id=\"$id\">[xmlescape $subject]</change>
	</item>"
	writeActivityFeeds $email $project $item
	}

	+ proc onChangeAbandoned {server change patchSet abandoner reason} {
	+ if {$server == "wmreview"} {
	+ foreach var "id project branch topic subject" { set $var [dg $change $var] }
	+ set itemBase "
	+ <date>[unixtime]</date>
	+ <user email=\"[dg $abandoner email]\">[dg $abandoner name]</user>
	+ <project>$project</project>
	+ <branch>$branch</branch>
	+ <topic>$topic</topic>
	+ <change id=\"$id\">[xmlescape $subject]</change>
	+ <message>$reason</message>"
	+ set item "\t<item type=\"abandon\">$itemBase\n\t</item>"
	+ set itemMerged "\t<item type=\"abandoned\">\n\t\t<owner email=\"[dg $change owner.email]\">[dg $change owner.name]</owner>$itemBase\n\t</item>"
	+
	+ set dir [registry get gerrit.feeds.path]
	+ writeActivityFeed $dir/user/[guidmd5 [dg $abandoner email]].xml $item
	+ if {[dg $change owner.email] != [dg $abandoner email]} {
	+ writeActivityFeed $dir/user/[guidmd5 [dg $change owner.email]].xml $itemMerged
	+ }
	+ writeActivityFeed $dir/project/[string map {/ . - _} $project].xml $itemMerged
	+ }
	+ }
	+
	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 id status" {
	if [dict exists $change $var] {
	set $var [dict get $change $var]
	} {
	set $var ""
	}
	}
	set CR 0
	if {$approvals != ""} {
	foreach approval $approvals {
	if {[dict get $approval type] == "CRVW"} {
	set CR [dict get $approval value]
	break
	}
	}
	}

	#Wikimedia: IRC notification, activity feed
	if {$server == "wmreview" && $who != "jenkins-bot"} {
	# English message
	set verbs {
	"\0034puts a veto on\003"
	"\0034suggests improvement on\003"
	"comments"
	"\0033approves\003"
	"\0033definitely approves\003"
	}
	set verb [lindex $verbs [expr $CR + 2]]
	regexp "\[a-z\\s\]+" $verb plainVerb
	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"

	# IRC notification
	if 0 {
	if {[string range $project 0 9] == "mediawiki/" && ($comment != "" \|\| $CR < 0)} {
	puthelp "PRIVMSG #mediawiki :$message"
	} {
	putdebug "Not on IRC -> $message"
	}
	}

	# Activity feed
	set message [string map [list $verb $plainVerb] $message]
	set email [dict get $author email]
	set item " <item type=\"comment\">
	+ <date>[unixtime]</date>
	<user email=\"$email\">$who</user>
	<project>$project</project>
	- <change id=\"$id\">$subject</change>
	- <message cr=\"$CR\">$comment</message>
	+ <change id=\"$id\">[xmlescape $subject]</change>
	+ <message cr=\"$CR\">[xmlescape $comment]</message>
	</item>"
	writeActivityFeeds $email $project $item
	}
	}

	# Called when a Gerrit change ismerged
	proc onChangeMerged {server change patchSet submitter} {
	if {$server == "wmreview" && [dg $submitter name] != "L10n-bot"} {
	foreach var "id project branch topic subject" { set $var [dg $change $var] }
	set itemBase "
	+ <date>[unixtime]</date>
	<user email=\"[dg $submitter email]\">[dg $submitter name]</user>
	<project>$project</project>
	<branch>$branch</branch>
	<topic>$topic</topic>
	- <change id=\"$id\">$subject</change>\n"
	+ <change id=\"$id\">[xmlescape $subject]</change>\n"
	set approvals [approvals $server $id]
	append itemBase [gerrit::approvals2xml $approvals 2 1]
	set item "\t<item type=\"merge\">$itemBase\n\t</item>"
	set itemMerged "\t<item type=\"merged\">\n\t\t<owner email=\"[dg $change owner.email]\">[dg $change owner.name]</owner>$itemBase\n\t</item>"

	set dir [registry get gerrit.feeds.path]
	writeActivityFeed $dir/user/[guidmd5 [dg $submitter email]].xml $item
	if {[dg $change owner.email] != [dg $submitter email]} {
	writeActivityFeed $dir/user/[guidmd5 [dg $change owner.email]].xml $itemMerged
	}
	writeActivityFeed $dir/project/[string map {/ . - _} $project].xml $itemMerged
	#TODO: OPW
	}
	}

	# Writes an activity feed item to the relevant feeds
	#
	# @param $who The user e-mail
	# @param $project The project
	# @param $item The XML item
	proc writeActivityFeeds {who project item} {
	set dir [registry get gerrit.feeds.path]
	writeActivityFeed $dir/user/[guidmd5 $who].xml $item
	writeActivityFeed $dir/project/[string map {/ . - _} $project].xml $item
	#TODO: opw feed
	}

	# Writes an activity feed item to the specifief file
	#
	# @param $file The output file
	# @param $item The XML item
	proc writeActivityFeed {file item} {
	if ![file exists $file] {
	set fd [open $file w]
	puts $fd "<items>"
	puts $fd $item
	puts $fd "</items>"
	} {
	set fd [open $file {RDWR CREAT}]
	set header [read $fd 4096]
	set startFound 0
	set pos [string first "<items" $header]
	if {$pos > -1} {
	set pos [string first ">" $header $pos]
	if {$pos > -1} {
	set startFound 1
	incr pos
	}
	}
	if $startFound {
	# Appends <item> block after <items>
	# Prepare our file in a temporary $fdtmp
	set fdtmp [file tempfile]
	seek $fd 0 start
	puts $fdtmp [read $fd $pos]
	puts -nonewline $fdtmp $item
	puts -nonewline $fdtmp [read $fd]
	flush $fdtmp
	seek $fdtmp 0 start
	seek $fd 0 start
	puts $fd [string trim [read $fdtmp]]
	close $fdtmp
	} {
	# Adds a comment at the end of the file
	seek $fd 0 end
	puts $fd "<!-- Can't find <items> / added at [unixtime]:"
	puts $fd $item
	puts $fd "-->"
	}
	}
	flush $fd
	close $fd

	}
	}

	#
	# Gerrit binds
	#

	# .gerrit query
	# .gerrit stats
	# .gerrit search <project> <query to searh in commit message>
	proc dcc:gerrit {handle idx arg} {
	set server [registry get gerrit.defaultserver]

	switch [lindex $arg 0] {
	"" {
	putdcc $idx "Usage: .gerrit <query>"
	putdcc $idx "Cmds: .gerrit stats"
	putdcc $idx "Cmds: .gerrit search <project> <query to searh in commit message>"
	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
	}

	"search" {
	set nbResults 0
	set project [lindex $arg 1]
	set query [lrange $arg 2 end]
	foreach result [gerrit::search $server $project $query] {
	putdcc $idx $result
	incr nbResults
	}
	if {$nbResults == 0} {
	putdcc $idx ":/"
	} {
	putcmdlog "#$handle# gerrit search ..."
	}
	return 0
	}

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

	#
	# Initialization code
	#

	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
	gerrit::event change-merged gerrit::onChangeMerged
	+gerrit::event change-abandoned gerrit::onChangeAbandoned
	diff --git a/Nasqueron/Last.fm.tcl b/Nasqueron/Last.fm.tcl
	new file mode 100644
	index 0000000..14237ce
	--- /dev/null
	+++ b/Nasqueron/Last.fm.tcl
	@@ -0,0 +1,68 @@
	+# .tcl source scripts/Nasqueron/Last.fm.tcl
	+
	+package require http
	+package require json
	+
	+bind dcc - lastfm dcc:lastfm
	+
	+proc dcc:lastfm {handle idx arg} {
	+ switch [set command [lindex $arg 0]] {
	+ "" {
	+ return [*dcc:help $handle $idx lastfm]
	+ }
	+
	+ "count" {
	+
	+ }
	+
	+ "top5" {
	+ set username [lindex $arg 1]
	+ if {$username == ""} { set username $handle }
	+ set i 0
	+ foreach track [lastfm::library_getTracks $username 5] {
	+ putdcc $idx "[incr i]. [dg $track artist.name] - [dg $track name] ([dg $track playcount])"
	+ }
	+ }
	+
	+ default {
	+ putdcc $idx "Unknown command: $command"
	+ return 0
	+ }
	+ }
	+}
	+
	+namespace eval ::lastfm {
	+ proc library_getTracks {username {tracks 50} {artist ""}} {
	+ set url "?method=library.gettracks&&user=[url::encode $username]&limit=$tracks"
	+ if {$artist != ""} {
	+ append url &artist=[url::encode $artist]
	+ }
	+ set result [get_json $url]
	+ dg $result tracks.track
	+ }
	+
	+ proc getTrackPlayCount {username artist track} {
	+ foreach artistTrack [library_getTracks $username 500 $artist] {
	+ if {[string tolower [dg $artistTrack name]] == [string tolower $track]} {
	+ return [dg $artistTrack playcount]
	+ }
	+ }
	+ return 0
	+ }
	+
	+ proc get_json {url} {
	+ set url [url]${url}&api_key=[key]&format=json
	+ set token [http::geturl $url]
	+ set data [http::data $token]
	+ http::cleanup $token
	+ json::json2dict $data
	+ }
	+
	+ proc key {} {
	+ registry get lastfm.api.key
	+ }
	+
	+ proc url {} {
	+ registry get lastfm.api.url
	+ }
	+}
	\ No newline at end of file
	diff --git a/Nasqueron/MediaWiki.tcl b/Nasqueron/MediaWiki.tcl
	index fc1d10d..8cb4cc1 100644
	--- a/Nasqueron/MediaWiki.tcl
	+++ b/Nasqueron/MediaWiki.tcl
	@@ -1,44 +1,66 @@
	+# .tcl source scripts/Nasqueron/MediaWiki.tcl
	#
	# MediaWiki RC
	#

	#
	# Configuration
	#
	set MediaWikiRC(source) 127.0.0.1
	-set MediaWikiRC(port) 8675
	+set MediaWikiRC(port) 8676
	set MediaWikiRC(channel) #wolfplex
	set MediaWikiRC(color) 0
	+set MediaWikiRC(warnKnownEditorsChanges) 0

	# This code implements "A simple UDP server"
	# sample from http://tcludp.sourceforge.net/
	package require udp

	+#Gets editor
	+proc get_editor {message} {
	+ set message [stripcodes abcgru $message]
	+ regexp "\\* (.?) \\" $message match0 match1
	+ if {![info exists match1]} {
	+ return ""
	+ }
	+ return $match1
	+}
	+
	+#Checks if editor is known
	+proc is_known_editor {editor} {
	+ expr {$editor == "Dereckson" \|\| $editor == "Spike"}
	+}
	+
	#Handles UDP event from $sock
	proc mediawiki_rc_udp_event_handler {sock} {
	global MediaWikiRC
	set pkt [read $sock]
	set peer [fconfigure $sock -peer]
	#Check if peer is source IP to avoid flood
	if {[string range $peer 0 [string length $MediaWikiRC(source)]-1] == $MediaWikiRC(source)} {
	- if $MediaWikiRC(color) {
	- puthelp "PRIVMSG $MediaWikiRC(channel) :$pkt"
	- } {
	- puthelp "PRIVMSG $MediaWikiRC(channel) :[stripcodes abcgru $pkt]"
	- }
	+ #putdebug "Received on udp: $pkt"
	+ #putdebug "Editor: [get_editor $pkt]"
	+ if {$MediaWikiRC(warnKnownEditorsChanges) \|\| ![is_known_editor [get_editor $pkt]]} {
	+ if $MediaWikiRC(color) {
	+ puthelp "PRIVMSG $MediaWikiRC(channel) :$pkt"
	+ } {
	+ puthelp "PRIVMSG $MediaWikiRC(channel) :[stripcodes abcgru $pkt]"
	+ }
	+ }
	} {
	putdebug "$peer: [string length $pkt] {$pkt}"
	}
	return
	}

	#Listens UDP on $port
	proc mediawiki_rc_udp_listen {port} {
	set srv [udp_open $port]
	+ putdebug "UDP connection on port $port: $srv"
	fconfigure $srv -buffering none -translation binary
	fileevent $srv readable [list ::mediawiki_rc_udp_event_handler $srv]
	#putdebug "Listening on udp port: [fconfigure $srv -myport]"
	return $srv
	}

	mediawiki_rc_udp_listen $MediaWikiRC(port)
	diff --git a/Nasqueron/Time.tcl b/Nasqueron/Time.tcl
	index 1dc8d46..ac272dd 100644
	--- a/Nasqueron/Time.tcl
	+++ b/Nasqueron/Time.tcl
	@@ -1,25 +1,31 @@
	utimer 8 onload
	bind cron - "* * * * *" cron:minute
	bind cron - "/5 * * *" cron:often
	bind cron - "0 * * * *" cron:hourly
	bind cron - "0 4 * * *" cron:daily

	proc onload {} {
	}

	#Every minute
	proc cron:minute {minute hour day month weekday} {
	}

	#Every 5 minutes
	proc cron:often {minute hour day month weekday} {
	sqlrehash
	+ regenerate_gerrit_index
	}

	#Every hour
	proc cron:hourly {minute hour day month weekday} {
	}

	#Every day, at 4am
	proc cron:daily {minute hour day month weekday} {
	}
	+
	+proc regenerate_gerrit_index {} {
	+ global env
	+ exec -- $env(HOME)/bin/update-gerrit-activity-feeds
	+}
	diff --git a/Nasqueron/Wolfplex.tcl b/Nasqueron/Wolfplex.tcl
	new file mode 100644
	index 0000000..6ad3cae
	--- /dev/null
	+++ b/Nasqueron/Wolfplex.tcl
	@@ -0,0 +1,31 @@
	+package require http
	+
	+bind pub - !open pub:open
	+bind pub - !ouvert pub:open
	+bind pub - !close pub:close
	+bind pub - !closed pub:close
	+bind pub - !ferme pub:close
	+bind pub - !fermé pub:close
	+
	+proc pub:open {nick uhost handle chan text} {
	+ setisopen yes
	+}
	+
	+proc pub:close {nick uhost handle chan text} {
	+ setisopen no
	+}
	+
	+proc setisopen {status} {
	+ package require http
	+ set query [::http::formatQuery oldid 0 wpTextbox1 $status wpSave Publier]
	+ set url "http://www.wolfplex.org/w/index.php?title=Mod%C3%A8le:IsOpen/status&action=edit"
	+ set tok [::http::geturl $url -query $query]
	+ set result [::http::data $tok]
	+ ::http::cleanup $tok
	+
	+ set fd [open debug.log w]
	+ puts $fd $result
	+ flush $fd
	+ close $fd
	+}
	+

File Metadata

Mime Type: text/x-diff
Expires: Wed, Jan 29, 05:14 (1 d, 9 h)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 2381793
Default Alt Text: (58 KB)

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions