No OneTemporary
Actions

Size

39 KB

Referenced Files

None

Subscribers

None

View Options

	diff --git a/Core.tcl b/Core.tcl
	--- a/Core.tcl
	+++ b/Core.tcl
	@@ -1,552 +1,555 @@
	+#
	+# HTTP support
	+#
	+
	+package require http
	+package require tls
	+::tls::init -ssl2 false -ssl3 false -tls1 true
	+::http::register https 443 ::tls::socket
	+
	#
	# TCL helpers
	#

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

	#
	# Trivial procs
	#

	#Determines if $v is a number
	proc isnumber {v} {
	return [expr {! [catch {expr {int($v)}}]}]
	}

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

	#Returns "s" if $count implies a plural
	#TODO: keep this method for French (ie NOT adjusting values for English)
	# and grab the plural proc from wiki.tcl.tk for English.
	proc s {count} {
	if {$count >= 2 \|\| $count <= -2} {return "s"}
	}

	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
	}

	#Adds specified data to specified SQL table
	proc sqladd {table {data1 ""} {data2 ""}} {
	if {$data1 == ""} {
	set fields ""
	#Prints field to fill
	foreach row [sql "SHOW COLUMNS FROM $table"] {
	lappend fields [lindex $row 0]
	}
	return $fields
	}

	if {$data2 == ""} {
	set sql "INSERT INTO $table VALUES ("
	set data $data1
	} {
	set sql "INSERT INTO $table (`[join $data1 "`, `"]`) VALUES ("
	set data $data2
	}
	set first 1
	foreach value $data {
	if {$first == 1} {set first 0} {append sql ", "}
	append sql "'[sqlescape $value]'"
	}
	append sql ")"
	sql $sql
	}

	# Gets the value of the AUTOINCREMENT column for the last INSERT
	#
	# @return the last value of the primary key
	proc sqllastinsertid {} {
	sql "SELECT LAST_INSERT_ID()"
	}

	#
	# Registry
	#

	#Gets, sets, deletes or increments a registry value
	proc registry {command key {value ""}} {
	switch -- $command {
	"add" {
	sqladd registry "data value" [list $key $value]
	}

	"get" {
	sqlscalar "SELECT value FROM registry WHERE `data` = '$key'"
	}

	"set" {
	sqlreplace registry "data value" [list $key $value]
	}

	"del" {
	registry delete $key $value
	}

	"delete" {
	set sql "DELETE FROM registry WHERE `data` = '$key'"
	putdebug $sql
	sql $sql
	}

	"incr" {
	set current [registry get $key]
	if {$value == ""} {set term 1}
	if {$current == ""} {
	registry set $key $term
	} {
	registry set $key [incr current $term]
	}
	}

	default {
	error "unknown subcommand: must be add, get, set, incr or delete"
	}
	}
	}

	#
	# Users information
	#

	# Gets user_id from a username, idx or user_id
	#
	#
	proc getuserid {who} {
	if {$who == ""} {
	return
	} elseif {![isnumber $who]} {
	#username -> user_id
	sql "SELECT user_id FROM users WHERE username = '[sqlescape $who]'"
	} elseif {$who < 1000} {
	#idx -> user_id
	getuserid [idx2hand $who]
	} else {
	#user_id -> user_id (or "" if not existing)
	sql "SELECT user_id FROM users WHERE user_id = $who"
	}
	}

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

	#
	# Text parsing
	#

	proc geturls {text} {
	#Finds the first url position
	set pos -1
	foreach needle "http:// https:// www. youtu.be" {
	set pos1 [string first $needle $text]
	if {$pos1 != -1 && ($pos == -1 \|\| $pos1 < $pos)} {
	set pos $pos1
	}
	}

	#No URL found
	if {$pos == -1} {return}

	#URL found
	set pos2 [string first " " $text $pos]
	if {$pos2 == -1} {
	#Last URL to be found
	string range $text $pos end
	} {
	#Recursive call to get other URLs
	concat [string range $text $pos $pos2-1] [geturls [string range $text $pos2+1 end]]
	}
	}

	#Reads specified URL and returns content
	proc geturltext {url {trim 1}} {
	- package require http
	- if {[string range [string tolower $url] 0 5] == "https:"} {
	- package require tls
	- http::register https 443 tls::socket
	- }
	-
	set fd [http::geturl $url]
	set text [http::data $fd]
	http::cleanup $fd
	if $trim {
	string trim $text
	} {
	return $text
	}
	}

	proc numeric2ordinal {n} {
	switch $n {
	1 { return first }
	2 { return second }
	3 { return third }
	5 { return fifth }
	8 { return eight }
	9 { return ninth }
	#todo: ve -> f / y -> ie
	12 { return twelfth }
	default {
	set ordinal "[numeric2en $n]th"
	set m [expr $n % 10]
	if {$m == 0} {
	return [string map "yth ieth" $ordinal]
	}
	if {$n < 20} { return $ordinal }
	if {$n > 100} { return "${n}th" }
	return "[numeric2en [expr $n - $m]]-[numeric2ordinal $m]"
	}
	}
	}

	proc numeric2en {n {optional 0}} {
	#---------------- English spelling for integer numbers
	if {[catch {set n [expr $n]}]} {return $n}
	if {$optional && $n==0} {return ""}
	array set dic {
	0 zero 1 one 2 two 3 three 4 four 5 five 6 six 7 seven
	8 eight 9 nine 10 ten 11 eleven 12 twelve
	}
	if [info exists dic($n)] {return $dic($n)}
	foreach {value word} {1000000 million 1000 thousand 100 hundred} {
	if {$n>=$value} {
	return "[numeric2en $n/$value] $word [numeric2en $n%$value 1]"
	}
	} ;#--------------- composing between 13 and 99...
	if $n>=20 {
	set res $dic([expr $n/10])ty
	if $n%10 {append res -$dic([expr $n%10])}
	} else {
	set res $dic([expr $n-10])teen
	} ;#----------- fix over-regular compositions
	regsub "twoty" $res "twenty" res
	regsub "threet" $res "thirt" res
	regsub "fourty" $res "forty" res
	regsub "fivet" $res "fift" res
	regsub "eightt" $res "eight" res
	set res
	} ;#RS

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

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

	#Output
	set text [string map {& {&} ' {'} {"} {"}} $text]
	if {$useCDATA} {
	return "<!\[CDATA\[$text]]>"
	}
	return $text
	}

	#
	# URLs
	#

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

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

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

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

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

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

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

	#
	# GUID
	#

	# Gets the MD5 of a string, and returns it following the GUID format
	#
	# @param $str The string to compute the hash
	# @return The MD5, formatted as a GUID
	proc guidmd5 {str} {
	set md5 [md5 $str]
	set output ""
	for {set i 0} {$i < 32} {incr i} {
	if {$i == 8 \|\| $i == 12 \|\| $i == 16 \|\| $i == 20} {
	append output "-"
	}
	append output [string index $md5 $i]
	}
	return $output
	}

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

	# 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 $state a state object to send to the callback proc
	proc run_command {cmd callbackProc state} {
	set fd [open "\| $cmd" r]
	fconfigure $fd -blocking false
	fileevent $fd readable [list interactive_command_handler $fd $callbackProc $state]
	}

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

	# 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 {state ""}} {
	set status [catch {gets $fd line} result]
	if { $status != 0 } {
	# unexpected error
	putdebug "Unexpected error running command: "$result
	close_interactive_command $fd
	} elseif {$result >= 0} {
	$callbackProc $fd $line $state
	} elseif {[eof $fd]} {
	close_interactive_command $fd
	} 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
	}
	diff --git a/Daeghrefn/Bugzilla.tcl b/Daeghrefn/Bugzilla.tcl
	--- a/Daeghrefn/Bugzilla.tcl
	+++ b/Daeghrefn/Bugzilla.tcl
	@@ -1,66 +1,63 @@
	# .tcl source scripts/Daeghrefn/Bugzilla.tcl

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

	bind dcc - bug dcc:bug

	#
	# Bugzilla structures
	#

	namespace import -force rpcvar::typedef

	typedef {
	login string
	password string
	remember boolean
	} userLoginRequest

	#
	# Bugzilla libraries
	#

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

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

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

	#
	# XML-RPC procedures
	#

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

	#
	# Userland
	#

	proc dcc:bug {handle idx arg} {

	}
	\ No newline at end of file
	diff --git a/Daeghrefn/Communication.tcl b/Daeghrefn/Communication.tcl
	--- a/Daeghrefn/Communication.tcl
	+++ b/Daeghrefn/Communication.tcl
	@@ -1,413 +1,409 @@
	-package require http
	-
	bind dcc - sms dcc:sms
	bind dcc - mail dcc:mail
	bind dcc - twitter dcc:twitter
	bind pub - !sms pub:sms
	bind pub - !identica pub:identica
	bind pub - !pub pub:twitter
	bind pub - !twit pub:twitter
	bind pub - !tweet pub:twitter
	bind pub - !idee pub:idee
	bind pub - !idees pub:idee
	bind pub - !idée pub:idee

	#
	# SMS
	#

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

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

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

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

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

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

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

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

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

	#
	# Identi.ca and Twitter
	#

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

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

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

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

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

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

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

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

	}

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

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

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

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

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

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

	# By NickServ
	# TODO: code with callback

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

	# Can't identify
	return ""
	}

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

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

	#
	# Mail
	#

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

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

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

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

	# Sends a mail
	#
	# @param to The recipient
	# @param subject The mail subject
	# @param message The message to send
	# @param from The mail author (optional)
	proc mail.send {to subject message {from {}}} {
	set fd [open "\|sendmail -t" w]
	if {$from != ""} {
	puts $fd "From: $from"
	}
	puts $fd "To: $to"
	puts $fd "Subject: $subject"
	puts $fd
	puts $fd "$message"
	flush $fd
	close $fd
	-}
	\ No newline at end of file
	+}
	diff --git a/Daeghrefn/Last.fm.tcl b/Daeghrefn/Last.fm.tcl
	--- a/Daeghrefn/Last.fm.tcl
	+++ b/Daeghrefn/Last.fm.tcl
	@@ -1,68 +1,67 @@
	# .tcl source scripts/Daeghrefn/Last.fm.tcl

	-package require http
	package require json

	bind dcc - lastfm dcc:lastfm

	proc dcc:lastfm {handle idx arg} {
	switch [set command [lindex $arg 0]] {
	"" {
	return [*dcc:help $handle $idx lastfm]
	}

	"count" {

	}

	"top5" {
	set username [lindex $arg 1]
	if {$username == ""} { set username $handle }
	set i 0
	foreach track [lastfm::library_getTracks $username 5] {
	putdcc $idx "[incr i]. [dg $track artist.name] - [dg $track name] ([dg $track playcount])"
	}
	}

	default {
	putdcc $idx "Unknown command: $command"
	return 0
	}
	}
	}

	namespace eval ::lastfm {
	proc library_getTracks {username {tracks 50} {artist ""}} {
	set url "?method=library.gettracks&&user=[url::encode $username]&limit=$tracks"
	if {$artist != ""} {
	append url &artist=[url::encode $artist]
	}
	set result [get_json $url]
	dg $result tracks.track
	}

	proc getTrackPlayCount {username artist track} {
	foreach artistTrack [library_getTracks $username 500 $artist] {
	if {[string tolower [dg $artistTrack name]] == [string tolower $track]} {
	return [dg $artistTrack playcount]
	}
	}
	return 0
	}

	proc get_json {url} {
	set url [url]${url}&api_key=[key]&format=json
	set token [http::geturl $url]
	set data [http::data $token]
	http::cleanup $token
	json::json2dict $data
	}

	proc key {} {
	registry get lastfm.api.key
	}

	proc url {} {
	registry get lastfm.api.url
	}
	}
	\ No newline at end of file
	diff --git a/Daeghrefn/Wolfplex.tcl b/Daeghrefn/Wolfplex.tcl
	--- a/Daeghrefn/Wolfplex.tcl
	+++ b/Daeghrefn/Wolfplex.tcl
	@@ -1,31 +1,28 @@
	-package require http
	-
	bind pub - !open pub:open
	bind pub - !ouvert pub:open
	bind pub - !close pub:close
	bind pub - !closed pub:close
	bind pub - !ferme pub:close
	bind pub - !fermé pub:close

	proc pub:open {nick uhost handle chan text} {
	setisopen yes
	}

	proc pub:close {nick uhost handle chan text} {
	setisopen no
	}

	proc setisopen {status} {
	- package require http
	set query [::http::formatQuery oldid 0 wpTextbox1 $status wpSave Publier]
	set url "http://www.wolfplex.org/w/index.php?title=Mod%C3%A8le:IsOpen/status&action=edit"
	set tok [::http::geturl $url -query $query]
	set result [::http::data $tok]
	::http::cleanup $tok

	set fd [open debug.log w]
	puts $fd $result
	flush $fd
	close $fd
	}

	diff --git a/Daeghrefn/oauth.tcl b/Daeghrefn/oauth.tcl
	--- a/Daeghrefn/oauth.tcl
	+++ b/Daeghrefn/oauth.tcl
	@@ -1,200 +1,196 @@
	#
	# 0.2 - ???
	# - create base_url correctly for signing (remove ?params=...)
	# - improve error msg if http timeout occurs
	# - remove need to hardcode consumer key/secret by providing them as arguments
	# to the various functions
	#
	# 0.1 - May 18 2010
	# - Initial release
	#
	# by horgh (www.summercat.com)
	#
	# OAuth (1.0/1.0a) library for Twitter
	#
	# Requirements:
	# - Tcl 8.5+ and "recent" tcllib (developed with tcllib 1.12)
	#
	# Setup for users:
	# - Register for consumer key/secret at http://twitter.com/oauth_clients
	#
	# Library usage:
	# - You can store oauth_token/oauth_token_secret from get_access_token[] and
	# use it indefinitely (unless twitter starts expiring the tokens). Thus the
	# setup (below) need only be done once by storing and reusing these.
	#
	# - start with oauth::get_request_token
	# - usage: oauth::get_request_token $consumer_key $consumer_secret
	# - returns dict including oauth_token/oauth_token_secret for https://api.twitter.com/oauth/authorize?oauth_token=OAUTH_TOKEN
	# - going to this url, logging in, and allowing will give a PIN e.g. 1021393
	#
	# - then use pin as value for oauth_verifier in oauth::get_access_token
	# - Usage: oauth::get_access_token $consumer_key $consumer_token $oauth_token $oauth_token_secret $pin
	# - also use oauth_token/oauth_token_secret from get_request_token here
	# - returns dict including new oauth_token & oauth_token_secret (access token)
	#
	# - afterwards use oauth_token/oauth_token_secret from get_access_token in
	# oauth::query_api to make api calls
	# - usage: oauth::query_api $url $consumer_key $consumer_secret $http_method $oauth_token $oauth_token_secret $key:value_http_query
	# - the $key:value_http_query is such that you would pass to http::formatQuery
	# e.g. status {this is a tweet}
	# - example call: puts [oauth::query_api http://api.twitter.com/1/statuses/update.json <key> <secret> POST $oauth_token_done $oauth_token_secret_done [list status "does it work"]]
	#

	-package require http
	# tcllib packages
	package require base64
	package require sha1
	-package require tls

	package provide oauth 0.1

	-http::register https 443 ::tls::socket
	-
	namespace eval oauth {
	variable request_token_url https://api.twitter.com/oauth/request_token
	variable authorize_url https://api.twitter.com/oauth/authorize
	variable access_token_url https://api.twitter.com/oauth/access_token

	# timeout for http requests (ms)
	variable timeout 60000
	}

	# first step
	proc oauth::get_request_token {consumer_key consumer_secret} {
	set params [list [list oauth_callback oob]]
	set data [oauth::query_call $oauth::request_token_url $consumer_key $consumer_secret GET $params]

	# dict has oauth_token, oauth_token_secret, ...
	set result [oauth::params_to_dict $data]
	dict append result auth_url ${oauth::authorize_url}?[http::formatQuery oauth_token [dict get $result oauth_token]]

	return $result
	}

	# second step
	# for twitter, oauth_verifier is pin
	# oauth_token & oauth_token_secret from get_request_token
	proc oauth::get_access_token {consumer_key consumer_secret oauth_token oauth_token_secret oauth_verifier} {
	set params [list [list oauth_token $oauth_token] [list oauth_verifier $oauth_verifier]]
	set result [oauth::query_call $oauth::access_token_url $consumer_key $consumer_secret POST $params]

	# dict has oauth_token, oauth_token_secret (different than before), ...
	return [oauth::params_to_dict $result]
	}

	# after first two steps succeed, we now can make api requests to twitter
	# query_dict is POST request to twitter as before, key:value pairing (dict)
	# oauth_token, oauth_token_secret from get_access_token
	proc oauth::query_api {url consumer_key consumer_secret method oauth_token oauth_token_secret query_dict} {
	set params [list [list oauth_token $oauth_token]]
	set result [oauth::query_call $url $consumer_key $consumer_secret $method $params $query_dict $oauth_token_secret]
	return $result
	}

	# build header & query, call http request and return result
	# params stay in oauth header
	# sign_params are only used in base string for signing (optional) - dict
	proc oauth::query_call {url consumer_key consumer_secret method params {sign_params {}} {token_secret {}}} {
	set oauth_raw [dict create oauth_nonce [oauth::nonce]]
	dict append oauth_raw oauth_signature_method HMAC-SHA1
	dict append oauth_raw oauth_timestamp [clock seconds]
	dict append oauth_raw oauth_consumer_key $consumer_key
	dict append oauth_raw oauth_version 1.0

	# variable number of params
	foreach param $params {
	dict append oauth_raw {*}$param
	}

	# second oauth_raw holds data to be signed but not placed in header
	set oauth_raw_sign $oauth_raw
	foreach key [dict keys $sign_params] {
	dict append oauth_raw_sign $key [dict get $sign_params $key]
	}

	set signature [oauth::signature $url $consumer_secret $method $oauth_raw_sign $token_secret]
	dict append oauth_raw oauth_signature $signature

	set oauth_header [oauth::oauth_header $oauth_raw]
	set oauth_query [oauth::uri_escape $sign_params]

	return [oauth::query $url $method $oauth_header $oauth_query]
	}

	# do http request with oauth header
	proc oauth::query {url method oauth_header {query {}}} {
	set header [list Authorization [concat "OAuth" $oauth_header]]
	if {$method != "GET"} {
	set token [http::geturl $url -headers $header -query $query -method $method -timeout $oauth::timeout]
	} else {
	set token [http::geturl $url -headers $header -method $method -timeout $oauth::timeout]
	}
	set data [http::data $token]
	set ncode [http::ncode $token]
	set status [http::status $token]
	http::cleanup $token
	if {$status == "reset"} {
	error "OAuth failure: HTTP timeout"
	}
	if {$ncode != 200} {
	error "OAuth failure: (code: $ncode) $data"
	}
	return $data
	}

	# take a dict of params and create as follows:
	# create string as: key="value",...,key2="value2"
	proc oauth::oauth_header {params} {
	set header []
	foreach key [dict keys $params] {
	set header "${header}[oauth::uri_escape $key]=\"[oauth::uri_escape [dict get $params $key]]\","
	}
	return [string trimright $header ","]
	}

	# take dict of params and create as follows
	# sort params by key
	# create string as key=value&key2=value2...
	# TODO: if key matches, sort by value
	proc oauth::params_signature {params} {
	set str []
	foreach key [lsort [dict keys $params]] {
	set str ${str}[oauth::uri_escape [list $key [dict get $params $key]]]&
	}
	return [string trimright $str &]
	}

	# build signature as in section 9 of oauth spec
	# token_secret may be empty
	proc oauth::signature {url consumer_secret method params {token_secret {}}} {
	# We want base URL for signing (remove ?params=...)
	set url [lindex [split $url "?"] 0]
	set base_string [oauth::uri_escape ${method}]&[oauth::uri_escape ${url}]&[oauth::uri_escape [oauth::params_signature $params]]
	set key [oauth::uri_escape $consumer_secret]&[oauth::uri_escape $token_secret]
	set signature [sha1::hmac -bin -key $key $base_string]
	return [base64::encode $signature]
	}

	proc oauth::nonce {} {
	set nonce [clock milliseconds][expr [tcl::mathfunc::rand] * 10000]
	return [sha1::sha1 $nonce]
	}

	# wrapper around http::formatQuery which uppercases octet characters
	proc oauth::uri_escape {str} {
	set str [http::formatQuery {*}$str]
	# uppercase all %hex where hex=2 octets
	set str [regsub -all -- {%(\w{2})} $str {%[string toupper \1]}]
	return [subst $str]
	}

	# convert replies from http query into dict
	# params of form key=value&key2=value2
	proc oauth::params_to_dict {params} {
	set answer []
	foreach pair [split $params &] {
	dict set answer {*}[split $pair =]
	}
	return $answer
	}

File Metadata

Mime Type: text/x-diff
Expires: Sat, Nov 7, 14:28 (1 w, 1 d ago)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 4251287
Default Alt Text: (39 KB)

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions