Page MenuHomeDevCentral
Files F11722546

No OneTemporary
Actions

View Options

diff --git a/Core.tcl b/Core.tcl
index ccda51d..a3c9ae6 100644
--- a/Core.tcl
+++ b/Core.tcl
@@ -1,87 +1,174 @@
#
# TCL helpers
#
#Determines if $proc exists
proc proc_exists {proc} {
expr {[info procs $proc] == $proc}
}
#
# Trivial procs
#
#Determines if $v is a number
proc isnumber {v} {
return [expr {! [catch {expr {int($v)}}]}]
}
#Returns "s" if $count implies a plural
#TODO: keep this method for French (ie NOT adjusting values for English)
# and grab the plural proc from wiki.tcl.tk for English.
proc s {count} {
if {$count >= 2 || $count <= 2} {return "s"}
}
+#
+# SQL
+#
+
+#Reconnects to the sql & sql2 server
+proc sqlrehash {} {
+ global sql
+ catch {
+ sql disconnect
+ sql2 disconnect
+ }
+ sql connect $sql(host) $sql(user) $sql(pass)
+ sql2 connect $sql(host) $sql(user) $sql(pass)
+ sql selectdb $sql(database)
+ sql2 selectdb $sql(database)
+}
+
+#Escape a string to use as sql query parameter
+proc sqlescape {data} {
+ #\ -> \\
+ #' -> \'
+ string map {"\\" "\\\\" "'" "\\'"} $data
+
+}
+
+#Gets the first item of the first row of a sql query (scalar results)
+proc sqlscalar {sql} {
+ lindex [lindex [sql $sql] 0] 0
+}
+
+#Adds specified data to specified SQL table
+proc sqladd {table {data1 ""} {data2 ""}} {
+ if {$data1 == ""} {
+ set fields ""
+ #Prints field to fill
+ foreach row [sql "SHOW COLUMNS FROM $table"] {
+ lappend fields [lindex $row 0]
+ }
+ return $fields
+ }
+
+ if {$data2 == ""} {
+ set sql "INSERT INTO $table VALUES ("
+ set data $data1
+ } {
+ set sql "INSERT INTO $table (`[join $data1 "`, `"]`) VALUES ("
+ set data $data2
+ }
+ set first 1
+ foreach value $data {
+ if {$first == 1} {set first 0} {append sql ", "}
+ append sql "'[sqlescape $value]'"
+ }
+ append sql ")"
+ sql $sql
+}
+
#
# Registry
#
#Gets, sets, deletes or increments a registry value
proc registry {command key {value ""}} {
switch -- $command {
"add" {
sqladd registry "data value" [list $key $value]
}
"get" {
sqlscalar "SELECT value FROM registry WHERE `data` = '$key'"
}
"set" {
sqlreplace registry "data value" [list $key $value]
}
"del" {
registry delete $key $value
}
"delete" {
set sql "DELETE FROM registry WHERE `data` = '$key'"
putdebug $sql
sql $sql
}
"incr" {
set current [registy get $key]
if {$value == ""} {set term 1}
if {$current == ""} {
registry set $key $term
} {
registry set $key [incr current $term]
}
}
default {
error "unknown subcommand: must be add, get, set, incr or delete"
}
}
}
#
# Users information
#
+
+#Gets user_id from a username, idx or user_id
proc getuserid {data} {
if {$data == ""} {
return
} elseif {![isnumber $data]} {
#username -> user_id
sql "SELECT user_id FROM users WHERE username = '[sqlescape $data]'"
} elseif {$data < 1000} {
#idx -> user_id
getuserid [idx2hand $data]
} else {
#user_id -> user_id (or "" if not existing)
sql "SELECT user_id FROM users WHERE user_id = $data"
}
}
+
+#
+# Text parsing
+#
+
+proc geturls {text} {
+ #Finds the first url position
+ set pos -1
+ foreach needle "http:// https:// www." {
+ 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]]
+ }
+}
diff --git a/Nasqueron/Channel.tcl b/Nasqueron/Channel.tcl
index 4d63bd9..7f8db5a 100644
--- a/Nasqueron/Channel.tcl
+++ b/Nasqueron/Channel.tcl
@@ -1,62 +1,43 @@
# #wolfplex
bind pubm - "#wolfplex *" pubm:url
#
# URL management
#
-proc geturls {text} {
- #Finds the first url position
- set pos -1
- foreach needle "http:// https:// www." {
- 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]]
- }
-}
-
+#Determines if the URL matches a video site url:getvideotitle can handle
proc url:isvideo {url} {
#We use grep "_VALID_URL =" /usr/local/bin/youtube-dl for this list
foreach site "youtu.be metacafe.com dailymotion video.google.com photobucket.com video.yahoo.com youtube.com depositfiles.com" {
if {[string first $site $url] > -1} {
return 1
}
}
return 0
}
-proc url:getvideoinfo {url} {
+#Gets video title
+proc url:getvideotitle {url} {
set title ""
catch {
set title [exec -- youtube-dl -e $url]
}
return $title
}
+#This proc allows to handle URLs in lines
+#Currently, it prints the video title when not provided with the URL
+#TODO: checks 402/403/404/500 error codes
proc pubm:url {nick uhost handle channel text} {
foreach url [geturls $text] {
if [url:isvideo $url] {
#Prints video information on the channel
#if it's not already in $text
- set info [url:getvideoinfo $url]
+ set info [url:getvideotitle $url]
if {[string first $info $text] == -1} {
putserv "PRIVMSG $channel :$info"
}
}
}
}
diff --git a/Nasqueron/Communication.tcl b/Nasqueron/Communication.tcl
index 4202980..cdc9522 100644
--- a/Nasqueron/Communication.tcl
+++ b/Nasqueron/Communication.tcl
@@ -1,64 +1,67 @@
package require http
bind dcc - sms dcc:sms
bind pub - !identica pub:identica
bind pub - !pub pub:identica
bind pub - !twit pub:identica
#
# SMS
#
#.sms
proc dcc:sms {handle idx arg} {
if {$arg == "" || $arg == "config"} {
#Prints config
return 1
} elseif {[string range $arg 0 6] == "config "} {
putcmdlog "#$handle# sms config ..."
return 0
} else {
#Sends a SMS
set to [lindex $arg 0]
putcmdlog "#$handle# sms ..."
}
return 0
}
#
# Identi.ca
#
+#Posts $message on the identi.ca $account account
proc identicapost {account message} {
set row [lindex [sql "SELECT account_username, account_password FROM identica_accounts WHERE account_code = '$account'"] 0]
set auth "Basic [base64::encode [join $row :]]"
set tok [::http::geturl http://identi.ca/api/statuses/update.xml -headers [list Authorization $auth] -query [::http::formatQuery status $message]]
::http::cleanup $tok
}
+#.identica
proc dcc:identica {handle idx arg} {
}
+#!pub !identica or !twit
proc pub:identica {nick uhost handle chan text} {
if {$chan == "#wikipedia-fr"} {
set account wikipediafr
} elseif {$chan == "#wolfplex"} {
set account wolfplex
} {
putquick "NOTICE $nick :!pub n'est pas activésur $chan"
return
}
if {$text == ""} {
putquick "NOTICE $nick :Syntaxe : !pub <texte à publier sur identi.ca et Twitter>"
return
}
set len [string length $text]
if {$len > 140} {
putquick "NOTICE $nick :140 caractères max, là il y en a $len."
return
}
identicapost $account $text
putquick "NOTICE $nick :Publié sur identi.ca"
return 1
}
diff --git a/Tech.tcl b/Tech.tcl
index bf5fe86..4af0530 100644
--- a/Tech.tcl
+++ b/Tech.tcl
@@ -1,230 +1,177 @@
unbind dcc n rehash *dcc:rehash
bind dcc T rehash dcc:rehash
bind dcc T s dcc:source
unbind dcc n tcl *dcc:tcl
bind dcc T tcl dcc:tcl
bind dcc T sql dcc:sql
bind dcc T sql? dcc:sql?
bind dcc T sql! dcc:sql!
bind dcc T sql1 dcc:sql1
bind dcc T sql1? dcc:sql1?
bind dcc T sql1! dcc:sql1!
bind dcc T sqlrehash dcc:sqlrehash
bind dcc T tcldoc dcc:tcldoc
#
# Helpers methods
#
#Logs a timestamped message to the specified file
proc log {logfile handle message} {
global username
set fd [open "logs/$username/$logfile.log" a]
puts $fd "\[[unixtime]\] <$handle> $message"
close $fd
}
#Prints a message to all the techs
proc putdebug {message} {
foreach conn [dcclist CHAT] {
foreach "idx handle uhost type flags idle" $conn {}
#dccputchan 0 "(debug) $conn"
if [matchattr $handle T] {
putdcc $idx "\[DEBUG\] $message"
}
}
}
#
# Tech commands
#
#Disconnect SQL, then rehash (to prevent sql connect fatal errors)
proc dcc:rehash {handle idx arg} {
catch {
sql disconnect
sql2 disconnect
}
*dcc:rehash $handle $idx $arg
}
#Loads a script
proc dcc:source {handle idx arg} {
if {$arg == ""} {
putdcc $idx "Usage: .s <script> [script2 ...]"
return
}
foreach file $arg {
if ![sourcetry $file] {
putdcc $idx "Can't find script $file"
}
}
}
#Tries to load a script
proc sourcetry {file} {
global username
set scriptlist "$file $file.tcl scripts/$file scripts/$file.tcl scripts/$username/$file scripts/$username/$file.tcl"
foreach script $scriptlist {
if [file exists $script] {
source $script
return 1
}
}
return 0
}
#.tcl with tech.log logging
proc dcc:tcl {handle idx arg} {
#Logs every .tcl commands, except sql connect
#You should add here any line with password.
catch {
if ![string match "*sql*connect*" $arg] {
log tech $handle $arg
}
}
*dcc:tcl $handle $idx $arg
}
#
# SQL
#
-#TODO: move to Core.tcl
-proc sqlrehash {} {
- global sql
- catch {
- sql disconnect
- sql2 disconnect
- }
- sql connect $sql(host) $sql(user) $sql(pass)
- sql2 connect $sql(host) $sql(user) $sql(pass)
- sql selectdb $sql(database)
- sql2 selectdb $sql(database)
-}
-
-#Escape a string to use as sql query parameter
-proc sqlescape {data} {
- #\ -> \\
- #' -> \'
- string map {"\\" "\\\\" "'" "\\'"} $data
-
-}
-
-#Gets the first item of the first row of a sql query (scalar results)
-proc sqlscalar {sql} {
- lindex [lindex [sql $sql] 0] 0
-}
-
-#Adds specified data to specified SQL table
-proc sqladd {table {data1 ""} {data2 ""}} {
- if {$data1 == ""} {
- set fields ""
- #Prints field to fill
- foreach row [sql "SHOW COLUMNS FROM $table"] {
- lappend fields [lindex $row 0]
- }
- return $fields
- }
-
- if {$data2 == ""} {
- set sql "INSERT INTO $table VALUES ("
- set data $data1
- } {
- set sql "INSERT INTO $table (`[join $data1 "`, `"]`) VALUES ("
- set data $data2
- }
- set first 1
- foreach value $data {
- if {$first == 1} {set first 0} {append sql ", "}
- append sql "'[sqlescape $value]'"
- }
- append sql ")"
- sql $sql
-}
-
#Reconnects to the MySQL main server (sql and sql2)
proc dcc:sqlrehash {handle idx arg} {
sqlrehash
return 1
}
#
# dcc:sql1 dcc:sql1? and dcc:sql1! are the main procedures
# They will be cloned for the 9 other connections command
#
#Executes a query
proc dcc:sql1 {handle idx arg} {
if {$arg == ""} {
putdcc $idx "Usage: .sql1 <query>"
return
}
#Executes the query and prints the query one row per line
set t1 [clock milliseconds]
if [catch {
foreach row [sql1 $arg] {
putdcc $idx $row
}
} err] {
putdcc $idx $err
}
#Warns after a long query
set delta_t [expr [clock milliseconds] - $t1]
if {$delta_t > 1999} {
putcmdlog "Fin de la requête SQL ($delta_t ms)."
}
#Logs the query
log sql $handle "sql1\t$arg"
}
#Dumps (SELECT * FROM <table>) a table
proc dcc:sql1! {handle idx arg} {
if {$arg == ""} {
putdcc $idx "Usage: .sql1! <table>"
return
}
dcc:sql1 $handle $idx "SELECT * FROM $arg"
}
#Without parameters, list the tables (SHOW TABLES)
#With a parameter, dump tables info (SHOW CREATE TABLE)
proc dcc:sql1? {handle idx arg} {
if {$arg == ""} {
dcc:sql1 $handle $idx "SHOW TABLES"
}
foreach table $arg {
dcc:sql1 $handle $idx "SHOW CREATE TABLE $table"
}
}
#Clones .sql1, .sql1? and .sql1! commands into .sql, .sql? and .sql!
proc dcc:sql {handle idx arg} [string map "sql1 sql" [info body dcc:sql1]]
proc dcc:sql? {handle idx arg} [string map "sql1 sql" [info body dcc:sql1?]]
proc dcc:sql! {handle idx arg} [string map "sql1 sql" [info body dcc:sql1!]]
proc sqlreplace {table {data1 ""} {data2 ""}} [string map {"INSERT INTO" "REPLACE INTO"} [info body sqladd]]
#Clones .sql1, .sql1? and .sql1! commands into .sql2, .sql3, ..., .sql10.
for {set i 2} {$i < 11} {incr i} {
bind dcc T sql$i dcc:sql$i
bind dcc T sql$i? dcc:sql$i?
bind dcc T sql$i! dcc:sql$i!
proc dcc:sql$i {handle idx arg} [string map "sql1 sql$i" [info body dcc:sql1]]
proc dcc:sql$i! {handle idx arg} [string map "sql1 sql$i" [info body dcc:sql1!]]
proc dcc:sql$i? {handle idx arg} [string map "sql1 sql$i" [info body dcc:sql1?]]
}
#
# Reference documentation
#
proc dcc:tcldoc {handle idx arg} {
putdcc $idx [exec -- grep $arg doc/tcl-commands.doc]
return 1
}

File Metadata

Mime Type
text/x-diff
Expires
Thu, Sep 18, 03:13 (13 h, 28 m)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
2989914
Default Alt Text
(12 KB)

Event Timeline

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