D1943.id4915.diff
No OneTemporary
Actions

Size

32 KB

Referenced Files

None

Subscribers

None

D1943.id4915.diff
View Options

	diff --git a/Core.tcl b/Core.tcl
	--- a/Core.tcl
	+++ b/Core.tcl
	@@ -11,24 +11,24 @@

	# 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
	- }
	+ 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
	- }
	+ 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
	+ ::http::cleanup $fd
	+ return $result
	}


	@@ -38,16 +38,16 @@

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


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

	proc has_no_args {args} {
	- expr {$args == "" \|\| $args == "{}" \|\| $args == "{{}}"}
	+ expr {$args == "" \|\| $args == "{}" \|\| $args == "{{}}"}
	}

	#
	@@ -65,36 +65,36 @@

	# Gets the maximal value of a numeric list
	proc lmax {items} {
	- getultimatecomparedfromlist $items >
	+ getultimatecomparedfromlist $items >
	}

	# Gets the minimal value of a numeric list
	proc lmin {items} {
	- getultimatecomparedfromlist $items <
	+ getultimatecomparedfromlist $items <
	}

	# Gets the ultimately compared item from a list
	proc getultimatecomparedfromlist {items op} {
	- set hasValue 0
	- set max {}
	+ set hasValue 0
	+ set max {}

	- foreach item $items {
	- if {![string is double $item]} {
	- continue
	- }
	+ foreach item $items {
	+ if {![string is double $item]} {
	+ continue
	+ }

	- if {!$hasValue} {
	- set hasValue 1
	- set max $item
	- continue
	- }
	+ if {!$hasValue} {
	+ set hasValue 1
	+ set max $item
	+ continue
	+ }

	- if {[expr $item $op $max]} {
	- set max $item
	- }
	- }
	+ if {[expr $item $op $max]} {
	+ set max $item
	+ }
	+ }

	- return $max
	+ return $max
	}

	#
	@@ -102,11 +102,11 @@
	#

	proc iso8601date {{clockval ""}} {
	- if {$clockval == {}} {
	- set clockval [clock seconds]
	- }
	+ if {$clockval == {}} {
	+ set clockval [clock seconds]
	+ }

	- clock format $clockval -format %Y-%m-%dT%H:%M:%S%z
	+ clock format $clockval -format %Y-%m-%dT%H:%M:%S%z
	}

	#
	@@ -120,26 +120,26 @@

	# Returns +-<number>
	proc numberSign {number} {
	- if {$number > 0} {
	- return "+$number"
	- } {
	- return $number
	- }
	+ if {$number > 0} {
	+ return "+$number"
	+ } {
	+ return $number
	+ }
	}

	# Returns the value as is if numeric, or "0" if not
	proc zeroornumber {value} {
	- if {$value == "" \|\| ![string is double $value]} {
	- return 0
	- }
	- return $value
	+ if {$value == "" \|\| ![string is double $value]} {
	+ return 0
	+ }
	+ return $value
	}

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

	proc isnotasciiutf8char {char} {
	@@ -170,17 +170,17 @@
	# @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"
	- }
	+ 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"
	+ }
	}

	proc dict2json {dictToEncode} {
	@@ -199,27 +199,27 @@

	#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
	- }
	+ 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
	+ 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
	@@ -228,18 +228,18 @@
	## @param $digits The number length
	## @return The zerofilled number
	proc zerofill {number digits} {
	- format "%0${digits}d" $number
	+ format "%0${digits}d" $number
	}

	# Maps from a list of words the length of those words
	# e.g. strlenmap "a aaa aa" will return {1 3 2}
	proc strlenmap {words} {
	- lmap key $words { string length $key }
	+ lmap key $words { string length $key }
	}

	# Search the max string lenghth from a list of strings
	proc strlenmax {words} {
	- zeroornumber [lmax [strlenmap $words]]
	+ zeroornumber [lmax [strlenmap $words]]
	}

	#
	@@ -248,84 +248,84 @@

	#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)
	+ 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
	+ #\ -> \\
	+ #' -> \'
	+ 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
	+ 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()"
	+ sql "SELECT LAST_INSERT_ID()"
	}

	proc sqlconnect {{sqlinstance "sql"} {defaultsfile ""}} {
	- if {$defaultsfile == ""} {
	- global env
	- set defaultsfile $env(HOME)/.my.cnf
	- }
	+ if {$defaultsfile == ""} {
	+ global env
	+ set defaultsfile $env(HOME)/.my.cnf
	+ }

	- set config [readmycnf $defaultsfile]
	- $sqlinstance connect [dict get $config host] [dict get $config user] [dict get $config password]
	+ set config [readmycnf $defaultsfile]
	+ $sqlinstance connect [dict get $config host] [dict get $config user] [dict get $config password]
	}

	proc readmycnf {defaultsfile} {
	- set config {}
	- set fd [open $defaultsfile]
	- while {[gets $fd line] != -1} {
	- set entry [split $line =]
	- if {[llength $entry] == 2} {
	- dict set config {*}$entry
	- }
	- }
	- close $fd
	- return $config
	+ set config {}
	+ set fd [open $defaultsfile]
	+ while {[gets $fd line] != -1} {
	+ set entry [split $line =]
	+ if {[llength $entry] == 2} {
	+ dict set config {*}$entry
	+ }
	+ }
	+ close $fd
	+ return $config
	}

	#
	@@ -334,48 +334,48 @@

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

	#
	@@ -386,18 +386,18 @@
	#
	#
	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"
	- }
	+ 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
	@@ -405,7 +405,7 @@
	# @param who The user
	# @param what The information to get
	proc getuserinfo {who what} {
	- sqlscalar "SELECT $what FROM users WHERE user_id = [getuserid $who]"
	+ sqlscalar "SELECT $what FROM users WHERE user_id = [getuserid $who]"
	}

	#
	@@ -413,62 +413,62 @@
	#

	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]]
	- }
	+ #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
	- }
	+ 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]"
	- }
	- }
	+ 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}} {
	@@ -510,21 +510,21 @@
	}

	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 < >
	+ #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]
	+ #Output
	+ set text [string map {& {&} ' {'} "\"" {"}} $text]

	- if {$useCDATA} {
	- return "<!\[CDATA\[$text]]>"
	- }
	- return $text
	+ if {$useCDATA} {
	+ return "<!\[CDATA\[$text]]>"
	+ }
	+ return $text
	}

	#
	@@ -592,15 +592,15 @@
	# @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
	+ 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
	}

	#
	@@ -694,7 +694,7 @@
	putdebug $result
	close_interactive_command $fd $errorCallbackProc $state
	} elseif {$result >= 0} {
	- $callbackProc $fd $line $state
	+ $callbackProc $fd $line $state
	} elseif {[eof $fd]} {
	close_interactive_command $fd $errorCallbackProc $state
	} elseif {[fblocked $f]} {
	@@ -717,9 +717,9 @@

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

	# Extracts the error from Python
	@@ -745,52 +745,52 @@
	}

	proc resolve_nick {nickname} {
	- set resolved [whois $nickname 0]
	+ set resolved [whois $nickname 0]

	- if {$resolved == ""} {
	- return $nickname
	- }
	+ if {$resolved == ""} {
	+ return $nickname
	+ }

	- return $resolved
	+ return $resolved
	}

	# Returns an identified nickname or "" if not identified
	# By default, can also return strings like "kumkum!kumkum@eglide.org"
	proc whois {nickname {useUserHost 1}} {
	- # By handle
	- set result [nick2hand $nickname]
	- if {$result != "*"} {
	- #Will return "", when nick doesn't exist to avoid further processing.
	- return $result
	- }
	+ # 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]
	+ #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 $cloak 0]
	+ # By Cloak
	+ if {[regexp / $host]} {
	+ set cloak [split $host /]
	+ 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]
	- }
	- }
	+ 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 NickServ
	+ # TODO: code with callback

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

	- # Can't identify
	- return ""
	+ # Can't identify
	+ return ""
	}

	#
	@@ -799,84 +799,84 @@

	# 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
	+ 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
	+ # 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
	+ #
	+ # 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]
	+ expr [isipv4 $string] \|\| [isipv6 $string]
	}

	###
	@@ -886,27 +886,27 @@
	# 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]
	- }
	+ 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
	- }
	+ # 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 ""
	+ 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]
	- }
	+ if {[string first / $host] > -1} {
	+ return [extract_addr_from_cloak $host]
	+ }

	- return $host
	+ return $host
	}

	###
	@@ -937,8 +937,8 @@
	}

	default {
	- error "Unknown mode: $mode"
	- }
	+ error "Unknown mode: $mode"
	+ }
	}
	}

	diff --git a/Tech.tcl b/Tech.tcl
	--- a/Tech.tcl
	+++ b/Tech.tcl
	@@ -1,18 +1,18 @@
	- bind dcc T s dcc:source
	-unbind dcc n tcl *dcc:tcl
	- bind dcc T tcl dcc:tcl
	+ bind dcc T s dcc:source
	+unbind dcc n tcl *dcc:tcl
	+ bind dcc T tcl dcc:tcl

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

	- bind dcc T tcldoc dcc:tcldoc
	+ bind dcc T tcldoc dcc:tcldoc

	- bind dcc T env dcc:env
	+ bind dcc T env dcc:env

	bind evnt - prerehash evnt:prerehash

	@@ -22,25 +22,25 @@

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

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

	#
	@@ -49,54 +49,54 @@

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

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

	proc should_log_tcl_command {arg} {
	- set noLogMatches {
	- "sqlconnect*"
	- "genpass *"
	- }
	- foreach noLogMatch $noLogMatches {
	- if {[string match $noLogMatch $arg]} {
	- return 0
	- }
	- }
	-
	- return 1
	+ set noLogMatches {
	+ "sqlconnect*"
	+ "genpass *"
	+ }
	+ foreach noLogMatch $noLogMatches {
	+ if {[string match $noLogMatch $arg]} {
	+ return 0
	+ }
	+ }
	+
	+ return 1
	}

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

	#
	@@ -105,8 +105,8 @@

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

	#
	@@ -116,49 +116,49 @@

	#Executes a query
	proc dcc:sql1 {handle idx arg} {
	- if {$arg == ""} {
	- putdcc $idx "Usage: .sql1 <query>"
	- return
	- }
	-
	- #Executes the query and prints the query one row per line
	- set t1 [clock milliseconds]
	- if [catch {
	- foreach row [sql1 $arg] {
	- putdcc $idx $row
	- }
	- } err] {
	- putdcc $idx $err
	- }
	-
	- #Warns after a long query
	- set delta_t [expr [clock milliseconds] - $t1]
	- if {$delta_t > 1999} {
	- putcmdlog "Fin de la requête SQL ($delta_t ms)."
	- }
	-
	- #Logs the query
	- log sql $handle "sql1\t$arg"
	+ if {$arg == ""} {
	+ putdcc $idx "Usage: .sql1 <query>"
	+ return
	+ }
	+
	+ #Executes the query and prints the query one row per line
	+ set t1 [clock milliseconds]
	+ if [catch {
	+ foreach row [sql1 $arg] {
	+ putdcc $idx $row
	+ }
	+ } err] {
	+ putdcc $idx $err
	+ }
	+
	+ #Warns after a long query
	+ set delta_t [expr [clock milliseconds] - $t1]
	+ if {$delta_t > 1999} {
	+ putcmdlog "Fin de la requête SQL ($delta_t ms)."
	+ }
	+
	+ #Logs the query
	+ log sql $handle "sql1\t$arg"
	}

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

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

	#Clones .sql1, .sql1? and .sql1! commands into .sql, .sql? and .sql!
	@@ -170,12 +170,12 @@

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

	#
	@@ -183,8 +183,8 @@
	#

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

	#
	@@ -206,8 +206,8 @@
	#

	proc evnt:prerehash {type} {
	- catch {
	- sql disconnect
	- sql2 disconnect
	- }
	+ catch {
	+ sql disconnect
	+ sql2 disconnect
	+ }
	}

File Metadata

Mime Type: text/plain
Expires: Sat, Nov 23, 23:31 (19 h, 5 m)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 2258659
Default Alt Text: D1943.id4915.diff (32 KB)

D1943.id4915.diffNo OneTemporaryActions

D1943.id4915.diffView Options

File Metadata

Event Timeline

D1943.id4915.diff
No OneTemporary
Actions

D1943.id4915.diff
View Options