No OneTemporary
Actions

Size

76 KB

Referenced Files

None

Subscribers

None

View Options

This document is not UTF8. It was detected as ISO-8859-1 (Latin 1) and converted to UTF8 for display.

	diff --git a/Core.tcl b/Core.tcl
	index a499e41..d9a46b2 100644
	--- a/Core.tcl
	+++ b/Core.tcl
	@@ -1,745 +1,744 @@
	package require http
	package require tls

	#
	# HTTP support
	#

	::tls::init -ssl2 false -ssl3 false -tls1 true
	::http::register https 443 ::tls::socket

	# Determines if a specified page's source code contains the specified string
	proc http_contains {pattern url} {
	try {
	set fd [::http::geturl $url -timeout 600]
	} on error {result} {
	return 0
	}

	if {[::http::status $fd] != "ok"} {
	set result 0
	} elseif {[::http::ncode $fd] != 200} {
	set result 0
	} elseif {[string first $pattern [::http::data $fd]] > -1} {
	set result 1
	} {
	set result 0
	}

	::http::cleanup $fd
	return $result
	}


	#
	# TCL helpers
	#

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


	proc is_package_present {package} {
	expr ![catch {package present $package}]
	}

	#
	# Loop constructs
	#

	# http://wiki.tcl.tk/3603
	proc do {code while cond} {
	tailcall try $code\n[list $while $cond $code]
	}

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

	proc isnotasciiutf8char {char} {
	regexp {(?x)
	[\xC0-\xDF] [\x80-\xBF] \| # Two-byte chars (\u0080-\u07FF)
	[\xE0-\xEF] [\x80-\xBF]{2} \| # Three-byte chars (\u0800-\uFFFF)
	[\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not suppoted by Tcl 8.5)
	} $char
	}

	proc isutf8char {char} {
	regexp {(?x)
	[\x00-\x7F] \| # Single-byte chars (ASCII range)
	[\xC0-\xDF] [\x80-\xBF] \| # Two-byte chars (\u0080-\u07FF)
	[\xE0-\xEF] [\x80-\xBF]{2} \| # Three-byte chars (\u0800-\uFFFF)
	[\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not suppoted by Tcl 8.5)
	} $char
	}

	#
	# 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
	+ 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" {
	sql "DELETE FROM registry WHERE `data` = '$key'"
	}

	"incr" {
	if {$value == ""} {
	set term 1
	} elseif {[string is integer $value]} {
	set term $value
	} {
	error "The increment term must be an integer."
	}

	set current [registry get $key]
	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}} {
	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
	}

	#
	# Run interactive commands with callbacks
	#

	# Uses fileevent example code by Bryan Oakley
	# http://stackoverflow.com/a/172061/1930997
	#
	# e.g. proc put_command_callback {fd line state} { put[lindex $state 0] [lindex $state 1] $line }
	#
	# run_command "pwd" put_command_callback "" {dcc 12}
	# run_command "pwd" put_command_callback "" {quick "#foo"}
	#
	# (we provide a more generic print_command_callback procedure for this general use.)

	# Callback to print non interactive commands output in partyline, debug, channel or query
	#
	# @param $fd File descriptor of the command (not used)
	# @param $line Line printed by the command result
	# @param $state A list of two items, the first the mode, the second the target
	#
	# Accepted modes and matched target descriptions:
	# - bot: target is another linked bot. A third optional state parameter could be the bot command.
	# - quick/serv/help: target is a channel or a nick (through a private message)
	# - notice: target is a nick (through a notice, sent in the putserv queue)
	# - dcc: target is the dcc connection IDX
	# - debug: prints the line as debug, target is ignored
	proc print_command_callback {fd line state} {
	foreach "mode target" $state {}
	switch $mode {
	bot {
	if {[llength $state] > 2} {
	set cmd [lindex $state 2]
	putbot $target $cmd $line
	} {
	putbot $target $line
	}
	}
	dcc { putdcc $target $line }
	quick { putquick "PRIVMSG $target :$line" }
	serv { putserv "PRIVMSG $target :$line" }
	help { puthelp "PRIVMSG $target :$line" }
	notice { putserv "NOTICE $target :$line" }
	debug { putdebug $line }
	default { putdebug "Unknown message mode: $mode (line were $line)" }
	}
	}

	# Same to print a Python error without the traceback
	proc print_python_error_callback {fd output state} {
	print_command_callback $fd [extractPythonError $output] $state
	}

	# Runs a command, opens a file descriptor to communicate with the process
	#
	# @param $cmd the command to run
	# @param $callbackProc a callback proc to handle the command output and send input
	# @param $errorCallbackProc a callback proc to handle the command error output
	# @param $state a state object to send to the callback proc
	proc run_command {cmd callbackProc {errorCallbackProc ""} state} {
	set fd [open "\| $cmd" r]
	fconfigure $fd -blocking false
	fileevent $fd readable [list interactive_command_handler $fd $callbackProc $errorCallbackProc $state]
	}

	# Closes a command
	#
	# @param $fd File descriptor to the command process
	proc close_interactive_command {fd {errorCallbackProc ""} {state ""}} {
	fconfigure $fd -blocking true
	if {[catch {close $fd} err]} {
	if {$errorCallbackProc == ""} {
	putdebug $err
	} {
	$errorCallbackProc $fd $err $state
	}
	}
	}

	# Callback for fileevent to handle command output and state
	#
	# @param $fd File descriptor to the command process
	# @param $callbackProc a callback proc to handle the command output and send input
	# @param $state a state object to send to the callback proc
	proc interactive_command_handler {fd callbackProc errorCallbackProc {state ""}} {
	set status [catch {gets $fd line} result]
	if { $status != 0 } {
	# unexpected error
	putdebug "Unexpected error running command: "
	putdebug $result
	close_interactive_command $fd $errorCallbackProc $state
	} elseif {$result >= 0} {
	$callbackProc $fd $line $state
	} elseif {[eof $fd]} {
	close_interactive_command $fd $errorCallbackProc $state
	} elseif {[fblocked $f]} {
	# Read blocked, so do nothing
	}
	}

	proc posix_escape {name} {
	foreach char [split $name {}] {
	switch -regexp $char {
	{'} {append escaped \\' }
	{[[:alnum:]]} {append escaped $char }
	{[[:space:]]} {append escaped \\$char }
	{[[:punct:]]} {append escaped \\$char }
	default {append escaped '$char' }
	}
	}
	return $escaped
	}

	# Returns absolute path to external script
	proc get_external_script {script} {
	global env
	set path $env(HOME)/bin/
	append path $script
	}

	# Extracts the error from Python
	proc extractPythonError {exception} {
	# The exception is one of the line of the text (so the newline-sensitive matching)
	# Before that, we have the full traceback we want to ignore
	# e.g. of a line to match: pywikibot.data.api.APIError: modification-failed: Item â¦
	if {[regexp -line {^([A-Za-z\.]+)\: (.*)$} $exception line type message]} {
	return $line
	} {
	putdebug "Regexp doesn't match a Python error for this output in extractPythonError:"
	putdebug $exception
	}
	}

	#
	# IP and host string manipulations
	#

	# Gets the host part of a [nick!]user@host string
	proc gethost {uhost} {
	set pos [string first @ $uhost]
	if {$pos == -1} {
	return ""
	}
	string range $uhost [expr $pos + 1] end
	}

	# Determines if the specified string is a valid IPv4 address
	proc isipv4 {string} {
	# http://wiki.tcl.tk/989 - Michael A. Cleverly
	set octet {(?:\d\|[1-9]\d\|1\d\d\|2[0-4]\d\|25[0-5])}
	regexp -- "^[join [list $octet $octet $octet $octet] {\.}]\$" $string

	}

	# Determines if the specified string is a valid IPv6 address
	proc isipv6 {string} {
	#
	# NOTE: 2001:0db8:0000:0000:0000:0000:1428:57ab
	# 2001:0db8:0000:0000:0000::1428:57ab
	# 2001:0db8:0:0:0:0:1428:57ab
	# 2001:0db8:0:0::1428:57ab
	# 2001:0db8::1428:57ab
	# 2001:db8::1428:57ab
	# 2001:0db8:0000:0000:0000:0000:<IPv4>
	# ::1
	# ::
	#
	if {$string eq "::"} then {
	return true
	}

	if {[string range $string 0 1] == "::"} then {
	set string [string range $string 1 end]
	}

	if {[string range $string end-1 end] == "::"} then {
	set string [string range $string 0 end-1]
	}

	set octets [split $string :]
	set llength [llength $octets]

	if {$llength > 0 && $llength <= 8} then {
	set last [expr {$llength - 1}]

	for {set index 0} {$index < $llength} {incr index} {
	set octet [lindex $octets $index]
	set length [string length $octet]

	if {$length == 0} then {
	if {![info exists null]} then {
	set null $index; continue
	} else {
	return false
	}
	}

	if {$length <= 4 && [string is xdigit -strict $octet]} then {
	continue
	}

	if {$llength <= 7 && $index == $last && [isipv4 $octet]} then {
	continue
	}

	return false
	}

	return true
	}

	return false
	}

	# Determines if the specified string is a valid IP address
	proc isip {string} {
	expr [isipv4 $string] \|\| [isipv6 $string]
	}

	###
	###Â IP helper procedures
	###

	# Extracts an IP address from a Freenode cloak
	# Freenode tends to add IPs as suffix for gateway cloaks.
	proc extract_addr_from_cloak {host} {
	if {[string first gateway/web/cgi-irc/kiwiirc.com/ip. $host] == 0} {
	return [string range $host 35 end]
	}

	# Finds an IPv4
	# Regexp from http://www.jamesoff.net/site/projects/eggdrop-scripts/proxycheck
	if {[regexp {[0-9]{1,3}.[0-9]{1,3}.[0-9]{1,3}.[0-9]{1,3}$} $host ip]} {
	return $ip
	}

	return ""
	}

	# Extracts an IP or hostname from an IRC host
	#Â If the host is a cloak not parseable, returns "".
	proc extract_addr {host} {
	if {[string first / $host] > -1} {
	return [extract_addr_from_cloak $host]
	}

	return $host
	}
	diff --git a/Daeghrefn/Gerrit.tcl b/Daeghrefn/Gerrit.tcl
	index ab8da69..5ace703 100644
	--- a/Daeghrefn/Gerrit.tcl
	+++ b/Daeghrefn/Gerrit.tcl
	@@ -1,586 +1,586 @@
	# .tcl source scripts/Daeghrefn/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 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 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\">[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\">[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\">[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/Daeghrefn/Last.fm.tcl b/Daeghrefn/Last.fm.tcl
	index e35e235..df43084 100644
	--- a/Daeghrefn/Last.fm.tcl
	+++ b/Daeghrefn/Last.fm.tcl
	@@ -1,67 +1,67 @@
	# .tcl source scripts/Daeghrefn/Last.fm.tcl

	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/Daeghrefn/Wikimedia.tcl b/Daeghrefn/Wikimedia.tcl
	index 662b391..7817dfe 100644
	--- a/Daeghrefn/Wikimedia.tcl
	+++ b/Daeghrefn/Wikimedia.tcl
	@@ -1,247 +1,247 @@
	bind pub - .config pub:config
	bind dcc - config dcc:config
	bind pub - .+surname pub:surname
	bind dcc D +surname dcc:surname
	bind pub - .+nom pub:surname
	bind dcc D +nom dcc:surname
	bind pub - .+prenom pub:givenname
	bind dcc D +prenom dcc:givenname
	bind pub - .+prÃ©nom pub:givenname
	bind dcc D +prÃ©nom dcc:givenname
	bind pub - .+givenname pub:givenname
	bind dcc D +givenname dcc:givenname

	#
	# Wikidata
	#

	# Determines if the Wikidata channel is Wikidata specific
	# Wikidata channels allow commands for everyone, not only for D users.
	proc isWikidataChannel {chan} {
	expr [lsearch [registry get wikidata.channels] $chan] != -1
	}

	# Determines if the specified handle on the specified channel
	#Â is allowed to run a Wikidata comamnd.
	proc areWikidataCommandsAllowed {chan handle} {
	if {[matchattr $handle D]} {
	return 1
	}

	isWikidataChannel $chan
	}

	# Handles .+surname command
	proc pub:surname {nick uhost handle chan arg} {
	if {![areWikidataCommandsAllowed $chan $handle]} {
	return 0
	}

	if {[isAcceptableItemTitle $arg]} {
	create_surname $arg "serv $chan"
	return 1
	} {
	putserv "PRIVMSG $chan :$nick : ne sont gÃ©rÃ©s comme que les caractÃ¨res alphanumÃ©riques, le tiret, l'apostrophe droite, de mÃªme que tout ce qui n'est pas ASCII standard."
	}
	return 0
	}

	# Handles .+surname command
	proc dcc:surname {handle idx arg} {
	if {[isAcceptableItemTitle $arg]} {
	create_surname $arg "dcc $idx"
	return 1
	} {
	putdcc $idx "crÃ©e cet item manuellement, je ne suis pas conÃ§u pour gÃ©rer ces caractÃ¨res dans le titre."
	}
	return 0
	}

	# Creates a surname
	#Â @param $title the item title
	# @param $state the state to pass to the create command callback (here with a mode and a target to print result)
	proc create_surname {title state} {
	run_command "[get_external_script create_surname] [posix_escape $title]" print_command_callback print_python_error_callback $state
	}

	# Handles .+givenname command
	proc pub:givenname {nick uhost handle chan arg} {
	if {![areWikidataCommandsAllowed $chan $handle]} {
	return 0
	}

	set params [split $arg]
	if {[llength $params] == 0} {
	putdcc $idx "Quel prÃ©nom ajouter ? e.g. .+prenom Aude F"
	return 0
	} elseif {[llength $params] > 1} {
	set title [lindex $params 0]
	set genre [string toupper [lindex $params 1]]
	switch -- $genre {
	M {}
	F {}
	D {}
	U {}
	E {set genre U}
	default {
	puthelp "PRIVMSG $chan :Attendu : F (fÃ©minin), M (masculin), U (Ã©picÃ¨ne) â e.g. .+prenom Aude F"
	return 0
	}
	}
	} {
	set title $arg
	set genre D
	}
	if {[isAcceptableItemTitle $title]} {
	create_givenname $title $genre "serv $chan"
	return 1
	} {
	puthelp "PRIVMSG $chan :$nick : crÃ©e cet item manuellement, je ne suis pas conÃ§u pour gÃ©rer ces caractÃ¨res dans le titre."
	}

	}

	# Handles .+givenname command
	proc dcc:givenname {handle idx arg} {
	set params [split $arg]
	if {[llength $params] == 0} {
	putdcc $idx "Quel prÃ©nom ajouter ? e.g. .+prenom Aude F"
	return 0
	} elseif {[llength $params] > 1} {
	set title [lindex $params 0]
	set genre [string toupper [lindex $params 1]]
	switch -- $genre {
	M {}
	F {}
	D {}
	U {}
	E {set genre U}
	default {
	putdcc $idx "Attendu : F (fÃ©minin), M (masculin), U (Ã©picÃ¨ne) â e.g. .+prenom Aude F"
	return 0
	}
	}
	} {
	set title $arg
	set genre D
	}
	if {[isAcceptableItemTitle $title]} {
	create_givenname $title $genre "dcc $idx"
	return 1
	} {
	putdcc $idx "crÃ©e cet item manuellement, je ne suis pas conÃ§u pour gÃ©rer ces caractÃ¨res dans le titre."
	}
	}

	# Creates a given name
	#Â @param $title the item title
	# @param $state the state to pass to the create command callback (here with a mode and a target to print result)
	proc create_givenname {title genre state} {
	run_command "[get_external_script create_given_name] [posix_escape $title] $genre" print_command_callback print_python_error_callback $state
	}

	# Determines if the specified title is suitable to pass as shell argument
	#Â @param $title The title to check
	#Â @return 0 is the title is acceptable; otherwise, false.
	proc isAcceptableItemTitle {title} {
	set re {[A-Za-z \-']}
	foreach char [split $title {}] {
	set value [scan $char %c]
	if {$value < 128} {
	#ASCII
	if {![regexp $re $char]} { return 0 }
	}
	#UTF-8 ok
	- }
	+ }
	return 1
	}


	#
	# Wikimedia configuration files
	#

	# Handles .config pub command
	proc pub:config {nick uhost handle chan arg} {
	if {[llength $arg] < 2} {
	puthelp "NOTICE $nick :Usage: .config <setting> <project>"
	return 0
	}
	putserv "PRIVMSG $chan :[wikimedia::get_config_variable [lindex $arg 0] [lindex $arg 1] [lrange $arg 2 end]]"
	return 1
	}

	# Handles .config dcc command
	proc dcc:config {handle idx arg} {
	if {[llength $arg] < 2} {
	putdcc $idx "Usage: .config <setting> <project>"
	return 0
	}
	putdcc $idx [wikimedia::get_config_variable [lindex $arg 0] [lindex $arg 1] [lrange $arg 2 end]]
	return 1
	}

	namespace eval ::wikimedia {
	# Script to get a configuration variable
	set get_config_script {
	<?php
	error_reporting(0);
	require_once('%%dir%%/wmf-config/InitialiseSettings.php');
	$value = $wgConf->settings%%key%%;
	if (is_array($value)) {
	$values = array();
	if (array_keys($value) !== range(0, count($value) - 1)) {
	//Associative arary
	foreach ($value as $k => $v) {
	$values[] = "$k => $v";
	}
	echo implode(' / ', $values);
	} else {
	//Numeric array
	echo implode(', ', $value);
	}
	} else if (is_bool($value)) {
	echo $value ? 'true' : 'false';
	} else {
	echo $value;
	}
	?>
	}

	# Gets a configuration variable, defined in $wgConf aray
	#
	# @param $setting the config variable's name
	# @param $project the project
	# @param $args If the config variable is an array, the keys to get (facultative, specify how many you want)
	# @return the config value
	proc get_config_variable {setting project args} {
	if {[string index $setting 0] == "\$"} {
	set setting [string rang $setting 1 end]
	}
	if {![regexp "^\[a-z]\[A-Za-z0-9]*$" $setting]} {
	return "Not a valid setting: $setting"
	}
	-
	+
	if {![regexp "^\[a-z]\[a-z0-9_]*$" $project]} {
	return "Not a valid project: $project"
	}
	set key "\['$setting']\['$project']"
	foreach arg $args {
	if {$arg == ""} break
	if {![regexp "^\[A-Za-z0-9]*$" $arg]} {
	return "Not a valid setting: $arg"
	}
	append key "\['$arg']"
	}
	set code [string map [list %%key%% $key %%dir%% [registry get repositories.operations.mediawiki-config]] $wikimedia::get_config_script]
	exec_php $code
	}

	# Executes inline PHP code
	#
	# @param code The PHP code to execute
	# @return the script stdout
	proc exec_php {code} {
	string trim [exec -- echo $code \| php]
	}
	}
	diff --git a/Daeghrefn/Wolfplex.tcl b/Daeghrefn/Wolfplex.tcl
	index 01993cd..8ad7917 100644
	--- a/Daeghrefn/Wolfplex.tcl
	+++ b/Daeghrefn/Wolfplex.tcl
	@@ -1,28 +1,27 @@
	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} {
	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
	}
	-
	diff --git a/TC2/Server.tcl b/TC2/Server.tcl
	index 61ee1b3..1e47b3b 100644
	--- a/TC2/Server.tcl
	+++ b/TC2/Server.tcl
	@@ -1,810 +1,810 @@
	# ===============================================
	-# ========= ==== ====== ============
	-# ============ ====== === === = ==========
	-# ============ ===== ======== === =========
	-# ============ ===== ============= ==========
	-# ============ ===== ============ ===========
	-# == DcK ===== ===== =========== ============
	-# ============ ===== ========== =============
	-# ============ ====== === === ==============
	-# ============ ======= === ==========
	+# ========= ==== ====== ============
	+# ============ ====== === === = ==========
	+# ============ ===== ======== === =========
	+# ============ ===== ============= ==========
	+# ============ ===== ============ ===========
	+# == DcK ===== ===== =========== ============
	+# ============ ===== ========== =============
	+# ============ ====== === === ==============
	+# ============ ======= === ==========
	# ===============================================
	# ===============================================
	# == Tau Ceti Central == Server administration ==
	# == This is a very dangerous product to use ==
	# == Don't deploy it in stable environment ==
	-# == Or say goodbye to the serv security ==
	-# == This warning will not be repeated ==
	-# == All your base are belong to us! ==
	+# == Or say goodbye to the serv security ==
	+# == This warning will not be repeated ==
	+# == All your base are belong to us! ==
	# ===============================================
	# ===============================================
	#
	-# (c) 2011 SÃ©bastien Santoro aka Dereckson.
	+# (c) 2001 SÃ©bastien Santoro aka Dereckson.
	# Released under BSD license.

	bind bot - tc2 bot:tc2

	#
	# Eggdrop events
	#

	#Handles tc2 requests from linked bots
	proc bot:tc2 {sourcebot command text} {
	#Sourcebot: Nasqueron
	#Command: tc2
	- #Text: requester Dereckson command phpfpm arg status
	+ #Text: requester Dereckson command phpfpm arg status
	set requester [dict get $text requester]
	set cmd [dict get $text command]
	set arg [dict get $text arg]
	set bind [dict get $text bind]
	set who [dict get $text who]

	#Logs entry
	log tc2 "$requester@$sourcebot" "$cmd $arg"

	#Executes command
	if [proc_exists tc2:command:$cmd] {
	putcmdlog "(tc2) <$requester@$sourcebot> $cmd $arg"
	set reply [tc2:command:$cmd $requester $arg]
	} {
	set reply "0 {Unknown command: $cmd}"
	}

	#Reports result
	putbot $sourcebot "tc2 [dict create success [lindex $reply 0] reply [lindex $reply 1] bind $bind who $who]"
	return 1
	}

	#
	# Helper procs
	#

	#Checks if $username begins by a letter and contains only letters, digits, -, _ or .
	proc tc2:username_isvalid {username} {
	regexp {^[A-Za-z][A-Za-z0-9_\-\.]*$} $username
	}

	#Determines if $username exists on the system
	#SECURITY: to avoid shell injection, call first tc2:username_isvalid $username
	proc tc2:username_exists {username} {
	#TODO: Windows and other OSes (this line has been tested under FreeBSD)
	if {[exec -- logins -oxl $username] == ""} {
	- return 0
	+ return 0
	} {
	- return 1
	+ return 1
	}
	}

	#Gets server hostname
	proc tc2:hostname {} {
	exec hostname -s
	}

	#Determines if $username is root
	proc tc2:isroot {username} {
	#Validates input data
	set username [string tolower $username]
	if ![tc2:username_isvalid $username] {
	return 0
	}

	#Check 1 - User has local accreditation
	if ![sql "SELECT count(*) FROM tc2_roots WHERE account_username = '$username' AND server_name = '[sqlescape [tc2:hostname]]'"] {
	return 0
	}

	#Check 2 - User is in the group wheel on the server
	if {[lsearch [exec -- id -Gn $username] wheel] == "-1"} {
	return 0
	} {
	return 1
	}
	}

	#Determines if $requester is EXPLICITELY allowed to allowed to manage the account $user
	#When you invoke this proc, you should also check if the user is root.
	# e.g. if {[tc2:isroot $requester] \|\| [tc2:userallow $requester $user]} { ... }
	proc tc2:userallow {requester user} {
	set sql "SELECT count(*) FROM tc2_users_permissions WHERE server_name = '[sqlescape [tc2:hostname]]' AND account_username = '[sqlescape $user]' AND user_id = [getuserid $user]"
	putdebug $sql
	sql $sql
	}

	#tc2:getpermissions on $username: Gets permissions on the $username account
	#tc2:getpermissions from $username: Gets permissions $username have on server accounts
	proc tc2:getpermissions {keyword username} {
	switch $keyword {
	"from" {
	set sql "SELECT account_username FROM tc2_users_permissions WHERE server_name = '[sqlescape [tc2:hostname]]' AND user_id = '[getuserid $username]'"
	}
	"on" {
	set sql "SELECT u.username FROM tc2_users_permissions p, users u WHERE p.server_name = '[sqlescape [tc2:hostname]]' AND p.account_username = '$username' AND u.user_id = p.user_id"
	}
	default {
	error "from or on expected"
	}
	}
	set accounts ""
	foreach row [sql $sql] {
	lappend accounts [lindex $row 0]
	}
	}

	-#Creates an account $username froÃm the $specified group
	+#Creates an account $username from the $specified group
	proc tc2:createaccount {username group} {
	if {$group == "web"} {
	set key "tc2.[tc2:hostname].wwwroot"
	if {[set wwwroot [registry get $key]] == ""} {
	error "You must define the registry key $key"
	}
	set homedir $wwwroot/$username
	if [catch {
	set reply [exec -- pw user add $username -g $group -b $wwwroot -w random]
	exec -- mkdir -p -m 0711 $homedir
	exec -- chown -R $username:web $homedir
	} err] {
	append reply " / "
	append reply $err
	}
	return $reply
	} {
	exec -- pw user add $username -g $group -m -w random
	}
	}

	#Checks if $username begins by a letter and contains only letters, digits, -, _ or .
	proc tc2:isdomain {domain} {
	regexp "^\[a-z0-9A-Z\]\[a-z0-9A-Z\\-.\]*\[a-z0-9A-Z\]$" $domain
	}

	proc tc2:cutdomain {domain} {
	#a.b.hostname a.b hostname
	#a.tld a.tld
	#a.b.tld a b.tld
	set items [split $domain .]
	if {[llength $items] < 3} {
	list "" $domain
	} elseif {[llength $items] == 3} {
	list [lindex $items 0] [join [lrange $items 1 end] .]
	} {
	set hostname [exec hostname -f]
	set k [expr [llength $hostname] + 1]
	if {[lrange $items end-$k end] == [split $hostname .]} {
	list [join [lrange $items 0 $k] .] $hostname
	} {
	list [join [lrange $items 0 end-2] .] [join [lrange $items end-1 end] .]
	}
	}
	}

	#Determines if $username is a valid MySQL user
	proc tc2:mysql_user_exists {username} {
	sql7 "SELECT count(*) FROM mysql.user WHERE user = '[sqlescape $username]'"
	}

	#Gets the host matching the first $username MySQL user
	proc tc2:mysql_get_host {username} {
	sql7 "SELECT host FROM mysql.user WHERE user = '[sqlescape $username]' LIMIT 1"
	}

	#Gets a temporary password
	proc tc2:randpass {} {
	encrypt [rand 99999999] [rand 99999999]
	}

	#Adds the SSH key $key to the $username account
	proc tc2:sshaddkey {username key} {
	set sshdir "/home/$username/.ssh"
	set keysfile "$sshdir/authorized_keys"
	if ![file exists $sshdir] {
	exec -- mkdir -p -m 0700 $sshdir
	exec chown $username $sshdir
	}
	if ![file isdirectory $sshdir] {
	return 0
	}
	set fd [open $keysfile a]
	puts $fd $key
	close $fd
	exec chmod 600 $keysfile
	exec chown $username $keysfile
	return 1
	}

	#Guesses web user from requester or domain
	proc tc2:guesswebuser {requester domain} {
	set alphanumdomain [regsub -all {([^[:alnum:]])} [string range $domain 0 [string last . $domain]-1] ""]
	foreach candidate [list $domain [string tolower $domain] $alphanumdomain $requester [string tolower $requester]] {
	if {[tc2:username_isvalid $candidate] && [tc2:username_exists $candidate]} {
	return $candidate
	}
	}
	registry get tc2.[tc2:hostname].nginx.defaultuser
	}

	#
	# tc2 commands
	#

	#account permission
	#account isroot
	#account exists
	#account create <username> <group> [SSH public key url]
	proc tc2:command:account {requester arg} {
	set command [lindex $arg 0]
	switch -- $command {
	"exists" {
	set username [lindex $arg 1]
	if ![tc2:username_isvalid $username] {
	return {0 "this is not a valid username"}
	}
	if [tc2:username_exists $username] {
	list 1 "$username is a valid account on [tc2:hostname]."
	} {
	list 1 "$username isn't a valid account on [tc2:hostname]."
	}
	}

	"isroot" {
	set username [lindex $arg 1]
	if ![tc2:username_isvalid $username] {
	return {0 "this is not a valid username"}
	}
	if [tc2:isroot $username] {
	list 1 "$username has got root accreditation on [tc2:hostname]."
	} {
	list 1 "$username doesn't seem to have any root accreditation [tc2:hostname]."
	}
	}

	"permission" {
	set username [lindex $arg 1]
	if ![tc2:username_isvalid $username] {
	return {0 "this is not a valid username"}
	}

	switch -- [lindex $arg 2] {
	"" {
	set sentences {}
	set accounts_from [tc2:getpermissions from $username]
	set accounts_on [tc2:getpermissions on $username]
	if {$accounts_on != ""} {
	lappend sentences "has authority upon [join $accounts_on ", "]"
	}
	if {$accounts_from != ""} {
	lappend sentences "account can be managed from IRC by [join $accounts_from ", "]"
	}
	if {[tc2:isroot $username]} {
	lappend sentences "has root access"
	}
	if {$sentences == ""} {
	list 1 nada
	} {
	list 1 "$username [join $sentences " / "]."
	}
	}

	"add" {
	#e.g. .account permission espacewin add dereckson
	# will give access to the espacewin account to dereckson
	if {![tc2:isroot $requester] && ![tc2:userallow $requester $username]} {
	return "0 {you don't have the authority to give access to $username account.}"
	}

	#Asserts mandataire has an account
	set mandataire [lindex $arg 3]
	if {[set mandataire_user_id [getuserid $mandataire]] == ""} {
	return "0 {please create first a bot account for $mandataire.}"
	}

	#Adds the permission
	sqlreplace tc2_users_permissions "server_name account_username user_id" [list [tc2:hostname] $username $mandataire_user_id]

	return "1 {$mandataire has now access to $username account.}"
	}

	"del" {
	#e.g. .account permission espacewin del dereckson
	# will remove access to the espacewin account to dereckson
	if {![tc2:isroot $requester] && ![tc2:userallow $requester $username]} {
	return "0 {you don't have the authority to manage the $username account.}"
	}

	#Asserts mandataire is a valid bot account
	set mandataire [lindex $arg 3]
	if {[set mandataire_user_id [getuserid $mandataire]] == ""} {
	return "0 {$mandataire doesn't have a bot account, and so, no such permission.}"
	}

	#Checks if the permission exists
	if ![tc2:userallow $requester $mandataire] {
	return "0 {$mandataire haven't had an access to $username account.}"
	}

	#Removess the permission
	sql "DELETE FROM tc2_users_permissions WHERE server_name = '[sqlescape [tc2:hostname]]' AND account_username = '$username' AND user_id = '$mandataire_user_id'"

	return "1 {$mandataire doesn't have access to $username account anymore.}"
	}

	"+root" {
	#Checks right and need
	if ![tc2:isroot $requester] {
	return "0 {you don't have root authority yourself.}"
	}
	if [tc2:isroot $username] {
	return "0 {$username have already root authority.}"
	}

	#Declares him as root
	sqlreplace tc2_roots "server_name account_username user_id" [list [tc2:hostname] $username [getuserid $username]]

	#Checks if our intervention is enough
	if [tc2:isroot $username] {
	list 1 "$username have now root authority."
	} {
	list 1 "$username have been added as root and will have root authority once in the wheel group."
	}
	}

	"-root" {
	if ![tc2:isroot $requester] {
	return {0 "you don't have root authority yourself."}
	}
	if ![tc2:isroot $username] {
	list 0 "$username doesn't have root authority."
	} {
	#Removes entry from db
	sql "DELETE FROM tc2_roots WHERE server_name = '[sqlescape [tc2:hostname]]' AND account_username = '[sqlescape $username]'"

	#Checks if our intervention is enough
	list 1 "$username doesn't have root authority on IRC anymore. Check also the wheel group."
	}
	}

	default {
	list 0 "expected: add <username>, del <username>, +root, -root, or nothing"
	}
	}
	}

	"groups" {
	set username [lindex $arg 1]
	if ![tc2:username_isvalid $username] {
	return {0 "this is not a valid username"}
	}
	if [tc2:username_exists $username] {
	list 1 [exec -- id -Gn $username]
	} {
	list 0 "$username isn't a valid account on [tc2:hostname]."
	}
	}

	"create" {
	#Checks access and need
	set username [lindex $arg 1]
	if ![tc2:username_isvalid $username] {
	return {0 "this is not a valid username"}
	}
	if [tc2:username_exists $username] {
	return "0 {there is already a $username account}"
	}
	if ![tc2:isroot $requester] {
	return "0 {you don't have root authority, which is required to create an account.}"
	}

	#Checks group
	set group [lindex $arg 2]
	set validgroups [registry get tc2.[tc2:hostname].usergroups]
	if {$group == ""} {
	return "0 {In which group? Must be amongst $validgroups.}"
	}
	if {[lsearch $validgroups $group] == -1} {
	return "0 {$group isn't a valid group, must be among $validgroups}"
	}

	#Checks public key URL. If so, creates user with SSH key and random password.
	if {[set url [geturls [lindex $arg 3]]] != ""} {
	set password [tc2:createaccount $username $group]
	set keyAdded 0
	if {[catch {
	set key [geturltext $url]
	if {$key != ""} {
	set keyAdded [tc2:sshaddkey $username $key]
	}
	}]} {
	putdebug "An error occured adding the SSH key."
	set keyAdded 0
	}
	if {$keyAdded} {
	return [list 1 "account created"]
	} {
	return [list 1 "account created but can't install SSH key ; you can use the password $password"]
	}
	}

	#Creates user without SSH key.
	list 1 [tc2:createaccount $username $group]
	}

	"" {
	return {0 "permission, isroot, exists or groups expected"}
	}

	default {
	set reply 0
	lappend reply "unknown command: $command"
	}
	}
	}

	#.mysql create database [username]
	proc tc2:command:mysql {requester arg} {
	switch -- [set command [lindex $arg 0]] {
	"create" {
	set database [lindex $arg 1]
	set username [lindex $arg 2]
	if ![tc2:username_isvalid $database] {
	list 0 "Invalid database name: $database"
	} elseif [file exists [registry get tc2.[tc2:hostname].mysql.datadir]/$database] {
	list 1 "database $database already exists"
	} elseif {$username == ""} {
	if {[tc2:mysql_user_exists $database]} {
	tc2:command:mysql $requester [list create $database $database]
	} {
	#Ok, create the database and a new user with same login than db and random password
	set password [tc2:randpass]
	if [catch {
	sql7 "CREATE DATABASE $database"
	sql7 "GRANT ALL PRIVILEGES ON $database.* TO '$database'@'localhost' IDENTIFIED BY '$password'"
	} err] {
	list 0 $err
	} {
	list 1 "database created, with rights granted to user $database, with $password as temporary password"
	}
	}
	} {
	if {![tc2:username_isvalid $username]} {
	list 0 "Invalid username: $username"
	}
	if {[tc2:isroot $requester] \|\| [tc2:userallow $requester $username]} {
	if [catch {
	set host [tc2:mysql_get_host $username]
	sql7 "CREATE DATABASE $database"
	sql7 "GRANT ALL PRIVILEGES ON $database.* TO '$username'@'$host'"
	} err] {
	list 0 $err
	} {
	list 1 "database $database created, with rights granted to $username@$host"
	}
	} {
	[list 0 "You aren't root nor have authority on $username"
	}
	}
	}

	default {
	list 0 "try .mysql create <database> \[username\]"
	}
	}
	}

	#.nginx reload
	#.nginx status
	#.nginx server add <domain> [directory] [+php \| +upstream <keyword> <url>] [+ssl]
	#TODO .nginx server edit <domain> <new directory>
	#TODO .nginx server edit <domain> <-php\|+php>
	#TODO .nginx server edit <domain> <-ssl\|+ssl>
	proc tc2:command:nginx {requester arg} {
	switch -- [set command [lindex $arg 0]] {
	"reload" {
	if [catch {exec /usr/local/etc/rc.d/nginx reload} output] {
	if {[string first "is successful" $output] == -1} {
	return [list 0 $output]
	} {
	return {1 "ok, nginx reloaded"}
	}
	} {
	return {1 "ok, nginx reloaded"}
	}
	}

	"status" {
	set conn [exec sockstat \| grep nginx \| grep -c tcp]
	if {$conn == 0} {
	return {1 "nginx not running"}
	} {
	return "1 {$conn connection[s $conn]}"
	}
	return $reply
	}

	"create" {
	tc2:command:nginx $requester [list server add {*}[lrange $arg 1 end]]
	}

	"server" {
	#.nginx server add <domain> [directory] [+php] [+upstream <url>] [+ssl]
	#.nginx server edit <domain> <+php\|-php>
	set subcommand [lindex $arg 1]
	set domain [lindex $arg 2]
	-
	+
	if {$subcommand != "" && $domain != "" && [tc2:isdomain $domain]} {
	set fulldomain $domain
	foreach "subdomain domain" [tc2:cutdomain $fulldomain] {}
	set tpldir [registry get tc2.[tc2:hostname].nginx.tpldir]
	set config [registry get tc2.[tc2:hostname].nginx.etcdir]/$domain.conf
	switch $subcommand {
	add {
	#Default options
	global username
	set wwwdir [registry get tc2.[tc2:hostname].wwwroot]/$domain/$subdomain
	set logdir [registry get tc2.[tc2:hostname].nginx.logdir]/$domain
	set ssldir [registry get tc2.[tc2:hostname].nginx.ssldir]/$domain
	set user [tc2:guesswebuser $requester $domain]
	set tpl vhost.tpl
	set php 0
	set ssl 0
	set upstream 0
	set upstream_keyword ""
	set upstream_url ""
	set index "index.html index.htm default.html default.htm"
	set phpfpmport ""

	#Parses options
	for {set i 3} {$i < [llength $arg]} {incr i} {
	set option [lindex $arg $i]
	if {$option == "+php"} {
	set php 1
	set index "index.html index.php index.htm"

	#Determines php-fpm port
	set phpfpmport [sqlscalar "SELECT pool_port FROM tc2_phpfpm_pools WHERE pool_user = '[sqlescape $user]'"]
	if {$phpfpmport == ""} {
	#Fallbacks to default www pool
	set port [registry get tc2.[tc2:hostname].phpfpm.defaultport]
	if {$phpfpmport == ""} {
	return "0 {no pool for $user, and tc2.[tc2:hostname].phpfpm.defaultport registry key isn't defined to fallback to www pool}"
	}
	}
	} elseif {$option == "+upstream"} {
	set upstream 1
	set upstream_keyword [lindex $arg [incr i]]
	set upstream_url [lindex $arg [incr i]]
	} elseif {$option == "+ssl"} {
	set ssl 1
	} elseif {[string index $option 0] == "/"} {
	set wwwdir $option
	} else {
	return [list 0 "Unknown option: $option"]
	}
	}

	#TODO: check if $user is legitimate
	if {$user != "www" && ![tc2:isroot $requester] && ![tc2:userallow $requester $user]} {
	return "0 {you don't have the authority to create a website linked to $user account.}"
	}

	#Creates needed directories
	if ![file exists $wwwdir] {
	exec -- mkdir -m 0711 -p $wwwdir
	exec -- chown $user $wwwdir
	}
	if ![file exists $logdir] {
	exec -- mkdir -m 0711 -p $wwwdir
	exec -- chown $user $wwwdir
	}

	#Prepares new config block
	set fd [open $tpldir/$tpl r]
	set template [read $fd]
	close $fd
	set xtra ""
	foreach option "ssl php upstream" {
	if $$option {
	set xtrafile $tpldir/extra-$option.tpl
	if ![file exists $xtrafile] {
	return [list 0 "Template file not found: $xtrafile"]
	}
	set fd [open $xtrafile]
	append xtra "\n\n"
	append xtra [read $fd]
	close $fd
	}
	}
	set configblock [string map [list %EXTRACONFIG% $xtra] $template]
	set configblock [string map [list %REQUESTER% $requester %TIME% [unixtime] %COMMENT% "Autogenerated by $username" %FULLDOMAIN% $fulldomain %LOGDIR% $logdir %SSLDIR% $ssldir %SUBDOMAIN% $subdomain %WWWDIR% $wwwdir %PHPFPMPORT% $phpfpmport %CUSTOM-PREPHP% "" %CUSTOM-PHP% "" %CUSTOM% "" %UPSTREAMKEYWORD% $upstream_keyword %UPSTREAMURL% $upstream_url %INDEX% $index %EXTRACONFIG% $xtra] $configblock]

	#Opens or creates domain config file
	if [file exists $config] {
	set fd [open $config a]
	} {
	#We use a also template for ou config file header
	set fd [open $tpldir/vhost-header.tpl r]
	set template [read $fd]
	close $fd
	set fd [open $config w]
	puts $fd [string map "%DOMAIN% $domain" $template]
	flush $fd
	}

	#Writes new config block
	puts $fd ""
	puts $fd $configblock
	close $fd
	return [list 1 "done, $fulldomain server block added to $config ; use .nginx reload to save"]
	}

	edit {
	return [list 1 "not yet implemented, edit the file $config"]
	}
	}
	}
	return {0 "usage: .nginx server add/edit domain \[options\]"}
	}

	"" {
	return {0 "server add, server edit, status or reload expected"}
	}

	default {
	set reply 0
	lappend reply "unknown command: $command"
	}
	}

	}

	#phpfpm reload
	#phpfpm status
	#phpfpm create <user>
	proc tc2:command:phpfpm {requester arg} {
	set command [lindex $arg 0]

	switch $command {
	"reload" {
	if [catch {exec /usr/local/etc/rc.d/php-fpm reload} output] {
	list 0 [string map {"\n" " "} $output]
	} {
	return {1 "ok, php-fpm reloaded"}
	}
	}

	"restart" {
	if [catch {exec /usr/local/etc/rc.d/php-fpm restart} output] {
	list 0 [string map {"\n" " "} $output]
	} {
	return {1 "ok, php-fpm reloaded"}
	}
	}

	"status" {
	catch {exec /usr/local/etc/rc.d/php-fpm status} output
	list 1 [string map {"\n" " "} $output]
	}

	"create" {
	set user [lindex $arg 1]
	if {$user == ""} {
	return {0 "syntax: phpfpm create <user>"}
	}
	if ![tc2:username_isvalid $user] {
	return {0 "not a valid username"}
	}
	if ![tc2:username_exists $user] {
	return "0 {$user isn't a valid [tc2:hostname] user}"
	}
	if [file exists [set file "/usr/local/etc/php-fpm/pool-prod/$user.conf"]] {
	return "0 {there is already a $user pool}"
	}
	if {![tc2:isroot $requester] && ![tc2:userallow $requester $user]} {
	return "0 {you don't have the authority to create a pool under $user user}"
	}
	set port [sql "SELECT MAX(pool_port) FROM tc2_phpfpm_pools"]
	if {$port == ""} {
	set port 9000
	} {
	incr port
	}

	#Adds it in MySQL table
	set time [unixtime]
	sqladd tc2_phpfpm_pools {pool_user pool_port pool_requester pool_time} [list $user $port $requester $time]

	#Write config gile
	global username
	set fd [open /usr/local/etc/php-fpm/pool.tpl r]
	set template [read $fd]
	close $fd
	set fd [open $file w]
	puts $fd [string map "%REQUESTER% $requester %TIME% $time %PORT% $port %USER% $user %GROUP% [exec -- id -gn $user] %COMMENT% {Autogenerated by $username}" $template]
	close $fd
	exec -- chown root:config $file
	exec -- chmod 644 $file
	return {1 "pool created, use '.phpfpm reload' to enable it"}
	}

	"" {
	return {0 "create, status or reload expected"}
	}

	default {
	set reply 0
	lappend reply "unknown command: $command"
	}
	}
	}

	#.df
	#.df pull [extension]
	proc tc2:command:df {requester arg} {
	set command [lindex $arg 0]

	switch $command {
	"pull" {
	set what [lindex $arg 1]
	if {$what == ""} {
	set what core
	} {
	if {![file exists [registry get df.paths.extensions]/$what]} {
	return [list 0 "Invalid extension: $what"]
	}
	}

	catch {exec -- su -m [registry get df.who] -c "[registry get df.paths.bin]/dfpull $what"} status
	if { $status == "Already up-to-date." } {
	return { 1 "Repository already up-to-date." }
	} elseif { [string first "Can't currently pull code" $status] > -1 } {
	list 0 $status
	} else {
	putdebug $status
	return { 1 "repository updated" }
	}
	}

	"" {
	return {0 "pull expected"}
	}

	default {
	set reply 0
	lappend reply "unknown command: $command"
	}

	}
	}

	#ci status
	#ci stop
	proc tc2:command:ci {requester arg} {
	set command [lindex $arg 0]

	switch $command {
	"start" {
	list 0 [string range "use /usr/local/etc/rc.d/jenkins onestart" 0 end]
	}

	"status" {
	catch {exec /usr/local/etc/rc.d/jenkins onestatus} status
	list 1 [string range $status 0 [string first . $status]]
	}

	"stop" {
	#Jenkins doesn't reply to stop signal on the server, so we kill it.
	if [catch {exec -- kill -9 [exec cat /var/run/jenkins/jenkins.pid]} output] {
	list 0 [string map {"\n" " "} $output]
	} {
	return {1 "ok, Jenkins stopped"}
	}
	}

	"" {
	return {0 "status or stop expected"}
	}

	default {
	set reply 0
	lappend reply "unknown command: $command"
	}
	}
	}
	diff --git a/Wearg/Notifications.tcl b/Wearg/Notifications.tcl
	index 296507c..f0c5e30 100644
	--- a/Wearg/Notifications.tcl
	+++ b/Wearg/Notifications.tcl
	@@ -1,170 +1,170 @@
	package require json

	bind time - "30 *" ::notifications::channel_notify_periodics

	namespace eval notifications {
	proc init {} {
	::broker::bind [registry get broker.queue.notifications] ::notifications::on_broker_message
	-
	+
	bind * * * * ::notifications::channel_notify
	bind "DockerHub" * * * ::notifications::docker_build_summary
	}

	proc bind {service project group type callback} {
	global notificationsbinds
	set entry [list $service $project $group $type $callback]

	if {[info exists notificationsbinds]} {
	foreach bind $notificationsbinds {
	if {$bind == $entry} {
	# Bind is already here
	return
	}
	}
	}

	lappend notificationsbinds $entry
	}

	proc binds {} {
	global notificationsbinds

	if {[info exists notificationsbinds]} {
	return $notificationsbinds
	}

	return ""
	}

	proc is_matching_notification_bind {bind notification} {
	set bindFields "service project group type callback"

	# We want to ensure the first four bind fields match the values of the notification dictionary
	foreach $bindFields $bind {}
	set fields [lrange $bindFields 0 end-1]
	foreach field $fields {
	if {![string match [set $field] [dict get $notification $field]]} {
	return 0
	}
	}

	return 1
	}

	proc on_broker_message {queue message} {
	set notification [json::json2dict $message]
	set message [dict get $notification text]

	foreach field "service project group rawContent type text link" {
	lappend params [dict get $notification $field]
	}
	-
	+
	set matchingBinds 0
	foreach bind [binds] {
	if {[is_matching_notification_bind $bind $notification]} {
	set callback [lindex $bind 4]
	$callback {*}$params
	incr matchingBinds
	}
	}
	if {$matchingBinds == 0} {
	putdebug "No bind for queue $queue message $message"
	}
	}

	proc get_projects {} {
	registry get notifications.projects
	}

	proc get_notification_channel {project group} {
	if {$project == "Wolfplex"} {
	return "#wolfplex"
	}
	if {$project == "TrustSpace"} {
	return "#wolfplex"
	}
	if {$project == "Keruald"} {
	return "#nasqueron-logs"
	}
	if {$project == "Nasqueron"} {
	switch $group {
	eglide { return "#eglide" }
	tasacora { return "#tasacora" }
	trustspace { return "#wolfplex" }
	docker { return "#nasqueron-ops" }
	ops { return "#nasqueron-ops" }
	orgz { return "#nasqueron-ops" }
	devtools { return "#nasqueron-logs" }
	nasqueron { return "#nasqueron-logs" }
	default {
	putdebug "Message for unknown group: $project $group"
	return "#nasqueron-logs"
	}
	}
	}
	return ""
	}

	proc get_image_from_docker_payload {payload} {
	set repository [dict get $payload repository]
	dict get $repository repo_name
	}

	proc docker_build_summary {service project group rawContent type text link} {
	if {$service != "DockerHub" \|\| $type != "push"} {
	return
	}

	set image [get_image_from_docker_payload $rawContent]
	set key notifications.periodics.docker.$project

	set periodicsNotifications [registry get $key]
	dict incr periodicsNotifications $image
	registry set $key $periodicsNotifications
	}

	proc channel_notify_periodics {minutes hours day month year} {
	foreach project [get_projects] {
	channel_notify_periodics_for_project $project
	}
	}

	proc docker_format_builds {builds} {
	set first 1
	foreach "image count" $builds {
	lappend list "$image (${count}x)"
	}
	join $list ", "
	}

	proc channel_notify_periodics_for_project {project} {
	set key notifications.periodics.docker.$project
	set builds [registry get $key]
	if {$builds == ""} {
	return
	}

	set channel [get_notification_channel $project docker]
	putquick "PRIVMSG $channel :New images pushed to Docker Hub: [docker_format_builds $builds]"
	registry delete $key
	}

	proc channel_notify {service project group rawContent type text link} {
	# T790 - Ignores Docker Hub notification in real time to offer a summary instead
	if {$service == "DockerHub"} {
	return
	}

	set channel [get_notification_channel $project $group]
	if {$channel == ""} {
	return
	}

	set message $text
	if {$link != ""} {
	append message " â $link"
	}

	putquick "PRIVMSG $channel :$message"
	}
	}

File Metadata

Mime Type: text/x-diff
Expires: Sat, Mar 7, 02:08 (1 d, 1 h)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 3500326
Default Alt Text: (76 KB)

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions