--- /dev/null
+# Ignore all CVS dirs and emacs temp copies.
+CVS
+.#*
+*~
--- /dev/null
+# bf_irc.tcl -- Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Handle the IRC transport (using picoirc)
+#
+#
+
+package require picoirc 0.5; # tcllib
+
+variable ircuid
+if {![info exists ircuid]} { set ircuid -1 }
+
+proc IrcLogin {app} {
+ set dlg $app.irclogin
+ variable $dlg {}
+ variable irc
+ if {![info exists irc]} {
+ array set irc {server irc.freenode.net port 6667 channel "" passwd ""}
+ }
+ if {![winfo exists $dlg]} {
+ set dlg [toplevel $dlg -class Dialog]
+ wm withdraw $dlg
+ wm transient $dlg $app
+ wm title $dlg "IRC Login"
+
+ set f [ttk::frame $dlg.f]
+ set g [ttk::frame $f.g]
+ ttk::label $f.sl -text Server -anchor w
+ ttk::entry $f.se -textvariable [namespace which -variable irc](server)
+ ttk::entry $f.sp -textvariable \
+ [namespace which -variable irc](port) -width 5
+ ttk::label $f.nl -text Username -anchor w
+ ttk::entry $f.nn -textvariable [namespace which -variable irc](nick)
+ ttk::label $f.pl -text Password -anchor w
+ ttk::entry $f.pw -show * -textvariable [namespace which -variable irc](passwd)
+ ttk::label $f.cl -text Channel -anchor w
+ ttk::entry $f.cn -textvariable [namespace which -variable irc](channel)
+ ttk::button $f.ok -text Login -default active \
+ -command [list set [namespace which -variable $dlg] "ok"]
+ ttk::button $f.cancel -text Cancel \
+ -command [list set [namespace which -variable $dlg] "cancel"]
+
+ bind $dlg <Return> [list $f.ok invoke]
+ bind $dlg <Escape> [list $f.cancel invoke]
+ wm protocol $dlg WM_DELETE_WINDOW [list $f.cancel invoke]
+
+ grid $f.sl $f.se $f.sp -in $g -sticky new -padx 1 -pady 1
+ grid $f.nl $f.nn - -in $g -sticky new -padx 1 -pady 1
+ grid $f.pl $f.pw - -in $g -sticky new -padx 1 -pady 1
+ grid $f.cl $f.cn - -in $g -sticky new -padx 1 -pady 1
+ grid columnconfigure $g 1 -weight 1
+
+ grid $g - -sticky news
+ grid $f.ok $f.cancel -sticky e -padx 1 -pady 1
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+
+ grid $f -sticky news
+ grid rowconfigure $dlg 0 -weight 1
+ grid columnconfigure $dlg 0 -weight 1
+
+ wm resizable $dlg 0 0
+ raise $dlg
+ }
+
+ catch {::tk::PlaceWindow $dlg widget $app}
+ wm deiconify $dlg
+ tkwait visibility $dlg
+ focus -force $dlg.f.ok
+ grab $dlg
+ vwait [namespace which -variable $dlg]
+ grab release $dlg
+ wm withdraw $dlg
+
+ if {[set $dlg] eq "ok"} {
+ after idle [list [namespace origin IrcConnect] $app \
+ -server $irc(server) -port $irc(port) \
+ -channel $irc(channel) \
+ -nick $irc(nick) -passwd $irc(passwd)]
+ }
+}
+
+proc IrcConnect {app args} {
+ variable ircuid
+ set id irc[incr ircuid]
+ set Chat [namespace current]::$id
+ upvar #0 $Chat chat
+ array set chat [list app $app type irc passwd "" nick ""]
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -server { set chat(server) [Pop args 1] }
+ -port { set chat(port) [Pop args 1] }
+ -channel { set chat(channel) [Pop args 1] }
+ -nick { set chat(nick) [Pop args 1] }
+ -passwd { set chat(passwd) [Pop args 1] }
+ default {
+ return -code error "invalid option \"$option\""
+ }
+ }
+ Pop args
+ }
+ set chat(window) [chatwidget::chatwidget $app.nb.$id]
+ $chat(window) names hide
+ set chat(targets) [list]
+ set url irc://$chat(server):$chat(port)
+ if {[info exists chat(channel)] && $chat(channel) ne ""} {
+ append url /$chat(channel)
+ }
+ set chat(irc) [picoirc::connect \
+ [list [namespace origin IrcCallback] $Chat] \
+ $chat(nick) $chat(passwd) $url]
+ $chat(window) hook add post [list ::picoirc::post $chat(irc) ""]
+ bind $chat(window) <Destroy> "+unset -nocomplain $Chat"
+ $app.nb add $chat(window) -text $chat(server)
+ after idle [list $app.nb select $chat(window)]
+ return $Chat
+}
+
+proc IrcJoinChannel {Chat args} {
+ variable ircuid
+ # FIX ME:
+}
+
+proc IrcAddChannel {Chat channel} {
+ upvar #0 $Chat chat
+ set Channel "${Chat}/$channel"
+ upvar #0 $Channel chan
+ array set chan [array get chat]
+ set chan(channel) $channel
+ set chan(window) [chatwidget::chatwidget $chat(window)$channel]
+ lappend chat(targets) [list $channel $chan(window)]
+ set m0 [font measure ChatwidgetFont {[00:00]m}]
+ set m1 [font measure ChatwidgetFont [string repeat m 10]]
+ set mm [expr {$m0 + $m1}]
+ $chan(window) chat configure -tabs [list $m0 $mm]
+ $chan(window) chat tag configure MSG -lmargin1 $mm -lmargin2 $mm
+ $chan(window) chat tag configure NICK -font ChatwidgetBoldFont
+ $chan(window) chat tag configure TYPE-system -font ChatwidgetItalicFont
+ $chan(window) chat tag bind URL <Enter> [list UrlEnter %W]
+ $chan(window) chat tag bind URL <Leave> [list UrlLeave %W]
+ $chan(window) chat tag bind URL <Button-1> [list UrlClick %W %x %y]
+ $chan(window) names tag bind NICK <Button-3> \
+ [list [namespace origin IrcChannelNickMenu] $Channel %W %x %y]
+ $chan(window) names tag bind NICK <Enter> \
+ [list [namespace origin IrcNickTooltip] $Chat enter %W %x %y]
+ $chan(window) names tag bind NICK <Leave> \
+ [list [namespace origin IrcNickTooltip] $Chat leave %W %x %y]
+ $chan(window) hook add post [list ::picoirc::post $chan(irc) $channel]
+ bind $chan(window) <Destroy> "+unset -nocomplain $Channel"
+ $chat(app).nb add $chan(window) -text $channel
+ after idle [list $chat(app).nb select $chan(window)]
+ return
+}
+
+proc IrcRemoveChannel {Chat target} {
+ upvar #0 $Chat chat
+ Status $Chat "Left channel $target"
+ set w [IrcFindWindow $Chat $target]
+ if {[winfo exists $w]} { destroy $w }
+ if {[set ndx [lsearch -index 0 $chat(targets) $target]] != -1} {
+ set chat(targets) [lreplace $chat(targets) $ndx $ndx]
+ }
+}
+
+proc IrcChannelNickMenu {Channel w x y} {
+ set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
+ if {$nick eq ""} { return }
+ destroy $w.popup
+ set m [menu $w.popup -tearoff 0]
+ $m add command -label "$nick" -state disabled
+ $m add separator
+ $m add command -label "Whois" -underline 0 \
+ -command [list [namespace origin IrcChannelNickCommand] $Channel whois $nick]
+ $m add command -label "Version" \
+ -command [list [namespace origin IrcChannelNickCommand] $Channel version $nick]
+ tk_popup $m [winfo pointerx $w] [winfo pointery $w]
+}
+
+proc IrcChannelNickCommand {Channel cmd nick} {
+ upvar #0 $Channel chan
+ switch -exact -- $cmd {
+ whois { picoirc::send $chan(irc) "WHOIS $nick" }
+ version { picoirc::send $chan(irc) "PRIVMSG $nick :\001VERSION\001" }
+ default {}
+ }
+}
+
+proc IrcNickTooltip {Chat type w x y} {
+ if {[package provide tooltip] eq {}} { return }
+ set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
+ if {$nick eq ""} { return }
+ puts stderr "Tooltip $type $nick"
+ return
+}
+
+proc IrcFindWindow {Chat target} {
+ upvar #0 $Chat chat
+ set w $chat(window)
+ if {[set ndx [lsearch -nocase -index 0 $chat(targets) $target]] != -1} {
+ set w [lindex [lindex $chat(targets) $ndx] 1]
+ }
+ return $w
+}
+
+proc IrcCallback {Chat context state args} {
+ upvar #0 $Chat chat
+ upvar #0 $context irc
+ switch -exact -- $state {
+ init {
+ Status $Chat "Attempting to connect to $irc(server)"
+ }
+ connect {
+ $chat(window) message "Logging into $irc(server) as $irc(nick)" -type system
+ Status $Chat "Connection to IRC server established."
+ State $Chat connected
+ }
+ close {
+ if {[llength $args] != 0} {
+ $chat(window) message "Failed to connect: [lindex $args 0]" -type system
+ Status $Chat [lindex $args 0]
+ } else {
+ $chat(window) message "Disconnected from server" -type system
+ Status $Chat "Disconnected."
+ }
+ State $Chat !connected
+ }
+ userlist {
+ foreach {target users} $args break
+ set colors {black SteelBlue4 tomato chocolate SeaGreen4 red4
+ green4 blue4 pink4}
+ set w [IrcFindWindow $Chat $target]
+ set current [$w name list -full]
+ foreach nick $users {
+ set opts [list -status online]
+ if {[string match @* $nick]} {
+ set nick [string range $nick 1 end]
+ lappend opts -group operators
+ } else { lappend opts -group users }
+ if {[lsearch -index 0 $current $nick] == -1} {
+ lappend opts -color \
+ [lindex $colors [expr {int(rand() * [llength $colors])}]]
+ }
+ eval [list $w name add $nick] $opts
+ }
+ }
+ userinfo {
+ foreach {nick userinfo} $args break
+ array set info {name {} host {} channels {} userinfo {}}
+ array set info $userinfo
+ set chat(userinfo,$nick) [array get info]
+ }
+ chat {
+ foreach {target nick msg type} $args break
+ if {$type eq ""} {set type normal}
+ set w [IrcFindWindow $Chat $target]
+ if {$nick eq "tcl@tach.tclers.tk"} {
+ set action ""; set jnick "" ; set jnew ""
+ if {[regexp {^\s*([^ ]+) is now known as (.*)} $msg -> jnick jnew]} {
+ set action nickchange
+ } elseif {[regexp {^\s*([^ ]+) has left} $msg -> jnick]} {
+ set action left
+ } elseif {[regexp {^\s*([^ ]+) has become available} $msg -> jnick]} {
+ set action entered
+ }
+ if {$action ne ""} {
+ IrcCallbackNick $w $action $target $jnick $jnew jabber
+ return
+ }
+ }
+ $w message $msg -nick $nick -type $type
+ }
+ system {
+ foreach {target msg} $args break
+ [IrcFindWindow $Chat $target] message $msg -type system
+ }
+ topic {
+ foreach {target topic} $args break
+ set w [IrcFindWindow $Chat $target]
+ $w topic show
+ $w topic set $topic
+ }
+ traffic {
+ foreach {action target nick new} $args break
+ if {$nick eq $irc(nick)} {
+ switch -exact -- $action {
+ left { IrcRemoveChannel $Chat $target }
+ entered { IrcAddChannel $Chat $target}
+ nickchange { set irc(nick) $new }
+ }
+ }
+ if {$target ne {}} {
+ set w [IrcFindWindow $Chat $target]
+ IrcCallbackNick $w $action $target $nick $new
+ } else {
+ foreach window_target $chat(targets) {
+ foreach {window_channel w} $window_target break
+ set current [$w name list -full]
+ if {[lsearch -index 0 $current $nick] != -1} {
+ IrcCallbackNick $w $action $target $nick $new
+ }
+ }
+ }
+ }
+ debug {
+ foreach {type line} $args break
+ Debug $Chat $line $type
+
+ # You can log raw IRC to file by uncommenting the following lines:
+ #if {![info exists chat(log)]} {set chat(log) [open irc.log a]}
+ #puts $chat(log) "[string toupper [string range $type 0 0]] $line"
+ }
+ version { return "" }
+ default {
+ $chat(window) message "unknown irc callback \"$state\": $args" -type error
+ }
+ }
+}
+
+proc IrcCallbackNick {w action target nick new {group users}} {
+ #puts stderr "process traffic $w $nick $action $new $target"
+ if {$action eq "nickchange"} {
+ $w name delete $nick
+ $w name add $new -group $group
+ $w message "$nick changed to $new" -type system
+ } else {
+ switch -exact -- $action {
+ left { $w name delete $nick }
+ entered { $w name add $nick -group $group }
+ }
+ $w message "$nick $action" -type system
+ }
+}
--- /dev/null
+# Present a callback interface akin to the picoirc callback.
+# The idea is to have the picoirc application be able to use multiple transports
+# with only the callback being the comms interface.
+#
+#
+# TODO:
+#
+# One-to-one chats should show the nick name - either from the
+# additional elements in the message stanza, or the resource if from a
+# groupchat source or just the node.
+# They also don't need a names window.
+# We must echo our own messages in such a window.
+# <message xmlns='jabber:client'
+# to='patthoyts@all.tclers.tk/Bullfrog'
+# type='chat'
+# from='tcl@tach.tclers.tk/rmax'>
+# <body>:)</body>
+# <x xmlns='urn:tkchat:chat' color='660016'/>
+# </message>
+#
+package require jlib
+package require jlib::connect
+package require jlib::disco
+package require jlib::roster
+package require jlib::muc
+package require jlib::caps
+package require jlib::vcard
+
+package require uuid
+package require messagewidget
+
+namespace eval ::xmppplugin {
+ variable version 0.2
+ variable uid; if {![info exists uid]} { set uid 0 }
+ variable defaults {
+ -server "all.tclers.tk"
+ -resource "Bullfrog"
+ -port 5222
+ -channel "tcl@tach.tclers.tk"
+ callback ""
+ motd {}
+ users {}
+ }
+ namespace export connect send post splituri
+}
+
+proc ::xmppplugin::connect {callback args} {
+ variable defaults
+ variable uid
+ set context [namespace current]::xmpp[incr uid]
+ upvar #0 $context xmpp
+ array set xmpp $defaults
+ array set xmpp $args ;# see XmppLogin for the list of pairs
+
+ set xmpp(callback) $callback
+ set xmpp(jlib) [jlib::new [namespace origin OnNetwork] \
+ -messagecommand [namespace origin OnMessage] \
+ -presencecommand [namespace origin OnPresence] \
+ -iqcommand [namespace origin OnIq] \
+ -keepalivesecs 90 \
+ -autodiscocaps 1]
+
+ # IQ handlers
+ $xmpp(jlib) iq_register get jabber:iq:version \
+ [namespace code [list OnIqVersion $context]] 40
+ $xmpp(jlib) iq_register get jabber:iq:last \
+ [namespace code [list OnIqLast $context]] 40
+ $xmpp(jlib) iq_register result jabber:iq:version \
+ [namespace code [list OnIqVersionResult $context]] 40
+
+ # Presence handlers
+ $xmpp(jlib) roster register_cmd [list [namespace origin OnRosterChange] $context]
+ $xmpp(jlib) presence_register available \
+ [namespace code [list OnPresenceChange $context]]
+ $xmpp(jlib) presence_register unavailable \
+ [namespace code [list OnPresenceChange $context]]
+
+ # Discovery support
+ $xmpp(jlib) disco registeridentity client pc Bullfrog
+ foreach feature {jabber:client jabber:iq:last jabber:iq:time \
+ jabber:iq:version jabber:x:event} {
+ jlib::disco::registerfeature $feature
+ }
+
+ #$xmpp(jlib) caps register ? ? ?
+ set [set xmpp(jlib)]::AppContext $context
+ Callback $context init
+ set xmpp(jid) [jlib::joinjid $xmpp(-username) $xmpp(-server) $xmpp(-resource)]
+ $xmpp(jlib) connect init
+ $xmpp(jlib) connect configure -defaultresource $xmpp(-resource)
+
+ if {$xmpp(-useproxy)} {
+ # this one traverses an http proxy:
+ if {$xmpp(-connect) eq "plain"} {set method sasl} else {set method ssl}
+ $xmpp(jlib) connect connect $xmpp(jid) $xmpp(-passwd) \
+ -command [list [namespace origin OnConnect] $context] \
+ -secure 1 -method $method -transport tunnel\
+ -ip $xmpp(-server) -port $xmpp(-port)
+ } else {
+ $xmpp(jlib) connect connect $xmpp(jid) $xmpp(-passwd) \
+ -command [list [namespace origin OnConnect] $context] \
+ -secure 1 -method tlssasl \
+ -ip $xmpp(-server) -port $xmpp(-port)
+ }
+ return $context
+}
+
+proc ::xmppplugin::post {ctx channel msg} {
+ upvar #0 $ctx xmpp
+ if {[string match "/*" $msg]} {
+ switch -glob -- $msg {
+ "/join *" {
+ set target [string trim [string range $msg 6 end]]
+ JoinMUC $ctx $target $xmpp(jlib) $xmpp(-nick)
+ return
+ }
+ "/part*" - "/close*" {
+ set target [string trim [string range $msg 6 end]]
+ if {$target eq ""} {set target $channel}
+ if {[$xmpp(jlib) muc isroom $target]} {
+ $xmpp(jlib) muc exit $target ;# no -command it seems
+ } else {
+ #$xmpp(jlib) send_presence -type unavailable -to who
+ }
+ Callback $ctx close $target
+ return
+ }
+ "/nick *" {
+ set nick [string trim [string range $msg 6 end]]
+ $xmpp(jlib) muc setnick $channel $nick
+ set xmpp(-nick) $nick ;# should be ony if it works.
+ Callback $ctx userlist muc $target
+ return
+ }
+ "/users*" - "/userlist*" {
+ set target $channel
+ regexp {^/users?(?:list)?(?:\s+(.*))?$} $msg -> target
+ if {[$xmpp(jlib) muc isroom $target]} {
+ Callback $ctx userlist muc $target
+ } else {
+ Callback $ctx userlist roster
+ }
+ return
+ }
+ "/create *" {
+ set target [string trim [string range $msg 8 end]]
+ $xmpp(jlib) muc create $target $xmpp(-nick) \
+ [namespace code [list OnMucCreate $ctx $target]]
+ return
+ }
+ "/invite *" {
+ if {[regexp {^/invite\s+(\S+)\s+(.*)$} $msg -> who reason]} {
+ $xmpp(jlib) muc invite $channel $who -reason $reason
+ } else {
+ Callback $ctx system $channel "usage: /invite jid ?reason?"
+ }
+ return
+ }
+ "/me *" { }
+ default {
+ Callback $ctx system $channel "unrecognised chat command '$msg'"
+ return
+ }
+ }
+ }
+
+ # Check the type of channel and for one-to-one chat re-use the thread
+ # or create a thread if this is a new conversation.
+ set type groupchat
+ set thread ""
+ if {![$xmpp(jlib) muc isroom $channel]} {
+ set type chat
+ catch {set thread [dict get $xmpp(opts) $channel -thread]}
+ if {$thread eq ""} {set thread [uuid::uuid generate] }
+ }
+
+ if {[catch {dict get $xmll(opts) $channel -chatstate} chatstate]} {
+ set chatstate active
+ }
+
+ lappend xlist [wrapper::createtag x \
+ -attrlist {xmlns urn:tkchat:chat color 387070}]
+ if {$chatstate ne {}} {
+ lappend xlist [wrapper::createtag $chatstate \
+ -attrlist {xmlns http://jabber.org/protocol/chatstates}]
+ }
+ set margs [list -type $type -body $msg -xlist $xlist]
+ if {$thread ne ""} { lappend margs -thread $thread }
+ eval [linsert $margs 0 $xmpp(jlib) send_message $channel]
+ if {$type eq "chat"} {
+ set mtype normal
+ if {[string match "/me *" $msg]} { set mtype action }
+ Callback $ctx chat $channel $xmpp(-nick) $msg $mtype
+ }
+}
+
+proc ::xmppplugin::Callback {ctx state args} {
+ upvar #0 $ctx xmpp
+ if {[llength $xmpp(callback)] > 0
+ && [llength [info commands [lindex $xmpp(callback) 0]]] == 1} {
+ if {[catch {eval $xmpp(callback) [list $ctx $state] $args} err]} {
+ puts stderr "callback error \"$state\": $err"
+ }
+ }
+}
+
+proc ::xmppplugin::Version {ctx} {
+ global tcl_platform
+ if {[catch {Callback $ctx version} ver]} { set ver {} }
+ if {$ver eq {}} {
+ set os $tcl_platform(os)
+ if {[info exists tcl_platform(osVersion)]} {
+ append os " $tcl_platform(osVersion)"
+ }
+ append os "/Tcl [info patchlevel]"
+ set os [string map {":" ";"} $os]
+ set ver "Bullfrog:[package provide xmppplugin]:$os"
+ }
+ return $ver
+}
+
+proc ::xmppplugin::get_caps {ctx} {
+ foreach {name ver os} [split [Version $ctx] :] break
+ set caps [wrapper::createtag c -attrlist \
+ [list xmlns "http://jabber.org/protocol/caps" \
+ node "http://tkchat.tclers.tk/$name/caps" \
+ ver $ver ext {color time}]]
+ return $caps
+}
+
+proc ::xmppplugin::Log {ctx msg {type {}}} {
+ Callback $ctx debug system $msg
+}
+
+proc ::xmppplugin::OnAnything {ctx args} {
+ Log $ctx "Anything: $args"
+}
+
+proc ::xmppplugin::OnNetwork {jlib cmd args} {
+ puts stderr "-- OnNetwork $jlib $cmd $args"
+ set ctx [set [set jlib]::AppContext]
+ if {[catch {
+ array set a [linsert $args 0 -body {} -errormsg {}]
+ switch -glob -- $cmd {
+ connect { Log $ctx "* connected" }
+ disconnect {
+ Log $ctx "* disconnected"
+ Callback $ctx disconnect "disconnected"
+ }
+ networkerror {
+ Log $ctx "* Network error: $a(-body)"
+ Callback $ctx disconnect "network error: $a(-body)"
+ }
+ xmpp-streams-error-* - streamerror {
+ Log $ctx "* Stream error: $a(-errormsg)"
+ Callback $ctx disconnect "stream error: $a(-errormsg)"
+ }
+ xmlerror {
+ Log $ctx "* XML parse error: $a(-errormsg)"
+ Callback $ctx disconnect "xml error: $a(-errormsg)"
+ }
+ default { Log $ctx "* Default: $cmd $args" }
+ }
+ } err]} { Log $ctx "OnNetwork: $err" error }
+}
+
+proc ::xmppplugin::OnConnect {ctx jlib type args} {
+ Log $ctx "OnConnect $ctx $jlib $type $args"
+ upvar #0 $ctx xmpp
+ switch -exact -- $type {
+ initnetwork { Log $ctx "$type $args" }
+ initstream { Log $ctx "$type $args" }
+ authenticate { Log $ctx "$type $args" }
+ ok {
+ Callback $ctx connect
+ $jlib send_presence
+ $jlib send_presence -priority 2 -extras [list [get_caps $ctx]]
+ $jlib roster send_get -command [list [namespace origin OnRosterGet] $ctx]
+ if {$xmpp(-autoconnect) && $xmpp(-channel) ne {}} {
+ Log $ctx "Attempting to join $xmpp(-channel)"
+ JoinMUC $ctx $xmpp(-channel) $jlib $xmpp(-nick)
+ }
+ }
+ error {
+ Log $ctx "network error: $args"
+ Callback $ctx close
+ Callback $ctx disconnect $args
+ }
+ }
+}
+
+proc ::xmppplugin::JoinMUC {ctx channel jlib nick} {
+ #set t 1202713200
+ #set since [list since [clock format $t -format {%Y-%m-%dT%T}]]
+ set since [list maxstanzas 100]
+ set x [wrapper::createtag x \
+ -attrlist {xmlns http://jabber.org/protocol/muc} \
+ -subtags [list [wrapper::createtag history \
+ -attrlist $since]]]
+ Callback $ctx addchat $channel groupchat
+ $jlib muc enter $channel $nick -extras [list $x] \
+ -command [list [namespace origin OnMucEnter] $ctx $channel]
+}
+
+proc ::xmppplugin::OnMucEnter {ctx channel jlib xmldata} {
+ if {[catch {
+ #puts stderr "MucEnter: $xmldata"
+ switch -exact -- [wrapper::getattribute $xmldata type] {
+ "" - available {
+ Log $ctx "Joined $channel"
+ Callback $ctx traffic joining $channel
+ after idle [list [namespace origin Callback] \
+ $ctx userlist muc $channel]
+ # FIX ME: cause history loading
+ # FIX ME: send custom presence to the conference for auto-away?
+ }
+ error {
+ set e [wrapper::getfirstchildwithtag $xmldata error]
+ set code [wrapper::getattribute $e code]
+ set msg {}
+ switch -exact -- $code {
+ 401 { set msg "This conference is password protected." }
+ 403 { set msg "You have been banned from this conference." }
+ 404 { set msg "The requested server does not exist." }
+ 405 { set msg "The maximum number of participants has been reached."}
+ 407 { set msg "You must be a member to enter this conference." }
+ 409 {
+ # nick conflict
+ upvar #0 $ctx xmpp
+ set n 0 ; set nick $xmpp(-nick)
+ regexp {^(.*)/(\d+)$} $nick -> nick n
+ set xmpp(-nick) $nick/[incr $n]
+ JoinMUC $ctx $channel $jlib $xmpp(-nick)
+ }
+ default {
+ set msg "An unknown error was returned on attempting to join the\
+ conference."
+ }
+ }
+ if {$msg ne {}} {
+ tk_messageBox -icon error -title "Failed to join conference" \
+ -message $msg
+ }
+ }
+ }
+ } err]} {
+ puts stderr "OnMucEnter: $err {$ctx $channel}"
+ }
+}
+proc ::xmppplugin::OnMucCreate {ctx channel jlib xmldata} {
+ if {[catch {
+ Log $ctx "MucCreate $xmldata"
+ set x [wrapper::getchildswithtagandxmlns $xmldata x \
+ "http://jabber.org/protocol/muc#user"]
+ if {[llength $x] > 0} {
+ set status [wrapper::getchildswithtag [lindex $x 0] status]
+ array set s [linsert [wrapper::getattrlist [lindex $status 0]] 0 code 0]
+ switch -exact -- $s(code) {
+ 201 {
+ $jlib muc getroom $channel \
+ [namespace code [list OnMucConfigure $ctx $channel]]
+ }
+ default {
+ Callback $ctx system $channel "muc create code $s(code)!"
+ }
+ }
+ }
+ } err]} { puts stderr "OnMucCreate $err" }
+}
+proc ::xmppplugin::OnMucConfigure {ctx channel jlib type subiq} {
+ if {[catch {
+ set form [lindex [wrapper::getchildswithtagandxmlns $subiq x jabber:x:data] 0]
+ #set r [ShowForm $form]
+ $jlib muc setroom $channel submit -form [list $form] \
+ -command [namespace code [list OnMucConfigured $ctx $channel]]
+ } err]} { puts stderr "OnMucConfigure $err" }
+}
+proc ::xmppplugin::OnMucConfigured {ctx channel jlib type subiq} {
+ upvar #0 $ctx xmpp
+ if {[catch {
+ $jlib muc enter $channel $xmpp(-nick) \
+ -command [list [namespace origin OnMucEnter] $ctx $channel]
+ } err]} { puts stderr "OnMucConfigured $err" }
+}
+
+proc ::xmppplugin::ShowForm {ctx form} {
+ set dlg [toplevel .xmppform -class Dialog]
+ wm title $dlg "Configure room"
+ wm withdraw $dlg
+ set f [ttk::frame $dlg.f]
+ set wid 0
+ foreach field [wrapper::getchildren $form] {
+ set ftag [wrapper::gettag $field]
+ puts "$ftag"
+ switch -exact -- [wrapper::gettag $field] {
+ title { wm title $dlg [wrapper::getcdata $field] }
+ instructions {
+ set w [ttk::label $f.w[incr wid] -text [wrapper::getcdata $field]]
+ grid $w - -sticky news
+ }
+ field {
+ array set a [linsert [wrapper::getattrlist $field] 0 type {}]
+ switch -exact -- $a(type) {
+ hidden {}
+ text-single {}
+ text-multi {}
+ fixed {
+ set txt {}
+ foreach node [wrapper::getchildswithtag $field "value"] {
+ lappend txt [wrapper::getcdata $node]
+ }
+ set w [ttk::label $f.w[incr wid] -text [join $txt "\n"]
+ grid $w - -sticky news
+ }
+ boolean {
+ set w [ttk::checkbutton $f.w[incr wid] -text $a(label)]
+ grid $w - -sticky news
+ }
+ list-single {}
+
+ }
+ }
+ }
+ }
+ set b0 [ttk::button $f.ok -text OK -default active \
+ -command [list set [namespace current]::$dlg ok]]
+ set b1 [ttk::button $f.cn -text Cancel -default normal \
+ -command [list set [namespace current]::$dlg cancel]]
+
+ grid $b0 $b1 -sticky e
+ grid rowconfigure $f [incr n] -weight 1
+ grid columnconfigure $f 2 -weight 1
+ grid $f -sticky news
+ grid rowconfigure $dlg 0 -weight 1
+ grid columnconfigure $dlg 0 -weight 1
+
+ bind $dlg <Return> [list $b0 invoke]
+ bind $dlg <Escape> [list $b1 invoke]
+ wm deiconify $dlg
+ set [namespace current]::$dlg waiting
+ tkwait variable [namespace current]::$dlg
+ set r [set [namespace current]::$dlg]
+ unset [namespace current]::$dlg
+ destroy $dlg
+ return $r
+}
+
+
+proc ::xmppplugin::OnIqVersion {ctx jlib from subiq args} {
+ array set a [linsert $args 0 -id {}]
+ set opts [list -to $from]
+ if {$a(-id) ne {}} {lappend opts -id $a(-id)}
+ foreach {cname cver cos} [split [Version $ctx] :] break
+ set subtags [list \
+ [wrapper::createtag name -chdata $cname] \
+ [wrapper::createtag version -chdata $cver] \
+ [wrapper::createtag os -chdata $cos]]
+ set xmllist [wrapper::createtag query -subtags $subtags \
+ -attrlist {xmlns jabber:iq:version}]
+ eval [linsert $opts 0 $jlib send_iq result [list $xmllist]]
+ return 1 ;# handled
+}
+
+proc ::xmppplugin::OnIqLast {ctx jlib from subiq args} {
+ if {[catch {tk inactive} last]} {
+ return 0 ;# not handled
+ }
+ set last [expr {int($last / 1000.0)}]
+ array set a [linsert $args 0 -id {}]
+ set opts [list -to $from]
+ if {$a(-id) ne {}} { lappend opts -id $a(-id) }
+ set xml [wrapper::createtag query \
+ -attrlist [list xmlns jabber:id:last seconds $last]]
+ eval [linsert $opts 0 $jlib send_iq result [list $xml]]
+ return 1 ;# handled
+}
+
+proc ::xmppplugin::OnIqVersionResult {ctx jlib from subiq args} {
+ upvar #0 $ctx xmpp
+ if {[catch {
+ array set a [linsert $args 0 -id {}]
+ jlib::splitjid $from jid nick
+ puts stderr "result: $jid $nick => $xmpp(-channel)"
+ if {[jlib::jidequal $jid $xmpp(-channel)]} {
+ array set data {}
+ foreach sub [wrapper::getchildren $subiq] {
+ set data([wrapper::gettag $sub]) [wrapper::getcdata $sub]
+ }
+ set ver ""
+ if {[info exists data(name)]} { append ver $data(name) }
+ if {[info exists data(version)]} { append ver " " $data(version) }
+ if {[info exists data(os)]} { append ver " : $data(os)" }
+ set xmpp(userversion,$nick) $ver
+ Callback $ctx userinfo $xmpp(-channel) $nick -version $ver
+ Log $ctx "$nick: $ver"
+ }
+ } err]} {
+ tk_messageBox -icon error -message $err \
+ -title "Error handling version result"
+ }
+ return 1 ;# handled
+}
+
+# initiate from $jlib vcard get_async $jid [namespace code OnVCard]
+# once got - try get_cache if getcache is {} then do above.
+proc ::xmppplugin::OnVCard {jlib type xmldata} {
+ switch -exact -- $type {
+ result {
+ foreach kid [wrapper::getchildren $xmldata] {
+ # tags are FN, NICKNAME, URL etc
+ }
+ }
+ error {
+ foreach {code text} $xmldata break
+
+ }
+ }
+}
+
+proc ::xmppplugin::OnRosterGet {ctx args} {
+ if {[catch {
+ Log $ctx "Recieved roster"
+ after idle [list [namespace origin Callback] $ctx userlist roster]
+ } err]} { puts stderr "OnRosterGet: $err" }
+ return 0;
+}
+
+proc ::xmppplugin::OnRosterChange {ctx jlib what {jid {}} args} {
+ #Log $ctx "Roster '$what' '$jid' '$args'"
+ #enterroster | exitroster | set jid args | remove jid |
+ #switch -exact -- $what {}
+ return 0
+}
+
+# Look for MUC presence changes
+proc ::xmppplugin::OnPresenceChange {ctx jlib xmldata} {
+ if {[catch {
+ set x [lindex [wrapper::getchildswithtagandxmlns $xmldata x \
+ "http://jabber.org/protocol/muc#user"] 0]
+ if {[llength $x] > 0} {
+ array set a [linsert [wrapper::getattrlist $xmldata] 0 type available]
+ jlib::splitjid $a(from) room nick
+ # avoid people just becoming active/inactive
+ if {$a(type) eq "available"} {
+ if {[set present [lsearch [$jlib muc participants $room] $a(from)]] == -1} {
+ set status [wrapper::getcdata \
+ [wrapper::getfirstchildwithtag $xmldata status]]
+ Callback $ctx traffic entered $room $nick -status $status
+ } else {
+ Log $ctx "presence available for $nick who is present index $present"
+ }
+
+ # update the userlist
+ set details {}
+ lappend details -show [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata show]]
+ lappend details -status [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata status]]
+ lappend details -priority [wrapper::getcdata [wrapper::getfirstchildwithtag $xmldata priority]]
+ # x/item contains attrs jid (full jid), affiliation and role
+ if {[set item [wrapper::getfirstchildwithtag $x item]] ne {}} {
+ lappend details -jid [wrapper::getattribute $item jid]
+ lappend details -role [wrapper::getattribute $item role]
+ lappend details -affiliation [wrapper::getattribute $item affiliation]
+ }
+ eval [linsert $details 0 Callback $ctx userinfo $room $nick]
+ } elseif {$a(type) eq "unavailable"} {
+ set status [wrapper::getcdata \
+ [wrapper::getfirstchildwithtag $xmldata status]]
+ Callback $ctx traffic left $room $nick -status $status
+ }
+ }
+ } err]} { puts stderr "OnPresenceChange: $err" }
+ return 0
+}
+
+proc ::xmppplugin::OnPresence {jlib xmldata} {
+ set ctx [set [set jlib]::AppContext]
+ if {[catch {OnPresence2 $ctx $jlib $xmldata} res]} {
+ Log $ctx "OnPresence: $err" error
+ return 0
+ }
+ return $res
+}
+proc ::xmppplugin::OnPresence2 {ctx jlib xmldata} {
+ #Log $ctx "P: $xmldata"
+ return 0
+}
+
+proc ::xmppplugin::OnIq {jlib xmldata} {
+ set ctx [set [set jlib]::AppContext]
+ if {[catch {OnIq2 $ctx $jlib $xmldata} res]} {
+ Log $ctx "OnIq: $err" error
+ return 0
+ }
+ return $res
+}
+proc ::xmppplugin::OnIq2 {ctx jlib xmldata} {
+ Log $ctx "IQ: $xmldata"
+ return 0
+}
+
+proc ::xmppplugin::OnMessage {jlib xmldata} {
+ set ctx [set [set jlib]::AppContext]
+ if {[catch {OnMessage2 $ctx $jlib $xmldata} err]} {
+ Log $ctx "OnMessage: $err" error
+ }
+ return 0
+}
+proc ::xmppplugin::OnMessage2 {ctx jlib xmldata} {
+ upvar #0 $ctx xmpp
+ array set a [linsert [wrapper::getattrlist $xmldata] 0 from {} to {} type normal]
+ jlib::splitjid $a(from) fromjid fromres
+ jlib::splitjid $a(to) tojid tores
+ set body [wrapper::getchildswithtag $xmldata body]
+ set subject [string trim [wrapper::getcdata \
+ [wrapper::getfirstchildwithtag $xmldata subject]]]
+ set thread [string trim [wrapper::getcdata \
+ [wrapper::getfirstchildwithtag $xmldata thread]]]
+ set chatstate [wrapper::gettag \
+ [wrapper::getfirstchildwithxmlns $xmldata http://jabber.org/protocol/chatstates]]
+
+ foreach x [wrapper::getchildswithtag $xmldata x] {
+ switch -exact -- [wrapper::getattribute $x xmlns] {
+ "jabber:x:delay" {}
+ "jabber:x:event" {}
+ "urn:tkchat:chat" {
+ set color [wrapper::getattribute $x color]
+ if {[regexp {^[[:xdigit:]]{6}$} $color]} {
+ Callback $ctx userlist update $fromjid $fromres -color "#$color"
+ }
+ }
+ "urn:tkchat:changenick" {}
+ "urn:tkchat:whiteboard" {}
+ "coccinella:whiteboard" {}
+ }
+ }
+
+ switch -exact -- $a(type) {
+ groupchat {
+ #Log $ctx "groupchat: $a(from)->$a(to)"
+ if {$subject ne {}} {
+ Callback $ctx topic $fromjid $subject
+ }
+ set msg [wrapper::getcdata [lindex $body 0]]
+ set what normal
+ if {$fromres eq "ijchain"} {
+ if {![regexp {^(<.*?>)\s(.*)$} $msg -> fromres msg]} {
+ # *** x left | *** x entered | *** x is now known as y
+ if {[regexp {\*{3} ([^\s]+)\s(.*)$} $msg -> fromres msg]} {
+ set newnick {} ; set what unknown
+ switch -glob -- $msg {
+ joins* -
+ entered* { set what entered }
+ leaves* -
+ left* { set what left }
+ is* {
+ set what nickchange
+ set newnick [lindex [split $msg] 4]
+ }
+ }
+ Callback $ctx traffic $what $fromjid $fromres $newnick -group irc
+ return 0
+ } elseif {[regexp {^\* (\S+) (.*)$} $msg -> fromres msg]} {
+ set what action
+ }
+ }
+ }
+ if {[string match "/me *" $msg]} {
+ set what action
+ set msg [string range $msg 3 end]
+ }
+ if {[string length $msg] > 0} {
+ Callback $ctx chat $fromjid $fromres $msg $what
+ }
+ }
+ chat {
+ # subject? could show the topic if we ever get such an element.
+
+ # record the current conversation thread or create one
+ if {$thread eq {}} { set thread [uuid::uuid generate] }
+ # maintain per chat state in dicts. Note: we should receive an active
+ # from the remote client in response to our initial message which enables
+ # chatstate support.
+ dict set xmpp(opts) $a(from) \
+ [dict create -thread $thread -chatstate $chatstate]
+
+ set nick [string trim [wrapper::getcdata \
+ [wrapper::getfirstchildwithtag $xmldata nick]]]
+ if {$nick eq {}} {
+ jlib::splitjid $a(from) node resource
+ if {[$jlib muc isroom $node]} {
+ set nick $resource
+ } else {
+ set nick $node
+ }
+ }
+ # if chatstate stuff -- display somehow
+ if {[llength $body] > 0} {
+ Callback $ctx chat $a(from) $nick \
+ [wrapper::getcdata [lindex $body 0]] normal
+ }
+ }
+ normal {
+ set nicktag [wrapper::getchildswithtag $xmldata nick]
+ jlib::splitjid $a(from) from res
+ if {[llength $nicktag] >0} {
+ set from "[wrapper::getcdata [lindex $nicktag 0]] <$from>"
+ }
+ set time [clock seconds]
+ set delay [lindex [wrapper::getchildswithtag $xmldata delay] 0]
+ if {$delay ne {}} {
+ set stamp [wrapper::getattribute $delay stamp]
+ catch {set time [clock scan $da(stamp) \
+ -format {%Y-%m-%dT%H:%M:%S%Z}]}
+ }
+ set p [list -date $time -subject $subject]
+ if {$thread ne {}} {lappend p -thread $thread}
+ lappend p -body [wrapper::getcdata [lindex $body 0]]
+ eval [linsert $p 0 Callback $ctx message $a(to) $from]
+ }
+ headline {
+ Callback $ctx chat $a(to) $a(from) \
+ "header: [wrapper::etcdata [lindex $body 0]]" normal
+ Log $ctx "$a(from)->$a(to) headline $xmldata"
+ }
+ error {
+ # If we receive a error from a chat partner we must stop the thread and
+ # avoid sending anything else.
+ # Had thread, gone(chatstate) and <error code='404'>Not Found</error>
+ Log $ctx "Message error: $xmldata" error
+ set err [wrapper::getchildswithtag $xmldata error]
+ set emsg [wrapper::getcdata [lindex $err 0]]
+ Callback $ctx system $a(from) "error from $a(from): $emsg"
+ }
+ default {
+ set body [wrapper::getcdata [lindex $body 0]]
+ Log $ctx "message: $a(type) $a(from)->$a(to): $subject\n$body"
+ }
+ }
+}
+
+
+proc ::xmppplugin::query_user {Chat user what} {
+ upvar #0 $Chat ctx
+ upvar #0 $ctx(xmpp) xmpp
+
+ array set q {
+ version "jabber:iq:version"
+ last "jabber:iq:last"
+ time "jabber:iq:time"
+ discover "http://jabber.org/protocol/disco#info"
+ }
+ if {![info exists q($what)]} {
+ return -code error "invalid query \"$what\": must be one of\
+ [join [array names q] {, }]"
+ }
+
+ if {[string first @ $user] == -1} {
+ set jid $xmpp(-channel)/$user
+ } else {
+ set jid $user
+ }
+ set xmllist [wrapper::createtag query -attrlist [list xmlns $q($what)]]
+ $xmpp(jlib) send_iq get [list $xmllist] -to $jid
+ return
+}
+
+package provide xmppplugin $::xmppplugin::version
+
+# -------------------------------------------------------------------------
+# APPLICATION LEVEL CODE
+# -------------------------------------------------------------------------
+variable xmppuid
+if {![info exists xmppuid]} { set xmppuid 0 }
+
+proc Grid {w junk row junk column} {
+ grid rowconfigure $w $row -weight 1
+ grid columnconfigure $w $column -weight 1
+}
+proc Var {arrayname key} {
+ set n [uplevel 1 namespace which -variable $arrayname]
+ if {$n eq {}} { return -code error "invalid variable name \"$arrayname\"" }
+ return $n\($key\)
+}
+proc EnableChildren { parent varname } {
+ upvar #0 $varname var
+ set state [expr {$var ? "normal" : "disabled"}]
+ foreach child [winfo children $parent] {
+ catch {EnableChildren $child $varname}
+ catch {$child configure -state $state}
+ }
+}
+
+proc XmppLogin {app} {
+ set dlg $app.xmpplogin
+ variable $dlg {}
+ variable xmpp
+ if {![info exists xmpp(-connect)]} {
+ array set xmpp {
+ -useproxy 0 -proxyhost "" -proxyport "" -proxyuser "" -proxypass ""
+ -server all.tclers.tk -port 5222 -username "" -passwd ""
+ -connect tlssasl -resource Bullfrog
+ -autoconnect 0 -channel "tcl@tach.tclers.tk" -nick ""
+ }
+ set xmpp(-proxyhost) [autoproxy::cget -proxy_host]
+ set xmpp(-proxyport) [autoproxy::cget -proxy_port]
+ puts stderr "proxy: $xmpp(-proxyhost) $xmpp(-proxyport)"
+ }
+ if {![winfo exists $dlg]} {
+ set dlg [toplevel $dlg -class Dialog]
+ wm withdraw $dlg
+ wm transient $dlg $app
+ wm title $dlg "Login"
+
+ set f [ttk::frame $dlg.f]
+ set g [ttk::frame $f.g]
+
+ ttk::checkbutton $f.prx -text "Use proxy" \
+ -command [list EnableChildren $f.fp [Var xmpp -useproxy]] \
+ -variable [Var xmpp -useproxy] -underline 7
+ set fp [ttk::labelframe $f.fp -labelwidget $f.prx]
+ ttk::label $fp.lph -text "Proxy host:port" -underline 0
+ set fpx [ttk::frame $fp.fpx]
+ ttk::entry $fpx.eph -textvariable [Var xmpp -proxyhost]
+ ttk::entry $fpx.epp -textvariable [Var xmpp -proxyport] -width 5
+ ttk::label $fp.lpan -text "Proxy username" -underline 11
+ ttk::entry $fp.epan -textvariable [Var xmpp -proxyuser]
+ ttk::label $fp.lpap -text "Proxy password" -underline 13
+ ttk::entry $fp.epap -textvariable [Var xmpp -proxypass] -show {*}
+ grid $fpx.eph $fpx.epp -sticky news -padx 1 -pady 1
+ Grid $fpx row 0 column 0
+ grid $fp.lph $fpx -sticky new -padx 1 -pady 1
+ grid $fp.lpan $fp.epan -sticky new -padx 1 -pady 1
+ grid $fp.lpap $fp.epap -sticky new -padx 1 -pady 1
+ EnableChildren $f.fp [Var xmpp -useproxy]
+
+ ttk::label $f.sl -text Server -anchor w
+ ttk::entry $f.se -textvariable [Var xmpp -server]
+ ttk::entry $f.sp -textvariable [Var xmpp -port] -width 5
+ ttk::label $f.nl -text Username -anchor w
+ ttk::entry $f.nn -textvariable [Var xmpp -username]
+ ttk::label $f.pl -text Password -anchor w
+ ttk::entry $f.pw -textvariable [Var xmpp -passwd] -show {*}
+ ttk::label $f.rl -text Resource -anchor w
+ ttk::entry $f.re -textvariable [Var xmpp -resource]
+
+ set fo [ttk::labelframe $f.fo -text "Connection options"]
+ ttk::radiobutton $fo.ssl0 -text Normal -underline 0 \
+ -variable [Var xmpp -connect] -value tlssasl
+ ttk::radiobutton $fo.ssl1 -text SSL -underline 0 \
+ -variable [Var xmpp -connect] -value tls
+ ttk::radiobutton $fo.ssl2 -text Plain -underline 0 \
+ -variable [Var xmpp -connect] -value sasl
+ grid $fo.ssl0 $fo.ssl1 $fo.ssl2 -sticky ew -padx 1 -pady 1
+ Grid $fo row 1 column 3
+
+ ttk::checkbutton $f.acx -text "Auto-connect" \
+ -command [list EnableChildren $f.ac [Var xmpp -autoconnect]]\
+ -variable [Var xmpp -autoconnect] -underline 0
+ set fa [ttk::labelframe $f.ac -labelwidget $f.acx]
+ ttk::label $fa.cl -text Channel -anchor w
+ ttk::entry $fa.cn -textvariable [Var xmpp -channel]
+ ttk::label $fa.kl -text Nick -anchor w
+ ttk::entry $fa.kn -textvariable [Var xmpp -nick]
+ grid $fa.cl $fa.cn -sticky news -padx 1 -pady 1
+ grid $fa.kl $fa.kn -sticky news -padx 1 -pady 1
+ Grid $fa row 2 column 1
+ EnableChildren $f.ac [Var xmpp -autoconnect]
+
+ ttk::button $f.ok -text Login -default active \
+ -command [list set [namespace which -variable $dlg] "ok"]
+ ttk::button $f.cancel -text Cancel \
+ -command [list set [namespace which -variable $dlg] "cancel"]
+
+
+ bind $dlg <Return> [list $f.ok invoke]
+ bind $dlg <Escape> [list $f.cancel invoke]
+ wm protocol $dlg WM_DELETE_WINDOW [list $f.cancel invoke]
+
+ grid $f.fp - - -in $g -sticky new -padx 1 -pady 1
+ grid $f.sl $f.se $f.sp -in $g -sticky new -padx 1 -pady 1
+ grid $f.rl $f.re - -in $g -sticky new -padx 1 -pady 1
+ grid $f.nl $f.nn - -in $g -sticky new -padx 1 -pady 1
+ grid $f.pl $f.pw - -in $g -sticky new -padx 1 -pady 1
+ grid $fo - - -in $g -sticky new -padx 1 -pady 1
+ grid $fa - - -in $g -sticky new -padx 1 -pady 1
+ grid columnconfigure $g 1 -weight 1
+
+ grid $g - -sticky news
+ grid $f.ok $f.cancel -sticky e -padx 1 -pady 1
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+
+ grid $f -sticky news
+ grid rowconfigure $dlg 0 -weight 1
+ grid columnconfigure $dlg 0 -weight 1
+
+ wm resizable $dlg 0 0
+ raise $dlg
+ }
+
+ catch {::tk::PlaceWindow $dlg widget $app}
+ wm deiconify $dlg
+ tkwait visibility $dlg
+ focus -force $dlg.f.ok
+ grab $dlg
+ vwait [namespace which -variable $dlg]
+ grab release $dlg
+ wm withdraw $dlg
+
+ puts stderr [array get xmpp]
+ if {[set $dlg] eq "ok"} {
+ after idle [linsert [array get xmpp] 0 \
+ [namespace origin XmppConnect] $app]
+ }
+}
+
+proc Grid {w junk row junk column} {
+ grid rowconfigure $w $row -weight 1
+ grid columnconfigure $w $column -weight 1
+}
+
+proc XmppAddXmlConsole {app} {
+ if {[winfo exists $app.nb.xmlconsole]} { return }
+ set w [ttk::frame $app.nb.xmlconsole -style ChatwidgetFrame]
+ text $w.text -relief flat -borderwidth 0 -wrap char -state disabled \
+ -font DebugFont -yscrollcommand [list $w.vs set]
+ set m0 [font measure DebugFont {00:00:00mm}]
+ $w.text configure -tabs [list $m0 [expr {$m0 * 2}]]
+ $w.text tag configure read -foreground blue3
+ $w.text tag configure write -foreground red3
+ $w.text tag configure time -foreground "#202020"
+ $w.text tag configure msg -lmargin1 $m0 -lmargin2 $m0 -spacing3 2
+ $w.text tag configure message -foreground "#000080"
+ $w.text tag configure presence -foreground "#800080"
+ $w.text tag configure iq -foreground "#008080"
+ ttk::scrollbar $w.vs -command [list $w.text yview]
+ grid $w.text $w.vs -sticky news -padx 1 -pady 1
+ grid rowconfigure $w 0 -weight 1
+ grid columnconfigure $w 0 -weight 1
+ $app.nb add $w -text XML
+ jlib::setdebug 2
+ if {[info commands ::jlib::_Debug] eq {}} {
+ rename ::jlib::Debug ::jlib::_Debug
+ interp alias {} ::jlib::Debug {} ::XmppDebugXml $w.text
+ }
+ set ::jlib::disco::debug 2
+ if {[info commands ::jlib::disco::_Debug] eq {}} {
+ rename ::jlib::disco::Debug ::jlib::disco::_Debug
+ interp alias {} ::jlib::disco::Debug {} ::XmppDebugJlib $app
+ }
+}
+
+# Divert generic jabberlib debug stuff into our debug pane
+proc XmppDebugJlib {app num str} {
+ set w $app.nb.debug.text
+ if {[winfo exists $w]} {
+ set t [clock format [clock seconds] -format "%T"]
+ $w configure -state normal
+ $w insert end "$t\t$str\n" debug
+ $w configure -state disabled
+ }
+}
+
+# Divert the jabberlib debug function into our tab window.
+proc XmppDebugXml {w num str} {
+ if {[jlib::setdebug] >= $num} {
+ set autoscroll [expr {[lindex [$w yview] 1] == 1.0}]
+ set t [clock format [clock seconds] -format {%H:%M:%S}]
+ set tags {}
+ if {[string match "RECV:*" $str]} {
+ set str [string range $str 6 end]
+ lappend tags read
+ switch -glob -- $str {
+ "<message*" { lappend tags message }
+ "<presence*" { lappend tags presence }
+ "<iq*" { lappend tags iq }
+ }
+ } elseif {[string match "SEND:*" $str]} {
+ set str [string range $str 6 end]
+ if {[string length [string trim $str " \n"]] < 1} {return}
+ lappend tags write
+ }
+ $w configure -state normal
+ $w insert end "$t\t" time "$str\n" [linsert $tags 0 msg]
+ $w configure -state disabled
+ if {$autoscroll} { $w see end }
+ }
+}
+
+# Create the window for this XMPP session then call the xmppplugin to connect.
+proc XmppConnect {app args} {
+ variable xmppuid
+ set id xmpp[incr xmppuid]
+ set Session [namespace current]::$id
+ upvar #0 $Session session
+ #array set a [linsert $args 0 -username "" -server unknown]
+ #set session(server) $a(-server)
+ set session(app) $app
+ set session(type) xmpp
+ if {[set ndx [lsearch -exact $args -server]] != -1} {
+ set session(server) [lindex $args [incr ndx]]
+ } else {
+ set session(server) xmpp
+ }
+
+ # If debugging, add the Xml console window.
+ XmppAddXmlConsole $app
+
+ # Create a messagewidget and add to the application tabs
+ set session(window) [messagewidget::messagewidget $app.nb.$id]
+ $app.nb add $session(window) -text $session(server)
+ after idle [list $app.nb select $session(window)]
+
+ # Begin the xmpp session
+ set session(xmpp) [eval [linsert $args 0 xmppplugin::connect \
+ [list [namespace origin XmppCallback] $Session]]]
+ bind $session(window) <Destroy> "+unset -nocomplain $Session"
+ bind $session(app).nb <<NotebookTabChanged>> \
+ [namespace code "XmppUnalert $Session \[%W select\]"]
+ return $Session
+}
+
+# Add a new chatroom into the gui.
+proc XmppAddChannel {Session channel "-type" type} {
+ upvar #0 $Session session
+ set Channel "${Session}/$channel"
+ upvar #0 $Channel chan
+ array set chan [array get session]
+ Debug $Session "XmppAddChannel $channel -type $type"
+ set chan(channel) $channel
+ set chan(type) $type
+ set chan(session) $Session
+ unset -nocomplain chan(targets)
+ set chan(window) [chatwidget::chatwidget \
+ $session(window)[string map {. _} $channel]]
+ lappend session(targets) [list $channel $chan(window)]
+ set m0 [font measure ChatwidgetFont {[00:00]m}]
+ set m1 [font measure ChatwidgetFont [string repeat m 10]]
+ set mx [expr {$m0 + $m1}]
+ $chan(window) chat configure -tabs [list $m0 $mx]
+ $chan(window) chat tag configure MSG -lmargin1 $mx -lmargin2 $mx
+ $chan(window) chat tag configure NICK -font ChatwidgetBoldFont
+ $chan(window) chat tag configure TYPE-system -font ChatwidgetItalicFont
+ $chan(window) chat tag bind URL <Enter> [list UrlEnter %W]
+ $chan(window) chat tag bind URL <Leave> [list UrlLeave %W]
+ $chan(window) chat tag bind URL <Button-1> [list UrlClick %W %x %y]
+ if {$type eq "chat"} {
+ $chan(window) names hide
+ $chan(window) hook add chatstate [list XmppChatstate $Channel]
+ } else {
+ $chan(window) names tag bind NICK <Button-3> \
+ [namespace code [list XmppChannelNickMenu $Channel %W %x %y]]
+ $chan(window) names tag bind NICK <Enter> \
+ [list [namespace origin XmppNickTooltip] $Channel enter %W %x %y]
+ $chan(window) names tag bind NICK <Leave> \
+ [list [namespace origin XmppNickTooltip] $Channel leave %W %x %y]
+ $chan(window) hook add names_nick \
+ [namespace code [list XmppNamesHook $Channel]]
+ }
+ $chan(window) hook add post [list ::xmppplugin::post $chan(xmpp) $channel]
+ bind $chan(window) <Destroy> "+unset -nocomplain $Channel"
+
+ # If the channel domain is a muc then use the resource.
+ upvar #0 $chan(xmpp) xmpp
+ jlib::splitjidex $channel node domain resource
+ if {[$xmpp(jlib) muc isroom $node@$domain]} {
+ set title $resource
+ } elseif {$node ne {}} {
+ set title $node
+ } else { set title $domain }
+ $session(app).nb add $chan(window) -text $title
+ after idle [list $session(app).nb select $chan(window)]
+ return $chan(window)
+}
+
+proc XmppChatstate {Chat chatstate} {
+ upvar #0 $Chat chat
+ upvar #0 $chat(xmpp) xmpp
+ if {![catch {dict get $xmpp(opts) $chat(channel) -chatstate} use]} {
+ if {$use ne {}} {
+ lappend xlist [wrapper::createtag $chatstate \
+ -attrlist {xmlns http://jabber.org/protocol/chatstates}]
+ set margs [list -type $chat(type) -xlist $xlist]
+ if {![catch {set thread [dict get $xmpp(opts) $chat(channel) -thread]}]} {
+ lappend margs -thread $thread
+ }
+ eval [linsert $margs 0 $xmpp(jlib) send_message $chat(channel)]
+ }
+ }
+}
+
+# Hook called each time the names part of the chatwidget is updated.
+# args are the options for the nick
+proc XmppNamesHook {Chat nick args} {
+ upvar #0 $Chat chat
+ set wclass [winfo class $chat(window)]
+ #puts stderr "names hook: $Chat $nick $args class:$wclass"
+ if {[set ndx [lsearch $args -version]] != -1} {
+ if {$wclass eq "Chatwidget"} {
+ after idle [list ::tooltip::tooltip \
+ [$chat(window) names] -tag NICK-$nick \
+ [lindex $args [incr ndx]]]
+ }
+ }
+}
+
+proc XmppChannelNickMenu {Chat w x y} {
+ set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
+ if {$nick eq ""} { return }
+ destroy $w.nickmenupopup
+ set m [menu $w.nickmenupopup -tearoff 0]
+ $m add command -label "$nick" -state disabled
+ $m add separator
+ $m add command -label "Chat" -underline 0 \
+ -command [namespace code [list XmppChannelNickCommand $Chat chat $nick]]
+ $m add command -label "Whois" -underline 0 -state disabled \
+ -command [namespace code [list XmppChannelNickCommand $Chat whois $nick]]
+ $m add command -label "Version" -state normal \
+ -command [namespace code [list XmppChannelNickCommand $Chat version $nick]]
+ tk_popup $m [winfo pointerx $w] [winfo pointery $w]
+}
+
+proc XmppChannelNickCommand {Chat cmd nick} {
+ upvar #0 $Chat ctx
+ upvar #0 $ctx(xmpp) xmpp
+ switch -exact -- $cmd {
+ version { xmppplugin::query_user $Chat $nick version }
+ last { xmppplugin::query_user $Chat $nick last }
+ chat {
+ # open a private chat to a MUC user.
+ set w [XmppCreateWindow $ctx(session) $ctx(channel)/$nick -type chat]
+ $ctx(app).nb tab $w -text $nick
+ $ctx(app).nb select $w
+ }
+ send {
+ XmppCreateMessage $ctx(session) $ctx(channel)/$nick
+ }
+ }
+}
+
+proc XmppNickTooltip {Chat type w x y} {
+ return
+ if {[package provide tooltip] eq {}} { return }
+ set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
+ if {$nick eq ""} { return }
+ upvar #0 $Chat chat
+ puts stderr "tooltip: $w name $nick"
+ #return
+ set version [$chat(window) name get $nick -version]
+ if {$version ne {}} {
+ ::tooltip::tooltip $w -tag NICK-$nick $version
+ }
+ return
+}
+
+proc XmppCreateWindow {Session target "-type" type} {
+ upvar #0 $Session session
+ set w [XmppFindWindow $Session $target]
+ if {$w eq $session(window)} {
+ set w [XmppAddChannel $Session $target -type $type]
+ }
+ return $w
+}
+
+proc XmppFindWindow {Session target} {
+ upvar #0 $Session session
+ set result $session(window)
+ if {[info exists session(targets)]} {
+ foreach pair $session(targets) {
+ foreach {name wid} $pair break
+ if {$name eq $target} {
+ # check for detached window
+ if {[lsearch -exact [$session(app).nb tabs] $wid] == -1} {
+ if {[wm state $wid] eq "withdrawn"} { wm deiconify $wid }
+ } else {
+ if {[$session(app).nb tab $wid -state] eq "hidden"} {
+ $session(app).nb tab $wid -state normal
+ }
+ }
+ set result $wid
+ break
+ }
+ }
+ }
+ return $result
+}
+
+proc XmppRemoveWindow {Session target} {
+ upvar #0 $Session session
+ if {[info exists session(targets)]} {
+ foreach pair $session(targets) {
+ foreach {name wid} $pair break
+ if {$name eq $target} {
+ $session(app).nb hide $wid
+ break
+ }
+ }
+ }
+}
+
+proc XmppAlert {Session target} {
+ set alert 0
+ set w [XmppFindWindow $Session $target]
+ set top [winfo toplevel $w]
+ set focus [focus -displayof $top]
+ set txt [WindowTitle $Session $w]
+ set count 0
+ regexp {^(\d+) - (.*)$} $txt -> count txt
+ if {[string match "${w}*" $focus]} {
+ WindowTitle $Session $w $txt
+ } else {
+ WindowTitle $Session $w "[incr count] - $txt"
+ puts stderr "Alert focus:'$focus' '[focus]' state:[wm state $top]"
+ if {[llength $focus] == 0} {
+ # the focus is in some other app - check its not the console
+ if {[llength [console eval focus]] == 0} {
+ puts stderr "raising and so on"
+ wm deiconify $top
+ raise $top
+ }
+ }
+ set alert 1
+ }
+ return $alert
+}
+
+proc XmppUnalert {Session w} {
+ set title [WindowTitle $Session $w]
+ if {[regexp {^(\d+) - (.*)$} $title -> count tail]} {
+ WindowTitle $Session $w $tail
+ }
+}
+
+proc XmppCallback {Session context state args} {
+ upvar #0 $Session session
+ upvar #0 $context xmpp
+ #puts stderr [list $Session $context $state $args]
+ switch -exact -- $state {
+ init {
+ Status $Session "Attempting to connect to $xmpp(-server)"
+ }
+ connect {
+ XmppCallback $Session $context debug \
+ "Logging into $xmpp(-server) as $xmpp(-username)"
+ Status $Session "Connection to XMPP server established."
+ State $Session connected
+ }
+ disconnect {
+ foreach {reason} $args break
+ if {$reason ne {}} { set reason ": $reason" }
+ Status $Session "Disconnected$reason"
+ State $Session disconnected
+ }
+ close {
+ foreach {target} $args break
+ Debug $Session "closing $target"
+ XmppRemoveWindow $Session $target
+ }
+ addchat {
+ foreach {target type} $args break
+ set w [XmppCreateWindow $Session $target -type $type]
+ }
+ userlist {
+ foreach {type target} $args break
+ switch -exact -- $type {
+ roster {
+ foreach jid [$xmpp(jlib) roster getusers] {
+ array set item [linsert [$xmpp(jlib) roster \
+ getrosteritem $jid] 0 -groups {}]
+ if {![info exists item(-name)]} { set item(-name) $jid }
+ #$session(window) name add $item(-name) -jid $jid -group $item(-groups)
+ }
+ }
+ muc {
+ set colors {black tomato chocolate blue4 green4 pink4 SteelBlue4 SeaGreen4}
+ set w [XmppFindWindow $Session $target]
+ puts stderr "userlist: $target $w\
+ [$xmpp(jlib) muc participants $target]"
+ set current [$w name list -full]
+ foreach jid [$xmpp(jlib) muc participants $target] {
+ jlib::splitjid $jid room nick
+ set opts [list -status online]
+ if {[lsearch -index 0 $current $nick] == -1} {
+ lappend opts -color \
+ [lindex $colors [expr {int(rand() * [llength $colors])}]]
+ }
+ eval [list $w name add $nick] $opts
+ }
+ }
+ update {
+ #update tcl@tach.tclers.tk nick -color x -affiliation y -group users -status
+ set w [XmppFindWindow $Session $target]
+ if {[winfo class $w] eq "Chatwidget"} {
+ set nick [lindex $args 2]
+ eval [list $w name add $nick] [lrange $args 3 end]
+ }
+ }
+ }
+ }
+ userinfo {
+ foreach {target nick} $args break
+ set w [XmppFindWindow $Session $target]
+ if {[winfo class $w] eq "Chatwidget"} {
+ foreach {what value} [lrange $args 2 end] {
+ switch -exact -- $what {
+ -affiliation { set group $value }
+ -show {}
+ -status {}
+ -jid {}
+ -role { }
+ -version {
+ Status $Session "$nick using $value"
+ }
+ }
+ }
+ eval [linsert [lrange $args 2 end] 0 $w name add $nick]
+ }
+ }
+ chat {
+ foreach {target nick msg type} $args break
+ if {$type eq ""} {set type normal}
+ set w [XmppCreateWindow $Session $target -type chat]
+ XmppAlert $Session $target
+ switch -exact -- [winfo class $w] {
+ Chatwidget {$w message $msg -nick $nick -type $type}
+ Messagewidget {
+ $w add -from $nick -to Me -body $msg -date [clock seconds]
+ }
+ default {puts stderr "invalid chat target \"$target\""}
+ }
+ }
+ message {
+ foreach {target from} $args break
+ jlib::splitjidex $target node domain resource
+ set w $session(window)
+ XmppAlert $Session $domain
+ eval [list $w add -to $target -from $from] [lrange $args 2 end]
+ }
+ system {
+ foreach {target msg} $args break
+ set w [XmppFindWindow $Session $target]
+ XmppAlert $Session $target
+ switch -exact -- [winfo class $w] {
+ Chatwidget {$w message $msg -type system}
+ Messagewidget {
+ $w add -from SYSTEM -to Me -body $msg -date [clock seconds]
+ }
+ default {
+ Debug $Session "invalid system target \"$target\"" debug
+ }
+ }
+ }
+ topic {
+ foreach {target topic} $args break
+ set w [XmppFindWindow $Session $target]
+ if {[winfo class $w] eq "Chatwidget"} {
+ $w topic show
+ $w topic set $topic
+ }
+ }
+ traffic {
+ foreach {action target nick new} $args break
+ set w [XmppFindWindow $Session $target]
+ if {[winfo class $w] ne "Chatwidget"} {return}
+ switch -exact -- $action {
+ joining { XmppCreateWindow $Session $target -type groupchat}
+ entered {
+ eval [linsert $args 0 $w name add $nick]
+ $w message "$nick $action" -nick $nick -type system
+ }
+ left {
+ $w name delete $nick
+ $w message "$nick $action" -nick $nick -type system
+ }
+ nickchange {
+ $w name delete $nick
+ eval [linsert $args 0 $w name add $new]
+ $w message "$nick is now known as $new" -nick $nick -type system
+ }
+ default {
+ $w message "$nick $action" -nick $nick -type system
+ }
+ }
+ }
+ debug {
+ foreach {type line} $args break
+ Debug $Session $line $type
+ }
+ version { return "" }
+ default {
+ puts stderr "*** unknown xmpp callback \"$state\": $args"
+ }
+ }
+}
--- /dev/null
+# bullfrog.tcl -
+#
+# This is a multi-transport chat application with support for
+# IRC (using the picoirc package) and Jabber (using the current
+# jabberlib from the coccinella project).
+# It makes use of the chatwidget from tklib
+#
+# Copyright (C) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: picoirc.tcl,v 1.2 2007/10/24 10:35:25 patthoyts Exp $
+
+package require Tk 8.5
+package require chatwidget 1.1; # tklib
+package require tooltip 1.4; # tklib
+
+if {![catch {package require autoproxy}]} {
+ autoproxy::init
+}
+
+set root [file dirname [info script]]
+source [file join $root message.tcl]
+source [file join $root tab.tcl]
+
+# Load the transport specific files...
+source [file join $root bf_irc.tcl]
+source [file join $root bf_xmpp.tcl]
+
+# -------------------------------------------------------------------------
+
+proc Main {args} {
+ global env
+ array set opts {-debug 1 -nick "" -name ""}
+ if {[info exists env(IRCNICK)]} {set opts(-nick) $env(IRCNICK)}
+ if {[info exists env(IRCNAME)]} {set opts(-nick) $env(IRCNAME)}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -nick { set opts(-nick) [Pop args 1] }
+ -name { set opts(-name) [Pop args 1] }
+ -debug { set opts(-debug) 1 }
+ -- { Pop args ; break }
+ default { break }
+ }
+ Pop args
+ }
+
+ ConfigureFonts
+
+ set app [toplevel .chat -class Bullfrog]
+ wm withdraw $app
+ wm title $app "Bullfrog"
+
+ set imgfile [file join [file dirname [info script]] bullfrog48.gif]
+ if {[file exists $imgfile]} {
+ image create photo bullfrogImage -file $imgfile
+ wm iconphoto $app bullfrogImage
+ }
+
+ set menu [menu $app.menu -tearoff 0]
+ # File menu
+ $menu add cascade -label Network -menu [menu $menu.file -tearoff 0]
+ $menu.file add command -label "IRC Login..." -underline 0 \
+ -command [namespace code [list IrcLogin $app]]
+ if {[llength [info commands XmppLogin]] != 0} {
+ $menu.file add command -label "Jabber Login..." -underline 0 \
+ -command [namespace code [list XmppLogin $app]]
+ }
+ $menu.file add separator
+ $menu.file add command -label Exit \
+ -command [namespace code [list Exit $app]]
+ # Windows menu
+ $menu add cascade -label Window \
+ -menu [menu $menu.window -tearoff 0 \
+ -postcommand [namespace code [list OnPostWindow $app $menu.window]]]
+
+ $app configure -menu $menu
+
+ ttk::notebook $app.nb -style ButtonNotebook
+
+ if {$opts(-debug)} {
+ set debugf [frame $app.nb.debugf -borderwidth 0 -highlightthickness 0]
+ set debug [ttk::frame $app.nb.debugf.debug -style ChatwidgetFrame]
+ text $debug.text -relief flat -borderwidth 0 -wrap word \
+ -state disabled -font DebugFont \
+ -yscrollcommand [list $debug.vs set]
+ $debug.text tag configure read -foreground blue3
+ $debug.text tag configure write -foreground red3
+ ttk::scrollbar $debug.vs -command [list $debug.text yview]
+ grid $debug.text $debug.vs -sticky news -padx 1 -pady 1
+ grid rowconfigure $debug 0 -weight 1
+ grid columnconfigure $debug 0 -weight 1
+ grid $debug -sticky news
+ grid rowconfigure $debugf 0 -weight 1
+ grid columnconfigure $debugf 0 -weight 1
+ $app.nb add $debugf -text Debug
+ }
+
+ set status [ttk::frame $app.status]
+ ttk::label $status.pane0 -anchor w
+ ttk::separator $status.sep0 -orient vertical
+ ttk::label $status.pane1 -anchor w
+ ttk::separator $status.sep1 -orient vertical
+ ttk::sizegrip $status.sizegrip
+ grid $status.pane0 $status.sep0 $status.pane1\
+ $status.sep1 $status.sizegrip -sticky news
+ grid columnconfigure $status 0 -weight 1
+ grid rowconfigure $status 0 -weight 1
+
+ grid $app.nb -sticky news
+ grid $status -sticky sew
+ grid rowconfigure $app 0 -weight 1
+ grid columnconfigure $app 0 -weight 1
+
+ ttk::notebook::enableTraversal $app.nb
+ bind $app <Control-F2> {console show}
+
+ wm geometry .chat 600x400
+ wm deiconify $app
+
+ set uri [lindex $args 0]
+ if {$opts(-nick) ne "" && $uri ne ""} {
+ foreach {server port channel} [picoirc::splituri $uri] break
+ after idle [list [namespace origin IrcConnect] $app \
+ -server $server -port $port \
+ -channel $channel -nick $opts(-nick)]
+ }
+
+ tkwait window $app
+ return
+}
+
+# Configure the fixed fonts for the debug windows
+proc ConfigureFonts {} {
+ if {[lsearch -exact [font names] DebugFont] == -1} {
+ set base [font actual TkDefaultFont]
+ eval font create DebugFont [font actual TkFixedFont]
+ }
+
+ set families [font families]
+ switch -exact -- [tk windowingsystem] {
+ aqua { set preferred {Monaco 10} }
+ win32 { set preferred {ProFontWindows 8 Consolas 8} }
+ default { set preferred {} }
+ }
+ foreach {family size} $preferred {
+ if {[lsearch -exact $families $family] != -1} {
+ font configure DebugFont -family $family -size $size
+ break
+ }
+ }
+}
+
+proc Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+proc Exit {app} {
+ destroy $app
+ exit
+}
+
+proc Status {Chat message} {
+ upvar #0 $Chat chat
+ $chat(app).status.pane0 configure -text $message
+}
+
+proc State {Chat message} {
+ upvar #0 $Chat chat
+ $chat(app).status.pane1 configure -text $message
+}
+
+proc Debug {Chat message {type debug}} {
+ upvar #0 $Chat chat
+ set w $chat(app).nb.debugf.debug.text
+ if {[winfo exists $w]} {
+ set t [clock format [clock seconds] -format "%H:%M:%S"]
+ $w configure -state normal
+ $w insert end "$t\t$message\n" $type
+ $w configure -state disabled
+ }
+}
+
+proc bgerror {args} {
+ tk_messageBox -icon error -title "Error" -message $::errorInfo
+}
+
+proc OnPostWindow {app menu} {
+ set ndx 0
+ $menu delete 0 end
+ set mod [expr {[tk windowingsystem] eq "aqua" ? "Cmd" : "Ctrl"}]
+ $menu add command -label "Close tab" -underline 0 \
+ -command [namespace code [list CloseWindow $app]]
+ $menu add command -label "Detach tab" -underline 0 \
+ -command [namespace code [list DetachWindow $app]]
+ $menu add separator
+ set tabs [$app.nb tabs]
+ foreach w [winfo children $app.nb] {
+ set ndx [incr ndx]
+ # children that are forgotten raise a 'not managed' error but we can ignore this
+ catch {
+ if {[winfo toplevel $w] eq $w} {
+ set title [wm title $w]
+ } else {
+ set title [$app.nb tab $w -text]
+ }
+ $menu add command -label "$ndx $title" -underline 0 \
+ -accel "$mod-$ndx" -command [namespace code [list SelectWindow $app $w]]
+ }
+ }
+}
+proc SelectWindow {app w} {
+ if {[lsearch -exact [$app.nb tabs] $w] != -1} {
+ $app.nb select $w
+ } else {
+ wm deiconify $w
+ }
+}
+proc CloseWindow {app} {
+ set tab [$app.nb select]
+ if {[winfo exists $tab]} {
+ $app.nb forget $tab
+ event generate $app.nb <<NotebookClosedTab>>
+ }
+}
+proc DetachWindow {app} {
+ set tab [$app.nb select]
+ if {[winfo exists $tab]} {
+ set title [$app.nb tab $tab -text]
+ set index [$app.nb index $tab]
+ $app.nb forget $tab
+ wm manage $tab
+ wm title $tab $title
+ wm protocol $tab WM_DELETE_WINDOW \
+ [namespace code [list AttachWindow $app $tab $index]]
+ }
+}
+proc AttachWindow {app w {index end}} {
+ set title [wm title $w]
+ wm forget $w
+ if {[catch {
+ if {[catch {$app.nb insert $index $w -text $title} err]} {
+ puts stderr "AttachWindow: ($index) $err"
+ $app.nb add $w -text $title
+ }
+ $app.nb select $w
+ } err]} {
+ puts stderr "AttachWindow: $err"
+ wm manage $w
+ wm title $w $title
+ }
+}
+proc WindowTitle {Session w {title {}}} {
+ upvar #0 $Session session
+ if {[lsearch -exact [$session(app).nb tabs] $w] == -1} {
+ if {$title eq {}} {
+ return [wm title $w]
+ } else {
+ wm title $w $title
+ }
+ } else {
+ if {$title eq {}} {
+ return [$session(app).nb tab $w -text]
+ } else {
+ $session(app).nb tab $w -text $title
+ }
+ }
+}
+
+
+proc UrlEnter {w} {
+ variable cursor:$w
+ set cursor:$w [$w cget -cursor]
+ $w configure -cursor hand2
+}
+
+proc UrlLeave {w} {
+ variable cursor:$w
+ if {![info exists cursor:$w]} {set cursor:$w {}}
+ $w configure -cursor [set cursor:$w]
+}
+
+proc UrlClick {w x y} {
+ set tags [$w tag names @$x,$y]
+ if {[set ndx [lsearch -glob $tags URL-*]] != -1} {
+ set url ""
+ foreach {b e} [$w tag ranges [lindex $tags $ndx]] {
+ append url [$w get $b $e]
+ }
+ if {[string length $url] > 0} {
+ if {[catch {GotoURL $w $url} err]} {
+ tk_messageBox -icon error -type ok -title "An error occurred"\
+ -message $err
+ }
+ }
+ }
+}
+
+proc GotoURL {w url} {
+ global tcl_platform
+ set dlg [winfo toplevel $w]
+ $dlg configure -cursor watch
+ clipboard clear
+ clipboard append $url
+ switch -- $tcl_platform(platform) {
+ "windows" {
+ # Try using DDE. Escape commas
+ package require dde
+ set url [string map {, %2c} $url]
+ set handled 0
+ foreach app {Firefox Mozilla Netscape Opera IExplore} {
+ if {[set srv [dde services $app WWW_OpenURL]] != {}} {
+ # We cant actually check for success here.
+ catch {dde execute $app WWW_OpenURL $url}
+ set handled 1
+ break
+ }
+ }
+ # Try the shell exec (quote the & chars)
+ if {!$handled} {
+ if {$tcl_platform(os) eq "Windows NT"} {
+ set url [string map {& ^&} $url]
+ }
+ if {[catch {
+ eval exec [auto_execok start] [list $url] &
+ } err]} then {
+ tk_messageBox -icon error -type ok \
+ -title "Failed top open url" \
+ -message "Error displaying \"$url\" in browser\n$err"
+ }
+ }
+ }
+ "unix" {
+ # darwin: open -a $env(BROWSER) $url
+ # gnome-open
+ # kde?
+ # find executable, then exec.
+ }
+ default {
+ tk_messageBox -icon error -type ok \
+ -title "Unsupported platform" \
+ -message "Your platform \"$tcl_platform(platform)\"\
+ is not supported. Contact the developers."
+ }
+ }
+ $dlg configure -cursor {}
+}
+
+
+
+# -------------------------------------------------------------------------
+
+if {![info exists initialized] && !$tcl_interactive} {
+ set initialized 1
+ wm withdraw .
+ set r [catch [linsert $argv 0 Main] err]
+ if {$r} {tk_messageBox -icon error -type ok -message $::errorInfo}
+ exit $r
+}
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+namespace eval ::scrolledframe {}
+
+proc ::scrolledframe::scrolledframe {w args} {
+ eval [linsert $args 0 Create $w]
+ interp hide {} $w
+ interp alias {} $w {} [namespace origin WidgetProc] $w
+ return $w
+}
+
+proc ::scrolledframe::WidgetProc {w args} {
+}
+
+proc ::scrolledframe::Create {w} {
+ set outer [ttk::frame $w\#f]
+ ttk::frame $w
+ set vs [ttk::scrollbar $w\#vs]
+ $vs configure -command [namespace code [list Scroll $vs $w]]
+
+ place $w -in $outer -anchor nw -x 0 -y 0
+ place $vs -in $outer -anchor nw -y 0 -rely 0 -relheight 1.0 \
+ -relx 1.0 -x -17 ;#-[winfo width $vs]
+
+ bind $w <Configure> [namespace code [list Update $vs $w %w %h]]
+
+ return $w
+}
+
+proc ::scrolledframe::Update {scrollbar frame width height} {
+ puts stderr "Update $width $height"
+ array set pinfo [place info $frame]
+ set parent [winfo parent $frame]
+ set ratio [expr {1.0 / [winfo height $frame]}]
+ set start [expr {(-$pinfo(-y)) * $ratio}]
+ set end [expr {$start + ($ratio * [winfo height $parent])}]
+
+ if {$start < 0.0} {
+ set start 0.0
+ }
+
+ if {$end > 1.0} {
+ set end 1.0
+ }
+ $scrollbar set $start $end
+}
+
+proc ::scrolledframe::Scroll {scrollbar frame type ratio args} {
+ puts stderr "Scroll $type $ratio $args"
+ switch -exact -- $type {
+ moveto {
+ #Don't allow the frame to scroll beyond the very top
+ if {$ratio < 0.0} {
+ set ratio 0.0
+ }
+
+ # Don't allow the frame to scroll beyond the frame boundary.
+ set yratio [expr {1.0 / [winfo height $frame]}]
+ set parent [winfo parent $frame]
+ set yratiopeak [expr {$yratio * ([winfo height $frame] - [winfo height $parent])}]
+ if {$ratio > $yratiopeak} {
+ set ratio $yratiopeak
+ }
+ array set pinfo [place info $frame]
+ set pixel [expr {-round([winfo height $frame] * $ratio)}]
+ place $frame -y $pixel
+ }
+ scroll {
+ foreach {count what} $args break
+ # FIX ME
+ }
+
+ default {
+ puts TYPE:$type
+ }
+ }
+}
+
+proc Main {} {
+ set f [scrolledframe::scrolledframe .f]
+ for {set n 0} {$n < 20} {incr n} {
+ set w [ttk::label $f.l$n -text "Label $n"]
+ grid $w -sticky ew
+ }
+
+ grid $f\#f -sticky news
+ grid rowconfigure . 0 -weight 1
+ grid columnconfigure . 0 -weight 1
+
+ bind . <Control-F2> {console show}
+ tkwait window .
+}
+
+if {!$tcl_interactive} {
+ set r [catch [linsert $argv 0 Main] err]
+ if {$r} {tk_messageBox -message $::errorInfo}
+ exit $r
+}
\ No newline at end of file
--- /dev/null
+# history.tcl - Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Get history from tclers.tk for a conference
+#
+#
+
+package require Tcl 8.5 ;# uses dict and {*}
+source [file join [file dirname [info script]] httpredir.tcl]
+if {![catch {package require autoproxy}]} {
+ autoproxy::init
+}
+
+namespace eval ::tclers.tk {
+ #variable url_base http://tclers.tk/conferences
+ variable url_base http://localhost/conferences
+}
+
+proc ::tclers.tk::gethistory {room args} {
+ # -messagecommand
+ # -progress
+}
+
+proc ::tclers.tk::Progress {tok total current} {
+ .htest.f.status.progress configure -value $current -maximum $total
+}
+
+proc ::tclers.tk::GetIndex {room} {
+ variable url_base
+ set url ${url_base}/$room
+ set headers [list Accept-Charset utf-8 Cache-control no-cache]
+ ::http::geturl2 $url -headers $headers \
+ -timeout 120000 \
+ -progress [namespace code [list Progress]] \
+ -command [namespace code [list GotIndex $url]]
+}
+
+proc ::tclers.tk::GotIndex {url tok} {
+ if {[catch {
+ set ncode [::http::ncode $tok]
+ set status [string tolower [::http::status $tok]]
+ array set ::TOK [array get $tok]
+ if {$status eq "ok" && $ncode < 300} {
+ after idle [namespace code [list ProcessIndex $url [::http::data $tok]]]
+ } else {
+ puts stderr "GotIndex Failure: [http::status $tok] [http::code $tok]"
+ if {$status eq "error"} { puts stderr [http::error $tok] }
+ }
+ ::http::cleanup $tok
+ } err]} { puts stderr $err }
+}
+
+proc ::tclers.tk::ProcessIndex {url data} {
+ set RE {<A HREF="([0-9\-%d]+\.tcl)">.*\s([0-9]+) bytes}
+ foreach line [split $data \n] {
+ if { [regexp -- $RE $line -> logname size] } {
+ set logname [string map {"%2d" -} $logname]
+ set size [expr { $size / 1024 }]k
+ lappend loglist $logname $size
+ }
+ }
+
+ ## Only show 7 days worth.
+ set loglist [lrange $loglist end-13 end]
+ #after idle [list after 0 ::tkchat::LoadHistoryFromIndex $loglist]
+ #foreach {name size} $loglist {}
+ GetLog $url/[lindex $loglist end-1]
+}
+
+proc ::tclers.tk::GetLog {url} {
+ set headers [list Accept-Charset utf-8 Cache-control no-cache]
+ set tok [::http::geturl2 $url -headers $headers -timeout 120000 \
+ -progress [namespace code Progress] \
+ -command [namespace code GotLog]]
+}
+
+proc ::tclers.tk::GotLog {tok} {
+ upvar #0 $tok state
+ if {[catch {
+ set ncode [::http::ncode $tok]
+ set status [string tolower [::http::status $tok]]
+ if {$status eq "ok" && $ncode < 300} {
+ if {$state(charset) eq "iso8859-1"} {
+ set data [encoding convertfrom utf-8 [::http::data $tok]]
+ } else {
+ set data [::http::data $tok]
+ }
+ after idle [namespace code [list ProcessLog $data]]
+ } else {
+ puts stderr "GotIndex Failure: [http::status $tok] [http::code $tok]"
+ if {$status eq "error"} { puts stderr [http::error $tok] }
+ }
+ ::http::cleanup $tok
+ } err]} { puts stderr $err }
+}
+
+proc ::tclers.tk::ProcessLog {data} {
+ if {[catch {
+ #.htest.f.txt delete 1.0 end
+ set interp [interp create -safe]
+ interp alias $interp m {} [namespace origin Message]
+ interp eval $interp $data
+ interp delete $interp
+ } err]} {
+ puts stderr "error processing log file: $err"
+ }
+}
+
+proc ::tclers.tk::Message {when nick msg {opts ""} args} {
+ if {[catch {clock scan $when -format "%Y-%m-%dT%H:%M:%S%Z" -gmt 1} s]} {
+ set s [clock scan $when -format "%Y%m%dT%H:%M:%S" -gmt 1]
+ }
+ set ts [clock format $s -format "%H:%M"]
+ if {$opts ne ""} {puts stderr "OPTS: '$opts'"}
+ .htest.f.txt insert history "$ts " TIMESTAMP "$nick\t$msg\n" [list NICK-$nick MSG]
+}
+
+# testing
+proc ::tclers.tk::TestGUI {} {
+ set dlg [toplevel .htest -class Dialog]
+ wm withdraw $dlg
+ wm title $dlg "Test history fetch"
+ set f [ttk::frame $dlg.f]
+ text $f.txt -background white -height 8 -width 30 \
+ -yscrollcommand [list $f.vs set] -font TkDefaultFont
+ ttk::scrollbar $f.vs -command [list $f.txt yview]
+ set status [ttk::frame $f.status]
+ ttk::label $status.pane0
+ ttk::progressbar $status.progress
+ ttk::sizegrip $status.sg
+ grid $status.pane0 $status.progress $status.sg -sticky news
+ grid rowconfigure $status 0 -weight 1
+ grid columnconfigure $status 0 -weight 1
+ grid $f.txt $f.vs -sticky news
+ grid $status - -sticky ew
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+ grid $f -sticky news
+ grid rowconfigure $dlg 0 -weight 1
+ grid columnconfigure $dlg 0 -weight 1
+ wm deiconify $dlg
+}
--- /dev/null
+# httpredir.tcl - Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# This is a wrapper for the http package that handles redirects. If too
+# many redirections are encountered then it is converted into an error
+# response and the -command procedure called.
+#
+
+package require Tcl 8.5 ;# uses dict and {*}
+package require http 2.5
+
+namespace eval ::http {
+ # This is the set of additional options we take. They are removed before we
+ # call the http::geturl command but are maintained in this package.
+ variable extrafields {-redirects -maxredirects}
+}
+
+proc ::http::Redirect {opts tok} {
+ upvar #0 $tok state
+ variable extrafields
+ if {[set ndx [lsearch -nocase $state(meta) location]] != -1} {
+ if {[dict incr opts -redirects] > [dict get $opts -maxredirects]} {
+ set state(status) error
+ set state(error) "Too many redirections. Loop detected."
+ uplevel #0 [dict get $opts -command] [list $tok]
+ } else {
+ # RFC 2626:14.30 specifies the location to be absolute url
+ set url [lindex $state(meta) [incr ndx]]
+ # RFC 2616:14.36 if not human generated, include Referer header
+ dict set opts -headers Referer $state(url)
+ set args [dict remove $opts {*}$extrafields]
+ dict set args -command [namespace code [list RedirectCheck $opts]]
+ after idle [list ::http::geturl $url {*}$args]
+ }
+ } else {
+ set state(status) error
+ set state(error) "Received [http::code $tok] but no Location header."
+ uplevel #0 [dict get $opts -command] [list $tok]
+ }
+ return
+}
+proc ::http::RedirectCheck {opts tok} {
+ set ncode [::http::ncode $tok]
+ set status [string tolower [::http::status $tok]]
+ if {$status eq "ok" && $ncode < 400 && $ncode >= 300} {
+ Redirect $opts $tok
+ } else {
+ set state(-command) [dict get $opts -command]
+ uplevel #0 [dict get $opts -command] [list $tok]
+ }
+ ::http::cleanup $tok
+}
+
+proc ::http::geturl2 {url args} {
+ variable extrafields
+ set opts [dict create {*}$args]
+ if {![dict exists $opts -command]} {
+ return -code error "missing -command argument"
+ }
+ if {![dict exists $opts -maxredirects]} {
+ dict set opts -maxredirects 10
+ }
+ # call the http package with _only_ http package options
+ set args [dict remove $opts {*}$extrafields]
+ dict set args -command [namespace code [list RedirectCheck $opts]]
+ return [http::geturl $url {*}$args]
+}
--- /dev/null
+# message.tcl - Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Implementation of a composite widget that displays a set of
+# messages from some storage. This could be e-mail or instant-messaging
+# or some other source. The upper part shows a summary of each
+# message and clicking a message triggers the display in the lower
+# section
+#
+# -------------------------------------------------------------------------
+# TODO:
+# - delete
+# - images for type/state
+#
+# - Should abstract the data storage out so that we could use
+# sqlite if we have it. Persistence will be simpler as a db.
+# Data interface is: add, select, delete so it all looks like sql.
+#
+# -------------------------------------------------------------------------
+
+package require Tk 8.5
+
+namespace eval messagewidget {
+ variable version 1.0.0
+
+ namespace export messagewidget
+
+ if {[lsearch -exact [font names] MessagewidgetFont] == -1} {
+ eval [list font create MessagewidgetFont] [font actual TkTextFont]
+ eval [list font create MessagewidgetBoldFont] \
+ [font actual TkTextFont] -weight bold
+ eval [list font create MessagewidgetItalicFont] \
+ [font actual TkTextFont] -slant italic
+ }
+ namespace eval ::img {}
+ set imgdir [file join [file dirname [info script]] images]
+ image create photo ::img::msgnorm -file [file join $imgdir mail.gif]
+ image create photo ::img::msgchat -file [file join $imgdir chat.gif]
+}
+
+proc messagewidget::messagewidget {w args} {
+ Create $w
+ interp hide {} $w
+ interp alias {} $w {} [namespace origin WidgetProc] $w
+ return $w
+}
+
+proc messagewidget::WidgetProc {self cmd args} {
+ upvar #0 [namespace current]::$self state
+ switch -exact -- $cmd {
+ add {
+ return [uplevel 1 [list [namespace origin Add] $self] $args]
+ }
+ summary {
+ return [uplevel 1 [list [namespace origin Summary] $self] $args]
+ }
+ body -
+ default {
+ return [uplevel 1 [list [namespace origin Body] $self] $args]
+ }
+ }
+}
+
+proc messagewidget::Summary {self args} {
+ upvar #0 [namespace current]::$self state
+ if {[llength $args] == 0} {
+ return $state(mlist)
+ }
+ return [uplevel 1 [list $state(mlist)] $args]
+}
+
+proc messagewidget::Body {self args} {
+ upvar #0 [namespace current]::$self state
+ if {[llength $args] == 0} {
+ return $state(body)
+ }
+ return [uplevel 1 [list $state(body)] $args]
+}
+
+proc messagewidget::Create {self} {
+ upvar #0 [set State [namespace current]::$self] state
+
+ set self [ttk::frame $self -class Messagewidget]
+ set inner [ttk::panedwindow $self.inner -orient vertical]
+
+ # top part shows subject lines, from, date etc
+ set mlist [ttk::frame $inner.mlist]
+ set state(mcols) {date from subject}
+ set state(summary) [ttk::treeview $mlist.tree -height 4 \
+ -columns $state(mcols)]
+ ttk::scrollbar $mlist.vs -command [list $mlist.tree yview]
+ $mlist.tree configure -yscrollcommand [list $mlist.vs set]
+ $mlist.tree heading date -anchor w -text Date
+ $mlist.tree heading from -anchor w -text From
+ $mlist.tree heading subject -anchor w -text Subject
+ $mlist.tree column #0 -width 5
+ $mlist.tree column date -width \
+ [font measure TkHeadingFont "31/12 00:00"]
+ $mlist.tree column from -width \
+ [font measure TkHeadingFont "somenames@xyzzy.xyzzy.com"]
+ $mlist.tree column subject -anchor w -stretch 1
+ $mlist.tree tag bind item <Button-1> \
+ [namespace code [list OnSummaryClick $self %W %x %y]]
+ grid $mlist.tree $mlist.vs -sticky news
+ Grid $mlist row 0 column 0
+
+ # lower part displays message
+ set view [ttk::frame $inner.view]
+ set state(body) [text $view.body -borderwidth 0 -relief flat \
+ -font MessagewidgetFont]
+ ttk::scrollbar $view.vs -command [list $view.body yview]
+ $view.body configure -yscrollcommand [list $view.vs set]
+ grid $view.body $view.vs -sticky news -padx 1 -pady 1
+ Grid $view row 0 column 0
+ $view.body tag configure header -background LightSteelBlue
+ $view.body tag configure subject -font MessagewidgetBoldFont
+
+ bind $self <Destroy> "+unset -nocomplain $State"
+
+ $inner add $mlist
+ $inner add $view -weight 1
+ grid $inner -sticky news
+ Grid $self row 0 column 0
+ return $self
+}
+
+proc messagewidget::Grid {w junk row junk column} {
+ grid rowconfigure $w $row -weight 1
+ grid columnconfigure $w $column -weight 1
+}
+
+proc messagewidget::DisplayTime {time} {
+ set r $time
+ catch {
+ set delta [expr {[clock seconds] - $time}]
+ if {$delta < 86400} {
+ set format {%H:%M:%S}
+ } else {
+ set format {%a %d %b}
+ }
+ set r [clock format $time -format $format]
+ }
+ return $r
+}
+
+proc messagewidget::Add {self args} {
+ upvar #0 [namespace current]::$self state
+ set msg [eval [linsert $args 0 dict create -state U \
+ -from "" -to "" -subject "" -body ""]]
+ lappend state(messages) $msg
+ lappend values [DisplayTime [dict get $msg -date]]
+ lappend values [dict get $msg -from]
+ lappend values [dict get $msg -subject]
+ set img ::img::msgnorm
+ set item [$state(summary) insert {} end -image $img -tags item -values $values]
+}
+
+proc messagewidget::OnSummaryClick {self w x y} {
+ upvar #0 [namespace current]::$self state
+ set item [$w identify row $x $y]
+ set M [lindex $state(messages) [$w index $item]]
+ # ? dict set $M -state R
+ $state(summary) item $item -text " "
+ $state(body) delete 1.0 end
+ $state(body) insert end \
+ "From:\t[dict get $M -from]\n" header \
+ "To:\t[dict get $M -to]\n" header \
+ "Date:\t[clock format [dict get $M -date]]\n" header \
+ "Subject:\t[dict get $M -subject]\n\n" header \
+ "[dict get $M -body]\n" body
+}
+
+# -------------------------------------------------------------------------
+
+package provide messagewidget $messagewidget::version
+
+# -------------------------------------------------------------------------
+
+# testing
+
+proc messagewidget::Test {} {
+ destroy .t
+ toplevel .t
+ pack [messagewidget::messagewidget .t.t] -fill both -expand 1
+ .t.t add -from rmax@all.tclers.tk -to patthoyts@all.tclers.tk \
+ -date 1202540181 -subject "Testing message one" \
+ -body [info body [lindex [info procs] [expr {int(rand() * 10)}]]]
+ .t.t add -from kostix@007sp.ru -to patthoyts@all.tclers.tk \
+ -date 1202544181 -subject "Russian testing message" \
+ -body [info body [lindex [info procs] [expr {int(rand() * 10)}]]]
+ .t.t add -from pennythoyts@googlemail.com -to patthoyts@all.tclers.tk \
+ -date 1202550181 -subject "Another test" \
+ -body [info body [lindex [info procs] [expr {int(rand() * 10)}]]]
+}
\ No newline at end of file
--- /dev/null
+# Replace the standard notebook tab with one that includes a close
+# button.
+# In future versions of ttk this will be supported more directly when
+# the identify command will be able to identify parts of the tab.
+
+namespace eval ::ButtonNotebook {
+}
+
+# Tk 8.6 has the Visual Styles element engine on windows. If this is
+# available we use it to get proper windows close buttons.
+#
+proc ::ButtonNotebook::CreateElements {} {
+ if {[lsearch -exact [ttk::style element names] close] == -1} {
+ if {[catch {
+ # WINDOW WP_SMALLCLOSEBUTTON (19)
+ # WINDOW WP_MDICLOSEBUTTON (20)
+ # WINDOW WP_MDIRESTOREBUTTON (22)
+ #ttk::style element create close vsapi \
+ # WINDOW 20 {disabled 4 {active pressed} 3 active 2 {} 1}
+ ttk::style element create close vsapi \
+ EXPLORERBAR 2 {disabled 4 {active pressed} 3 active 2 {} 1}
+ ttk::style element create detach vsapi \
+ WINDOW 22 {disabled 4 {active pressed} 3 active 2 {} 1}
+ }]} then {
+ # No XP element engine - use images...
+ CreateImageElements
+ }
+ }
+}
+
+proc ::ButtonNotebook::CreateImageElements {} {
+ # Create two image based elements to provide buttons to close the
+ # tabs or to detach a tab and turn it into a toplevel.
+ namespace eval ::img {}
+ set imgdir [file join [file dirname [info script]] images]
+ image create photo ::img::close -file [file join $imgdir xhn.gif]
+ image create photo ::img::closepressed -file [file join $imgdir xhd.gif]
+ image create photo ::img::closeactive -file [file join $imgdir xhu.gif]
+ image create photo ::img::detach -file [file join $imgdir dhn.gif]
+ image create photo ::img::detachup -file [file join $imgdir dhu.gif]
+ image create photo ::img::detachdown -file [file join $imgdir dhd.gif]
+ if {[lsearch -exact [ttk::style element names] close] == -1} {
+ if {[catch {
+ ttk::style element create close image \
+ [list ::img::close \
+ {active pressed !disabled} ::img::closepressed \
+ {active !disabled} ::img::closeactive] \
+ -border 3 -sticky {}
+ ttk::style element create detach image \
+ [list ::img::detach \
+ {active pressed !disabled} ::img::detachdown \
+ {active !disabled} ::img::detachup] \
+ -border 3 -sticky {}
+ } err]} { puts stderr $err }
+ }
+}
+
+proc ::ButtonNotebook::Init {{pertab 0}} {
+ CreateElements
+
+ # This places the buttons on the right end of the tab area -- but in
+ # Tk 8.5 we cannot identify these elements.
+ if {!$pertab} {
+ ttk::style layout ButtonNotebook {
+ ButtonNotebook.client -sticky nswe
+ ButtonNotebook.close -side right -sticky ne
+ ButtonNotebook.detach -side right -sticky ne
+ }
+ }
+
+ # This places the button elements on each tab which uses quite a
+ # lot of space but we can identify the elements. Changes to the
+ # widget state affect all the button elements though.
+ if {$pertab} {
+ ttk::style layout ButtonNotebook {
+ ButtonNotebook.client -sticky nswe
+ }
+ ttk::style layout ButtonNotebook.Tab {
+ ButtonNotebook.tab -sticky nswe -children {
+ ButtonNotebook.focus -side top -sticky nswe -children {
+ ButtonNotebook.padding -side right -sticky nswe -children {
+ ButtonNotebook.close -side right -sticky {}
+ }
+ ButtonNotebook.label -side left -sticky {}
+ }
+ }
+ }
+ if {$::ttk::currentTheme eq "xpnative"} {
+ ttk::style configure ButtonNotebook.Tab -width -8
+ ttk::style configure ButtonNotebook.Tab -padding {8 0 0 0}
+ }
+ }
+
+ bind TNotebook <ButtonPress-1> {+::ButtonNotebook::Press %W %x %y}
+ bind TNotebook <Motion> {+::ButtonNotebook::Drag %W %x %y %X %Y}
+ bind TNotebook <ButtonRelease-1> {+::ButtonNotebook::Release %W %x %y %X %Y}
+ bind TNotebook <<ThemeChanged>> [namespace code [list Init $pertab]]
+}
+
+# Hook in some event extras:
+# set the state to pressed if button down over a button element.
+proc ::ButtonNotebook::Press {w x y} {
+ set e [$w identify $x $y]
+ if {[string match "*close" $e] || [string match "*detach" $e]} {
+ $w state pressed
+ } else {
+ upvar #0 [namespace current]::$w state
+ if {![info exists state]} {
+ set state(drag) 1
+ set state(drag_index) [$w index @$x,$y]
+ set state(drag_under) $state(drag_index)
+ set state(drag_from_x) $x
+ set state(draw_from_y) $y
+ set state(drag_indic) [ttk::label $w._indic -text v]
+ }
+ }
+}
+
+proc ::ButtonNotebook::Drag {w x y rootX rootY} {
+ upvar #0 [namespace current]::$w state
+ if {[info exists state]} {
+ if {[winfo containing $rootX $rootY] eq $w} {
+ set index [$w index @$x,$y]
+ if {$index != $state(drag_under)} {
+ puts "moved to $index"
+ place $state(drag_indic) -anchor nw -x $x -y 0
+ set state(drag_under) $index
+ }
+ }
+ }
+}
+
+# On release, do the button action if any.
+proc ::ButtonNotebook::Release {w x y rootX rootY} {
+ $w state !pressed
+ set e [$w identify $x $y]
+ set index [$w index @$x,$y]
+ if {[string match "*close" $e]} {
+ $w forget $index
+ event generate $w <<NotebookClosedTab>>
+ } elseif {[string match "*detach" $e]} {
+ Detach $w $index
+ } else {
+ upvar #0 [namespace current]::$w state
+ if {[info exists state]} {
+ set dropwin [winfo containing $rootX $rootY]
+ if {$dropwin eq {}} {
+ Detach $w $state(drag_index)
+ } elseif {$dropwin eq $w && $index != $state(drag_index)} {
+ Move $w $state(drag_index) $index
+ }
+ destroy $state(drag_indic)
+ unset state
+ }
+ }
+}
+
+# Move a tab from old index to new index position.
+proc ::ButtonNotebook::Move {notebook old_index new_index} {
+ set tab [lindex [$notebook tabs] $old_index]
+ set title [$notebook tab $old_index -text]
+ $notebook forget $old_index
+ if {[string is integer -strict $new_index]} {
+ incr new_index -1
+ if {$new_index < 0} {set new_index 0}
+ if {$new_index > [llength [$notebook tabs]]} { set new_index end }
+ } else {
+ set new_index end
+ }
+ $notebook insert $new_index $tab -text $title
+}
+
+# Turn a tab into a toplevel (must be a tk::frame)
+proc ::ButtonNotebook::Detach {notebook index} {
+ set tab [lindex [$notebook tabs] $index]
+ set title [$notebook tab $index -text]
+ $notebook forget $index
+ wm manage $tab
+ wm title $tab $title
+ wm protocol $tab WM_DELETE_WINDOW \
+ [namespace code [list Attach $notebook $tab $index]]
+ bind $tab <Configure> \
+ [namespace code [list Debug $notebook "Configure %wx%h %x,%y"]]
+ bind $tab <Expose> [namespace code [list Debug $notebook "Expose"]]
+ bind $tab <Activate> [namespace code [list Debug $notebook "Activate"]]
+ bind $tab <Deactivate> [namespace code [list Debug $notebook "Deactivate"]]
+ bind $tab <ButtonPress> [namespace code [list Debug $notebook "Button"]]
+ bind $tab <Visibility> \
+ [namespace code [list Debug $notebook "Visibility %s"]]
+
+ event generate $tab <<DetachedTab>>
+}
+proc ::ButtonNotebook::Debug {notebook msg} {
+ $notebook.page0.text insert end $msg\n {}
+ $notebook.page0.text see end
+}
+
+# Attach a toplevel to the notebook
+proc ::ButtonNotebook::Attach {notebook tab {index end}} {
+ set title [wm title $tab]
+ wm forget $tab
+ if {[catch {
+ if {[catch {$notebook insert $index $tab -text $title} err]} {
+ $notebook add $tab -text $title
+ }
+ $notebook select $tab
+ } err]} {
+ puts stderr "AttachWindow: $err"
+ wm manage $w
+ wm title $w $title
+ }
+}
+proc ::ButtonNotebook::Test {} {
+ variable tabtest
+ set dlg [toplevel .test[incr tabtest]]
+ wm title $dlg "Notebook test"
+ wm withdraw $dlg
+ set nb [ttk::notebook $dlg.nb -style ButtonNotebook]
+ frame $nb.page0 -background red -width 100 -height 100
+ frame $nb.page1 -background blue -width 100 -height 100
+ frame $nb.page2 -background green -width 100 -height 100
+ frame $nb.page3 -background tomato -width 100 -height 100
+ $nb add $nb.page0 -text One
+ $nb add $nb.page1 -text Two
+ $nb add $nb.page2 -text Three
+ $nb add $nb.page3 -text "Some really long label."
+
+ set txt [text $nb.page0.text -height 10 -width 10]
+ set vs [scrollbar $nb.page0.vs -command [list $txt yview]]
+ $txt configure -yscrollcommand [list $vs set]
+ grid $txt $vs -sticky news
+ grid rowconfigure $nb.page0 0 -weight 1
+ grid columnconfigure $nb.page0 0 -weight 1
+
+ grid $dlg.nb -sticky news
+ grid rowconfigure $dlg 0 -weight 1
+ grid columnconfigure $dlg 0 -weight 1
+
+ bind TNotebook <Motion> [string map [list %txt $txt] {
+ %txt insert end [%W identify %x %y] {} "\n" {}
+ %txt see end
+ }]
+ bind $dlg <Control-F2> {console show}
+ wm withdraw .
+ wm protocol $dlg WM_DELETE_WINDOW {exit}
+ wm geometry $dlg 320x240
+ wm deiconify $dlg
+}
+
+::ButtonNotebook::Init 1
+if {[winfo class .] eq "Tab"} {::ButtonNotebook::Test; tkwait window .}
\ No newline at end of file
--- /dev/null
+package require Tk 8.4
+package require http
+package require uri
+package require autoproxy
+package require chatwidget
+
+package require jlib
+package require jlib::connect
+package require jlib::disco
+package require jlib::roster
+package require jlib::muc
+package require jlib::vcard
+
+# Enable proxy-aware TLS sockets.
+if {![catch {package require tls}]} {
+ http::register https 443 ::autoproxy::tls_socket
+}
+
+# Maybe support ipv6 and more efficient sockets on win32
+if {0 && ![catch {package require Iocpsock}]} {
+ http::register http 80 [info command socket2]
+}
+
+# Use either tile 0.8 or the ttk commands in 8.5a6.
+if {[llength [info commands ttk::*]] == 0} {
+ package require tile 0.8
+}
+
+# -------------------------------------------------------------------------
+
+namespace eval Link { }
+
+proc OnNetwork {tok cmd args} {
+ if {[catch {
+ array set a {-body {} -errormsg {}}
+ array set a $args
+ switch -exact -- $cmd {
+ connect { Log "* connected" }
+ disconnect { Log "* disconnected" }
+ networkerror { Log "* Network error: $a(-body)" }
+ xmpp-streams-error-* -
+ streamerror { Log "* Stream error: $a(-errormsg)" }
+ xmlerror { Log "* XML parse error: $a(-errormsg)" }
+ default { Log "* $cmd $args" }
+ }
+ } err]} { Log "OnNetwork: $err" error }
+}
+
+proc OnPresence {tok type args} {
+ if {[catch [linsert $args 0 OnPresence2 $tok $type] err]} {
+ Log "OnPresence: $err" error
+ }
+ return 0
+}
+proc OnPresence2 {tok type args} {
+ array set a {-from {} -to {} -status {}}
+ array set a $args
+ Log "< presence $type $a(-from) $a(-to) $a(-status)"
+}
+
+proc OnIq {tok type args} {
+ if {[catch [linsert $args 0 OnIq2 $tok $type] err]} {
+ Log "OnIq: $err" error
+ }
+ return 0
+}
+
+proc OnIq2 {tok type args} {
+ array set a {-from {} -to {}}
+ array set a $args
+ Log "< iq $type $a(-from) $a(-to)"
+}
+
+proc OnMessage {tok type args} {
+ if {[catch [linsert $args 0 OnMessage2 $tok $type] err]} {
+ Log "OnMessage: $err" error
+ }
+ return 0
+}
+
+proc OnMessage2 {tok type args} {
+ array set a {-from {} -to {} -subject {} -body {}}
+ array set a $args
+ switch -exact -- $type {
+ groupchat -
+ chat {
+ Print "$a(-from) $a(-body)"
+ }
+ headline {
+ Print "$a(-from) \"$a(-subject)\"\n $a(-body)"
+ }
+ error {
+ Log "Message error: $args" error
+ }
+ normal -
+ default {
+ Print "$a(-from) $a(-body)"
+ }
+ }
+}
+
+proc OnMucEnter {app jlib type args} {
+ if {[catch {
+ array set a {-from {} -to {}}
+ array set a $args
+ set room [jid !resource $a(-from)]
+
+ if {1} {
+ variable chatuid ; if {![info exists chatuid]} { set chatuid -1 }
+ set id chat[incr chatuid]
+ upvar #0 [set Chat [namespace current]::$id] chat
+ set chat(app) $app
+ set chat(type) jabber
+ set chat(room) $room
+ set chat(nick) [$jlib muc mynick $room]
+ set chat(window) [chatwidget::chatwidget $app.$id]
+ $app.nb add $chat(window) -text $room
+ }
+
+ Log "< MUC $type $a(-from) $a(-to)"
+ } err]} {
+ Log "OnMucEnter $err"
+ }
+}
+
+proc OnConnect {tok type args} {
+ Log "OnConnect $tok $type $args"
+
+ switch -exact -- $type {
+ initnetwork { }
+ initstream { }
+ authenticate { }
+ ok {
+ $tok send_presence -type available
+ $tok roster send_get
+ }
+ error { }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# tkjabber::jid --
+#
+# A helper function for splitting out parts of Jabber IDs.
+#
+proc jid {part jid} {
+ set r {}
+ if {[regexp {^(?:([^@]*)@)?([^/]+)(?:/(.+))?} $jid \
+ -> node domain resource]} {
+ switch -exact -- $part {
+ node { set r $node }
+ domain { set r $domain }
+ resource { set r $resource }
+ !resource { set r ${node}@${domain} }
+ jid { set r $jid }
+ default {
+ return -code error "invalid part \"$part\":\
+ must be one of node, domain, resource or jid."
+ }
+ }
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+proc Print {str} {.chat.main insert end $str {} "\n" {}}
+proc Log {str {tag {}}} {
+ .chat.main insert end $str\n [list log $tag]
+ .chat.main see end
+}
+proc Exit {app} { destroy $app }
+
+proc Main {} {
+ autoproxy::init
+ set app [toplevel .chat -class Chat]
+ wm withdraw $app
+ wm title $app "Chat test app"
+
+ set menu [menu $app.menu -tearoff 0]
+ $menu add cascade -label File -menu [menu $menu.file -tearoff 0]
+ $menu.file add command -label "Connect" \
+ -command [list [namespace origin Connect] $app]
+ $menu.file add command -label "Join tcl chat" \
+ -command [list [namespace origin JoinRoom] $app tcl@tach.tclers.tk]
+ $menu.file add command -label "Join test chat" \
+ -command [list [namespace origin JoinRoom] $app test@tach.tclers.tk]
+ $menu.file add separator
+ $menu.file add command -label Exit \
+ -command [list [namespace origin Exit] $app]
+ $app configure -menu $menu
+
+ ttk::notebook $app.nb
+
+ ttk::frame $app.mainf -style ChatwidgetFrame
+ text $app.main -yscrollcommand [list $app.mainvs set] -borderwidth 0 -relief flat
+ ttk::scrollbar $app.mainvs -command [list $app.main yview]
+ grid $app.main $app.mainvs -in $app.mainf -sticky news -padx 1 -pady 1
+ grid rowconfigure $app.mainf 0 -weight 1
+ grid columnconfigure $app.mainf 0 -weight 1
+
+ $app.main tag configure log -foreground black -background grey80
+ $app.main tag configure error -foreground red -background grey80
+
+ $app.nb add $app.mainf -text "Jabber"
+
+ set status [ttk::frame $app.status]
+ ttk::label $status.pane0 -anchor w
+ ttk::separator $status.sep0
+ ttk::label $status.pane1 -anchor w
+ ttk::separator $status.sep1
+ ttk::sizegrip $status.sizegrip
+ grid $status.pane0 $status.sep0 $status.pane1 $status.sep1 $status.sizegrip -sticky ew
+ grid columnconfigure $status 0 -weight 1
+ grid rowconfigure $status 0 -weight 1
+
+ grid $app.nb -sticky news
+ grid $status -sticky sew
+ grid rowconfigure $app 0 -weight 1
+ grid columnconfigure $app 0 -weight 1
+
+ bind $app <Control-F2> {console show}
+
+ wm geometry .chat 600x400
+ wm deiconify $app
+
+ tkwait window .
+}
+
+proc Connect {app} {
+ set user $::tcl_platform(user)
+ set server patthoyts.tk
+ set password SEKRET
+ set resource JDemo
+ set jid [jlib::joinjid $user $server $resource]
+
+ variable conn
+ set conn [jlib::new OnNetwork \
+ -iqcommand OnIq \
+ -messagecommand OnMessage \
+ -presencecommand OnPresence \
+ -keepalivesecs 0 \
+ -autodiscocaps 1]
+
+
+ #$conn roster register_cmd RosterProc
+ #$conn iq_register get jabber:iq:version OnGetVersion
+ #$conn presence_register subscribe OnSubscribe
+ #$conn presence_register subscribed OnSubscribed
+ #$conn presence_register unsubscribe OnUnsubscribe
+ #$conn presence_register unsubscribed OnUnsubscribed
+ $conn connect init
+ $conn connect configure -defaultresource "Chatdemo"
+ # -defaultport 5222 -defaultsslport 5223
+
+ $conn connect connect $jid $password -command OnConnect \
+ -secure 1 -method sasl \
+ -ip localhost -port 3128
+ #$conn send_message $jid -type chat -subject Subject -body $text
+}
+
+proc JoinRoom {app room {nick testing}} {
+ variable conn
+ $conn muc enter $room $nick -command [list OnMucEnter $app]
+}
+
+# -------------------------------------------------------------------------
+
+if {![info exists initialized] && !$tcl_interactive} {
+ set initialized 1
+ wm withdraw .
+ set r [catch [linsert $argv 0 Main] err]
+ if {$r} {puts $::errorInfo} else {puts $err}
+ exit $r
+}
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
\ No newline at end of file
--- /dev/null
+# irc.tcl - Copyright (C) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# This is a Tk GUI for the picoirc package that provides a simple IRC client
+#
+
+package require Tk 8.5
+package require chatwidget
+package require picoirc
+
+variable ircuid
+if {![info exists ircuid]} { set ircuid -1 }
+
+# -------------------------------------------------------------------------
+
+proc Main {} {
+ set app [toplevel .chat -class Chat]
+ wm withdraw $app
+ wm title $app "Chat test app"
+
+ set menu [menu $app.menu -tearoff 0]
+ $menu add cascade -label Network -menu [menu $menu.file -tearoff 0]
+ $menu.file add command -label "Login..." -underline 0 \
+ -command [list [namespace origin LoginIRC] $app]
+ $menu.file add separator
+ $menu.file add command -label Exit \
+ -command [list [namespace origin Exit] $app]
+ $app configure -menu $menu
+
+ ttk::notebook $app.nb
+
+ set status [ttk::frame $app.status]
+ ttk::label $status.pane0 -anchor w
+ ttk::separator $status.sep0 -orient vertical
+ ttk::label $status.pane1 -anchor w
+ ttk::separator $status.sep1 -orient vertical
+ ttk::sizegrip $status.sizegrip
+ grid $status.pane0 $status.sep0 $status.pane1\
+ $status.sep1 $status.sizegrip -sticky news
+ grid columnconfigure $status 0 -weight 1
+ grid rowconfigure $status 0 -weight 1
+
+ grid $app.nb -sticky news
+ grid $status -sticky sew
+ grid rowconfigure $app 0 -weight 1
+ grid columnconfigure $app 0 -weight 1
+
+ bind $app <Control-F2> {console show}
+
+ wm geometry .chat 600x400
+ wm deiconify $app
+
+ tkwait window $app
+ return
+}
+
+proc LoginIRC {app} {
+ set dlg $app.irclogin
+ variable $dlg {}
+ variable irc
+ if {![info exists irc]} {
+ array set irc {server irc.freenode.net port 6667 channel ""}
+ }
+ if {![winfo exists $dlg]} {
+ set dlg [toplevel $dlg -class Dialog]
+ wm withdraw $dlg
+ wm transient $dlg $app
+ wm title $dlg "IRC Login"
+
+ set f [ttk::frame $dlg.f]
+ set g [ttk::frame $f.g]
+ ttk::label $f.sl -text Server
+ ttk::entry $f.se -textvariable [namespace which -variable irc](server)
+ ttk::entry $f.sp -textvariable \
+ [namespace which -variable irc](port) -width 5
+ ttk::label $f.cl -text Channel
+ ttk::entry $f.cn -textvariable [namespace which -variable irc](channel)
+ ttk::label $f.nl -text Username
+ ttk::entry $f.nn -textvariable [namespace which -variable irc](nick)
+ ttk::button $f.ok -text Login -default active \
+ -command [list set [namespace which -variable $dlg] "ok"]
+ ttk::button $f.cancel -text Cancel \
+ -command [list set [namespace which -variable $dlg] "cancel"]
+
+ bind $dlg <Return> [list $f.ok invoke]
+ bind $dlg <Escape> [list $f.cancel invoke]
+ wm protocol $dlg WM_DELETE_WINDOW [list $f.cancel invoke]
+
+ grid $f.sl $f.se $f.sp -in $g -sticky new -padx 1 -pady 1
+ grid $f.cl $f.cn - -in $g -sticky new -padx 1 -pady 1
+ grid $f.nl $f.nn - -in $g -sticky new -padx 1 -pady 1
+ grid columnconfigure $g 1 -weight 1
+
+ grid $g - -sticky news
+ grid $f.ok $f.cancel -sticky e -padx 1 -pady 1
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+
+ grid $f -sticky news
+ grid rowconfigure $dlg 0 -weight 1
+ grid columnconfigure $dlg 0 -weight 1
+
+ wm resizable $dlg 0 0
+ raise $dlg
+ }
+
+ catch {::tk::PlaceWindow $dlg widget $app}
+ wm deiconify $dlg
+ tkwait visibility $dlg
+ focus -force $dlg.f.ok
+ grab $dlg
+ vwait [namespace which -variable $dlg]
+ grab release $dlg
+ wm withdraw $dlg
+
+ if {[set $dlg] eq "ok"} {
+ after idle [list [namespace origin IrcConnect] $app \
+ -server $irc(server) \
+ -port $irc(port) \
+ -channel $irc(channel) \
+ -nick $irc(nick)]
+ }
+}
+
+proc Exit {app} {
+ destroy $app
+ exit
+}
+
+proc Status {Chat message} {
+ upvar #0 $Chat chat
+ $chat(app).status.pane0 configure -text $message
+}
+
+proc State {Chat message} {
+ upvar #0 $Chat chat
+ $chat(app).status.pane1 configure -text $message
+}
+
+proc bgerror {args} {
+ tk_messageBox -icon error -title "Error" -message $::errorInfo
+}
+
+proc Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# Handle the IRC transport (using picoirc)
+
+proc IrcConnect {app args} {
+ variable ircuid
+ set id irc[incr ircuid]
+ set Chat [namespace current]::$id
+ upvar #0 $Chat chat
+ set chat(app) $app
+ set chat(type) irc
+
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -server { set chat(server) [Pop args 1] }
+ -port { set chat(port) [Pop args 1] }
+ -channel { set chat(channel) [Pop args 1] }
+ -nick { set chat(nick) [Pop args 1] }
+ default {
+ return -code error "invalid option \"$option\""
+ }
+ }
+ Pop args
+ }
+ set chat(window) [chatwidget::chatwidget $app.$id]
+ $chat(window) names hide
+ set chat(targets) [list]
+ $app.nb add $chat(window) -text $chat(server)
+ set url irc://$chat(server):$chat(port)
+ set chat(irc) [picoirc::connect \
+ [list [namespace origin IrcCallback] $Chat] \
+ $chat(nick) $url]
+ $chat(window) hook add post [list ::picoirc::post $chat(irc) ""]
+ bind $chat(window) <Destroy> "+unset -nocomplain $Chat"
+ return $Chat
+}
+
+proc IrcJoinChannel {Chat args} {
+ variable ircuid
+}
+
+proc IrcAddChannel {Chat channel} {
+ upvar #0 $Chat chat
+ set Channel "${Chat}/$channel"
+ upvar #0 $Channel chan
+ array set chan [array get chat]
+ set chan(channel) $channel
+ set chan(window) [chatwidget::chatwidget $chat(window)$channel]
+ lappend chat(targets) [list $channel $chan(window)]
+ $chat(app).nb add $chan(window) -text $channel
+ $chat(app).nb select $chan(window)
+ $chan(window) hook add post [list ::picoirc::post $chan(irc) $channel]
+ bind $chan(window) <Destroy> "+unset -nocomplain $Channel"
+ return
+}
+
+proc IrcRemoveChannel {Chat target} {
+ upvar #0 $Chat chat
+ Status $Chat "Left channel $target"
+ set w [IrcFindWindow $Chat $target]
+ if {[winfo exists $w]} { destroy $w }
+ if {[set ndx [lsearch -index 0 $chat(targets) $target]] != -1} {
+ set chat(targets) [lreplace $chat(targets) $ndx $ndx]
+ }
+}
+
+proc IrcFindWindow {Chat target} {
+ upvar #0 $Chat chat
+ set w $chat(window)
+ if {[set ndx [lsearch -index 0 $chat(targets) $target]] != -1} {
+ set w [lindex [lindex $chat(targets) $ndx] 1]
+ }
+ return $w
+}
+
+proc IrcCallback {Chat context state args} {
+ upvar #0 $Chat chat
+ upvar #0 $context irc
+ switch -exact -- $state {
+ init {
+ Status $Chat "Attempting to connect to $irc(server)"
+ }
+ connect {
+ $chat(window) message "Logging into $irc(server) as $irc(nick)" -type system
+ Status $Chat "Connection to IRC server established."
+ State $Chat connected
+ }
+ close {
+ if {[llength $args] != 0} {
+ $chat(window) message "Failed to connect: [lindex $args 0]" -type system
+ Status $Chat [lindex $args 0]
+ } else {
+ $chat(window) message "Disconnected from server" -type system
+ Status $Chat "Disconnected."
+ }
+ State $Chat !connected
+ }
+ userlist {
+ foreach {target users} $args break
+ set colors {black SteelBlue4 tomato chocolate SeaGreen4 red4
+ green4 blue4 pink4}
+ set w [IrcFindWindow $Chat $target]
+ set current [$w name list -full]
+ foreach nick $users {
+ set opts [list -status online]
+ if {[string match @* $nick]} {
+ set nick [string range $nick 1 end]
+ lappend opts -group operators
+ } else { lappend opts -group users }
+ if {[lsearch -index 0 $current $nick] == -1} {
+ lappend opts -color \
+ [lindex $colors [expr {int(rand() * [llength $colors])}]]
+ }
+ eval [list $w name add $nick] $opts
+ }
+ }
+ userinfo {
+ foreach {nick userinfo} $args break
+ array set info $userinfo
+ $chat(window) message "$nick $userinfo" -type system
+ }
+ chat {
+ foreach {target nick msg type} $args break
+ if {$type eq ""} {set type normal}
+ set w [IrcFindWindow $Chat $target]
+ $w message $msg -nick $nick -type $type
+ }
+ system {
+ foreach {target msg} $args break
+ [IrcFindWindow $Chat $target] message $msg -type system
+ }
+ topic {
+ foreach {target topic} $args break
+ set w [IrcFindWindow $Chat $target]
+ $w topic show
+ $w topic set $topic
+ }
+ traffic {
+ foreach {action target nick new} $args break
+ if {$nick eq $irc(nick)} {
+ switch -exact -- $action {
+ left { IrcRemoveChannel $Chat $target }
+ entered { IrcAddChannel $Chat $target}
+ }
+ }
+ if {$target ne {}} {
+ set w [IrcFindWindow $Chat $target]
+ IrcCallbackNick $w $action $target $nick $new
+ } else {
+ foreach window_target $chat(targets) {
+ foreach {window_channel w} $window_target break
+ set current [$w name list -full]
+ if {[lsearch -index 0 $current $nick] != -1} {
+ IrcCallbackNick $w $action $target $nick $new
+ }
+ }
+ }
+ }
+ debug {
+ foreach {type line} $args break
+ if {![info exists chat(log)]} {set chat(log) [open irc.log a]}
+ puts $chat(log) "[string toupper [string range $type 0 0]] $line"
+ }
+ version { return "" }
+ default {
+ $chat(window) message "unknown irc callback \"$state\": $args" -type error
+ }
+ }
+}
+
+proc IrcCallbackNick {w action target nick new} {
+ if {$action eq "nickchange"} {
+ $w name delete $nick
+ $w name add $new -group users
+ $w message "$nick changed to $new" -type system
+ } else {
+ switch -exact -- $action {
+ left { $w name delete $nick }
+ entered { $w name add $nick -group users }
+ }
+ $w message "$nick $action" -type system
+ }
+}
+
+# -------------------------------------------------------------------------
+
+if {![info exists initialized] && !$tcl_interactive} {
+ set initialized 1
+ wm withdraw .
+ set r [catch [linsert $argv 0 Main] err]
+ if {$r} {tk_messageBox -icon error -type ok -message $::errorInfo}
+ exit $r
+}
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+<?xml version='1.0'?><stream:stream xmlns:stream='http://etherx.jabber.org/streams' xmlns='jabber:client' from='all.tclers.tk' id='d78gzpp091vzv1ai3kn4r9oak5d7ubb8ijoi8eii'>
+<iq xmlns='jabber:client' type='result' id='1003' to='patthoyts@all.tclers.tk/Frog' from='pat0@tach.tclers.tk'><query xmlns='http://jabber.org/protocol/muc#owner'><x xmlns='jabber:x:data' type='form'><title>Room configuration</title><instructions>Your room "pat0" has been created! The default configuration is as follows:
+- No logging
+- No moderation
+- Up to 30 participants
+- No password required
+- No invitation required
+- Room is not persistent
+- Only admins may change the subject
+To accept the default configuration, click OK. To select a different configuration, please complete this form</instructions><field type='hidden' var='form'><value>config</value></field><field type='text-single' label='Natural-Language Room Name' var='muc#owner_roomname'><value>pat0</value></field><field type='text-multi' label='Short Description of Room' var='muc#owner_roomdesc'><value>pat0</value></field><field type='fixed'><value>The following messages are sent to legacy clients.</value></field><field type='text-single' label='Message for user leaving room' var='leave'><value>has left</value></field><field type='text-single' label='Message for user joining room' var='join'><value>has become available</value></field><field type='text-single' label='Message for user renaming nickname in room' var='rename'><value>is now known as</value></field><field type='boolean' label='Allow Occupants to Change Subject' var='muc#owner_changesubject'><value>0</value></field><field type='list-single' label='Maximum Number of Room Occupants' var='muc#owner_maxusers'><value>30</value><option label='1'><value>1</value></option><option label='10'><value>10</value></option><option label='20'><value>20</value></option><option label='30'><value>30</value></option><option label='40'><value>40</value></option><option label='50'><value>50</value></option><option label='None'><value>0</value></option></field><field type='boolean' label='Allow Occupants to query other Occupants?' var='privacy'><value>1</value></field><field type='boolean' label='Allow Public Searching for Room' var='muc#owner_publicroom'><value>1</value></field><field type='boolean' label='Make Room Persistent' var='muc#owner_persistentroom'><value>0</value></field><field type='boolean' label='Consider all Clients as Legacy (shown messages)' var='legacy'><value>0</value></field><field type='boolean' label='Make Room Moderated' var='muc#owner_moderatedroom'><value>0</value></field><field type='fixed'><value>By default, new users entering a moderated room are only visitors</value></field><field type='boolean' label='Make Occupants in a Moderated Room Default to Participant' var='defaulttype'><value>0</value></field><field type='boolean' label='Ban Private Messages between Occupants' var='privmsg'><value>0</value></field><field type='boolean' label='An Invitation is Required to Enter' var='muc#owner_inviteonly'><value>0</value></field><field type='fixed'><value>By default, only admins can send invites in an invite-only room</value></field><field type='boolean' label='Allow Occupants to Invite Others' var='muc#owner_allowinvites'><value>0</value></field><field type='boolean' label='A Password is required to enter?' var='muc#owner_passwordprotectedroom'><value>0</value></field><field type='fixed'><value>If a password is required to enter this room, you must specify the password below.</value></field><field type='text-private' label='The Room Password' var='muc#owner_roomsecret'><value/></field><field type='list-single' label='Affiliations that May Discover Real JIDs of Occupants' var='muc#owner_whois'><value>admins</value><option label='Room Owner and Admins Only'><value>admins</value></option><option label='Anyone'><value>anyone</value></option></field><field type='boolean' label='Enable Logging of Room Conversations' var='muc#owner_enablelogging'><value>0</value></field><field type='list-single' label='Logfile format' var='logformat'><value>text</value><option label='XML'><value>xml</value></option><option label='XHTML'><value>xhtml</value></option><option label='Tcl Script'><value>tcl</value></option><option label='Plain Text'><value>text</value></option></field></x></query></iq></stream:stream>
\ No newline at end of file
--- /dev/null
+proc Grid {w {row 0} {column 0}} {
+ grid rowconfigure $w $row -weight 1
+ grid columnconfigure $w $column -weight 1
+}
+
+proc Test {} {
+ set dlg [toplevel .dlg -class Dialog]
+ wm withdraw $dlg
+ wm title $dlg "Testing sashplacement"
+ set pw [ttk::panedwindow $dlg.pw -orient vertical]
+
+ set lower [ttk::frame $pw.lower]
+ set text [text $lower.text -relief flat -height 10]
+ set textvs [scrollbar $lower.vs -command [list $text yview]]
+ $text configure -yscrollcommand [list scroll_set $textvs $pw]
+ grid $text $textvs -sticky news
+ Grid $lower 0 0
+
+ set upper [ttk::frame $pw.upper]
+ set peer [$text peer create $upper.text -relief flat -height 1]
+ set peervs [scrollbar $upper.vs -command [list $peer yview]]
+ $peer configure -yscrollcommand [list scroll_set $peervs $pw]
+ grid $peer $peervs -sticky news
+ Grid $upper 0 0
+
+ $pw add $upper
+ $pw add $lower -weight 10
+ bind $peer <Map> [list map_pane %W $pw 0]
+
+ grid $pw -sticky news
+ Grid $dlg 0 0
+ wm deiconify $dlg
+}
+
+proc map_pane {w pw pos} {
+ bind $w <Map> {}
+ if {[llength [$pw panes]] > 1} {
+ after idle [list $pw sashpos 0 $pos]
+ }
+}
+
+proc scroll_set {scrollbar pw f1 f2} {
+ $scrollbar set $f1 $f2
+ if {($f1 == 0) && ($f2 == 1)} {
+ grid remove $scrollbar
+ } else {
+ if {[llength [$pw panes]] > 1} {
+ set pos [$pw sashpos 0]
+ grid $scrollbar
+ after idle [list $pw sashpos 0 $pos]
+ } else {
+ grid $scrollbar
+ }
+ }
+}
--- /dev/null
+# -------------------------------------------------------------------------
+# Handle the IRC transport (using picoirc)
+
+proc IrcConnect {app args} {
+ variable ircuid
+ set id irc[incr ircuid]
+ set Chat [namespace current]::$id
+ upvar #0 $Chat chat
+ array set chat [list app $app type irc passwd "" nick ""]
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -server { set chat(server) [Pop args 1] }
+ -port { set chat(port) [Pop args 1] }
+ -channel { set chat(channel) [Pop args 1] }
+ -nick { set chat(nick) [Pop args 1] }
+ -passwd { set chat(passwd) [Pop args 1] }
+ default {
+ return -code error "invalid option \"$option\""
+ }
+ }
+ Pop args
+ }
+ set chat(window) [chatwidget::chatwidget $app.$id]
+ $chat(window) names hide
+ set chat(targets) [list]
+ $app.nb add $chat(window) -text $chat(server)
+ $app.nb select $chat(window)
+ set url irc://$chat(server):$chat(port)
+ if {[info exists chat(channel)] && $chat(channel) ne ""} {
+ append url /$chat(channel)
+ }
+ set chat(irc) [picoirc::connect \
+ [list [namespace origin IrcCallback] $Chat] \
+ $chat(nick) $chat(passwd) $url]
+ $chat(window) hook add post [list ::picoirc::post $chat(irc) ""]
+ bind $chat(window) <Destroy> "+unset -nocomplain $Chat"
+ return $Chat
+}
+
+proc IrcJoinChannel {Chat args} {
+ variable ircuid
+}
+
+proc IrcAddChannel {Chat channel} {
+ upvar #0 $Chat chat
+ set Channel "${Chat}/$channel"
+ upvar #0 $Channel chan
+ array set chan [array get chat]
+ set chan(channel) $channel
+ set chan(window) [chatwidget::chatwidget $chat(window)$channel]
+ lappend chat(targets) [list $channel $chan(window)]
+ $chat(app).nb add $chan(window) -text $channel
+ $chat(app).nb select $chan(window)
+ set m0 [font measure ChatwidgetFont {[00:00]m}]
+ set m1 [font measure ChatwidgetFont [string repeat m 10]]
+ set mm [expr {$m0 + $m1}]
+ $chan(window) chat configure -tabs [list $m0 $mm]
+ $chan(window) chat tag configure MSG -lmargin1 $mm -lmargin2 $mm
+ $chan(window) chat tag configure NICK -font ChatwidgetBoldFont
+ $chan(window) chat tag configure TYPE-system -font ChatwidgetItalicFont
+ $chan(window) names tag bind NICK <Button-3> \
+ [list [namespace origin ChannelNickMenu] $Channel %W %x %y]
+ $chan(window) names tag bind NICK <Enter> \
+ [list [namespace origin IrcNickTooltip] $Chat enter %W %x %y]
+ $chan(window) names tag bind NICK <Leave> \
+ [list [namespace origin IrcNickTooltip] $Chat leave %W %x %y]
+ $chan(window) hook add post [list ::picoirc::post $chan(irc) $channel]
+ bind $chan(window) <Destroy> "+unset -nocomplain $Channel"
+ return
+}
+
+proc IrcRemoveChannel {Chat target} {
+ upvar #0 $Chat chat
+ Status $Chat "Left channel $target"
+ set w [IrcFindWindow $Chat $target]
+ if {[winfo exists $w]} { destroy $w }
+ if {[set ndx [lsearch -index 0 $chat(targets) $target]] != -1} {
+ set chat(targets) [lreplace $chat(targets) $ndx $ndx]
+ }
+}
+
+proc IrcNickTooltip {Chat type w x y} {
+ if {[package provide tooltip] eq {}} { return }
+ set nick [string trim [$w get "@$x,$y linestart" "@$x,$y lineend"]]
+ if {$nick eq ""} { return }
+ puts stderr "Tooltip $type $nick"
+ return
+}
+
+proc IrcFindWindow {Chat target} {
+ upvar #0 $Chat chat
+ set w $chat(window)
+ if {[set ndx [lsearch -nocase -index 0 $chat(targets) $target]] != -1} {
+ set w [lindex [lindex $chat(targets) $ndx] 1]
+ }
+ return $w
+}
+
+proc IrcCallback {Chat context state args} {
+ upvar #0 $Chat chat
+ upvar #0 $context irc
+ switch -exact -- $state {
+ init {
+ Status $Chat "Attempting to connect to $irc(server)"
+ }
+ connect {
+ $chat(window) message "Logging into $irc(server) as $irc(nick)" -type system
+ Status $Chat "Connection to IRC server established."
+ State $Chat connected
+ }
+ close {
+ if {[llength $args] != 0} {
+ $chat(window) message "Failed to connect: [lindex $args 0]" -type system
+ Status $Chat [lindex $args 0]
+ } else {
+ $chat(window) message "Disconnected from server" -type system
+ Status $Chat "Disconnected."
+ }
+ State $Chat !connected
+ }
+ userlist {
+ foreach {target users} $args break
+ set colors {black SteelBlue4 tomato chocolate SeaGreen4 red4
+ green4 blue4 pink4}
+ set w [IrcFindWindow $Chat $target]
+ set current [$w name list -full]
+ foreach nick $users {
+ set opts [list -status online]
+ if {[string match @* $nick]} {
+ set nick [string range $nick 1 end]
+ lappend opts -group operators
+ } else { lappend opts -group users }
+ if {[lsearch -index 0 $current $nick] == -1} {
+ lappend opts -color \
+ [lindex $colors [expr {int(rand() * [llength $colors])}]]
+ }
+ eval [list $w name add $nick] $opts
+ }
+ }
+ userinfo {
+ foreach {nick userinfo} $args break
+ array set info {name {} host {} channels {} userinfo {}}
+ array set info $userinfo
+ set chat(userinfo,$nick) [array get info]
+ }
+ chat {
+ foreach {target nick msg type} $args break
+ if {$type eq ""} {set type normal}
+ set w [IrcFindWindow $Chat $target]
+ if {$nick eq "tcl@tach.tclers.tk"} {
+ set action ""; set jnick "" ; set jnew ""
+ if {[regexp {^\s*([^ ]+) is now known as (.*)} $msg -> jnick jnew]} {
+ set action nickchange
+ } elseif {[regexp {^\s*([^ ]+) has left} $msg -> jnick]} {
+ set action left
+ } elseif {[regexp {^\s*([^ ]+) has become available} $msg -> jnick]} {
+ set action entered
+ }
+ if {$action ne ""} {
+ IrcCallbackNick $w $action $target $jnick $jnew jabber
+ return
+ }
+ }
+ $w message $msg -nick $nick -type $type
+ }
+ system {
+ foreach {target msg} $args break
+ [IrcFindWindow $Chat $target] message $msg -type system
+ }
+ topic {
+ foreach {target topic} $args break
+ set w [IrcFindWindow $Chat $target]
+ $w topic show
+ $w topic set $topic
+ }
+ traffic {
+ foreach {action target nick new} $args break
+ if {$nick eq $irc(nick)} {
+ switch -exact -- $action {
+ left { IrcRemoveChannel $Chat $target }
+ entered { IrcAddChannel $Chat $target}
+ nickchange { set irc(nick) $new }
+ }
+ }
+ if {$target ne {}} {
+ set w [IrcFindWindow $Chat $target]
+ IrcCallbackNick $w $action $target $nick $new
+ } else {
+ foreach window_target $chat(targets) {
+ foreach {window_channel w} $window_target break
+ set current [$w name list -full]
+ if {[lsearch -index 0 $current $nick] != -1} {
+ IrcCallbackNick $w $action $target $nick $new
+ }
+ }
+ }
+ }
+ debug {
+ foreach {type line} $args break
+ if {[winfo exists $chat(app).nb.debug.text]} {
+ $chat(app).nb.debug.text insert end "$line\n" $type
+ }
+ # You can log raw IRC to file by uncommenting the following lines:
+ #if {![info exists chat(log)]} {set chat(log) [open irc.log a]}
+ #puts $chat(log) "[string toupper [string range $type 0 0]] $line"
+ }
+ version { return "" }
+ default {
+ $chat(window) message "unknown irc callback \"$state\": $args" -type error
+ }
+ }
+}
+
+proc IrcCallbackNick {w action target nick new {group users}} {
+ #puts stderr "process traffic $w $nick $action $new $target"
+ if {$action eq "nickchange"} {
+ $w name delete $nick
+ $w name add $new -group $group
+ $w message "$nick changed to $new" -type system
+ } else {
+ switch -exact -- $action {
+ left { $w name delete $nick }
+ entered { $w name add $nick -group $group }
+ }
+ $w message "$nick $action" -type system
+ }
+}
--- /dev/null
+# autoproxy.tcl - Copyright (C) 2002-2008 Pat Thoyts <patthoyts@users.sf.net>
+#
+# On Unix the standard for identifying the local HTTP proxy server
+# seems to be to use the environment variable http_proxy or ftp_proxy and
+# no_proxy to list those domains to be excluded from proxying.
+#
+# On Windows we can retrieve the Internet Settings values from the registry
+# to obtain pretty much the same information.
+#
+# With this information we can setup a suitable filter procedure for the
+# Tcl http package and arrange for automatic use of the proxy.
+#
+# Example:
+# package require autoproxy
+# autoproxy::init
+# set tok [http::geturl http://wiki.tcl.tk/]
+# http::data $tok
+#
+# To support https add:
+# package require tls
+# http::register https 443 ::autoproxy::tls_socket
+#
+# @(#)$Id: autoproxy.tcl,v 1.13 2008/03/01 00:41:35 andreas_kupries Exp $
+
+package require http; # tcl
+package require uri; # tcllib
+package require base64; # tcllib
+
+namespace eval ::autoproxy {
+ variable rcsid {$Id: autoproxy.tcl,v 1.13 2008/03/01 00:41:35 andreas_kupries Exp $}
+ variable version 1.5.1
+ variable options
+
+ if {! [info exists options]} {
+ array set options {
+ proxy_host ""
+ proxy_port 80
+ no_proxy {}
+ basic {}
+ authProc {}
+ }
+ }
+
+ variable uid
+ if {![info exists uid]} { set uid 0 }
+
+ variable winregkey
+ set winregkey [join {
+ HKEY_CURRENT_USER
+ Software Microsoft Windows
+ CurrentVersion "Internet Settings"
+ } \\]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Obtain configuration options for the server.
+#
+proc ::autoproxy::cget {option} {
+ variable options
+ switch -glob -- $option {
+ -host -
+ -proxy_h* { set options(proxy_host) }
+ -port -
+ -proxy_p* { set options(proxy_port) }
+ -no* { set options(no_proxy) }
+ -basic { set options(basic) }
+ -authProc { set options(authProc) }
+ default {
+ set err [join [lsort [array names options]] ", -"]
+ return -code error "bad option \"$option\":\
+ must be one of -$err"
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Configure the autoproxy package settings.
+# You may only configure one type of authorisation at a time as once we hit
+# -basic, -digest or -ntlm - all further args are passed to the protocol
+# specific script.
+#
+# Of course, most of the point of this package is to fill as many of these
+# fields as possible automatically. You should call autoproxy::init to
+# do automatic configuration and then call this method to refine the details.
+#
+proc ::autoproxy::configure {args} {
+ variable options
+
+ if {[llength $args] == 0} {
+ foreach {opt value} [array get options] {
+ lappend r -$opt $value
+ }
+ return $r
+ }
+
+ while {[string match "-*" [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -host -
+ -proxy_h* { set options(proxy_host) [Pop args 1]}
+ -port -
+ -proxy_p* { set options(proxy_port) [Pop args 1]}
+ -no* { set options(no_proxy) [Pop args 1] }
+ -basic { Pop args; configure:basic $args ; break }
+ -authProc { set options(authProc) [Pop args] }
+ -- { Pop args; break }
+ default {
+ set opts [join [lsort [array names options]] ", -"]
+ return -code error "bad option \"$option\":\
+ must be one of -$opts"
+ }
+ }
+ Pop args
+ }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Initialise the http proxy information from the environment or the
+# registry (Win32)
+#
+# This procedure will load the http package and re-writes the
+# http::geturl method to add in the authorisation header.
+#
+# A better solution will be to arrange for the http package to request the
+# authorisation key on receiving an authorisation reqest.
+#
+proc ::autoproxy::init {{httpproxy {}} {no_proxy {}}} {
+ global tcl_platform
+ global env
+ variable winregkey
+ variable options
+
+ # Look for standard environment variables.
+ if {[string length $httpproxy] > 0} {
+
+ # nothing to do
+
+ } elseif {[info exists env(http_proxy)]} {
+ set httpproxy $env(http_proxy)
+ if {[info exists env(no_proxy)]} {
+ set no_proxy $env(no_proxy)
+ }
+ } else {
+ if {$tcl_platform(platform) == "windows"} {
+ #checker -scope block exclude nonPortCmd
+ package require registry 1.0
+ array set reg {ProxyEnable 0 ProxyServer "" ProxyOverride {}}
+ catch {
+ # IE5 changed ProxyEnable from a binary to a dword value.
+ switch -exact -- [registry type $winregkey "ProxyEnable"] {
+ dword {
+ set reg(ProxyEnable) [registry get $winregkey "ProxyEnable"]
+ }
+ binary {
+ set v [registry get $winregkey "ProxyEnable"]
+ binary scan $v i reg(ProxyEnable)
+ }
+ default {
+ return -code error "unexpected type found for\
+ ProxyEnable registry item"
+ }
+ }
+ set reg(ProxyServer) [GetWin32Proxy http]
+ set reg(ProxyOverride) [registry get $winregkey "ProxyOverride"]
+ }
+ if {![string is bool $reg(ProxyEnable)]} {
+ set reg(ProxyEnable) 0
+ }
+ if {$reg(ProxyEnable)} {
+ set httpproxy $reg(ProxyServer)
+ set no_proxy $reg(ProxyOverride)
+ }
+ }
+ }
+
+ # If we found something ...
+ if {[string length $httpproxy] > 0} {
+ # The http_proxy is supposed to be a URL - lets make sure.
+ if {![regexp {\w://.*} $httpproxy]} {
+ set httpproxy "http://$httpproxy"
+ }
+
+ # decompose the string.
+ array set proxy [uri::split $httpproxy]
+
+ # turn the no_proxy value into a tcl list
+ set no_proxy [string map {; " " , " "} $no_proxy]
+
+ # configure ourselves
+ configure -proxy_host $proxy(host) \
+ -proxy_port $proxy(port) \
+ -no_proxy $no_proxy
+
+ # Lift the authentication details from the environment if present.
+ if {[string length $proxy(user)] < 1 \
+ && [info exists env(http_proxy_user)] \
+ && [info exists env(http_proxy_pass)]} {
+ set proxy(user) $env(http_proxy_user)
+ set proxy(pwd) $env(http_proxy_pass)
+ }
+
+ # Maybe the proxy url has authentication parameters?
+ # At this time, only Basic is supported.
+ if {[string length $proxy(user)] > 0} {
+ configure -basic -username $proxy(user) -password $proxy(pwd)
+ }
+
+ # setup and configure the http package to use our proxy info.
+ http::config -proxyfilter [namespace origin filter]
+ }
+ return $httpproxy
+}
+
+# autoproxy::GetWin32Proxy --
+#
+# Parse the Windows Internet Settings registry key and return the
+# protocol proxy requested. If the same proxy is in use for all
+# protocols, then that will be returned. Otherwise the string is
+# parsed. Example:
+# ftp=proxy:80;http=proxy:80;https=proxy:80
+#
+proc ::autoproxy::GetWin32Proxy {protocol} {
+ variable winregkey
+ #checker exclude nonPortCmd
+ set proxies [split [registry get $winregkey "ProxyServer"] ";"]
+ foreach proxy $proxies {
+ if {[string first = $proxy] == -1} {
+ return $proxy
+ } else {
+ foreach {prot host} [split $proxy =] break
+ if {[string compare $protocol $prot] == 0} {
+ return $host
+ }
+ }
+ }
+ return -code error "failed to identify an '$protocol' proxy"
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Pop the nth element off a list. Used in options processing.
+proc ::autoproxy::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# Description
+# An example user authentication procedure.
+# Returns:
+# A two element list consisting of the users authentication id and
+# password.
+proc ::autoproxy::defAuthProc {{user {}} {passwd {}} {realm {}}} {
+ if {[string length $realm] > 0} {
+ set title "Realm: $realm"
+ } else {
+ set title {}
+ }
+
+ # If you are using BWidgets then the following will do:
+ #
+ # package require BWidget
+ # return [PasswdDlg .defAuthDlg -parent {} -transient 0 \
+ # -title $title -logintext $user -passwdtext $passwd]
+ #
+ # if you just have Tk and no BWidgets --
+
+ set dlg [toplevel .autoproxy_defAuthProc -class Dialog]
+ wm title $dlg $title
+ wm withdraw $dlg
+ label $dlg.ll -text Login -underline 0 -anchor w
+ entry $dlg.le -textvariable [namespace current]::${dlg}:l
+ label $dlg.pl -text Password -underline 0 -anchor w
+ entry $dlg.pe -show * -textvariable [namespace current]::${dlg}:p
+ button $dlg.ok -text OK -default active -width -11 \
+ -command [list set [namespace current]::${dlg}:ok 1]
+ grid $dlg.ll $dlg.le -sticky news
+ grid $dlg.pl $dlg.pe -sticky news
+ grid $dlg.ok - -sticky e
+ grid columnconfigure $dlg 1 -weight 1
+ bind $dlg <Return> [list $dlg.ok invoke]
+ bind $dlg <Alt-l> [list focus $dlg.le]
+ bind $dlg <Alt-p> [list focus $dlg.pe]
+ variable ${dlg}:l $user; variable ${dlg}:p $passwd
+ variable ${dlg}:ok 0
+ wm deiconify $dlg; focus $dlg.pe; update idletasks
+ set old [::grab current]; grab $dlg
+ tkwait variable [namespace current]::${dlg}:ok
+ grab release $dlg ; if {[llength $old] > 0} {::grab $old}
+ set r [list [set ${dlg}:l] [set ${dlg}:p]]
+ unset ${dlg}:l; unset ${dlg}:p; unset ${dlg}:ok
+ destroy $dlg
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Implement support for the Basic authentication scheme (RFC 1945,2617).
+# Options:
+# -user userid - pass in the user ID (May require Windows NT domain
+# as DOMAIN\\username)
+# -password pwd - pass in the user's password.
+# -realm realm - pass in the http realm.
+#
+proc ::autoproxy::configure:basic {arglist} {
+ variable options
+ array set opts {user {} passwd {} realm {}}
+ foreach {opt value} $arglist {
+ switch -glob -- $opt {
+ -u* { set opts(user) $value}
+ -p* { set opts(passwd) $value}
+ -r* { set opts(realm) $value}
+ default {
+ return -code error "invalid option \"$opt\": must be one of\
+ -username or -password or -realm"
+ }
+ }
+ }
+
+ # If nothing was provided, try calling the authProc
+ if {$options(authProc) != {} \
+ && ($opts(user) == {} || $opts(passwd) == {})} {
+ set r [$options(authProc) $opts(user) $opts(passwd) $opts(realm)]
+ set opts(user) [lindex $r 0]
+ set opts(passwd) [lindex $r 1]
+ }
+
+ # Store the encoded string to avoid re-encoding all the time.
+ set options(basic) [list "Proxy-Authorization" \
+ [concat "Basic" \
+ [base64::encode $opts(user):$opts(passwd)]]]
+ return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# An http package proxy filter. This attempts to work out if a request
+# should go via the configured proxy using a glob comparison against the
+# no_proxy list items. A typical no_proxy list might be
+# [list localhost *.my.domain.com 127.0.0.1]
+#
+# If we are going to use the proxy - then insert the proxy authorization
+# header.
+#
+proc ::autoproxy::filter {host} {
+ variable options
+
+ if {$options(proxy_host) == {}} {
+ return {}
+ }
+
+ foreach domain $options(no_proxy) {
+ if {[string match $domain $host]} {
+ return {}
+ }
+ }
+
+ # Add authorisation header to the request (by Anders Ramdahl)
+ catch {
+ upvar state State
+ if {$options(basic) != {}} {
+ set State(-headers) [concat $options(basic) $State(-headers)]
+ }
+ }
+ return [list $options(proxy_host) $options(proxy_port)]
+}
+
+# -------------------------------------------------------------------------
+# autoproxy::tls_connect --
+#
+# Create a connection to a remote machine through a proxy
+# if necessary. This is used by the tls_socket command for
+# use with the http package but can also be used more generally
+# provided your proxy will permit CONNECT attempts to ports
+# other than port 443 (many will not).
+# This command defers to 'tunnel_connect' to link to the target
+# host and then upgrades the link to SSL/TLS
+#
+proc ::autoproxy::tls_connect {args} {
+ variable options
+ if {[string length $options(proxy_host)] > 0} {
+ set s [eval [linsert $args 0 tunnel_connect]]
+ fconfigure $s -blocking 1 -buffering none -translation binary
+ if {[string equal "-async" [lindex $args end-2]]} {
+ eval [linsert [lrange $args 0 end-3] 0 ::tls::import $s]
+ } else {
+ eval [linsert [lrange $args 0 end-2] 0 ::tls::import $s]
+ }
+ } else {
+ set s [eval [linsert $args 0 ::tls::socket]]
+ }
+ return $s
+}
+
+# autoproxy::tunnel_connect --
+#
+# Create a connection to a remote machine through a proxy
+# if necessary. This is used by the tls_socket command for
+# use with the http package but can also be used more generally
+# provided your proxy will permit CONNECT attempts to ports
+# other than port 443 (many will not).
+# Note: this command just opens the socket through the proxy to
+# the target machine -- no SSL/TLS negotiation is done yet.
+#
+proc ::autoproxy::tunnel_connect {args} {
+ variable options
+ variable uid
+ set code ok
+ if {[string length $options(proxy_host)] > 0} {
+ set token [namespace current]::[incr uid]
+ upvar #0 $token state
+ set state(endpoint) [lrange $args end-1 end]
+ set state(state) connect
+ set state(data) ""
+ set state(useragent) [http::config -useragent]
+ set state(sock) [::socket $options(proxy_host) $options(proxy_port)]
+ fileevent $state(sock) writable [namespace code [list tunnel_write $token]]
+ vwait [set token](state)
+
+ if {[string length $state(error)] > 0} {
+ set result $state(error)
+ close $state(sock)
+ unset state
+ set code error
+ } elseif {$state(code) >= 300 || $state(code) < 200} {
+ set result [lindex $state(headers) 0]
+ regexp {HTTP/\d.\d\s+\d+\s+(.*)} $result -> result
+ close $state(sock)
+ set code error
+ } else {
+ set result $state(sock)
+ }
+ unset state
+ } else {
+ set result [eval [linsert $args 0 ::socket]]
+ }
+ return -code $code $result
+}
+
+proc ::autoproxy::tunnel_write {token} {
+ upvar #0 $token state
+ variable options
+ fileevent $state(sock) writable {}
+ if {[catch {set state(error) [fconfigure $state(sock) -error]} err]} {
+ set state(error) $err
+ }
+ if {[string length $state(error)] > 0} {
+ set state(state) error
+ return
+ }
+ fconfigure $state(sock) -blocking 0 -buffering line -translation crlf
+ foreach {host port} $state(endpoint) break
+ puts $state(sock) "CONNECT $host:$port HTTP/1.1"
+ puts $state(sock) "Host: $host"
+ if {[string length $state(useragent)] > 0} {
+ puts $state(sock) "User-Agent: $state(useragent)"
+ }
+ puts $state(sock) "Proxy-Connection: keep-alive"
+ puts $state(sock) "Connection: keep-alive"
+ if {[string length $options(basic)] > 0} {
+ puts $state(sock) [join $options(basic) ": "]
+ }
+ puts $state(sock) ""
+
+ fileevent $state(sock) readable [namespace code [list tunnel_read $token]]
+ return
+}
+
+proc ::autoproxy::tunnel_read {token} {
+ upvar #0 $token state
+ set len [gets $state(sock) line]
+ if {[eof $state(sock)]} {
+ fileevent $state(sock) readable {}
+ set state(state) eof
+ } elseif {$len == 0} {
+ set state(code) [lindex [split [lindex $state(headers) 0] { }] 1]
+ fileevent $state(sock) readable {}
+ set state(state) ok
+ } else {
+ lappend state(headers) $line
+ }
+}
+
+# autoproxy::tls_socket --
+#
+# This can be used to handle TLS connections independently of
+# proxy presence. It can only be used with the Tcl http package
+# and to use it you must do:
+# http::register https 443 ::autoproxy::tls_socket
+# After that you can use the http::geturl command to access
+# secure web pages and any proxy details will be handled for you.
+#
+proc ::autoproxy::tls_socket {args} {
+ variable options
+
+ # Look into the http package for the actual target. If a proxy is in use then
+ # The function appends the proxy host and port and not the target.
+
+ upvar host uhost port uport
+ set args [lrange $args 0 end-2]
+ lappend args $uhost $uport
+
+ set s [eval [linsert $args 0 tls_connect]]
+
+ # record the tls connection status in the http state array.
+ upvar state state
+ tls::handshake $s
+ set state(tls_status) [tls::status $s]
+
+ return $s
+}
+
+# -------------------------------------------------------------------------
+
+package provide autoproxy $::autoproxy::version
+
+# -------------------------------------------------------------------------
+#
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded autoproxy 1.5.1 [list source [file join $dir autoproxy.tcl]]
--- /dev/null
+# autosocks.tcl ---
+#
+# Interface to socks4/5 to make usage of 'socket' transparent.
+# Can also be used as a wrapper for the 'socket' command without any
+# proxy configured.
+#
+# (c) 2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# This source file is distributed under the BSD license.
+#
+# $Id: autosocks.tcl,v 1.9 2007/09/21 09:42:48 matben Exp $
+
+package provide autosocks 0.1
+
+namespace eval autosocks {
+ variable options
+ array set options {
+ -proxy ""
+ -proxyhost ""
+ -proxyport ""
+ -proxyusername ""
+ -proxypassword ""
+ -proxyno ""
+ -proxyfilter autosocks::filter
+ }
+
+ variable packs
+ foreach name {socks4 socks5} {
+ if {![catch {package require $name}]} {
+ set packs($name) 1
+ }
+ }
+}
+
+# autosocks::config --
+#
+# Get or set configuration options for the SOCKS proxy.
+#
+# Arguments:
+# args:
+# -proxy ""|socks4|socks5
+# -proxyhost hostname
+# -proxyport port number
+# -proxyusername user ID
+# -proxypassword (socks5) password
+# -proxyno glob list of hosts to not use proxy
+# -proxyfilter tclProc {host}
+#
+# Results:
+# one or many option values depending on arguments.
+
+proc autosocks::config {args} {
+ variable options
+ variable packs
+ if {[llength $args] == 0} {
+ return [array get options]
+ } elseif {[llength $args] == 1} {
+ return $options($args)
+ } else {
+ set idx [lsearch $args -proxy]
+ if {$idx >= 0} {
+ set proxy [lindex $args [incr idx]]
+ if {[string length $proxy] && ![info exists packs($proxy)]} {
+ return -code error "unsupported proxy \"$proxy\""
+ }
+ }
+ array set options $args
+ }
+}
+
+proc autosocks::init {} {
+ # @@@ Here we should get default settings from some system API.
+}
+
+# autosocks::socket --
+#
+# Subclassing the 'socket' command. Only client side.
+# We use -command tclProc instead of -async + fileevent writable.
+#
+# Arguments:
+# host: the peer address, not SOCKS server
+# port: the peer's port number
+# args:
+# -command tclProc {token status}
+# the 'status' is any of:
+# ok, error, timeout, network-failure,
+# rsp_*, err_* (see socks4/5)
+
+proc autosocks::socket {host port args} {
+ variable options
+
+ array set argsA $args
+ array set optsA $args
+ unset -nocomplain optsA(-command)
+ set proxy $options(-proxy)
+
+ set hostport [$options(-proxyfilter) $host]
+ if {[llength $hostport]} {
+ set ahost [lindex $hostport 0]
+ set aport [lindex $hostport 1]
+ } else {
+ set ahost $host
+ set aport $port
+ }
+
+ # Connect ahost + aport.
+ if {[info exists argsA(-command)]} {
+ set sock [eval ::socket -async [array get optsA] {$ahost $aport}]
+
+ # Take some precautions here since WiFi behaves odd.
+ if {[catch {eof $sock} iseof] || $iseof} {
+ return -code error eof
+ }
+ set err [fconfigure $sock -error]
+ if {$err ne ""} {
+ return -code error $err
+ }
+
+ set token [namespace current]::$sock
+ variable $token
+ upvar 0 $token state
+
+ set state(host) $host
+ set state(port) $port
+ set state(sock) $sock
+ set state(cmd) $argsA(-command)
+ fconfigure $sock -blocking 0
+
+ # There is a potential problem if the socket becomes writable in
+ # this call before we return! Therefore 'after idle'.
+ after idle [list \
+ fileevent $sock writable [namespace code [list writable $token]]]
+ } else {
+ set sock [eval {::socket $ahost $aport} [array get optsA]]
+ if {[string length $options(-proxy)]} {
+ eval {${proxy}::init $sock $host $port} [get_opts]
+ }
+ }
+ return $sock
+}
+
+proc autosocks::get_opts {} {
+ variable options
+
+ set opts [list]
+ if {[string length $options(-proxyusername)]} {
+ lappend opts -username $options(-proxyusername)
+ }
+ if {[string length $options(-proxypassword)]} {
+ lappend opts -password $options(-proxypassword)
+ }
+ return $opts
+}
+
+proc autosocks::writable {token} {
+ variable $token
+ upvar 0 $token state
+ variable options
+
+ set proxy $options(-proxy)
+ set sock $state(sock)
+ fileevent $sock writable {}
+
+ if {[catch {eof $sock} iseof] || $iseof} {
+ uplevel #0 $state(cmd) network-failure
+ unset -nocomplain state
+ } else {
+ if {[string length $proxy]} {
+ if {[catch {
+ eval {
+ $options(-proxy)::init $sock $state(host) $state(port) \
+ -command [namespace code [list socks_cb $token]]
+ } [get_opts]
+ } err]} {
+ uplevel #0 $state(cmd) $err
+ unset -nocomplain state
+ }
+ } else {
+ uplevel #0 $state(cmd) ok
+ unset -nocomplain state
+ }
+ }
+}
+
+proc autosocks::socks_cb {token stok status} {
+ variable $token
+ upvar 0 $token state
+ variable options
+
+ uplevel #0 $state(cmd) $status
+ $options(-proxy)::free $stok
+ unset -nocomplain state
+}
+
+proc autosocks::filter {host} {
+ variable options
+ if {[llength $options(-proxy)]} {
+ foreach domain $options(-proxyno) {
+ if {[string match $domain $host]} {
+ return {}
+ }
+ }
+ return [list $options(-proxyhost) $options(-proxyport)]
+ } else {
+ return [list]
+ }
+}
--- /dev/null
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded autosocks 0.1 [list source [file join $dir autosocks.tcl]]
--- /dev/null
+# base64.tcl --
+#
+# Encode/Decode base64 for a string
+# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems
+# The decoder was done for exmh by Chris Garrigues
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: base64.tcl,v 1.23 2004/10/03 23:06:55 andreas_kupries Exp $
+
+# Version 1.0 implemented Base64_Encode, Base64_Decode
+# Version 2.0 uses the base64 namespace
+# Version 2.1 fixes various decode bugs and adds options to encode
+# Version 2.2 is much faster, Tcl8.0 compatible
+# Version 2.2.1 bugfixes
+# Version 2.2.2 bugfixes
+# Version 2.3 bugfixes and extended to support Trf
+
+package require Tcl 8.2
+namespace eval ::base64 {
+ namespace export encode decode
+}
+
+if {![catch {package require Trf 2.0}]} {
+ # Trf is available, so implement the functionality provided here
+ # in terms of calls to Trf for speed.
+
+ # ::base64::encode --
+ #
+ # Base64 encode a given string.
+ #
+ # Arguments:
+ # args ?-maxlen maxlen? ?-wrapchar wrapchar? string
+ #
+ # If maxlen is 0, the output is not wrapped.
+ #
+ # Results:
+ # A Base64 encoded version of $string, wrapped at $maxlen characters
+ # by $wrapchar.
+
+ proc ::base64::encode {args} {
+ # Set the default wrapchar and maximum line length to match the output
+ # of GNU uuencode 4.2. Various RFCs allow for different wrapping
+ # characters and wraplengths, so these may be overridden by command line
+ # options.
+ set wrapchar "\n"
+ set maxlen 60
+
+ if { [llength $args] == 0 } {
+ error "wrong # args: should be \"[lindex [info level 0] 0]\
+ ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
+ }
+
+ set optionStrings [list "-maxlen" "-wrapchar"]
+ for {set i 0} {$i < [llength $args] - 1} {incr i} {
+ set arg [lindex $args $i]
+ set index [lsearch -glob $optionStrings "${arg}*"]
+ if { $index == -1 } {
+ error "unknown option \"$arg\": must be -maxlen or -wrapchar"
+ }
+ incr i
+ if { $i >= [llength $args] - 1 } {
+ error "value for \"$arg\" missing"
+ }
+ set val [lindex $args $i]
+
+ # The name of the variable to assign the value to is extracted
+ # from the list of known options, all of which have an
+ # associated variable of the same name as the option without
+ # a leading "-". The [string range] command is used to strip
+ # of the leading "-" from the name of the option.
+ #
+ # FRINK: nocheck
+ set [string range [lindex $optionStrings $index] 1 end] $val
+ }
+
+ # [string is] requires Tcl8.2; this works with 8.0 too
+ if {[catch {expr {$maxlen % 2}}]} {
+ error "expected integer but got \"$maxlen\""
+ }
+
+ set string [lindex $args end]
+ set result [::base64 -mode encode -- $string]
+ set result [string map [list \n ""] $result]
+
+ if {$maxlen > 0} {
+ set res ""
+ set edge [expr {$maxlen - 1}]
+ while {[string length $result] > $maxlen} {
+ append res [string range $result 0 $edge]$wrapchar
+ set result [string range $result $maxlen end]
+ }
+ if {[string length $result] > 0} {
+ append res $result
+ }
+ set result $res
+ }
+
+ return $result
+ }
+
+ # ::base64::decode --
+ #
+ # Base64 decode a given string.
+ #
+ # Arguments:
+ # string The string to decode. Characters not in the base64
+ # alphabet are ignored (e.g., newlines)
+ #
+ # Results:
+ # The decoded value.
+
+ proc ::base64::decode {string} {
+ regsub -all {\s} $string {} string
+ ::base64 -mode decode -- $string
+ }
+
+} else {
+ # Without Trf use a pure tcl implementation
+
+ namespace eval base64 {
+ variable base64 {}
+ variable base64_en {}
+
+ # We create the auxiliary array base64_tmp, it will be unset later.
+
+ set i 0
+ foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
+ a b c d e f g h i j k l m n o p q r s t u v w x y z \
+ 0 1 2 3 4 5 6 7 8 9 + /} {
+ set base64_tmp($char) $i
+ lappend base64_en $char
+ incr i
+ }
+
+ #
+ # Create base64 as list: to code for instance C<->3, specify
+ # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded
+ # ascii chars get a {}. we later use the fact that lindex on a
+ # non-existing index returns {}, and that [expr {} < 0] is true
+ #
+
+ # the last ascii char is 'z'
+ scan z %c len
+ for {set i 0} {$i <= $len} {incr i} {
+ set char [format %c $i]
+ set val {}
+ if {[info exists base64_tmp($char)]} {
+ set val $base64_tmp($char)
+ } else {
+ set val {}
+ }
+ lappend base64 $val
+ }
+
+ # code the character "=" as -1; used to signal end of message
+ scan = %c i
+ set base64 [lreplace $base64 $i $i -1]
+
+ # remove unneeded variables
+ unset base64_tmp i char len val
+
+ namespace export encode decode
+ }
+
+ # ::base64::encode --
+ #
+ # Base64 encode a given string.
+ #
+ # Arguments:
+ # args ?-maxlen maxlen? ?-wrapchar wrapchar? string
+ #
+ # If maxlen is 0, the output is not wrapped.
+ #
+ # Results:
+ # A Base64 encoded version of $string, wrapped at $maxlen characters
+ # by $wrapchar.
+
+ proc ::base64::encode {args} {
+ set base64_en $::base64::base64_en
+
+ # Set the default wrapchar and maximum line length to match the output
+ # of GNU uuencode 4.2. Various RFCs allow for different wrapping
+ # characters and wraplengths, so these may be overridden by command line
+ # options.
+ set wrapchar "\n"
+ set maxlen 60
+
+ if { [llength $args] == 0 } {
+ error "wrong # args: should be \"[lindex [info level 0] 0]\
+ ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
+ }
+
+ set optionStrings [list "-maxlen" "-wrapchar"]
+ for {set i 0} {$i < [llength $args] - 1} {incr i} {
+ set arg [lindex $args $i]
+ set index [lsearch -glob $optionStrings "${arg}*"]
+ if { $index == -1 } {
+ error "unknown option \"$arg\": must be -maxlen or -wrapchar"
+ }
+ incr i
+ if { $i >= [llength $args] - 1 } {
+ error "value for \"$arg\" missing"
+ }
+ set val [lindex $args $i]
+
+ # The name of the variable to assign the value to is extracted
+ # from the list of known options, all of which have an
+ # associated variable of the same name as the option without
+ # a leading "-". The [string range] command is used to strip
+ # of the leading "-" from the name of the option.
+ #
+ # FRINK: nocheck
+ set [string range [lindex $optionStrings $index] 1 end] $val
+ }
+
+ # [string is] requires Tcl8.2; this works with 8.0 too
+ if {[catch {expr {$maxlen % 2}}]} {
+ error "expected integer but got \"$maxlen\""
+ }
+
+ set string [lindex $args end]
+
+ set result {}
+ set state 0
+ set length 0
+
+
+ # Process the input bytes 3-by-3
+
+ binary scan $string c* X
+ foreach {x y z} $X {
+ # Do the line length check before appending so that we don't get an
+ # extra newline if the output is a multiple of $maxlen chars long.
+ if {$maxlen && $length >= $maxlen} {
+ append result $wrapchar
+ set length 0
+ }
+
+ append result [lindex $base64_en [expr {($x >>2) & 0x3F}]]
+ if {$y != {}} {
+ append result [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]]
+ if {$z != {}} {
+ append result \
+ [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]]
+ append result [lindex $base64_en [expr {($z & 0x3F)}]]
+ } else {
+ set state 2
+ break
+ }
+ } else {
+ set state 1
+ break
+ }
+ incr length 4
+ }
+ if {$state == 1} {
+ append result [lindex $base64_en [expr {(($x << 4) & 0x30)}]]==
+ } elseif {$state == 2} {
+ append result [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]=
+ }
+ return $result
+ }
+
+ # ::base64::decode --
+ #
+ # Base64 decode a given string.
+ #
+ # Arguments:
+ # string The string to decode. Characters not in the base64
+ # alphabet are ignored (e.g., newlines)
+ #
+ # Results:
+ # The decoded value.
+
+ proc ::base64::decode {string} {
+ if {[string length $string] == 0} {return ""}
+
+ set base64 $::base64::base64
+ set output "" ; # Fix for [Bug 821126]
+
+ binary scan $string c* X
+ foreach x $X {
+ set bits [lindex $base64 $x]
+ if {$bits >= 0} {
+ if {[llength [lappend nums $bits]] == 4} {
+ foreach {v w z y} $nums break
+ set a [expr {($v << 2) | ($w >> 4)}]
+ set b [expr {(($w & 0xF) << 4) | ($z >> 2)}]
+ set c [expr {(($z & 0x3) << 6) | $y}]
+ append output [binary format ccc $a $b $c]
+ set nums {}
+ }
+ } elseif {$bits == -1} {
+ # = indicates end of data. Output whatever chars are left.
+ # The encoding algorithm dictates that we can only have 1 or 2
+ # padding characters. If x=={}, we have 12 bits of input
+ # (enough for 1 8-bit output). If x!={}, we have 18 bits of
+ # input (enough for 2 8-bit outputs).
+
+ foreach {v w z} $nums break
+ set a [expr {($v << 2) | (($w & 0x30) >> 4)}]
+
+ if {$z == {}} {
+ append output [binary format c $a ]
+ } else {
+ set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}]
+ append output [binary format cc $a $b]
+ }
+ break
+ } else {
+ # RFC 2045 says that line breaks and other characters not part
+ # of the Base64 alphabet must be ignored, and that the decoder
+ # can optionally emit a warning or reject the message. We opt
+ # not to do so, but to just ignore the character.
+ continue
+ }
+ }
+ return $output
+ }
+}
+
+package provide base64 2.3.1
--- /dev/null
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded base64 2.3.1 [list source [file join $dir base64.tcl]]
+#package ifneeded uuencode 1.1.2 [list source [file join $dir uuencode.tcl]]
+#package ifneeded yencode 1.1.1 [list source [file join $dir yencode.tcl]]
--- /dev/null
+2008-02-16 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * pkgIndex.tcl: Incremented to 1.1.0
+ * chatwidget.tcl: Added support for chatstate notifications. This
+ is a Jabber (XEP-0085) concept that will likely be useful in many
+ chat implementations.
+ Also simpler support for changing the font with a cget/configure
+ override command and access the chatstate via cget -chatstate.
+
+2007-10-23 Andreas Kupries <andreask@activestate.com>
+
+ * chatwidget.man: Fixed syntax error in documentation.
+
+2007-10-19 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * chatwidget.tcl: Reorganized the widget tree to fix some problems
+ when adding scrollbars to the panes. Added
+ accessors for all the components.
+
+2007-10-19 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * chatwidget.tcl: Initial checkin of a composite widget for use
+ * chatwidget.man: in chat applications (eg: jabber or irc)
+ * pkgIndex.tcl:
+
+
--- /dev/null
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin chatwidget n 1.0.0]
+[moddesc {Composite widget for chat applications}]
+[titledesc {Provides a multi-paned view suitable for display of chat room or irc channel information}]
+[require Tk 8.5]
+[require chatwidget [opt 1.0.0]]
+[description]
+
+This is a composite widget designed to simplify the construction of
+chat applications. The widget contains display areas for chat
+messages, user names and topic and an entry area. It automatically
+handles colourization of messages per nick and manages nick
+completion. A system of hooks permit the application author to adjust
+display features. The main chat display area may be split for use
+displaying history or for searching.
+
+[para]
+
+The widget is made up of a number of text widget and panedwindow
+widgets so that the size of each part of the display may be adjusted
+by the user. All the text widgets may be accessed via widget
+passthrough commands if fine adjustment is required. The topic and
+names sections can also be hidden if desired.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::chatwidget::chatwidget] [arg path] [opt [arg options]]]
+
+Create a new chatwidget using the Tk window id [arg path]. Any options
+provided are currently passed directly to the main chat text widget.
+
+[list_end]
+
+[section {WIDGET COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd \$widget] topic [arg command] [arg args]]
+
+The chat widget can display a topic string, for instance the topic or
+name given to a multi-user chatroom or irc channel.
+[list_begin commands]
+[cmd_def show]
+Enable display of the topic.
+[cmd_def hide]
+Disable display of the topic
+[cmd_def "set [arg topic]"]
+Set the topic text to [arg topic].
+[list_end]
+
+[call [cmd \$widget] name [arg nick] [arg args]]
+
+Control the names and tags associated with names.
+[list_begin commands]
+[cmd_def "list [opt [arg -full]]"]
+Returns a list of all the user names from the names view. If [opt \
+-full] is given then the list returned is a list of lists where each
+sublist is made up of the nick followed by any options that have been
+set on this nick entry. This may be used to examine any application
+specific options that may be applied to a nick when using the
+[cmd add] command.
+[cmd_def "add [arg nick] [opt [arg options]]"]
+[cmd_def "delete [arg nick]"]
+[list_end]
+
+[call [cmd \$widget] message [arg text] [arg args]]
+
+Add messages to the display. options are -nick, -time, -type, -mark
+-tags
+
+[call [cmd \$widget] hook [arg command] [arg args]]
+
+Manage hooks. add (message, post names_group, names_nick, chatstate), remove, run
+
+[call [cmd \$widget] names [arg args]]
+
+Passthrough to the name display text widget. See the [cmd text] widget manual
+for all available commands. The chatwidget provides two additional
+commands [cmd show] and [cmd hide] which are used to control the
+display of this element in the widget.
+
+[call [cmd \$widget] entry [arg args]]
+
+Passthrough to the entry text widget. See the [cmd text] widget manual
+for all available commands.
+
+[list_end]
+
+
+[section EXAMPLE]
+
+[example {
+chatwidget::chatwidget .chat
+proc speak {w msg} {$w message $msg -nick user}
+.chat hook add post [list speak .chat]
+pack .chat -side top -fill both -expand 1
+.chat topic show
+.chat topic set "Chat widget demo"
+.chat name add "admin" -group admin
+.chat name add "user" -group users -color tomato
+.chat message "Chatwidget ready" -type system
+.chat message "Hello, user" -nick admin
+.chat message "Hello, admin" -nick user
+}]
+
+[para]
+
+A more extensive example is available by examining the code for the picoirc
+program in the tclapps repository which ties the tcllib [package picoirc] package to this
+[package chatwidget] package to create a simple irc client.
+
+[see_also text(n)]
+[keywords widget {mega-widget} {composite widget} chat irc chatwidget]
+[manpage_end]
--- /dev/null
+# chatwidget.tcl --
+#
+# This package provides a composite widget suitable for use in chat
+# applications. A number of panes managed by panedwidgets are available
+# for displaying user names, chat text and for entering new comments.
+# The main display area makes use of text widget peers to enable a split
+# view for history or searching.
+#
+# Copyright (C) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: chatwidget.tcl,v 1.3 2007/10/24 10:32:19 patthoyts Exp $
+
+package require Tk 8.5
+
+namespace eval chatwidget {
+ variable version 1.1.0
+
+ namespace export chatwidget
+
+ ttk::style layout ChatwidgetFrame {
+ Entry.field -sticky news -border 1 -children {
+ ChatwidgetFrame.padding -sticky news
+ }
+ }
+ if {[lsearch -exact [font names] ChatwidgetFont] == -1} {
+ eval [list font create ChatwidgetFont] [font configure TkTextFont]
+ eval [list font create ChatwidgetBoldFont] \
+ [font configure ChatwidgetFont] -weight bold
+ eval [list font create ChatwidgetItalicFont] \
+ [font configure ChatwidgetFont] -slant italic
+ }
+}
+
+proc chatwidget::chatwidget {w args} {
+ Create $w
+ interp hide {} $w
+ interp alias {} $w {} [namespace origin WidgetProc] $w
+ return $w
+}
+
+proc chatwidget::WidgetProc {self cmd args} {
+ upvar #0 [namespace current]::$self state
+ switch -- $cmd {
+ hook {
+ if {[llength $args] < 2} {
+ return -code error "wrong \# args: should be\
+ \"\$widget hook add|remove|list hook_type ?script? ?priority?\""
+ }
+ return [uplevel 1 [list [namespace origin Hook] $self] $args]
+ }
+ cget {
+ return [uplevel 1 [list [namespace origin Cget] $self] $args]
+ }
+ configure {
+ return [uplevel 1 [list [namespace origin Configure] $self] $args]
+ }
+ insert {
+ return [uplevel 1 [list [namespace origin Insert] $self] $args]
+ }
+ message {
+ return [uplevel 1 [list [namespace origin Message] $self] $args]
+ }
+ name {
+ return [uplevel 1 [list [namespace origin Name] $self] $args]
+ }
+ topic {
+ return [uplevel 1 [list [namespace origin Topic] $self] $args]
+ }
+ names {
+ return [uplevel 1 [list [namespace origin Names] $self] $args]
+ }
+ entry {
+ return [uplevel 1 [list [namespace origin Entry] $self] $args]
+ }
+ peer {
+ return [uplevel 1 [list [namespace origin Peer] $self] $args]
+ }
+ chat -
+ default {
+ return [uplevel 1 [list [namespace origin Chat] $self] $args]
+ }
+ }
+ return
+}
+
+proc chatwidget::Chat {self args} {
+ upvar #0 [namespace current]::$self state
+ if {[llength $args] == 0} {
+ return $state(chat_widget)
+ }
+ return [uplevel 1 [list $state(chat_widget)] $args]
+}
+
+proc chatwidget::Cget {self args} {
+ upvar #0 [namespace current]::$self state
+ switch -exact -- [set what [lindex $args 0]] {
+ -chatstate { return $state(chatstate) }
+ -history { return $state(history) }
+ default {
+ return [uplevel 1 [list $state(chat_widget) cget] $args]
+ }
+ }
+}
+
+proc chatwidget::Configure {self args} {
+ upvar #0 [namespace current]::$self state
+ switch -exact -- [set option [lindex $args 0]] {
+ -chatstate {
+ if {[llength $args] > 1} { set state(chatstate) [Pop args 1] }
+ else { return $state(chatstate) }
+ }
+ -history {
+ if {[llength $args] > 1} { set state(history) [Pop args 1] }
+ else { return $state(history) }
+ }
+ -font {
+ if {[llength $args] > 1} {
+ set font [Pop args 1]
+ set family [font actual $font -family]
+ set size [font actual $font -size]
+ font configure ChatwidgetFont -family $family -size $size
+ font configure ChatwidgetBoldFont -family $family -size $size
+ font configure ChatwidgetItalicFont -family $family -size $size
+ } else { return [$state(chat_widget) cget -font] }
+ }
+ default {
+ return [uplevel 1 [list $state(chat_widget) configure] $args]
+ }
+ }
+}
+
+proc chatwidget::Peer {self args} {
+ upvar #0 [namespace current]::$self state
+ if {[llength $args] == 0} {
+ return $state(chat_peer_widget)
+ }
+ return [uplevel 1 [list $state(chat_peer_widget)] $args]
+}
+
+proc chatwidget::Topic {self cmd args} {
+ upvar #0 [namespace current]::$self state
+ switch -exact -- $cmd {
+ show { grid $self.topic -row 0 -column 0 -sticky new }
+ hide { grid forget $self.topic }
+ set { set state(topic) [lindex $args 0] }
+ default {
+ return -code error "bad option \"$cmd\":\
+ must be show, hide or set"
+ }
+ }
+}
+
+proc chatwidget::Names {self args} {
+ upvar #0 [namespace current]::$self state
+ set frame [winfo parent $state(names_widget)]
+ set pane [winfo parent $frame]
+ if {[llength $args] == 0} {
+ return $state(names_widget)
+ }
+ if {[llength $args] == 1 && [lindex $args 0] eq "hide"} {
+ return [$pane forget $frame]
+ }
+ if {[llength $args] == 1 && [lindex $args 0] eq "show"} {
+ return [$pane add $frame]
+ }
+ return [uplevel 1 [list $state(names_widget)] $args]
+}
+
+proc chatwidget::Entry {self args} {
+ upvar #0 [namespace current]::$self state
+ if {[llength $args] == 0} {
+ return $state(entry_widget)
+ }
+ if {[llength $args] == 1 && [lindex $args 0] eq "text"} {
+ return [$state(entry_widget) get 1.0 end-1c]
+ }
+ return [uplevel 1 [list $state(entry_widget)] $args]
+}
+
+proc chatwidget::Message {self text args} {
+ upvar #0 [namespace current]::$self state
+ set chat $state(chat_widget)
+
+ set mark end
+ set type normal
+ set nick Unknown
+ set time [clock seconds]
+ set tags {}
+
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -nick { set nick [Pop args 1] }
+ -time { set time [Pop args 1] }
+ -type { set type [Pop args 1] }
+ -mark { set type [Pop args 1] }
+ -tags { set tags [Pop args 1] }
+ default {
+ return -code error "unknown option \"$option\""
+ }
+ }
+ Pop args
+ }
+
+ if {[catch {Hook $self run message $text \
+ -mark $mark -type $type -nick $nick \
+ -time $time -tags $tags}] == 3} then {
+ return
+ }
+
+ if {$type ne "system"} { lappend tags NICK-$nick }
+ lappend tags TYPE-$type
+ $chat configure -state normal
+ set ts [clock format $time -format "\[%H:%M\]\t"]
+ $chat insert $mark $ts [concat BOOKMARK STAMP $tags]
+ if {$type eq "action"} {
+ $chat insert $mark " * $nick " [concat BOOKMARK NICK $tags]
+ lappend tags ACTION
+ } elseif {$type eq "system"} {
+ } else {
+ $chat insert $mark "$nick\t" [concat BOOKMARK NICK $tags]
+ }
+ if {$type ne "system"} { lappend tags MSG NICK-$nick }
+ #$chat insert $mark $text $tags
+ Insert $self $mark $text $tags
+ $chat insert $mark "\n" $tags
+ $chat configure -state disabled
+ if {$state(autoscroll)} {
+ $chat see end
+ }
+ return
+}
+
+proc chatwidget::Insert {self mark args} {
+ upvar #0 [namespace current]::$self state
+ if {![info exists state(urluid)]} {set state(urluid) 0}
+ set w $state(chat_widget)
+ set parts {}
+ foreach {s t} $args {
+ while {[regexp -indices {\m(https?://[^\s]+)} $s -> ndx]} {
+ foreach {fr bk} $ndx break
+ lappend parts [string range $s 0 [expr {$fr - 1}]] $t
+ lappend parts [string range $s $fr $bk] \
+ [linsert $t end URL URL-[incr state(urluid)]]
+ set s [string range $s [incr bk] end]
+ }
+ lappend parts $s $t
+ }
+ set ws [$w cget -state]
+ $w configure -state normal
+ eval [list $w insert $mark] $parts
+ $w configure -state $ws
+}
+
+# $w name add ericthered -group admin -color red
+# state(names) {{pat -color red -group admin -thing wilf} {eric ....}}
+proc chatwidget::Name {self cmd args} {
+ upvar #0 [namespace current]::$self state
+ switch -exact -- $cmd {
+ list {
+ switch -exact -- [lindex $args 0] {
+ -full {
+ return $state(names)
+ }
+ default {
+ foreach item $state(names) { lappend r [lindex $item 0] }
+ return $r
+ }
+ }
+ }
+ add {
+ if {[llength $args] < 1 || ([llength $args] % 2) != 1} {
+ return -code error "wrong # args: should be\
+ \"add nick ?-group group ...?\""
+ }
+ set nick [lindex $args 0]
+ if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] == -1} {
+ array set opts {-group {} -colour black}
+ array set opts [lrange $args 1 end]
+ lappend state(names) [linsert [array get opts] 0 $nick]
+ } else {
+ array set opts [lrange [lindex $state(names) $ndx] 1 end]
+ array set opts [lrange $args 1 end]
+ lset state(names) $ndx [linsert [array get opts] 0 $nick]
+ }
+ UpdateNames $self
+ }
+ delete {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"delete nick\""
+ }
+ set nick [lindex $args 0]
+ if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} {
+ set state(names) [lreplace $state(names) $ndx $ndx]
+ UpdateNames $self
+ }
+ }
+ get {
+ if {[llength $args] < 1} {
+ return -code error "wrong # args:\
+ should be \"get nick\" ?option?"
+ }
+ set result {}
+ set nick [lindex $args 0]
+ if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} {
+ set result [lindex $state(names) $ndx]
+ if {[llength $args] > 1} {
+ if {[set ndx [lsearch $result [lindex $args 1]]] != -1} {
+ set result [lindex $result [incr ndx]]
+ } else {
+ set result {}
+ }
+ }
+ }
+ return $result
+ }
+ default {
+ return -code error "bad name option \"$cmd\":\
+ must be list, names, add or delete"
+ }
+ }
+}
+
+proc chatwidget::UpdateNames {self} {
+ upvar #0 [namespace current]::$self state
+ if {[info exists state(updatenames)]} {
+ after cancel $state(updatenames)
+ }
+ set state(updatenames) [after idle [list [namespace origin UpdateNamesExec] $self]]
+}
+
+proc chatwidget::UpdateNamesExec {self} {
+ upvar #0 [namespace current]::$self state
+ unset state(updatenames)
+ set names $state(names_widget)
+ set chat $state(chat_widget)
+
+ foreach tagname [lsearch -all -inline [$names tag names] NICK-*] {
+ $names tag delete $tagname
+ }
+ foreach tagname [lsearch -all -inline [$names tag names] GROUP-*] {
+ $names tag delete $tagname
+ }
+
+ $names configure -state normal
+ $names delete 1.0 end
+ array set groups {}
+ foreach item $state(names) {
+ set group {}
+ if {[set ndx [lsearch $item -group]] != -1} {
+ set group [lindex $item [incr ndx]]
+ }
+ lappend groups($group) [lindex $item 0]
+ }
+
+ foreach group [lsort [array names groups]] {
+ Hook $self run names_group $group
+ $names insert end "$group\n" [list SUBTITLE GROUP-$group]
+ foreach nick [lsort -dictionary $groups($group)] {
+ $names tag configure NICK-$nick
+ unset -nocomplain opts ; array set opts {}
+ if {[set ndx [lsearch -exact -index 0 $state(names) $nick]] != -1} {
+ array set opts [lrange [lindex $state(names) $ndx] 1 end]
+ if {[info exists opts(-color)]} {
+ $names tag configure NICK-$nick -foreground $opts(-color)
+ $chat tag configure NICK-$nick -foreground $opts(-color)
+ }
+ eval [linsert [lindex $state(names) $ndx] 0 \
+ Hook $self run names_nick]
+ }
+ $names insert end $nick\n [list NICK NICK-$nick GROUP-$group]
+ }
+ }
+ $names insert end "[llength $state(names)] nicks\n" [list SUBTITLE]
+
+ $names configure -state disabled
+}
+
+proc chatwidget::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+proc chatwidget::Hook {self do type args} {
+ upvar #0 [namespace current]::$self state
+ set valid {message post names_group names_nick chatstate url}
+ if {[lsearch -exact $valid $type] == -1} {
+ return -code error "unknown hook type \"$type\":\
+ must be one of [join $valid ,]"
+ }
+ switch -exact -- $do {
+ add {
+ if {[llength $args] < 1 || [llength $args] > 2} {
+ return -code error "wrong # args: should be \"add hook cmd ?priority?\""
+ }
+ foreach {cmd pri} $args break
+ if {$pri eq {}} { set pri 50 }
+ lappend state(hook,$type) [list $cmd $pri]
+ set state(hook,$type) [lsort -real -index 1 [lsort -unique $state(hook,$type)]]
+ }
+ remove {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"remove hook cmd\""
+ }
+ if {![info exists state(hook,$type)]} { return }
+ for {set ndx 0} {$ndx < [llength $state(hook,$type)]} {incr ndx} {
+ set item [lindex $state(hook,$type) $ndx]
+ if {[lindex $item 0] eq [lindex $args 0]} {
+ set state(hook,$type) [lreplace $state(hook,$type) $ndx $ndx]
+ break
+ }
+ }
+ set state(hook,$type)
+ }
+ run {
+ if {![info exists state(hook,$type)]} { return }
+ set res ""
+ foreach item $state(hook,$type) {
+ foreach {cmd pri} $item break
+ set code [catch {eval $cmd $args} err]
+ if {$code} {
+ ::bgerror "error running \"$type\" hook: $err"
+ break
+ } else {
+ lappend res $err
+ }
+ }
+ return $res
+ }
+ list {
+ if {[info exists state(hook,$type)]} {
+ return $state(hook,$type)
+ }
+ }
+ default {
+ return -code error "unknown hook action \"$do\":\
+ must be add, remove, list or run"
+ }
+ }
+}
+
+proc chatwidget::Grid {w {row 0} {column 0}} {
+ grid rowconfigure $w $row -weight 1
+ grid columnconfigure $w $column -weight 1
+}
+
+proc chatwidget::Create {self} {
+ upvar #0 [set State [namespace current]::$self] state
+ set state(history) {}
+ set state(current) 0
+ set state(autoscroll) 1
+ set state(names) {}
+ set state(chatstatetimer) {}
+ set state(chatstate) active
+
+ # NOTE: By using a non-ttk frame as the outermost part we are able
+ # to be [wm manage]d. The outermost frame should be invisible at all times.
+ set self [frame $self -class Chatwidget \
+ -borderwidth 0 -highlightthickness 0 -relief flat]
+ set outer [ttk::panedwindow $self.outer -orient vertical]
+ set inner [ttk::panedwindow $outer.inner -orient horizontal]
+
+ # Create a topic/subject header
+ set topic [ttk::frame $self.topic]
+ ttk::label $topic.label -anchor w -text Topic
+ ttk::entry $topic.text -state disabled -textvariable [set State](topic)
+ grid $topic.label $topic.text -sticky new -pady {2 0} -padx 1
+ Grid $topic 0 1
+
+ # Create the usernames scrolled text
+ set names [ttk::frame $inner.names -style ChatwidgetFrame]
+ text $names.text -borderwidth 0 -relief flat -font ChatwidgetFont
+ ttk::scrollbar $names.vs -command [list $names.text yview]
+ $names.text configure -width 10 -height 10 -state disabled \
+ -yscrollcommand [list [namespace origin scroll_set] $names.vs $inner 0]
+ bindtags $names.text [linsert [bindtags $names.text] 1 ChatwidgetNames]
+ grid $names.text $names.vs -sticky news -padx 1 -pady 1
+ Grid $names 0 0
+ set state(names_widget) $names.text
+
+ # Create the chat display
+ set chatf [ttk::frame $inner.chat -style ChatwidgetFrame]
+ set peers [ttk::panedwindow $chatf.peers -orient vertical]
+ set upper [ttk::frame $peers.upper]
+ set lower [ttk::frame $peers.lower]
+
+ set chat [text $lower.text -borderwidth 0 -relief flat -wrap word \
+ -state disabled -font ChatwidgetFont]
+ set chatvs [ttk::scrollbar $lower.vs -command [list $chat yview]]
+ $chat configure -height 10 -state disabled \
+ -yscrollcommand [list [namespace origin scroll_set] $chatvs $peers 1]
+ grid $chat $chatvs -sticky news
+ Grid $lower 0 0
+ set peer [$chat peer create $upper.text -borderwidth 0 -relief flat \
+ -wrap word -state disabled -font ChatwidgetFont]
+ set peervs [ttk::scrollbar $upper.vs -command [list $peer yview]]
+ $peer configure -height 0 \
+ -yscrollcommand [list [namespace origin scroll_set] $peervs $peers 0]
+ grid $peer $peervs -sticky news
+ Grid $upper 0 0
+ $peers add $upper
+ $peers add $lower -weight 1
+ grid $peers -sticky news -padx 1 -pady 1
+ Grid $chatf 0 0
+ bindtags $chat [linsert [bindtags $chat] 1 ChatwidgetText]
+ set state(chat_widget) $chat
+ set state(chat_peer_widget) $peer
+
+ # Create the entry widget
+ set entry [ttk::frame $outer.entry -style ChatwidgetFrame]
+ text $entry.text -borderwidth 0 -relief flat -font ChatwidgetFont
+ ttk::scrollbar $entry.vs -command [list $entry.text yview]
+ $entry.text configure -height 1 \
+ -yscrollcommand [list [namespace origin scroll_set] $entry.vs $outer 0]
+ bindtags $entry.text [linsert [bindtags $entry.text] 1 ChatwidgetEntry]
+ grid $entry.text $entry.vs -sticky news -padx 1 -pady 1
+ Grid $entry 0 0
+ set state(entry_widget) $entry.text
+
+ bind ChatwidgetEntry <Return> "[namespace origin Post] \[[namespace origin Self] %W\]"
+ bind ChatwidgetEntry <KP_Enter> "[namespace origin Post] \[[namespace origin Self] %W\]"
+ bind ChatwidgetEntry <Shift-Return> "#"
+ bind ChatwidgetEntry <Control-Return> "#"
+ bind ChatwidgetEntry <Key-Up> "[namespace origin History] \[[namespace origin Self] %W\] prev"
+ bind ChatwidgetEntry <Key-Down> "[namespace origin History] \[[namespace origin Self] %W\] next"
+ bind ChatwidgetEntry <Key-Tab> "[namespace origin Nickcomplete] \[[namespace origin Self] %W\]"
+ bind ChatwidgetEntry <Key-Prior> "\[[namespace origin Self] %W\] chat yview scroll -1 pages"
+ bind ChatwidgetEntry <Key-Next> "\[[namespace origin Self] %W\] chat yview scroll 1 pages"
+ bind ChatwidgetEntry <Key> "+[namespace origin Chatstate] \[[namespace origin Self] %W\] composing"
+ bind ChatwidgetEntry <FocusIn> "+[namespace origin Chatstate] \[[namespace origin Self] %W\] active"
+ bind $self <Destroy> "+unset -nocomplain [namespace current]::%W"
+ bind $peer <Map> [list [namespace origin PaneMap] %W $peers 0]
+ bind $names.text <Map> [list [namespace origin PaneMap] %W $inner -90]
+ bind $entry.text <Map> [list [namespace origin PaneMap] %W $outer -28]
+
+ bind ChatwidgetText <<ThemeChanged>> {
+ ttk::style layout ChatwidgetFrame {
+ Entry.field -sticky news -border 1 -children {
+ ChatwidgetFrame.padding -sticky news
+ }
+ }
+ }
+
+ $names.text tag configure SUBTITLE \
+ -background grey80 -font ChatwidgetBoldFont
+ $chat tag configure NICK -font ChatwidgetBoldFont
+ $chat tag configure TYPE-system -font ChatwidgetItalicFont
+ $chat tag configure URL -underline 1
+
+ $inner add $chatf -weight 1
+ $inner add $names
+ $outer add $inner -weight 1
+ $outer add $entry
+
+ grid $outer -row 1 -column 0 -sticky news -padx 1 -pady 1
+ Grid $self 1 0
+ return $self
+}
+
+proc chatwidget::Self {widget} {
+ set class [winfo class [set w $widget]]
+ while {[winfo exists $w] && [winfo class $w] ne "Chatwidget"} {
+ set w [winfo parent $w]
+ }
+ if {![winfo exists $w]} {
+ return -code error "invalid window $widget"
+ }
+ return $w
+}
+
+# Set initial position of sash
+proc chatwidget::PaneMap {w pane offset} {
+ bind $pane <Map> {}
+ if {[llength [$pane panes]] > 1} {
+ if {$offset < 0} {
+ if {[$pane cget -orient] eq "horizontal"} {
+ set axis width
+ } else {
+ set axis height
+ }
+ #after idle [list $pane sashpos 0 [expr {[winfo $axis $pane] + $offset}]]
+ after idle [namespace code [list PaneMapImpl $pane $axis $offset]]
+ } else {
+ #after idle [list $pane sashpos 0 $offset]
+ after idle [namespace code [list PaneMapImpl $pane {} $offset]]
+ }
+ }
+}
+
+proc chatwidget::PaneMapImpl {pane axis offset} {
+ if {$axis eq {}} {
+ set size 0
+ } else {
+ set size [winfo $axis $pane]
+ }
+ set sashpos [expr {$size + $offset}]
+ puts stderr "PaneMapImpl $pane $axis $offset : size:$size sashpos:$sashpos"
+ after 0 [list $pane sashpos 0 $sashpos]
+}
+
+# Handle auto-scroll smarts. This will cause the scrollbar to be removed if
+# not required and to disable autoscroll for the text widget if we are not
+# tracking the bottom line.
+proc chatwidget::scroll_set {scrollbar pw set f1 f2} {
+ $scrollbar set $f1 $f2
+ if {($f1 == 0) && ($f2 == 1)} {
+ grid remove $scrollbar
+ } else {
+ if {[winfo manager $scrollbar] eq {}} {}
+ if {[llength [$pw panes]] > 1} {
+ set pos [$pw sashpos 0]
+ grid $scrollbar
+ after idle [list $pw sashpos 0 $pos]
+ } else {
+ grid $scrollbar
+ }
+
+ }
+ if {$set} {
+ upvar #0 [namespace current]::[Self $scrollbar] state
+ set state(autoscroll) [expr {(1.0 - $f2) < 1.0e-6 }]
+ }
+}
+
+proc chatwidget::Post {self} {
+ set msg [$self entry get 1.0 end-1c]
+ if {$msg eq ""} { return -code break "" }
+ if {[catch {Hook $self run post $msg}] != 3} {
+ $self entry delete 1.0 end
+ upvar #0 [namespace current]::$self state
+ set state(history) [lrange [lappend state(history) $msg] end-50 end]
+ set state(current) [llength $state(history)]
+ }
+ return -code break ""
+}
+
+proc chatwidget::History {self dir} {
+ upvar #0 [namespace current]::$self state
+ switch -exact -- $dir {
+ prev {
+ if {$state(current) == 0} { return }
+ if {$state(current) == [llength $state(history)]} {
+ set state(temp) [$self entry get 1.0 end-1c]
+ }
+ if {$state(current)} { incr state(current) -1 }
+ $self entry delete 1.0 end
+ $self entry insert 1.0 [lindex $state(history) $state(current)]
+ return
+ }
+ next {
+ if {$state(current) == [llength $state(history)]} { return }
+ if {[incr state(current)] == [llength $state(history)] && [info exists state(temp)]} {
+ set msg $state(temp)
+ } else {
+ set msg [lindex $state(history) $state(current)]
+ }
+ $self entry delete 1.0 end
+ $self entry insert 1.0 $msg
+ }
+ default {
+ return -code error "invalid direction \"$dir\":
+ must be either prev or next"
+ }
+ }
+}
+
+proc chatwidget::Nickcomplete {self} {
+ upvar #0 [namespace current]::$self state
+ if {[info exists state(nickcompletion)]} {
+ foreach {index matches after} $state(nickcompletion) break
+ after cancel $after
+ incr index
+ if {$index > [llength $matches]} { set index 0 }
+ set delta 2c
+ } else {
+ set delta 1c
+ set partial [$self entry get "insert - $delta wordstart" "insert - $delta wordend"]
+ set matches [lsearch -all -inline -glob -index 0 $state(names) $partial*]
+ set index 0
+ }
+ switch -exact -- [llength $matches] {
+ 0 { bell ; return -code break ""}
+ 1 { set match [lindex [lindex $matches 0] 0]}
+ default {
+ set match [lindex [lindex $matches $index] 0]
+ set state(nickcompletion) [list $index $matches \
+ [after 2000 [list [namespace origin NickcompleteCleanup] $self]]]
+ }
+ }
+ $self entry delete "insert - $delta wordstart" "insert - $delta wordend"
+ $self entry insert insert "$match "
+ return -code break ""
+}
+
+proc chatwidget::NickcompleteCleanup {self} {
+ upvar #0 [namespace current]::$self state
+ if {[info exists state(nickcompletion)]} {
+ unset state(nickcompletion)
+ }
+}
+
+# Update the widget chatstate (one of active, composing, paused, inactive, gone)
+# These are from XEP-0085 but seem likey useful in many chat-type environments.
+# Note: this state is _per-widget_. This is not the same as [tk inactive]
+# active = got focus and recently active
+# composing = typing
+# paused = 5 secs non typing
+# inactive = no activity for 30 seconds
+# gone = no activity for 2 minutes or closed the window
+proc chatwidget::Chatstate {self what} {
+ upvar #0 [namespace current]::$self state
+ after cancel $state(chatstatetimer)
+ switch -exact -- $what {
+ composing - active {
+ set state(chatstatetimer) [after 5000 [namespace code [list Chatstate $self paused]]]
+ }
+ paused {
+ set state(chatstatetimer) [after 25000 [namespace code [list Chatstate $self inactive]]]
+ }
+ inactive {
+ set state(chatstatetimer) [after 120000 [namespace code [list Chatstate $self gone]]]
+ }
+ gone {}
+ }
+ set fire [expr {$state(chatstate) eq $what ? 0 : 1}]
+ set state(chatstate) $what
+ if {$fire} {
+ catch {Hook $self run chatstate $what}
+ event generate $self <<ChatwidgetChatstate>>
+ }
+}
+
+package provide chatwidget $chatwidget::version
--- /dev/null
+package ifneeded chatwidget 1.1.0 [list source [file join $dir chatwidget.tcl]]
--- /dev/null
+# dns.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Provide a Tcl only Domain Name Service client. See RFC 1034 and RFC 1035
+# for information about the DNS protocol. This should insulate Tcl scripts
+# from problems with using the system library resolver for slow name servers.
+#
+# This implementation uses TCP only for DNS queries. The protocol reccommends
+# that UDP be used in these cases but Tcl does not include UDP sockets by
+# default. The package should be simple to extend to use a TclUDP extension
+# in the future.
+#
+# Support for SPF (http://spf.pobox.com/rfcs.html) will need updating
+# if or when the proposed draft becomes accepted.
+#
+# Support added for RFC1886 - DNS Extensions to support IP version 6
+# Support added for RFC2782 - DNS RR for specifying the location of services
+# Support added for RFC1995 - Incremental Zone Transfer in DNS
+#
+# TODO:
+# - When using tcp we should make better use of the open connection and
+# send multiple queries along the same connection.
+#
+# - We must switch to using TCP for truncated UDP packets.
+#
+# - Read RFC 2136 - dynamic updating of DNS
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: dns.tcl,v 1.35 2007/08/26 00:44:34 patthoyts Exp $
+
+package require Tcl 8.2; # tcl minimum version
+package require logger; # tcllib 1.3
+package require uri; # tcllib 1.1
+package require uri::urn; # tcllib 1.2
+package require ip; # tcllib 1.7
+
+namespace eval ::dns {
+ variable version 1.3.2
+ variable rcsid {$Id: dns.tcl,v 1.35 2007/08/26 00:44:34 patthoyts Exp $}
+
+ namespace export configure resolve name address cname \
+ status reset wait cleanup errorcode
+
+ variable options
+ if {![info exists options]} {
+ array set options {
+ port 53
+ timeout 30000
+ protocol tcp
+ search {}
+ nameserver {localhost}
+ loglevel warn
+ }
+ variable log [logger::init dns]
+ ${log}::setlevel $options(loglevel)
+ }
+
+ # We can use either ceptcl or tcludp for UDP support.
+ if {![catch {package require udp 1.0.4} msg]} { ;# tcludp 1.0.4+
+ # If TclUDP 1.0.4 or better is available, use it.
+ set options(protocol) udp
+ } else {
+ if {![catch {package require ceptcl} msg]} {
+ set options(protocol) udp
+ }
+ }
+
+ variable types
+ array set types {
+ A 1 NS 2 MD 3 MF 4 CNAME 5 SOA 6 MB 7 MG 8 MR 9
+ NULL 10 WKS 11 PTR 12 HINFO 13 MINFO 14 MX 15 TXT 16
+ SPF 16 AAAA 28 SRV 33 IXFR 251 AXFR 252 MAILB 253 MAILA 254
+ ANY 255 * 255
+ }
+
+ variable classes
+ array set classes { IN 1 CS 2 CH 3 HS 4 * 255}
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Configure the DNS package. In particular the local nameserver will need
+# to be set. With no options, returns a list of all current settings.
+#
+proc ::dns::configure {args} {
+ variable options
+ variable log
+
+ if {[llength $args] < 1} {
+ set r {}
+ foreach opt [lsort [array names options]] {
+ lappend r -$opt $options($opt)
+ }
+ return $r
+ }
+
+ set cget 0
+ if {[llength $args] == 1} {
+ set cget 1
+ }
+
+ while {[string match -* [lindex $args 0]]} {
+ switch -glob -- [lindex $args 0] {
+ -n* -
+ -ser* {
+ if {$cget} {
+ return $options(nameserver)
+ } else {
+ set options(nameserver) [Pop args 1]
+ }
+ }
+ -po* {
+ if {$cget} {
+ return $options(port)
+ } else {
+ set options(port) [Pop args 1]
+ }
+ }
+ -ti* {
+ if {$cget} {
+ return $options(timeout)
+ } else {
+ set options(timeout) [Pop args 1]
+ }
+ }
+ -pr* {
+ if {$cget} {
+ return $options(protocol)
+ } else {
+ set proto [string tolower [Pop args 1]]
+ if {[string compare udp $proto] == 0 \
+ && [string compare tcp $proto] == 0} {
+ return -code error "invalid protocol \"$proto\":\
+ protocol must be either \"udp\" or \"tcp\""
+ }
+ set options(protocol) $proto
+ }
+ }
+ -sea* {
+ if {$cget} {
+ return $options(search)
+ } else {
+ set options(search) [Pop args 1]
+ }
+ }
+ -log* {
+ if {$cget} {
+ return $options(loglevel)
+ } else {
+ set options(loglevel) [Pop args 1]
+ ${log}::setlevel $options(loglevel)
+ }
+ }
+ -- { Pop args ; break }
+ default {
+ set opts [join [lsort [array names options]] ", -"]
+ return -code error "bad option [lindex $args 0]:\
+ must be one of -$opts"
+ }
+ }
+ Pop args
+ }
+
+ return
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Create a DNS query and send to the specified name server. Returns a token
+# to be used to obtain any further information about this query.
+#
+proc ::dns::resolve {query args} {
+ variable uid
+ variable options
+ variable log
+
+ # get a guaranteed unique and non-present token id.
+ set id [incr uid]
+ while {[info exists [set token [namespace current]::$id]]} {
+ set id [incr uid]
+ }
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ # Setup token/state defaults.
+ set state(id) $id
+ set state(query) $query
+ set state(qdata) ""
+ set state(opcode) 0; # 0 = query, 1 = inverse query.
+ set state(-type) A; # DNS record type (A address)
+ set state(-class) IN; # IN (internet address space)
+ set state(-recurse) 1; # Recursion Desired
+ set state(-command) {}; # asynchronous handler
+ set state(-timeout) $options(timeout); # connection timeout default.
+ set state(-nameserver) $options(nameserver);# default nameserver
+ set state(-port) $options(port); # default namerservers port
+ set state(-search) $options(search); # domain search list
+ set state(-protocol) $options(protocol); # which protocol udp/tcp
+
+ # Handle DNS URL's
+ if {[string match "dns:*" $query]} {
+ array set URI [uri::split $query]
+ foreach {opt value} [uri::split $query] {
+ if {$value != {} && [info exists state(-$opt)]} {
+ set state(-$opt) $value
+ }
+ }
+ set state(query) $URI(query)
+ ${log}::debug "parsed query: $query"
+ }
+
+ while {[string match -* [lindex $args 0]]} {
+ switch -glob -- [lindex $args 0] {
+ -n* - ns -
+ -ser* { set state(-nameserver) [Pop args 1] }
+ -po* { set state(-port) [Pop args 1] }
+ -ti* { set state(-timeout) [Pop args 1] }
+ -co* { set state(-command) [Pop args 1] }
+ -cl* { set state(-class) [Pop args 1] }
+ -ty* { set state(-type) [Pop args 1] }
+ -pr* { set state(-protocol) [Pop args 1] }
+ -sea* { set state(-search) [Pop args 1] }
+ -re* { set state(-recurse) [Pop args 1] }
+ -inv* { set state(opcode) 1 }
+ -status {set state(opcode) 2}
+ -data { set state(qdata) [Pop args 1] }
+ default {
+ set opts [join [lsort [array names state -*]] ", "]
+ return -code error "bad option [lindex $args 0]: \
+ must be $opts"
+ }
+ }
+ Pop args
+ }
+
+ if {$state(-nameserver) == {}} {
+ return -code error "no nameserver specified"
+ }
+
+ if {$state(-protocol) == "udp"} {
+ if {[llength [package provide ceptcl]] == 0 \
+ && [llength [package provide udp]] == 0} {
+ return -code error "udp support is not available,\
+ get ceptcl or tcludp"
+ }
+ }
+
+ # Check for reverse lookups
+ if {[regexp {^(?:\d{0,3}\.){3}\d{0,3}$} $state(query)]} {
+ set addr [lreverse [split $state(query) .]]
+ lappend addr in-addr arpa
+ set state(query) [join $addr .]
+ set state(-type) PTR
+ }
+
+ BuildMessage $token
+
+ if {$state(-protocol) == "tcp"} {
+ TcpTransmit $token
+ if {$state(-command) == {}} {
+ wait $token
+ }
+ } else {
+ UdpTransmit $token
+ }
+
+ return $token
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Return a list of domain names returned as results for the last query.
+#
+proc ::dns::name {token} {
+ set r {}
+ Flags $token flags
+ array set reply [Decode $token]
+
+ switch -exact -- $flags(opcode) {
+ 0 {
+ # QUERY
+ foreach answer $reply(AN) {
+ array set AN $answer
+ if {![info exists AN(type)]} {set AN(type) {}}
+ switch -exact -- $AN(type) {
+ MX - NS - PTR {
+ if {[info exists AN(rdata)]} {lappend r $AN(rdata)}
+ }
+ default {
+ if {[info exists AN(name)]} {
+ lappend r $AN(name)
+ }
+ }
+ }
+ }
+ }
+
+ 1 {
+ # IQUERY
+ foreach answer $reply(QD) {
+ array set QD $answer
+ lappend r $QD(name)
+ }
+ }
+ default {
+ return -code error "not supported for this query type"
+ }
+ }
+ return $r
+}
+
+# Description:
+# Return a list of the IP addresses returned for this query.
+#
+proc ::dns::address {token} {
+ set r {}
+ array set reply [Decode $token]
+ foreach answer $reply(AN) {
+ array set AN $answer
+
+ if {[info exists AN(type)]} {
+ switch -exact -- $AN(type) {
+ "A" {
+ lappend r $AN(rdata)
+ }
+ "AAAA" {
+ lappend r $AN(rdata)
+ }
+ }
+ }
+ }
+ return $r
+}
+
+# Description:
+# Return a list of all CNAME results returned for this query.
+#
+proc ::dns::cname {token} {
+ set r {}
+ array set reply [Decode $token]
+ foreach answer $reply(AN) {
+ array set AN $answer
+
+ if {[info exists AN(type)]} {
+ if {$AN(type) == "CNAME"} {
+ lappend r $AN(rdata)
+ }
+ }
+ }
+ return $r
+}
+
+# Description:
+# Return the decoded answer records. This can be used for more complex
+# queries where the answer isn't supported byb cname/address/name.
+proc ::dns::result {token args} {
+ array set reply [eval [linsert $args 0 Decode $token]]
+ return $reply(AN)
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Get the status of the request.
+#
+proc ::dns::status {token} {
+ upvar #0 $token state
+ return $state(status)
+}
+
+# Description:
+# Get the error message. Empty if no error.
+#
+proc ::dns::error {token} {
+ upvar #0 $token state
+ if {[info exists state(error)]} {
+ return $state(error)
+ }
+ return ""
+}
+
+# Description
+# Get the error code. This is 0 for a successful transaction.
+#
+proc ::dns::errorcode {token} {
+ upvar #0 $token state
+ set flags [Flags $token]
+ set ndx [lsearch -exact $flags errorcode]
+ incr ndx
+ return [lindex $flags $ndx]
+}
+
+# Description:
+# Reset a connection with optional reason.
+#
+proc ::dns::reset {token {why reset} {errormsg {}}} {
+ upvar #0 $token state
+ set state(status) $why
+ if {[string length $errormsg] > 0 && ![info exists state(error)]} {
+ set state(error) $errormsg
+ }
+ catch {fileevent $state(sock) readable {}}
+ Finish $token
+}
+
+# Description:
+# Wait for a request to complete and return the status.
+#
+proc ::dns::wait {token} {
+ upvar #0 $token state
+
+ if {$state(status) == "connect"} {
+ vwait [subst $token](status)
+ }
+
+ return $state(status)
+}
+
+# Description:
+# Remove any state associated with this token.
+#
+proc ::dns::cleanup {token} {
+ upvar #0 $token state
+ if {[info exists state]} {
+ catch {close $state(sock)}
+ catch {after cancel $state(after)}
+ unset state
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Dump the raw data of the request and reply packets.
+#
+proc ::dns::dump {args} {
+ if {[llength $args] == 1} {
+ set type -reply
+ set token [lindex $args 0]
+ } elseif { [llength $args] == 2 } {
+ set type [lindex $args 0]
+ set token [lindex $args 1]
+ } else {
+ return -code error "wrong # args:\
+ should be \"dump ?option? methodName\""
+ }
+
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set result {}
+ switch -glob -- $type {
+ -qu* -
+ -req* {
+ set result [DumpMessage $state(request)]
+ }
+ -rep* {
+ set result [DumpMessage $state(reply)]
+ }
+ default {
+ error "unrecognised option: must be one of \
+ \"-query\", \"-request\" or \"-reply\""
+ }
+ }
+
+ return $result
+}
+
+# Description:
+# Perform a hex dump of binary data.
+#
+proc ::dns::DumpMessage {data} {
+ set result {}
+ binary scan $data c* r
+ foreach c $r {
+ append result [format "%02x " [expr {$c & 0xff}]]
+ }
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Contruct a DNS query packet.
+#
+proc ::dns::BuildMessage {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ variable types
+ variable classes
+ variable options
+
+ if {! [info exists types($state(-type))] } {
+ return -code error "invalid DNS query type"
+ }
+
+ if {! [info exists classes($state(-class))] } {
+ return -code error "invalid DNS query class"
+ }
+
+ set qdcount 0
+ set qsection {}
+ set nscount 0
+ set nsdata {}
+
+ # In theory we can send multiple queries. In practice, named doesn't
+ # appear to like that much. If it did work we'd do this:
+ # foreach domain [linsert $options(search) 0 {}] ...
+
+
+ # Pack the query: QNAME QTYPE QCLASS
+ set qsection [PackName $state(query)]
+ append qsection [binary format SS \
+ $types($state(-type))\
+ $classes($state(-class))]
+ incr qdcount
+
+ if {[string length $state(qdata)] > 0} {
+ set nsdata [eval [linsert $state(qdata) 0 PackRecord]]
+ incr nscount
+ }
+
+ switch -exact -- $state(opcode) {
+ 0 {
+ # QUERY
+ set state(request) [binary format SSSSSS $state(id) \
+ [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \
+ $qdcount 0 $nscount 0]
+ append state(request) $qsection $nsdata
+ }
+ 1 {
+ # IQUERY
+ set state(request) [binary format SSSSSS $state(id) \
+ [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \
+ 0 $qdcount 0 0 0]
+ append state(request) \
+ [binary format cSSI 0 \
+ $types($state(-type)) $classes($state(-class)) 0]
+ switch -exact -- $state(-type) {
+ A {
+ append state(request) \
+ [binary format Sc4 4 [split $state(query) .]]
+ }
+ PTR {
+ append state(request) \
+ [binary format Sc4 4 [split $state(query) .]]
+ }
+ default {
+ return -code error "inverse query not supported for this type"
+ }
+ }
+ }
+ default {
+ return -code error "operation not supported"
+ }
+ }
+
+ return
+}
+
+# Pack a human readable dns name into a DNS resource record format.
+proc ::dns::PackName {name} {
+ set data ""
+ foreach part [split [string trim $name .] .] {
+ set len [string length $part]
+ append data [binary format ca$len $len $part]
+ }
+ append data \x00
+ return $data
+}
+
+# Pack a character string - byte length prefixed
+proc ::dns::PackString {text} {
+ set len [string length $text]
+ set data [binary format ca$len $len $text]
+ return $data
+}
+
+# Pack up a single DNS resource record. See RFC1035: 3.2 for the format
+# of each type.
+# eg: PackRecord name wiki.tcl.tk type MX class IN rdata {10 mail.example.com}
+#
+proc ::dns::PackRecord {args} {
+ variable types
+ variable classes
+ array set rr {name "" type A class IN ttl 0 rdlength 0 rdata ""}
+ array set rr $args
+ set data [PackName $rr(name)]
+
+ switch -exact -- $rr(type) {
+ CNAME - MB - MD - MF - MG - MR - NS - PTR {
+ set rr(rdata) [PackName $rr(rdata)]
+ }
+ HINFO {
+ array set r {CPU {} OS {}}
+ array set r $rr(rdata)
+ set rr(rdata) [PackString $r(CPU)]
+ append rr(rdata) [PackString $r(OS)]
+ }
+ MINFO {
+ array set r {RMAILBX {} EMAILBX {}}
+ array set r $rr(rdata)
+ set rr(rdata) [PackString $r(RMAILBX)]
+ append rr(rdata) [PackString $r(EMAILBX)]
+ }
+ MX {
+ foreach {pref exch} $rr(rdata) break
+ set rr(rdata) [binary format S $pref]
+ append rr(rdata) [PackName $exch]
+ }
+ TXT {
+ set str $rr(rdata)
+ set len [string length [set str $rr(rdata)]]
+ set rr(rdata) ""
+ for {set n 0} {$n < $len} {incr n} {
+ set s [string range $str $n [incr n 253]]
+ append rr(rdata) [PackString $s]
+ }
+ }
+ NULL {}
+ SOA {
+ array set r {MNAME {} RNAME {}
+ SERIAL 0 REFRESH 0 RETRY 0 EXPIRE 0 MINIMUM 0}
+ array set r $rr(rdata)
+ set rr(rdata) [PackName $r(MNAME)]
+ append rr(rdata) [PackName $r(RNAME)]
+ append rr(rdata) [binary format IIIII $r(SERIAL) \
+ $r(REFRESH) $r(RETRY) $r(EXPIRE) $r(MINIMUM)]
+ }
+ }
+
+ # append the root label and the type flag and query class.
+ append data [binary format SSIS $types($rr(type)) \
+ $classes($rr(class)) $rr(ttl) [string length $rr(rdata)]]
+ append data $rr(rdata)
+ return $data
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Transmit a DNS request over a tcp connection.
+#
+proc ::dns::TcpTransmit {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ # setup the timeout
+ if {$state(-timeout) > 0} {
+ set state(after) [after $state(-timeout) \
+ [list [namespace origin reset] \
+ $token timeout\
+ "operation timed out"]]
+ }
+
+ # Sometimes DNS servers drop TCP requests. So it's better to
+ # use asynchronous connect
+ set s [socket -async $state(-nameserver) $state(-port)]
+ fileevent $s writable [list [namespace origin TcpConnected] $token $s]
+ set state(sock) $s
+ set state(status) connect
+
+ return $token
+}
+
+proc ::dns::TcpConnected {token s} {
+ variable $token
+ upvar 0 $token state
+
+ fileevent $s writable {}
+ if {[catch {fconfigure $s -peername}]} {
+ # TCP connection failed
+ Finish $token "can't connect to server"
+ return
+ }
+
+ fconfigure $s -blocking 0 -translation binary -buffering none
+
+ # For TCP the message must be prefixed with a 16bit length field.
+ set req [binary format S [string length $state(request)]]
+ append req $state(request)
+
+ puts -nonewline $s $req
+
+ fileevent $s readable [list [namespace current]::TcpEvent $token]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Transmit a DNS request using UDP datagrams
+#
+# Note:
+# This requires a UDP implementation that can transmit binary data.
+# As yet I have been unable to test this myself and the tcludp package
+# cannot do this.
+#
+proc ::dns::UdpTransmit {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ # setup the timeout
+ if {$state(-timeout) > 0} {
+ set state(after) [after $state(-timeout) \
+ [list [namespace origin reset] \
+ $token timeout\
+ "operation timed out"]]
+ }
+
+ if {[llength [package provide ceptcl]] > 0} {
+ # using ceptcl
+ set state(sock) [cep -type datagram $state(-nameserver) $state(-port)]
+ fconfigure $state(sock) -blocking 0
+ } else {
+ # using tcludp
+ set state(sock) [udp_open]
+ udp_conf $state(sock) $state(-nameserver) $state(-port)
+ }
+ fconfigure $state(sock) -translation binary -buffering none
+ set state(status) connect
+ puts -nonewline $state(sock) $state(request)
+
+ fileevent $state(sock) readable [list [namespace current]::UdpEvent $token]
+
+ return $token
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Tidy up after a tcp transaction.
+#
+proc ::dns::Finish {token {errormsg ""}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ global errorInfo errorCode
+
+ if {[string length $errormsg] != 0} {
+ set state(error) $errormsg
+ set state(status) error
+ }
+ catch {close $state(sock)}
+ catch {after cancel $state(after)}
+ if {[info exists state(-command)] && $state(-command) != {}} {
+ if {[catch {eval $state(-command) {$token}} err]} {
+ if {[string length $errormsg] == 0} {
+ set state(error) [list $err $errorInfo $errorCode]
+ set state(status) error
+ }
+ }
+ if {[info exists state(-command)]} {
+ unset state(-command)
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Handle end-of-file on a tcp connection.
+#
+proc ::dns::Eof {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ set state(status) eof
+ Finish $token
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Process a DNS reply packet (protocol independent)
+#
+proc ::dns::Receive {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ binary scan $state(reply) SS id flags
+ set status [expr {$flags & 0x000F}]
+
+ switch -- $status {
+ 0 {
+ set state(status) ok
+ Finish $token
+ }
+ 1 { Finish $token "Format error - unable to interpret the query." }
+ 2 { Finish $token "Server failure - internal server error." }
+ 3 { Finish $token "Name Error - domain does not exist" }
+ 4 { Finish $token "Not implemented - the query type is not available." }
+ 5 { Finish $token "Refused - your request has been refused by the server." }
+ default {
+ Finish $token "unrecognised error code: $err"
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# file event handler for tcp socket. Wait for the reply data.
+#
+proc ::dns::TcpEvent {token} {
+ variable log
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ set s $state(sock)
+
+ if {[eof $s]} {
+ Eof $token
+ return
+ }
+
+ set status [catch {read $state(sock)} result]
+ if {$status != 0} {
+ ${log}::debug "Event error: $result"
+ Finish $token "error reading data: $result"
+ } elseif { [string length $result] >= 0 } {
+ if {[catch {
+ # Handle incomplete reads - check the size and keep reading.
+ if {![info exists state(size)]} {
+ binary scan $result S state(size)
+ set result [string range $result 2 end]
+ }
+ append state(reply) $result
+
+ # check the length and flags and chop off the tcp length prefix.
+ if {[string length $state(reply)] >= $state(size)} {
+ binary scan $result S id
+ set id [expr {$id & 0xFFFF}]
+ if {$id != [expr {$state(id) & 0xFFFF}]} {
+ ${log}::error "received packed with incorrect id"
+ }
+ # bug #1158037 - doing this causes problems > 65535 requests!
+ #Receive [namespace current]::$id
+ Receive $token
+ } else {
+ ${log}::debug "Incomplete tcp read:\
+ [string length $state(reply)] should be $state(size)"
+ }
+ } err]} {
+ Finish $token "Event error: $err"
+ }
+ } elseif { [eof $state(sock)] } {
+ Eof $token
+ } elseif { [fblocked $state(sock)] } {
+ ${log}::debug "Event blocked"
+ } else {
+ ${log}::critical "Event error: this can't happen!"
+ Finish $token "Event error: this can't happen!"
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# file event handler for udp sockets.
+proc ::dns::UdpEvent {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ set s $state(sock)
+
+ set payload [read $state(sock)]
+ append state(reply) $payload
+
+ binary scan $payload S id
+ set id [expr {$id & 0xFFFF}]
+ if {$id != [expr {$state(id) & 0xFFFF}]} {
+ ${log}::error "received packed with incorrect id"
+ }
+ # bug #1158037 - doing this causes problems > 65535 requests!
+ #Receive [namespace current]::$id
+ Receive $token
+}
+
+# -------------------------------------------------------------------------
+
+proc ::dns::Flags {token {varname {}}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {$varname != {}} {
+ upvar $varname flags
+ }
+
+ array set flags {query 0 opcode 0 authoritative 0 errorcode 0
+ truncated 0 recursion_desired 0 recursion_allowed 0}
+
+ binary scan $state(reply) SSSSSS mid hdr nQD nAN nNS nAR
+
+ set flags(response) [expr {($hdr & 0x8000) >> 15}]
+ set flags(opcode) [expr {($hdr & 0x7800) >> 11}]
+ set flags(authoritative) [expr {($hdr & 0x0400) >> 10}]
+ set flags(truncated) [expr {($hdr & 0x0200) >> 9}]
+ set flags(recursion_desired) [expr {($hdr & 0x0100) >> 8}]
+ set flafs(recursion_allowed) [expr {($hdr & 0x0080) >> 7}]
+ set flags(errorcode) [expr {($hdr & 0x000F)}]
+
+ return [array get flags]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Decode a DNS packet (either query or response).
+#
+proc ::dns::Decode {token args} {
+ variable log
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set opts {-rdata 0 -query 0}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -rdata { set opts(-rdata) 1 }
+ -query { set opts(-query) 1 }
+ default {
+ return -code error "bad option \"$option\":\
+ must be -rdata"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(-query)} {
+ binary scan $state(request) SSSSSSc* mid hdr nQD nAN nNS nAR data
+ } else {
+ binary scan $state(reply) SSSSSSc* mid hdr nQD nAN nNS nAR data
+ }
+
+ set fResponse [expr {($hdr & 0x8000) >> 15}]
+ set fOpcode [expr {($hdr & 0x7800) >> 11}]
+ set fAuthoritative [expr {($hdr & 0x0400) >> 10}]
+ set fTrunc [expr {($hdr & 0x0200) >> 9}]
+ set fRecurse [expr {($hdr & 0x0100) >> 8}]
+ set fCanRecurse [expr {($hdr & 0x0080) >> 7}]
+ set fRCode [expr {($hdr & 0x000F)}]
+ set flags ""
+
+ if {$fResponse} {set flags "QR"} else {set flags "Q"}
+ set opcodes [list QUERY IQUERY STATUS]
+ lappend flags [lindex $opcodes $fOpcode]
+ if {$fAuthoritative} {lappend flags "AA"}
+ if {$fTrunc} {lappend flags "TC"}
+ if {$fRecurse} {lappend flags "RD"}
+ if {$fCanRecurse} {lappend flags "RA"}
+
+ set info "ID: $mid\
+ Fl: [format 0x%02X [expr {$hdr & 0xFFFF}]] ($flags)\
+ NQ: $nQD\
+ NA: $nAN\
+ NS: $nNS\
+ AR: $nAR"
+ ${log}::debug $info
+
+ set ndx 12
+ set r {}
+ set QD [ReadQuestion $nQD $state(reply) ndx]
+ lappend r QD $QD
+ set AN [ReadAnswer $nAN $state(reply) ndx $opts(-rdata)]
+ lappend r AN $AN
+ set NS [ReadAnswer $nNS $state(reply) ndx $opts(-rdata)]
+ lappend r NS $NS
+ set AR [ReadAnswer $nAR $state(reply) ndx $opts(-rdata)]
+ lappend r AR $AR
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::dns::Expand {data} {
+ set r {}
+ binary scan $data c* d
+ foreach c $d {
+ lappend r [expr {$c & 0xFF}]
+ }
+ return $r
+}
+
+
+# -------------------------------------------------------------------------
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::dns::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Reverse a list. Code from http://wiki.tcl.tk/tcl/43
+#
+proc ::dns::lreverse {lst} {
+ set res {}
+ set i [llength $lst]
+ while {$i} {lappend res [lindex $lst [incr i -1]]}
+ return $res
+}
+
+# -------------------------------------------------------------------------
+
+proc ::dns::KeyOf {arrayname value {default {}}} {
+ upvar $arrayname array
+ set lst [array get array]
+ set ndx [lsearch -exact $lst $value]
+ if {$ndx != -1} {
+ incr ndx -1
+ set r [lindex $lst $ndx]
+ } else {
+ set r $default
+ }
+ return $r
+}
+
+
+# -------------------------------------------------------------------------
+# Read the question section from a DNS message. This always starts at index
+# 12 of a message but may be of variable length.
+#
+proc ::dns::ReadQuestion {nitems data indexvar} {
+ variable types
+ variable classes
+ upvar $indexvar index
+ set result {}
+
+ for {set cn 0} {$cn < $nitems} {incr cn} {
+ set r {}
+ lappend r name [ReadName data $index offset]
+ incr index $offset
+
+ # Read off QTYPE and QCLASS for this query.
+ set ndx $index
+ incr index 3
+ binary scan [string range $data $ndx $index] SS qtype qclass
+ set qtype [expr {$qtype & 0xFFFF}]
+ set qclass [expr {$qclass & 0xFFFF}]
+ incr index
+ lappend r type [KeyOf types $qtype $qtype] \
+ class [KeyOf classes $qclass $qclass]
+ lappend result $r
+ }
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+# Read an answer section from a DNS message.
+#
+proc ::dns::ReadAnswer {nitems data indexvar {raw 0}} {
+ variable types
+ variable classes
+ upvar $indexvar index
+ set result {}
+
+ for {set cn 0} {$cn < $nitems} {incr cn} {
+ set r {}
+ lappend r name [ReadName data $index offset]
+ incr index $offset
+
+ # Read off TYPE, CLASS, TTL and RDLENGTH
+ binary scan [string range $data $index end] SSIS type class ttl rdlength
+
+ set type [expr {$type & 0xFFFF}]
+ set type [KeyOf types $type $type]
+
+ set class [expr {$class & 0xFFFF}]
+ set class [KeyOf classes $class $class]
+
+ set ttl [expr {$ttl & 0xFFFFFFFF}]
+ set rdlength [expr {$rdlength & 0xFFFF}]
+ incr index 10
+ set rdata [string range $data $index [expr {$index + $rdlength - 1}]]
+
+ if {! $raw} {
+ switch -- $type {
+ A {
+ set rdata [join [Expand $rdata] .]
+ }
+ AAAA {
+ set rdata [ip::contract [ip::ToString $rdata]]
+ }
+ NS - CNAME - PTR {
+ set rdata [ReadName data $index off]
+ }
+ MX {
+ binary scan $rdata S preference
+ set exchange [ReadName data [expr {$index + 2}] off]
+ set rdata [list $preference $exchange]
+ }
+ SRV {
+ set x $index
+ set rdata [list priority [ReadUShort data $x off]]
+ incr x $off
+ lappend rdata weight [ReadUShort data $x off]
+ incr x $off
+ lappend rdata port [ReadUShort data $x off]
+ incr x $off
+ lappend rdata target [ReadName data $x off]
+ incr x $off
+ }
+ TXT {
+ set rdata [ReadString data $index $rdlength]
+ }
+ SOA {
+ set x $index
+ set rdata [list MNAME [ReadName data $x off]]
+ incr x $off
+ lappend rdata RNAME [ReadName data $x off]
+ incr x $off
+ lappend rdata SERIAL [ReadULong data $x off]
+ incr x $off
+ lappend rdata REFRESH [ReadLong data $x off]
+ incr x $off
+ lappend rdata RETRY [ReadLong data $x off]
+ incr x $off
+ lappend rdata EXPIRE [ReadLong data $x off]
+ incr x $off
+ lappend rdata MINIMUM [ReadULong data $x off]
+ incr x $off
+ }
+ }
+ }
+
+ incr index $rdlength
+ lappend r type $type class $class ttl $ttl rdlength $rdlength rdata $rdata
+ lappend result $r
+ }
+ return $result
+}
+
+
+# Read a 32bit integer from a DNS packet. These are compatible with
+# the ReadName proc. Additionally - ReadULong takes measures to ensure
+# the unsignedness of the value obtained.
+#
+proc ::dns::ReadLong {datavar index usedvar} {
+ upvar $datavar data
+ upvar $usedvar used
+ set r {}
+ set used 0
+ if {[binary scan $data @${index}I r]} {
+ set used 4
+ }
+ return $r
+}
+
+proc ::dns::ReadULong {datavar index usedvar} {
+ upvar $datavar data
+ upvar $usedvar used
+ set r {}
+ set used 0
+ if {[binary scan $data @${index}cccc b1 b2 b3 b4]} {
+ set used 4
+ # This gets us an unsigned value.
+ set r [expr {($b4 & 0xFF) + (($b3 & 0xFF) << 8)
+ + (($b2 & 0xFF) << 16) + ($b1 << 24)}]
+ }
+ return $r
+}
+
+proc ::dns::ReadUShort {datavar index usedvar} {
+ upvar $datavar data
+ upvar $usedvar used
+ set r {}
+ set used 0
+ if {[binary scan [string range $data $index end] cc b1 b2]} {
+ set used 2
+ # This gets us an unsigned value.
+ set r [expr {(($b2 & 0xff) + (($b1 & 0xff) << 8)) & 0xffff}]
+ }
+ return $r
+}
+
+# Read off the NAME or QNAME element. This reads off each label in turn,
+# dereferencing pointer labels until we have finished. The length of data
+# used is passed back using the usedvar variable.
+#
+proc ::dns::ReadName {datavar index usedvar} {
+ upvar $datavar data
+ upvar $usedvar used
+ set startindex $index
+
+ set r {}
+ set len 1
+ set max [string length $data]
+
+ while {$len != 0 && $index < $max} {
+ # Read the label length (and preread the pointer offset)
+ binary scan [string range $data $index end] cc len lenb
+ set len [expr {$len & 0xFF}]
+ incr index
+
+ if {$len != 0} {
+ if {[expr {$len & 0xc0}]} {
+ binary scan [binary format cc [expr {$len & 0x3f}] [expr {$lenb & 0xff}]] S offset
+ incr index
+ lappend r [ReadName data $offset junk]
+ set len 0
+ } else {
+ lappend r [string range $data $index [expr {$index + $len - 1}]]
+ incr index $len
+ }
+ }
+ }
+ set used [expr {$index - $startindex}]
+ return [join $r .]
+}
+
+proc ::dns::ReadString {datavar index length} {
+ upvar $datavar data
+ set startindex $index
+
+ set r {}
+ set max [expr {$index + $length}]
+
+ while {$index < $max} {
+ binary scan [string range $data $index end] c len
+ set len [expr {$len & 0xFF}]
+ incr index
+
+ if {$len != 0} {
+ append r [string range $data $index [expr {$index + $len - 1}]]
+ incr index $len
+ }
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Support for finding the local nameservers
+#
+# For unix we can just parse the /etc/resolv.conf if it exists.
+# Of course, some unices use /etc/resolver and other things (NIS for instance)
+# On Windows, we can examine the Internet Explorer settings from the registry.
+#
+switch -exact $::tcl_platform(platform) {
+ windows {
+ proc ::dns::nameservers {} {
+ package require registry
+ set base {HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services}
+ set param "$base\\Tcpip\\Parameters"
+ set interfaces "$param\\Interfaces"
+ set nameservers {}
+ if {[string equal $::tcl_platform(os) "Windows NT"]} {
+ AppendRegistryValue $param NameServer nameservers
+ AppendRegistryValue $param DhcpNameServer nameservers
+ foreach i [registry keys $interfaces] {
+ AppendRegistryValue "$interfaces\\$i" NameServer nameservers
+ AppendRegistryValue "$interfaces\\$i" DhcpNameServer nameservers
+ }
+ } else {
+ set param "$base\\VxD\\MSTCP"
+ AppendRegistryValue $param NameServer nameservers
+ }
+ return $nameservers
+ }
+ proc ::dns::AppendRegistryValue {key val listName} {
+ upvar $listName lst
+ if {![catch {registry get $key $val} v]} {
+ foreach ns [split $v ", "] {
+ if {[lsearch -exact $lst $ns] == -1} {
+ lappend lst $ns
+ }
+ }
+ }
+ }
+ }
+ unix {
+ proc ::dns::nameservers {} {
+ set nameservers {}
+ if {[file readable /etc/resolv.conf]} {
+ set f [open /etc/resolv.conf r]
+ while {![eof $f]} {
+ gets $f line
+ if {[regexp {^\s*nameserver\s+(.*)$} $line -> ns]} {
+ lappend nameservers $ns
+ }
+ }
+ close $f
+ }
+ if {[llength $nameservers] < 1} {
+ lappend nameservers 127.0.0.1
+ }
+ return $nameservers
+ }
+ }
+ default {
+ proc ::dns::nameservers {} {
+ return -code error "command not supported for this platform."
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+# Possible support for the DNS URL scheme.
+# Ref: http://www.ietf.org/internet-drafts/draft-josefsson-dns-url-04.txt
+# eg: dns:target?class=IN;type=A
+# dns://nameserver/target?type=A
+#
+# URI quoting to be accounted for.
+#
+
+catch {
+ uri::register {dns} {
+ set escape [set [namespace parent [namespace current]]::basic::escape]
+ set host [set [namespace parent [namespace current]]::basic::host]
+ set hostOrPort [set [namespace parent [namespace current]]::basic::hostOrPort]
+
+ set class [string map {* \\\\*} \
+ "class=([join [array names ::dns::classes] {|}])"]
+ set type [string map {* \\\\*} \
+ "type=([join [array names ::dns::types] {|}])"]
+ set classOrType "(?:${class}|${type})"
+ set classOrTypeSpec "(?:${class}|${type})(?:;(?:${class}|${type}))?"
+
+ set query "${host}(${classOrTypeSpec})?"
+ variable schemepart "(//${hostOrPort}/)?(${query})"
+ variable url "dns:$schemepart"
+ }
+}
+
+namespace eval ::uri {} ;# needed for pkg_mkIndex.
+
+proc ::uri::SplitDns {uri} {
+ upvar \#0 [namespace current]::dns::schemepart schemepart
+ upvar \#0 [namespace current]::dns::class classOrType
+ upvar \#0 [namespace current]::dns::class classRE
+ upvar \#0 [namespace current]::dns::type typeRE
+ upvar \#0 [namespace current]::dns::classOrTypeSpec classOrTypeSpec
+
+ array set parts {nameserver {} query {} class {} type {} port {}}
+
+ # validate the uri
+ if {[regexp -- $dns::schemepart $uri r] == 1} {
+
+ # deal with the optional class and type specifiers
+ if {[regexp -indices -- "${classOrTypeSpec}$" $uri range]} {
+ set spec [string range $uri [lindex $range 0] [lindex $range 1]]
+ set uri [string range $uri 0 [expr {[lindex $range 0] - 2}]]
+
+ if {[regexp -- "$classRE" $spec -> class]} {
+ set parts(class) $class
+ }
+ if {[regexp -- "$typeRE" $spec -> type]} {
+ set parts(type) $type
+ }
+ }
+
+ # Handle the nameserver specification
+ if {[string match "//*" $uri]} {
+ set uri [string range $uri 2 end]
+ array set tmp [GetHostPort uri]
+ set parts(nameserver) $tmp(host)
+ set parts(port) $tmp(port)
+ }
+
+ # what's left is the query domain name.
+ set parts(query) [string trimleft $uri /]
+ }
+
+ return [array get parts]
+}
+
+proc ::uri::JoinDns {args} {
+ array set parts {nameserver {} port {} query {} class {} type {}}
+ array set parts $args
+ set query [::uri::urn::quote $parts(query)]
+ if {$parts(type) != {}} {
+ append query "?type=$parts(type)"
+ }
+ if {$parts(class) != {}} {
+ if {$parts(type) == {}} {
+ append query "?class=$parts(class)"
+ } else {
+ append query ";class=$parts(class)"
+ }
+ }
+ if {$parts(nameserver) != {}} {
+ set ns "$parts(nameserver)"
+ if {$parts(port) != {}} {
+ append ns ":$parts(port)"
+ }
+ set query "//${ns}/${query}"
+ }
+ return "dns:$query"
+}
+
+# -------------------------------------------------------------------------
+
+catch {dns::configure -nameserver [lindex [dns::nameservers] 0]}
+
+package provide dns $dns::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+# ip.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Internet address manipulation.
+#
+# RFC 3513: IPv6 addressing.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: ip.tcl,v 1.12 2007/08/20 20:03:04 andreas_kupries Exp $
+
+# @mdgen EXCLUDE: ipMoreC.tcl
+
+package require Tcl 8.2; # tcl minimum version
+
+namespace eval ip {
+ variable version 1.1.2
+ variable rcsid {$Id: ip.tcl,v 1.12 2007/08/20 20:03:04 andreas_kupries Exp $}
+
+ namespace export is version normalize equal type contract mask
+ #catch {namespace ensemble create}
+
+ variable IPv4Ranges
+ if {![info exists IPv4Ranges]} {
+ array set IPv4Ranges {
+ 0/8 private
+ 10/8 private
+ 127/8 private
+ 172.16/12 private
+ 192.168/16 private
+ 223/8 reserved
+ 224/3 reserved
+ }
+ }
+
+ variable IPv6Ranges
+ if {![info exists IPv6Ranges]} {
+ # RFC 3513: 2.4
+ # RFC 3056: 2
+ array set IPv6Ranges {
+ 2002::/16 "6to4 unicast"
+ fe80::/10 "link local"
+ fec0::/10 "site local"
+ ff00::/8 "multicast"
+ ::/128 "unspecified"
+ ::1/128 "localhost"
+ }
+ }
+}
+
+proc ::ip::is {class ip} {
+ foreach {ip mask} [split $ip /] break
+ switch -exact -- $class {
+ ipv4 - IPv4 - 4 {
+ return [IPv4? $ip]
+ }
+ ipv6 - IPv6 - 6 {
+ return [IPv6? $ip]
+ }
+ default {
+ return -code error "bad class \"$class\": must be ipv4 or ipv6"
+ }
+ }
+}
+
+proc ::ip::version {ip} {
+ set version -1
+ foreach {addr mask} [split $ip /] break
+ if {[string first $addr :] < 0 && [IPv4? $addr]} {
+ set version 4
+ } elseif {[IPv6? $addr]} {
+ set version 6
+ }
+ return $version
+}
+
+proc ::ip::equal {lhs rhs} {
+ foreach {LHS LM} [SplitIp $lhs] break
+ foreach {RHS RM} [SplitIp $rhs] break
+ if {[set version [version $LHS]] != [version $RHS]} {
+ return -code error "type mismatch:\
+ cannot compare different address types"
+ }
+ if {$version == 4} {set fmt I} else {set fmt I4}
+ set LHS [Mask$version [Normalize $LHS $version] $LM]
+ set RHS [Mask$version [Normalize $RHS $version] $RM]
+ binary scan $LHS $fmt LLL
+ binary scan $RHS $fmt RRR
+ foreach L $LLL R $RRR {
+ if {$L != $R} {return 0}
+ }
+ return 1
+}
+
+proc ::ip::normalize {ip {Ip4inIp6 0}} {
+ foreach {ip mask} [SplitIp $ip] break
+ set version [version $ip]
+ set s [ToString [Normalize $ip $version] $Ip4inIp6]
+ if {($version == 6 && $mask != 128) || ($version == 4 && $mask != 32)} {
+ append s /$mask
+ }
+ return $s
+}
+
+proc ::ip::contract {ip} {
+ foreach {ip mask} [SplitIp $ip] break
+ set version [version $ip]
+ set s [ToString [Normalize $ip $version]]
+ if {$version == 6} {
+ set r ""
+ foreach o [split $s :] {
+ append r [format %x: 0x$o]
+ }
+ set r [string trimright $r :]
+ regsub {(?:^|:)0(?::0)+(?::|$)} $r {::} r
+ } else {
+ set r [string trimright $s .0]
+ }
+ return $r
+}
+
+# Returns an IP address prefix.
+# For instance:
+# prefix 192.168.1.4/16 => 192.168.0.0
+# prefix fec0::4/16 => fec0:0:0:0:0:0:0:0
+# prefix fec0::4/ffff:: => fec0:0:0:0:0:0:0:0
+#
+proc ::ip::prefix {ip} {
+ foreach {addr mask} [SplitIp $ip] break
+ set version [version $addr]
+ set addr [Normalize $addr $version]
+ return [ToString [Mask$version $addr $mask]]
+}
+
+# Return the address type. For IPv4 this is one of private, reserved
+# or normal
+# For IPv6 it is one of site local, link local, multicast, unicast,
+# unspecified or loopback.
+proc ::ip::type {ip} {
+ set version [version $ip]
+ upvar [namespace current]::IPv${version}Ranges types
+ set ip [prefix $ip]
+ foreach prefix [array names types] {
+ set mask [mask $prefix]
+ if {[equal $ip/$mask $prefix]} {
+ return $types($prefix)
+ }
+ }
+ if {$version == 4} {
+ return "normal"
+ } else {
+ return "unicast"
+ }
+}
+
+proc ::ip::mask {ip} {
+ foreach {addr mask} [split $ip /] break
+ return $mask
+}
+
+# -------------------------------------------------------------------------
+
+# Returns true is the argument can be converted into an IPv4 address.
+#
+proc ::ip::IPv4? {ip} {
+ if {[catch {Normalize4 $ip}]} {
+ return 0
+ }
+ return 1
+}
+
+proc ::ip::IPv6? {ip} {
+ set octets [split $ip :]
+ if {[llength $octets] < 3 || [llength $octets] > 8} {
+ return 0
+ }
+ set ndx 0
+ foreach octet $octets {
+ incr ndx
+ if {[string length $octet] < 1} continue
+ if {[regexp {^[a-fA-F\d]{1,4}$} $octet]} continue
+ if {$ndx >= [llength $octets] && [IPv4? $octet]} continue
+ if {$ndx == 2 && [lindex $octets 0] == 2002 && [IPv4? $octet]} continue
+ #"Invalid IPv6 address \"$ip\""
+ return 0
+ }
+ if {[regexp {^:[^:]} $ip]} {
+ #"Invalid ipv6 address \"$ip\" (starts with :)"
+ return 0
+ }
+ if {[regexp {[^:]:$} $ip]} {
+ # "Invalid IPv6 address \"$ip\" (ends with :)"
+ return 0
+ }
+ if {[regsub -all :: $ip "|" junk] > 1} {
+ # "Invalid IPv6 address \"$ip\" (more than one :: pattern)"
+ return 0
+ }
+ return 1
+}
+
+proc ::ip::Mask4 {ip {bits {}}} {
+ if {[string length $bits] < 1} { set bits 32 }
+ binary scan $ip I ipx
+ if {[string is integer $bits]} {
+ set mask [expr {(0xFFFFFFFF << (32 - $bits)) & 0xFFFFFFFF}]
+ } else {
+ binary scan [Normalize4 $bits] I mask
+ }
+ return [binary format I [expr {$ipx & $mask}]]
+}
+
+proc ::ip::Mask6 {ip {bits {}}} {
+ if {[string length $bits] < 1} { set bits 128 }
+ if {[string is integer $bits]} {
+ set mask [binary format B128 [string repeat 1 $bits]]
+ } else {
+ binary scan [Normalize6 $bits] I4 mask
+ }
+ binary scan $ip I4 Addr
+ binary scan $mask I4 Mask
+ foreach A $Addr M $Mask {
+ lappend r [expr {$A & $M}]
+ }
+ return [binary format I4 $r]
+}
+
+
+
+# A network address specification is an IPv4 address with an optional bitmask
+# Split an address specification into a IPv4 address and a network bitmask.
+# This doesn't validate the address portion.
+# If a spec with no mask is provided then the mask will be 32
+# (all bits significant).
+# Masks may be either integer number of significant bits or dotted-quad
+# notation.
+#
+proc ::ip::SplitIp {spec} {
+ set slash [string last / $spec]
+ if {$slash != -1} {
+ incr slash -1
+ set ip [string range $spec 0 $slash]
+ incr slash 2
+ set bits [string range $spec $slash end]
+ } else {
+ set ip $spec
+ if {[string length $ip] > 0 && [version $ip] == 6} {
+ set bits 128
+ } else {
+ set bits 32
+ }
+ }
+ return [list $ip $bits]
+}
+
+# Given an IP string from the user, convert to a normalized internal rep.
+# For IPv4 this is currently a hex string (0xHHHHHHHH).
+# For IPv6 this is a binary string or 16 chars.
+proc ::ip::Normalize {ip {version 0}} {
+ if {$version < 0} {
+ set version [version $ip]
+ if {$version < 0} {
+ return -code error "invalid address \"$ip\":\
+ value must be a valid IPv4 or IPv6 address"
+ }
+ }
+ return [Normalize$version $ip]
+}
+
+proc ::ip::Normalize4 {ip} {
+ set octets [split $ip .]
+ if {[llength $octets] > 4} {
+ return -code error "invalid ip address \"$ip\""
+ } elseif {[llength $octets] < 4} {
+ set octets [lrange [concat $octets 0 0 0] 0 3]
+ }
+ foreach oct $octets {
+ if {$oct < 0 || $oct > 255} {
+ return -code error "invalid ip address"
+ }
+ }
+ return [binary format c4 $octets]
+}
+
+proc ::ip::Normalize6 {ip} {
+ set octets [split $ip :]
+ set ip4embed [string first . $ip]
+ set len [llength $octets]
+ if {$len < 0 || $len > 8} {
+ return -code error "invalid address: this is not an IPv6 address"
+ }
+ set result ""
+ for {set n 0} {$n < $len} {incr n} {
+ set octet [lindex $octets $n]
+ if {$octet == {}} {
+ if {$n == 0 || $n == ($len - 1)} {
+ set octet \0\0
+ } else {
+ set missing [expr {9 - $len}]
+ if {$ip4embed != -1} {incr missing -1}
+ set octet [string repeat \0\0 $missing]
+ }
+ } elseif {[string first . $octet] != -1} {
+ set octet [Normalize4 $octet]
+ } else {
+ set m [expr {4 - [string length $octet]}]
+ if {$m != 0} {
+ set octet [string repeat 0 $m]$octet
+ }
+ set octet [binary format H4 $octet]
+ }
+ append result $octet
+ }
+ if {[string length $result] != 16} {
+ return -code error "invalid address: \"$ip\" is not an IPv6 address"
+ }
+ return $result
+}
+
+
+# This will convert a full ipv4/ipv6 in binary format into a normal
+# expanded string rep.
+proc ::ip::ToString {bin {Ip4inIp6 0}} {
+ set len [string length $bin]
+ set r ""
+ if {$len == 4} {
+ binary scan $bin c4 octets
+ foreach octet $octets {
+ lappend r [expr {$octet & 0xff}]
+ }
+ return [join $r .]
+ } elseif {$len == 16} {
+ if {$Ip4inIp6 == 0} {
+ binary scan $bin H32 hex
+ for {set n 0} {$n < 32} {incr n} {
+ append r [string range $hex $n [incr n 3]]:
+ }
+ return [string trimright $r :]
+ } else {
+ binary scan $bin H24c4 hex octets
+ for {set n 0} {$n < 24} {incr n} {
+ append r [string range $hex $n [incr n 3]]:
+ }
+ foreach octet $octets {
+ append r [expr {$octet & 0xff}].
+ }
+ return [string trimright $r .]
+ }
+ } else {
+ return -code error "invalid binary address:\
+ argument is neither an IPv4 nor an IPv6 address"
+ }
+}
+
+# -------------------------------------------------------------------------
+# Load extended command set.
+
+source [file join [file dirname [info script]] ipMore.tcl]
+
+# -------------------------------------------------------------------------
+
+package provide ip $::ip::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+#temporary home until this gets cleaned up for export to tcllib ip module
+# $Id: ipMore.tcl,v 1.4 2006/01/22 00:27:22 andreas_kupries Exp $
+
+
+##Library Header
+#
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ipMore
+#
+# Purpose:
+# Additional commands for the tcllib ip package.
+#
+# Author:
+# Aamer Akhter / aakhter@cisco.com
+#
+# Support Alias:
+# aakhter@cisco.com
+#
+# Usage:
+# package require ip
+# (The command are loaded from the regular package).
+#
+# Description:
+# A detailed description of the functionality provided by the library.
+#
+# Requirements:
+#
+# Variables:
+# namespace ::ip
+#
+# Notes:
+# 1.
+#
+# Keywords:
+#
+#
+# Category:
+#
+#
+# End of Header
+
+package require msgcat
+
+# Try to load various C based accelerato packages for two of the
+# commands.
+
+if {[catch {package require ipMorec}]} {
+ catch {package require tcllibc}
+}
+
+if {[llength [info commands ::ip::prefixToNativec]]} {
+ # An accelerator is present, providing the C variants
+ interp alias {} ::ip::prefixToNative {} ::ip::prefixToNativec
+ interp alias {} ::ip::isOverlapNative {} ::ip::isOverlapNativec
+} else {
+ # Link API to the Tcl variants, no accelerators are available.
+ interp alias {} ::ip::prefixToNative {} ::ip::prefixToNativeTcl
+ interp alias {} ::ip::isOverlapNative {} ::ip::isOverlapNativeTcl
+}
+
+namespace eval ::ip {
+ ::msgcat::mcload [file join [file dirname [info script]] msgs]
+}
+
+if {![llength [info commands lassign]]} {
+ # Either an older tcl version, or tclx not loaded; have to use our
+ # internal lassign from http://wiki.tcl.tk/1530 by Schelte Bron
+
+ proc ::ip::lassign {values args} {
+ uplevel 1 [list foreach $args $values break]
+ lrange $values [llength $args] end
+ }
+}
+if {![llength [info commands lvarpop]]} {
+ # Define an emulation of Tclx's lvarpop if the command
+ # is not present already.
+
+ proc ::ip::lvarpop {upVar {index 0}} {
+ upvar $upVar list;
+ set top [lindex $list $index];
+ set list [concat [lrange $list 0 [expr $index - 1]] \
+ [lrange $list [expr $index +1] end]];
+ return $top;
+ }
+}
+
+# Some additional aliases for backward compatability. Not
+# documented. The old names ar from previous versions while at Cisco.
+#
+# Old command name --> Documented command name
+interp alias {} ::ip::ToInteger {} ::ip::toInteger
+interp alias {} ::ip::ToHex {} ::ip::toHex
+interp alias {} ::ip::MaskToInt {} ::ip::maskToInt
+interp alias {} ::ip::MaskToLength {} ::ip::maskToLength
+interp alias {} ::ip::LengthToMask {} ::ip::lengthToMask
+interp alias {} ::ip::IpToLayer2Multicast {} ::ip::ipToLayer2Multicast
+interp alias {} ::ip::IpHostFromPrefix {} ::ip::ipHostFromPrefix
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::prefixToNative
+#
+# Purpose:
+# convert from dotted from to native (hex) form
+#
+# Synopsis:
+# prefixToNative <prefix>
+#
+# Arguments:
+# <prefix>
+# string in the <ipaddr>/<mask> format
+#
+# Return Values:
+# <prefix> in native format {<hexip> <hexmask>}
+#
+# Description:
+#
+# Examples:
+# % ip::prefixToNative 1.1.1.0/24
+# 0x01010100 0xffffff00
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+# fixed bug in C extension that modified
+# calling context variable
+# See Also:
+#
+# End of Header
+
+proc ip::prefixToNativeTcl {prefix} {
+ set plist {}
+ foreach p $prefix {
+ set newPrefix [ip::toHex [ip::prefix $p]]
+ if {[string equal [set mask [ip::mask $p]] ""]} {
+ set newMask 0xffffffff
+ } else {
+ set newMask [format "0x%08x" [ip::maskToInt $mask]]
+ }
+ lappend plist [list $newPrefix $newMask]
+ }
+ if {[llength $plist]==1} {return [lindex $plist 0]}
+ return $plist
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::nativeToPrefix
+#
+# Purpose:
+# convert from native (hex) form to dotted form
+#
+# Synopsis:
+# nativeToPrefix <nativeList>|<native> [-ipv4]
+#
+# Arguments:
+# <nativeList>
+# list of native form ip addresses native form is:
+# <native>
+# tcllist in format {<hexip> <hexmask>}
+# -ipv4
+# the provided native format addresses are in ipv4 format (default)
+#
+# Return Values:
+# if nativeToPrefix is called with <native> a single (non-listified) address
+# is returned
+# if nativeToPrefix is called with a <nativeList> address list, then
+# a list of addresses is returned
+#
+# return form is: <ipaddr>/<mask>
+#
+# Description:
+#
+# Examples:
+# % ip::nativeToPrefix {0x01010100 0xffffff00} -ipv4
+# 1.1.1.0/24
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::nativeToPrefix {nativeList args} {
+ set pList 1
+ set ipv4 1
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+ }
+ }
+ }
+
+ # if a single native element is passed eg {0x01010100 0xffffff00}
+ # instead of {{0x01010100 0xffffff00} {0x01010100 0xffffff00}...}
+ # then return a (non-list) single entry
+ if {[llength [lindex $nativeList 0]]==1} {set pList 0; set nativeList [list $nativeList]}
+ foreach native $nativeList {
+ lassign $native ip mask
+ if {[string equal $mask ""]} {set mask 32}
+ set pString ""
+ append pString [ip::ToString [binary format I [expr {$ip}]]]
+ append pString "/"
+ append pString [ip::maskToLength $mask]
+ lappend rList $pString
+ }
+ # a multi (listified) entry was given
+ # return the listified entry
+ if {$pList} { return $rList }
+ return $pString
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::intToString
+#
+# Purpose:
+# convert from an integer/hex to dotted form
+#
+# Synopsis:
+# intToString <integer/hex> [-ipv4]
+#
+# Arguments:
+# <integer>
+# ip address in integer form
+# -ipv4
+# the provided integer addresses is ipv4 (default)
+#
+# Return Values:
+# ip address in dotted form
+#
+# Description:
+#
+# Examples:
+# ip::intToString 4294967295
+# 255.255.255.255
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::intToString {int args} {
+ set ipv4 1
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+ }
+ }
+ }
+ return [ip::ToString [binary format I [expr {$int}]]]
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::toInteger
+#
+# Purpose:
+# convert dotted form ip to integer
+#
+# Synopsis:
+# toInteger <ipaddr>
+#
+# Arguments:
+# <ipaddr>
+# decimal dotted from ip address
+#
+# Return Values:
+# integer form of <ipaddr>
+#
+# Description:
+#
+# Examples:
+# % ::ip::toInteger 1.1.1.0
+# 16843008
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::toInteger {ip} {
+ binary scan [ip::Normalize4 $ip] I out
+ return $out
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::toHex
+#
+# Purpose:
+# convert dotted form ip to hex
+#
+# Synopsis:
+# toHex <ipaddr>
+#
+# Arguments:
+# <ipaddr>
+# decimal dotted from ip address
+#
+# Return Values:
+# hex form of <ipaddr>
+#
+# Description:
+#
+# Examples:
+# % ::ip::toHex 1.1.1.0
+# 0x01010100
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::toHex {ip} {
+ binary scan [ip::Normalize4 $ip] H8 out
+ return "0x$out"
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::maskToInt
+#
+# Purpose:
+# convert mask to integer
+#
+# Synopsis:
+# maskToInt <mask>
+#
+# Arguments:
+# <mask>
+# mask in either dotted form or mask length form (255.255.255.0 or 24)
+#
+# Return Values:
+# integer form of mask
+#
+# Description:
+#
+# Examples:
+# ::ip::maskToInt 24
+# 4294967040
+#
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::maskToInt {mask} {
+ if {[string is integer -strict $mask]} {
+ set maskInt [expr {(0xFFFFFFFF << (32 - $mask))}]
+ } else {
+ binary scan [Normalize4 $mask] I maskInt
+ }
+ set maskInt [expr {$maskInt & 0xFFFFFFFF}]
+ return [format %u $maskInt]
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::broadcastAddress
+#
+# Purpose:
+# return broadcast address given prefix
+#
+# Synopsis:
+# broadcastAddress <prefix> [-ipv4]
+#
+# Arguments:
+# <prefix>
+# route in the form of <ipaddr>/<mask> or native form {<hexip> <hexmask>}
+# -ipv4
+# the provided native format addresses are in ipv4 format (default)
+# note: broadcast addresses are not valid in ipv6
+#
+#
+# Return Values:
+# ipaddress of broadcast
+#
+# Description:
+#
+# Examples:
+# ::ip::broadcastAddress 1.1.1.0/24
+# 1.1.1.255
+#
+# ::ip::broadcastAddress {0x01010100 0xffffff00}
+# 0x010101ff
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::broadcastAddress {prefix args} {
+ set ipv4 1
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+ }
+ }
+ }
+ if {[llength $prefix] == 2} {
+ lassign $prefix net mask
+ } else {
+ set net [maskToInt [ip::prefix $prefix]]
+ set mask [maskToInt [ip::mask $prefix]]
+ }
+ set ba [expr {$net | ((~$mask)&0xffffffff)}]
+
+ if {[llength $prefix]==2} {
+ return [format "0x%08x" $ba]
+ }
+ return [ToString [binary format I $ba]]
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::maskToLength
+#
+# Purpose:
+# converts dotted or integer form of mask to length
+#
+# Synopsis:
+# maskToLength <dottedMask>|<integerMask>|<hexMask> [-ipv4]
+#
+# Arguments:
+# <dottedMask>
+# <integerMask>
+# <hexMask>
+# mask to convert to prefix length format (eg /24)
+# -ipv4
+# the provided integer/hex format masks are ipv4 (default)
+#
+# Return Values:
+# prefix length
+#
+# Description:
+#
+# Examples:
+# ::ip::maskToLength 0xffffff00 -ipv4
+# 24
+#
+# % ::ip::maskToLength 255.255.255.0
+# 24
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::maskToLength {mask args} {
+ set ipv4 1
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+ }
+ }
+ }
+ #pick the fastest method for either format
+ if {[string is integer -strict $mask]} {
+ binary scan [binary format I [expr {$mask}]] B32 maskB
+ if {[regexp -all {^1+} $maskB ones]} {
+ return [string length $ones]
+ } else {
+ return 0
+ }
+ } else {
+ regexp {\/(.+)} $mask dumb mask
+ set prefix 0
+ foreach ipByte [split $mask {.}] {
+ switch $ipByte {
+ 255 {incr prefix 8; continue}
+ 254 {incr prefix 7}
+ 252 {incr prefix 6}
+ 248 {incr prefix 5}
+ 240 {incr prefix 4}
+ 224 {incr prefix 3}
+ 192 {incr prefix 2}
+ 128 {incr prefix 1}
+ 0 {}
+ default {
+ return -code error [msgcat::mc "not an ip mask: %s" $mask]
+ }
+ }
+ break
+ }
+ return $prefix
+ }
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::lengthToMask
+#
+# Purpose:
+# converts mask length to dotted mask form
+#
+# Synopsis:
+# lengthToMask <maskLength> [-ipv4]
+#
+# Arguments:
+# <maskLength>
+# mask length
+# -ipv4
+# the provided mask length is ipv4 (default)
+#
+# Return Values:
+# mask in dotted form
+#
+# Description:
+#
+# Examples:
+# ::ip::lengthToMask 24
+# 255.255.255.0
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::lengthToMask {masklen args} {
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+ }
+ }
+ }
+ # the fastest method is just to look
+ # thru an array
+ return $::ip::maskLenToDotted($masklen)
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::nextNet
+#
+# Purpose:
+# returns next an ipaddress in same position in next network
+#
+# Synopsis:
+# nextNet <ipaddr> <mask> [<count>] [-ipv4]
+#
+# Arguments:
+# <ipaddress>
+# in hex/integer/dotted format
+# <mask>
+# mask in hex/integer/dotted/maskLen format
+# <count>
+# number of nets to skip over (default is 1)
+# -ipv4
+# the provided hex/integer addresses are in ipv4 format (default)
+#
+# Return Values:
+# ipaddress in same position in next network in hex
+#
+# Description:
+#
+# Examples:
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::nextNet {prefix mask args} {
+ set count 1
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ set count [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ }
+ }
+ if {![string is integer -strict $prefix]} {
+ set prefix [toInteger $prefix]
+ }
+ if {![string is integer -strict $mask] || ($mask < 33 && $mask > 0)} {
+ set mask [maskToInt $mask]
+ }
+
+ set prefix [expr $prefix + ($mask ^ 0xFFffFFff) + $count ]
+ return [format "0x%08x" $prefix]
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::isOverlap
+#
+# Purpose:
+# checks to see if prefixes overlap
+#
+# Synopsis:
+# isOverlap <prefix> <prefix1> <prefix2>...
+#
+# Arguments:
+# <prefix>
+# in form <ipaddr>/<mask> prefix to compare <prefixN> against
+# <prefixN>
+# in form <ipaddr>/<mask> prefixes to compare against
+#
+# Return Values:
+# 1 if there is an overlap
+#
+# Description:
+#
+# Examples:
+# % ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32
+# 0
+#
+# ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32 1.1.1.1/32
+# 1
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::isOverlap {ip args} {
+ lassign [SplitIp $ip] ip1 mask1
+ set ip1int [toInteger $ip1]
+ set mask1int [maskToInt $mask1]
+
+ set overLap 0
+ foreach prefix $args {
+ lassign [SplitIp $prefix] ip2 mask2
+ set ip2int [toInteger $ip2]
+ set mask2int [maskToInt $mask2]
+ set mask1mask2 [expr {$mask1int & $mask2int}]
+ if {[expr {$ip1int & $mask1mask2}] == [expr {$ip2int & $mask1mask2}]} {
+ set overLap 1
+ break
+ }
+ }
+ return $overLap
+}
+
+
+#optimized overlap, that accepts native format
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::isOverlapNative
+#
+# Purpose:
+# checks to see if prefixes overlap (optimized native form)
+#
+# Synopsis:
+# isOverlap <hexipaddr> <hexmask> {{<hexipaddr1> <hexmask1>} {<hexipaddr2> <hexmask2>...}
+#
+# Arguments:
+# -all
+# return all overlaps rather than the first one
+# -inline
+# rather than returning index values, return the actual overlap prefixes
+# <hexipaddr>
+# ipaddress in hex/integer form
+# <hexMask>
+# mask in hex/integer form
+# -ipv4
+# the provided native format addresses are in ipv4 format (default)
+#
+# Return Values:
+# non-zero if there is an overlap, value is element # in list with overlap
+#
+# Description:
+# isOverlapNative is avaliabel both as a C extension and in a native tcl form
+# if the extension is loaded (tried automatically), isOverlapNative will be
+# linked to isOverlapNativeC. If an extension is not loaded, then isOverlapNative
+# will be linked to the native tcl proc: ipOverlapNativeTcl.
+#
+# Examples:
+# % ::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff}}
+# 0
+#
+# %::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}
+# 2
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::isOverlapNativeTcl {args} {
+ set all 0
+ set inline 0
+ set notOverlap 0
+ set ipv4 1
+ foreach sw [lrange $args 0 end-3] {
+ switch -exact -- $sw {
+ -all {
+ set all 1
+ set allList [list]
+ }
+ -inline {set inline 1}
+ -ipv4 {}
+ }
+ }
+ set args [lassign [lrange $args end-2 end] ip1int mask1int prefixList]
+ if {$inline} {
+ set overLap [list]
+ } else {
+ set overLap 0
+ }
+ set count 0
+ foreach prefix $prefixList {
+ incr count
+ lassign $prefix ip2int mask2int
+ set mask1mask2 [expr {$mask1int & $mask2int}]
+ if {[expr {$ip1int & $mask1mask2}] == [expr {$ip2int & $mask1mask2}]} {
+ if {$inline} {
+ set overLap [list $prefix]
+ } else {
+ set overLap $count
+ }
+ if {$all} {
+ if {$inline} {
+ lappend allList $prefix
+ } else {
+ lappend allList $count
+ }
+ } else {
+ break
+ }
+ }
+ }
+ if {$all} {return $allList}
+ return $overLap
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::ipToLayer2Multicast
+#
+# Purpose:
+# converts ipv4 address to a layer 2 multicast address
+#
+# Synopsis:
+# ipToLayer2Multicast <ipaddr>
+#
+# Arguments:
+# <ipaddr>
+# ipaddress in dotted form
+#
+# Return Values:
+# mac address in xx.xx.xx.xx.xx.xx form
+#
+# Description:
+#
+# Examples:
+# % ::ip::ipToLayer2Multicast 224.0.0.2
+# 01.00.5e.00.00.02
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::ipToLayer2Multicast { ipaddr } {
+ regexp "\[0-9\]+\.(\[0-9\]+)\.(\[0-9\]+)\.(\[0-9\]+)" $ipaddr junk ip2 ip3 ip4
+ #remove MSB of 2nd octet of IP address for mcast L2 addr
+ set mac2 [expr {$ip2 & 127}]
+ return [format "01.00.5e.%02x.%02x.%02x" $mac2 $ip3 $ip4]
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::ipHostFromPrefix
+#
+# Purpose:
+# gives back a host address from a prefix
+#
+# Synopsis:
+# ::ip::ipHostFromPrefix <prefix> [-exclude <list of prefixes>]
+#
+# Arguments:
+# <prefix>
+# prefix is <ipaddr>/<masklen>
+# -exclude <list of prefixes>
+# list if ipprefixes that host should not be in
+# Return Values:
+# ip address
+#
+# Description:
+#
+# Examples:
+# %::ip::ipHostFromPrefix 1.1.1.5/24
+# 1.1.1.1
+#
+# %::ip::ipHostFromPrefix 1.1.1.1/32
+# 1.1.1.1
+#
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::ipHostFromPrefix { prefix args } {
+ set mask [mask $prefix]
+ set ipaddr [prefix $prefix]
+ if {[llength $args]} {
+ array set opts $args
+ } else {
+ if {$mask==32} {
+ return $ipaddr
+ } else {
+ return [intToString [expr {[toHex $ipaddr] + 1} ]]
+ }
+ }
+ set format {-ipv4}
+ # if we got here, then options were set
+ if {[info exists opts(-exclude)]} {
+ #basic algo is:
+ # 1. throw away prefixes that are less specific that $prefix
+ # 2. of remaining pfx, throw away prefixes that do not overlap
+ # 3. run reducetoAggregates on specific nets
+ # 4.
+
+ # 1. convert to hex format
+ set currHex [prefixToNative $prefix ]
+ set exclHex [prefixToNative $opts(-exclude) ]
+ # sort the prefixes by their mask, include the $prefix as a marker
+ # so we know from where to throw away prefixes
+ set sortedPfx [lsort -integer -index 1 [concat [list $currHex] $exclHex]]
+ # throw away prefixes that are less specific than $prefix
+ set specPfx [lrange $sortedPfx [expr {[lsearch -exact $sortedPfx $currHex] +1} ] end]
+
+ #2. throw away non-overlapping prefixes
+ set specPfx [isOverlapNative -all -inline \
+ [lindex $currHex 0 ] \
+ [lindex $currHex 1 ] \
+ $specPfx ]
+ #3. run reduce aggregates
+ set specPfx [reduceToAggregates $specPfx]
+
+ #4 now have to pick an address that overlaps with $currHex but not with
+ # $specPfx
+ # 4.1 find the largest prefix w/ most specific mask and go to the next net
+
+
+ # current ats tcl does not allow this in one command, so
+ # for now just going to grab the last prefix (list is already sorted)
+ set sPfx [lindex $specPfx end]
+ set startPfx $sPfx
+ # add currHex to specPfx
+ set oChkPfx [concat $specPfx [list $currHex]]
+
+
+ set notcomplete 1
+ set overflow 0
+ while {$notcomplete} {
+ #::ipMore::log::debug "doing nextnet on $sPfx"
+ set nextNet [nextNet [lindex $sPfx 0] [lindex $sPfx 1]]
+ #::ipMore::log::debug "trying $nextNet"
+ if {$overflow && ($nextNet > $startPfx)} {
+ #we've gone thru the entire net and didn't find anything.
+ return -code error [msgcat::mc "ip host could not be found in %s" $prefix]
+ break
+ }
+ set oPfx [isOverlapNative -all -inline \
+ $nextNet -1 \
+ $oChkPfx
+ ]
+ switch -exact [llength $oPfx] {
+ 0 {
+ # no overlap at all. meaning we have gone beyond the bounds of
+ # $currHex. need to overlap and try again
+ #::ipMore::log::debug {ipHostFromPrefix: overlap done}
+ set overflow 1
+ }
+ 1 {
+ #we've found what we're looking for. pick this address and exit
+ return [intToString $nextNet]
+ }
+ default {
+ # 2 or more overlaps, need to increment again
+ set sPfx [lindex $oPfx 0]
+ }
+ }
+ }
+ }
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::reduceToAggregates
+#
+# Purpose:
+# finds nets that overlap and filters out the more specifc nets
+#
+# Synopsis:
+# ::ip::reduceToAggregates <prefixList>
+#
+# Arguments:
+# <prefixList>
+# prefixList a list in the from of
+# is <ipaddr>/<masklen> or native format
+#
+# Return Values:
+# non-overlapping ip prefixes
+#
+# Description:
+#
+# Examples:
+#
+# % ::ip::reduceToAggregates {1.1.1.0/24 1.1.0.0/8 2.1.1.0/24 1.1.1.1/32 }
+# 1.0.0.0/8 2.1.1.0/24
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::reduceToAggregates { prefixList } {
+ #find out format of $prefixeList
+ set dotConv 0
+ if {[llength [lindex $prefixList 0]]==1} {
+ #format is dotted form convert all prefixes to native form
+ set prefixList [ip::prefixToNative $prefixList]
+ set dotConv 1
+ }
+
+ set nonOverLapping $prefixList
+ while {1==1} {
+ set overlapFound 0
+ set remaining $nonOverLapping
+ set nonOverLapping {}
+ while {[llength $remaining]} {
+ set current [lvarpop remaining]
+ set overLap [ip::isOverlapNative [lindex $current 0] [lindex $current 1] $remaining]
+ if {$overLap} {
+ #there was a overlap find out which prefix has a the smaller mask, and keep that one
+ if {[lindex $current 1] > [lindex [lindex $remaining [expr {$overLap -1}]] 1]} {
+ #current has more restrictive mask, throw that prefix away
+ # keep other prefix
+ lappend nonOverLapping [lindex $remaining [expr {$overLap -1}]]
+ } else {
+ lappend nonOverLapping $current
+ }
+ lvarpop remaining [expr {$overLap -1}]
+ set overlapFound 1
+ } else {
+ #no overlap, keep all prefixes, don't touch the stuff in
+ # remaining, it is needed for other overlap checking
+ lappend nonOverLapping $current
+ }
+ }
+ if {$overlapFound==0} {break}
+ }
+ if {$dotConv} {return [nativeToPrefix $nonOverLapping]}
+ return $nonOverLapping
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::longestPrefixMatch
+#
+# Purpose:
+# given host IP finds longest prefix match from set of prefixes
+#
+# Synopsis:
+# ::ip::longestPrefixMatch <ipaddr> <prefixList> [-ipv4]
+#
+# Arguments:
+# <prefixList>
+# is list of <ipaddr> in native or dotted form
+# <ipaddr>
+# ip address in <ipprefix> format, dotted form, or integer form
+# -ipv4
+# the provided integer format addresses are in ipv4 format (default)
+#
+# Return Values:
+# <ipprefix> that is the most specific match to <ipaddr>
+#
+# Description:
+#
+# Examples:
+# % ::ip::longestPrefixMatch 1.1.1.1 {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.0/28 }
+# 1.1.1.0/28
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::longestPrefixMatch { ipaddr prefixList args} {
+ set ipv4 1
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+ }
+ }
+ }
+ #find out format of prefixes
+ set dotConv 0
+ if {[llength [lindex $prefixList 0]]==1} {
+ #format is dotted form convert all prefixes to native form
+ set prefixList [ip::prefixToNative $prefixList]
+ set dotConv 1
+ }
+ #sort so that most specific prefix is in the front
+ if {[llength [lindex [lindex $prefixList 0] 1]]} {
+ set prefixList [lsort -decreasing -integer -index 1 $prefixList]
+ } else {
+ set prefixList [list $prefixList]
+ }
+ if {![string is integer -strict $ipaddr]} {
+ set ipaddr [prefixToNative $ipaddr]
+ }
+ set best [ip::isOverlapNative -inline \
+ [lindex $ipaddr 0] [lindex $ipaddr 1] $prefixList]
+ if {$dotConv && [llength $best]} {
+ return [nativeToPrefix $best]
+ }
+ return $best
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::cmpDotIP
+#
+# Purpose:
+# helper function for dotted ip address for use in lsort
+#
+# Synopsis:
+# ::ip::cmpDotIP <ipaddr1> <ipaddr2>
+#
+# Arguments:
+# <ipaddr1> <ipaddr2>
+# prefix is in dotted ip address format
+#
+# Return Values:
+# -1 if ipaddr1 is less that ipaddr2
+# 1 if ipaddr1 is more that ipaddr2
+# 0 if ipaddr1 and ipaddr2 are equal
+#
+# Description:
+#
+# Examples:
+# % lsort -command ip::cmpDotIP {1.0.0.0 2.2.0.0 128.0.0.0 3.3.3.3}
+# 1.0.0.0 2.2.0.0 3.3.3.3 128.0.0.0
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+# ip address in <ipprefix> format, dotted form, or integer form
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {
+ # 8.3+
+ proc ip::cmpDotIP {ipaddr1 ipaddr2} {
+ # convert dotted to list of integers
+ set ipaddr1 [split $ipaddr1 .]
+ set ipaddr2 [split $ipaddr2 .]
+ foreach a $ipaddr1 b $ipaddr2 {
+ #ipMore::log::debug "$ipInt1 $ipInt2"
+ if { $a < $b} {
+ return -1
+ } elseif {$a >$b} {
+ return 1
+ }
+ }
+ return 0
+ }
+} else {
+ # 8.4+
+ proc ip::cmpDotIP {ipaddr1 ipaddr2} {
+ # convert dotted to decimal
+ set ipInt1 [::ip::toHex $ipaddr1]
+ set ipInt2 [::ip::toHex $ipaddr2]
+ #ipMore::log::debug "$ipInt1 $ipInt2"
+ if { $ipInt1 < $ipInt2} {
+ return -1
+ } elseif {$ipInt1 >$ipInt2 } {
+ return 1
+ } else {
+ return 0
+ }
+ }
+}
+
+# Populate the array "maskLenToDotted" for fast lookups of mask to
+# dotted form.
+
+namespace eval ::ip {
+ variable maskLenToDotted
+ variable x
+
+ for {set x 0} {$x <33} {incr x} {
+ set maskLenToDotted($x) [intToString [maskToInt $x]]
+ }
+ unset x
+}
--- /dev/null
+# Skip this for window and a specific version of Solaris
+#
+# This could do with an explanation -- why are we avoiding these platforms
+# and perhaps using critcl's platform::platform command might be better?
+#
+if {[string equal $::tcl_platform(platform) windows] ||
+ ([string equal $::tcl_platform(os) SunOS] &&
+ [string equal $::tcl_platform(osVersion) 5.6])
+} {
+ # avoid warnings about nothing to compile
+ critcl::ccode {
+ /* nothing to do */
+ }
+ return
+}
+
+package require critcl;
+
+namespace eval ::ip {
+
+critcl::ccode {
+#include <stdlib.h>
+#include <stdio.h>
+#include <tcl.h>
+#include <inttypes.h>
+#include <arpa/inet.h>
+#include <string.h>
+#include <sys/socket.h>
+}
+
+critcl::ccommand prefixToNativec {clientData interp objc objv} {
+ int elemLen, maskLen, ipLen, mask;
+ int rval,convertListc,i;
+ Tcl_Obj **convertListv;
+ Tcl_Obj *listPtr,*returnPtr, *addrList;
+ char *stringIP, *slashPos, *stringMask;
+ char v4HEX[11];
+
+ uint32_t inaddr;
+ listPtr = NULL;
+
+ /* printf ("\n in prefixToNativeC"); */
+ /* printf ("\n objc = %d",objc); */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "<ipaddress>/<mask>");
+ return TCL_ERROR;
+ }
+
+
+ if (Tcl_ListObjGetElements (interp, objv[1],
+ &convertListc, &convertListv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ returnPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ for (i = 0; i < convertListc; i++) {
+ /* need to create a duplicate here because when we modify */
+ /* the stringIP it'll mess up the original in the calling */
+ /* context */
+ addrList = Tcl_DuplicateObj(convertListv[i]);
+ stringIP = Tcl_GetStringFromObj(addrList, &elemLen);
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ /* printf ("\n ### %s ### string \n", stringIP); */
+ /* split the ip address and mask */
+ slashPos = strchr(stringIP, (int) '/');
+ if (slashPos == NULL) {
+ /* straight ip address without mask */
+ mask = 0xffffffff;
+ ipLen = strlen(stringIP);
+ } else {
+ /* ipaddress has the mask, handle the mask and seperate out the */
+ /* ip address */
+ /* printf ("\n ** %d ",(uintptr_t)slashPos); */
+ stringMask = slashPos +1;
+ maskLen =strlen(stringMask);
+ /* put mask in hex form */
+ if (maskLen < 3) {
+ mask = atoi(stringMask);
+ mask = (0xFFFFFFFF << (32 - mask)) & 0xFFFFFFFF;
+ } else {
+ /* mask is in dotted form */
+ if ((rval = inet_pton(AF_INET,stringMask,&mask)) < 1 ) {
+ Tcl_AddErrorInfo(interp, "\n bad format encountered in mask conversion");
+ return TCL_ERROR;
+ }
+ mask = htonl(mask);
+ }
+ ipLen = (uintptr_t)slashPos - (uintptr_t)stringIP;
+ /* divide the string into ip and mask portion */
+ *slashPos = '\0';
+ /* printf("\n %d %d %d %d", (uintptr_t)stringMask, maskLen, (uintptr_t)stringIP, ipLen); */
+ }
+ if ( (rval = inet_pton(AF_INET,stringIP,&inaddr)) < 1) {
+ Tcl_AddErrorInfo(interp,
+ "\n bad format encountered in ip conversion");
+ return TCL_ERROR;
+ };
+ inaddr = htonl(inaddr);
+ /* apply the mask the to the ip portion, just to make sure */
+ /* what we return is cleaned up */
+ inaddr = inaddr & mask;
+ sprintf(v4HEX,"0x%08X",inaddr);
+ /* printf ("\n\n ### %s",v4HEX); */
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(v4HEX,-1));
+ sprintf(v4HEX,"0x%08X",mask);
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(v4HEX,-1));
+ Tcl_ListObjAppendElement(interp, returnPtr, listPtr);
+ Tcl_DecrRefCount(addrList);
+ }
+
+ if (convertListc==1) {
+ Tcl_SetObjResult(interp,listPtr);
+ } else {
+ Tcl_SetObjResult(interp,returnPtr);
+ }
+
+ return TCL_OK;
+}
+
+critcl::ccommand isOverlapNativec {clientData interp objc objv} {
+ int i;
+ unsigned int ipaddr,ipMask, mask1mask2;
+ unsigned int ipaddr2,ipMask2;
+ int compareListc,comparePrefixMaskc;
+ int allSet,inlineSet,index;
+ Tcl_Obj **compareListv,**comparePrefixMaskv, *listPtr;
+ Tcl_Obj *result;
+ static CONST char *options[] = {
+ "-all", "-inline", "-ipv4", NULL
+ };
+ enum options {
+ OVERLAP_ALL, OVERLAP_INLINE, OVERLAP_IPV4
+ };
+
+ allSet = 0;
+ inlineSet = 0;
+ listPtr = NULL;
+
+ /* printf ("\n objc = %d",objc); */
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?options? <hexIP> <hexMask> <hexList>");
+ return TCL_ERROR;
+ }
+ for (i = 1; i < objc-3; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (index) {
+ case OVERLAP_ALL:
+ allSet = 1;
+ /* printf ("\n all selected"); */
+ break;
+ case OVERLAP_INLINE:
+ inlineSet = 1;
+ /* printf ("\n inline selected"); */
+ break;
+ case OVERLAP_IPV4:
+ break;
+ }
+ }
+ /* options are parsed */
+
+ /* create return obj */
+ result = Tcl_GetObjResult (interp);
+
+ /* set ipaddr and ipmask */
+ Tcl_GetIntFromObj(interp,objv[objc-3],&ipaddr);
+ Tcl_GetIntFromObj(interp,objv[objc-2],&ipMask);
+
+ /* split the 3rd argument into <ipaddr> <mask> pairs */
+ if (Tcl_ListObjGetElements (interp, objv[objc-1], &compareListc, &compareListv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+/* printf("comparing %x/%x \n",ipaddr,ipMask); */
+
+ if (allSet || inlineSet) {
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ }
+
+ for (i = 0; i < compareListc; i++) {
+ /* split the ipaddr2 and ipmask2 */
+ if (Tcl_ListObjGetElements (interp,
+ compareListv[i],
+ &comparePrefixMaskc,
+ &comparePrefixMaskv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (comparePrefixMaskc != 2) {
+ Tcl_AddErrorInfo(interp,"need format {{<ipaddr> <mask>} {<ipad..}}");
+ return TCL_ERROR;
+ }
+ Tcl_GetIntFromObj(interp,comparePrefixMaskv[0],&ipaddr2);
+ Tcl_GetIntFromObj(interp,comparePrefixMaskv[1],&ipMask2);
+/* printf(" with %x/%x \n",ipaddr2,ipMask2); */
+ mask1mask2 = ipMask & ipMask2;
+/* printf(" mask1mask2 %x \n",mask1mask2); */
+/* printf(" ipaddr & mask1mask2 %x\n",ipaddr & mask1mask2); */
+/* printf(" ipaddr2 & mask1mask2 %x\n",ipaddr2 & mask1mask2); */
+ if ((ipaddr & mask1mask2) == (ipaddr2 & mask1mask2)) {
+ if (allSet) {
+ if (inlineSet) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ compareListv[i]);
+ } else {
+ /* printf("\n appending %d",i+1); */
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewIntObj(i+1));
+ };
+ } else {
+ if (inlineSet) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ compareListv[i]);
+ Tcl_SetObjResult(interp,listPtr);
+ } else {
+ Tcl_SetIntObj (result, i+1);
+ }
+ return TCL_OK;
+ };
+ };
+ };
+
+ if (allSet || inlineSet) {
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+ } else {
+ Tcl_SetIntObj (result, 0);
+ return TCL_OK;
+ }
+ return TCL_OK;
+
+
+
+}
+
+
+}
+
+# @sak notprovided ipMorec
+package provide ipMorec 1.0
--- /dev/null
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset en "option %s not supported" "option %s not supported"
+mcset en "option %s not supported" "option %s not supported"
+mcset en "not an ip mask: %s" "not an ip mask: %s"
+mcset en "ip host could not be found in %s" "ip host could not be found in %s"
--- /dev/null
+# pkgIndex.tcl -
+#
+# $Id: pkgIndex.tcl,v 1.18 2008/03/14 21:21:12 andreas_kupries Exp $
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded dns 1.3.2 [list source [file join $dir dns.tcl]]
+package ifneeded resolv 1.0.3 [list source [file join $dir resolv.tcl]]
+package ifneeded ip 1.1.2 [list source [file join $dir ip.tcl]]
+package ifneeded spf 1.1.1 [list source [file join $dir spf.tcl]]
--- /dev/null
+# resolv.tcl - Copyright (c) 2002 Emmanuel Frecon <emmanuel@sics.se>
+#
+# Original Author -- Emmanuel Frecon - emmanuel@sics.se
+# Modified by Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# A super module on top of the dns module for host name resolution.
+# There are two services provided on top of the regular Tcl library:
+# Firstly, this module attempts to automatically discover the default
+# DNS server that is setup on the machine that it is run on. This
+# server will be used in all further host resolutions. Secondly, this
+# module offers a rudimentary cache. The cache is rudimentary since it
+# has no expiration on host name resolutions, but this is probably
+# enough for short lived applications.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: resolv.tcl,v 1.9 2004/01/25 07:29:39 andreas_kupries Exp $
+
+package require dns 1.0; # tcllib 1.3
+
+namespace eval ::resolv {
+ variable version 1.0.3
+ variable rcsid {$Id: resolv.tcl,v 1.9 2004/01/25 07:29:39 andreas_kupries Exp $}
+
+ namespace export resolve init ignore hostname
+
+ variable R
+ if {![info exists R]} {
+ array set R {
+ initdone 0
+ dns ""
+ dnsdefault ""
+ ourhost ""
+ search {}
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+# Command Name -- ignore
+# Original Author -- Emmanuel Frecon - emmanuel@sics.se
+#
+# Remove a host name resolution from the cache, if present, so that the
+# next resolution will query the DNS server again.
+#
+# Arguments:
+# hostname - Name of host to remove from the cache.
+#
+proc ::resolv::ignore { hostname } {
+ variable Cache
+ catch {unset Cache($hostname)}
+ return
+}
+
+# -------------------------------------------------------------------------
+# Command Name -- init
+# Original Author -- Emmanuel Frecon - emmanuel@sics.se
+#
+# Initialise this module with a known host name. This host (not mandatory)
+# will become the default if the library was not able to find a DNS server.
+# This command can be called several times, its effect is double: actively
+# looking for the default DNS server setup on the running machine; and
+# emptying the host name resolution cache.
+#
+# Arguments:
+# defaultdns - Default DNS server
+#
+proc ::resolv::init { {defaultdns ""} {search {}}} {
+ variable R
+ variable Cache
+
+ # Clean the resolver cache
+ catch {unset Cache}
+
+ # Record the default DNS server and search list.
+ set R(dnsdefault) $defaultdns
+ set R(search) $search
+
+ # Now do some intelligent lookup. We do this on the current
+ # hostname to get a chance to get back some (full) information on
+ # ourselves. A previous version was using 127.0.0.1, not sure
+ # what is best.
+ set res [catch [list exec nslookup [info hostname]] lkup]
+ if { $res == 0 } {
+ set l [split $lkup]
+ set nl ""
+ foreach e $l {
+ if { [string length $e] > 0 } {
+ lappend nl $e
+ }
+ }
+
+ # Now, a lot of mixture to arrange so that hostname points at the
+ # DNS server that we should use for any further request. This
+ # code is complex, but was actually tested behind a firewall
+ # during the SITI Winter Conference 2003. There, strangly,
+ # nslookup returned an error but a DNS server was actually setup
+ # correctly...
+ set hostname ""
+ set len [llength $nl]
+ for { set i 0 } { $i < $len } { incr i } {
+ set e [lindex $nl $i]
+ if { [string match -nocase "*server*" $e] } {
+ set hostname [lindex $nl [expr {$i + 1}]]
+ if { [string match -nocase "UnKnown" $hostname] } {
+ set hostname ""
+ }
+ break
+ }
+ }
+
+ if { $hostname != "" } {
+ set R(dns) $hostname
+ } else {
+ for { set i 0 } { $i < $len } { incr i } {
+ set e [lindex $nl $i]
+ if { [string match -nocase "*address*" $e] } {
+ set hostname [lindex $nl [expr {$i + 1}]]
+ break
+ }
+ }
+ if { $hostname != "" } {
+ set R(dns) $hostname
+ }
+ }
+ }
+
+ if {$R(dns) == ""} {
+ set R(dns) $R(dnsdefault)
+ }
+
+
+ # Start again to find our full name
+ set ourhost ""
+ if {$res == 0} {
+ set dot [string first "." [info hostname]]
+ if { $dot < 0 } {
+ for { set i 0 } { $i < $len } { incr i } {
+ set e [lindex $nl $i]
+ if { [string match -nocase "*name*" $e] } {
+ set ourhost [lindex $nl [expr {$i + 1}]]
+ break
+ }
+ }
+ if { $ourhost == "" } {
+ if { ! [regexp {\d+\.\d+\.\d+\.\d+} $hostname] } {
+ set dot [string first "." $hostname]
+ set ourhost [format "%s%s" [info hostname] \
+ [string range $hostname $dot end]]
+ }
+ }
+ } else {
+ set ourhost [info hostname]
+ }
+ }
+
+ if {$ourhost == ""} {
+ set R(ourhost) [info hostname]
+ } else {
+ set R(ourhost) $ourhost
+ }
+
+
+ set R(initdone) 1
+
+ return $R(dns)
+}
+
+# -------------------------------------------------------------------------
+# Command Name -- resolve
+# Original Author -- Emmanuel Frecon - emmanuel@sics.se
+#
+# Resolve a host name to an IP address. This is a wrapping procedure around
+# the basic services of the dns library.
+#
+# Arguments:
+# hostname - Name of host
+#
+proc ::resolv::resolve { hostname } {
+ variable R
+ variable Cache
+
+ # Initialise if not already done. Auto initialisation cannot take
+ # any known DNS server (known to the caller)
+ if { ! $R(initdone) } { init }
+
+ # Check whether this is not simply a raw IP address. What about
+ # IPv6 ??
+ # - We don't have sockets in Tcl for IPv6 protocols - [PT]
+ #
+ if { [regexp {\d+\.\d+\.\d+\.\d+} $hostname] } {
+ return $hostname
+ }
+
+ # Look for hostname in the cache, if found return.
+ if { [array names ::resolv::Cache $hostname] != "" } {
+ return $::resolv::Cache($hostname)
+ }
+
+ # Scream if we don't have any DNS server setup, since we cannot do
+ # anything in that case.
+ if { $R(dns) == "" } {
+ return -code error "No dns server provided"
+ }
+
+ set R(retries) 0
+ set ip [Resolve $hostname]
+
+ # And store the result of resolution in our cache for further use.
+ set Cache($hostname) $ip
+
+ return $ip
+}
+
+# Description:
+# Attempt to resolve hostname via DNS. If the name cannot be resolved then
+# iterate through the search list appending each domain in turn until we
+# get one that succeeds.
+#
+proc ::resolv::Resolve {hostname} {
+ variable R
+ set t [::dns::resolve $hostname -server $R(dns)]
+ ::dns::wait $t; # wait with event processing
+ set status [dns::status $t]
+ if {$status == "ok"} {
+ set ip [lindex [::dns::address $t] 0]
+ ::dns::cleanup $t
+ } elseif {$status == "error"
+ && [::dns::errorcode $t] == 3
+ && $R(retries) < [llength $R(search)]} {
+ ::dns::cleanup $t
+ set suffix [lindex $R(search) $R(retries)]
+ incr R(retries)
+ set new [lindex [split $hostname .] 0].[string trim $suffix .]
+ set ip [Resolve $new]
+ } else {
+ set err [dns::error $t]
+ ::dns::cleanup $t
+ return -code error "dns error: $err"
+ }
+ return $ip
+}
+
+# -------------------------------------------------------------------------
+
+package provide resolv $::resolv::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+# spf.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Sender Policy Framework
+#
+# http://www.ietf.org/internet-drafts/draft-ietf-marid-protocol-00.txt
+# http://spf.pobox.com/
+#
+# Some domains using SPF:
+# pobox.org - mx, a, ptr
+# oxford.ac.uk - include
+# gnu.org - ip4
+# aol.com - ip4, ptr
+# sourceforge.net - mx, a
+# altavista.com - exists, multiple TXT replies.
+# oreilly.com - mx, ptr, include
+# motleyfool.com - include (looping includes)
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: spf.tcl,v 1.5 2008/03/14 21:21:12 andreas_kupries Exp $
+
+package require Tcl 8.2; # tcl minimum version
+package require dns; # tcllib 1.3
+package require logger; # tcllib 1.3
+package require ip; # tcllib 1.7
+package require struct::list; # tcllib 1.7
+package require uri::urn; # tcllib 1.3
+
+namespace eval spf {
+ variable version 1.1.1
+ variable rcsid {$Id: spf.tcl,v 1.5 2008/03/14 21:21:12 andreas_kupries Exp $}
+
+ namespace export spf
+
+ variable uid
+ if {![info exists uid]} {set uid 0}
+
+ variable log
+ if {![info exists log]} {
+ set log [logger::init spf]
+ ${log}::setlevel warn
+ proc ${log}::stdoutcmd {level text} {
+ variable service
+ puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\
+ $service $level\] $text"
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+# ip : ip address of the connecting host
+# domain : the domain to match
+# sender : full sender email address
+#
+proc ::spf::spf {ip domain sender} {
+ variable log
+
+ # 3.3: Initial processing
+ # If the sender address has no local part, set it to postmaster
+ set addr [split $sender @]
+ if {[set len [llength $addr]] == 0} {
+ return -code error -errorcode permanent "invalid sender address"
+ } elseif {$len == 1} {
+ set sender "postmaster@$sender"
+ }
+
+ # 3.4: Record lookup
+ set spf [SPF $domain]
+ if {[string equal $spf none]} {
+ return $spf
+ }
+
+ return [Spf $ip $domain $sender $spf]
+}
+
+proc ::spf::Spf {ip domain sender spf} {
+ variable log
+
+ # 3.4.1: Matching Version
+ if {![regexp {^v=spf(\d)\s+} $spf -> version]} {
+ return none
+ }
+
+ ${log}::debug "$spf"
+
+ if {$version != 1} {
+ return -code error -errorcode permanent \
+ "version mismatch: we only understand SPF 1\
+ this domain has provided version \"$version\""
+ }
+
+ set result ?
+ set seen_domains $domain
+ set explanation {denied}
+
+ set directives [lrange [split $spf { }] 1 end]
+ foreach directive $directives {
+ set prefix [string range $directive 0 0]
+ if {[string equal $prefix "+"] || [string equal $prefix "-"]
+ || [string equal $prefix "?"] || [string equal $prefix "~"]} {
+ set directive [string range $directive 1 end]
+ } else {
+ set prefix "+"
+ }
+
+ set cmd [string tolower [lindex [split $directive {:/=}] 0]]
+ set param [string range $directive [string length $cmd] end]
+
+ if {[info command ::spf::_$cmd] == {}} {
+ # 6.1 Unrecognised directives terminate processing
+ # but unknown modifiers are ignored.
+ if {[string match "=*" $param]} {
+ continue
+ } else {
+ set result unknown
+ break
+ }
+ } else {
+ set r [catch {::spf::_$cmd $ip $domain $sender $param} res]
+ if {$r} {
+ if {$r == 2} {return $res};# deal with return -code return
+ if {[string equal $res "none"]
+ || [string equal $res "error"]
+ || [string equal $res "unknown"]} {
+ return $res
+ }
+ return -code error "error in \"$cmd\": $res"
+ }
+ if {$res} { set result $prefix }
+ }
+
+ ${log}::debug "$prefix $cmd\($param) -> $result"
+ if {[string equal $result "+"]} break
+ }
+
+ return $result
+}
+
+proc ::spf::loglevel {level} {
+ variable log
+ ${log}::setlevel $level
+}
+
+# get a guaranteed unique and non-present token id.
+proc ::spf::create_token {} {
+ variable uid
+ set id [incr uid]
+ while {[info exists [set token [namespace current]::$id]]} {
+ set id [incr uid]
+ }
+ return $token
+}
+
+# -------------------------------------------------------------------------
+#
+# SPF MECHANISM HANDLERS
+#
+# -------------------------------------------------------------------------
+
+# 4.1: The "all" mechanism is a test that always matches. It is used as the
+# rightmost mechanism in an SPF record to provide an explicit default
+#
+proc ::spf::_all {ip domain sender param} {
+ return 1
+}
+
+# 4.2: The "include" mechanism triggers a recursive SPF query.
+# The domain-spec is expanded as per section 8.
+proc ::spf::_include {ip domain sender param} {
+ variable log
+ upvar seen_domains Seen
+
+ if {![string equal [string range $param 0 0] ":"]} {
+ return -code error "dubious parameters for \"include\""
+ }
+ set r ?
+ set new_domain [Expand [string range $param 1 end] $ip $domain $sender]
+ if {[lsearch $Seen $new_domain] == -1} {
+ lappend Seen $new_domain
+ set spf [SPF $new_domain]
+ if {[string equal $spf none]} {
+ return $spf
+ }
+ set r [Spf $ip $new_domain $sender $spf]
+ }
+ return [string equal $r "+"]
+}
+
+# 4.4: This mechanism matches if <ip> is one of the target's
+# IP addresses.
+# e.g: a:smtp.example.com a:mail.%{d} a
+#
+proc ::spf::_a {ip domain sender param} {
+ variable log
+ foreach {testdomain bits} [ip::SplitIp [string trimleft $param :]] {}
+ if {[string length $testdomain] < 1} {
+ set testdomain $domain
+ } else {
+ set testdomain [Expand $testdomain $ip $domain $sender]
+ }
+ ${log}::debug " fetching A for $testdomain"
+ set dips [A $testdomain]; # get the IPs for the testdomain
+ foreach dip $dips {
+ ${log}::debug " compare: ${ip}/${bits} with ${dip}/${bits}"
+ if {[ip::equal $ip/$bits $dip/$bits]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+# 4.5: This mechanism matches if the <sending-host> is one of the MX hosts
+# for a domain name.
+#
+proc ::spf::_mx {ip domain sender param} {
+ variable log
+ foreach {testdomain bits} [ip::SplitIp [string trimleft $param :]] {}
+ if {[string length $testdomain] < 1} {
+ set testdomain $domain
+ } else {
+ set testdomain [Expand $testdomain $ip $domain $sender]
+ }
+ ${log}::debug " fetching MX for $testdomain"
+ set mxs [MX $testdomain]
+
+ foreach mx $mxs {
+ set mx [lindex $mx 1]
+ set mxips [A $mx]
+ foreach mxip $mxips {
+ ${log}::debug " compare: ${ip}/${bits} with ${mxip}/${bits}"
+ if {[ip::equal $ip/$bits $mxip/$bits]} {
+ return 1
+ }
+ }
+ }
+ return 0
+}
+
+# 4.6: This mechanism tests if the <sending-host>'s name is within a
+# particular domain.
+#
+proc ::spf::_ptr {ip domain sender param} {
+ variable log
+ set validnames {}
+ if {[catch { set names [PTR $ip] } msg]} {
+ ${log}::debug " \"$ip\" $msg"
+ return 0
+ }
+ foreach name $names {
+ set addrs [A $name]
+ foreach addr $addrs {
+ if {[ip::equal $ip $addr]} {
+ lappend validnames $name
+ continue
+ }
+ }
+ }
+
+ ${log}::debug " validnames: $validnames"
+ set testdomain [Expand [string trimleft $param :] $ip $domain $sender]
+ if {$testdomain == {}} {
+ set testdomain $domain
+ }
+ foreach name $validnames {
+ if {[string match "*$testdomain" $name]} {
+ return 1
+ }
+ }
+
+ return 0
+}
+
+# 4.7: These mechanisms test if the <sending-host> falls into a given IP
+# network.
+#
+proc ::spf::_ip4 {ip domain sender param} {
+ variable log
+ foreach {network bits} [ip::SplitIp [string range $param 1 end]] {}
+ ${log}::debug " compare ${ip}/${bits} to ${network}/${bits}"
+ if {[ip::equal $ip/$bits $network/$bits]} {
+ return 1
+ }
+ return 0
+}
+
+# 4.6: These mechanisms test if the <sending-host> falls into a given IP
+# network.
+#
+proc ::spf::_ip6 {ip domain sender param} {
+ variable log
+ foreach {network bits} [ip::SplitIp [string range $param 1 end]] {}
+ ${log}::debug " compare ${ip}/${bits} to ${network}/${bits}"
+ if {[ip::equal $ip/$bits $network/$bits]} {
+ return 1
+ }
+ return 0
+}
+
+# 4.7: This mechanism is used to construct an arbitrary host name that is
+# used for a DNS A record query. It allows for complicated schemes
+# involving arbitrary parts of the mail envelope to determine what is
+# legal.
+#
+proc ::spf::_exists {ip domain sender param} {
+ variable log
+ set testdomain [Expand [string range $param 1 end] $ip $domain $sender]
+ ${log}::debug " checking existence of '$testdomain'"
+ if {[catch {A $testdomain}]} {
+ return 0
+ }
+ return 1
+}
+
+# 5.1: Redirected query
+#
+proc ::spf::_redirect {ip domain sender param} {
+ variable log
+ set new_domain [Expand [string range $param 1 end] $ip $domain $sender]
+ ${log}::debug ">> redirect to '$new_domain'"
+ set spf [SPF $new_domain]
+ if {![string equal $spf none]} {
+ set spf [Spf $ip $new_domain $sender $spf]
+ }
+ ${log}::debug "<< redirect returning '$spf'"
+ return -code return $spf
+}
+
+# 5.2: Explanation
+#
+proc ::spf::_exp {ip domain sender param} {
+ variable log
+ set new_domain [string range $param 1 end]
+ set exp [TXT $new_domain]
+ set exp [Expand $exp $ip $domain $sender]
+ ${log}::debug "exp expanded to \"$exp\""
+ # FIX ME: need to store this somehow.
+}
+
+# 5.3: Sender accreditation
+#
+proc ::spf::_accredit {ip domain sender param} {
+ variable log
+ set accredit [Expand [string range $param 1 end] $ip $domain $sender]
+ ${log}::debug " accreditation '$accredit'"
+ # We are not using this at the moment.
+ return 0
+}
+
+
+# 7: Macro expansion
+#
+proc ::spf::Expand {txt ip domain sender} {
+ variable log
+ set re {%\{[[:alpha:]](?:\d+)?r?[\+\-\.,/_=]*\}}
+ set txt [string map {\[ \\\[ \] \\\]} $txt]
+ regsub -all $re $txt {[ExpandMacro & $ip $domain $sender]} cmd
+ set cmd [string map {%% % %_ \ %- %20} $cmd]
+ return [subst -novariables $cmd]
+}
+
+proc ::spf::ExpandMacro {macro ip domain sender} {
+ variable log
+ set re {%\{([[:alpha:]])(\d+)?(r)?([\+\-\.,/_=]*)\}}
+ set C {} ; set T {} ; set R {}; set D {}
+ set r [regexp $re $macro -> C T R D]
+ if {$R == {}} {set R 0} else {set R 1}
+ set res $macro
+ if {$r} {
+ set enc [string is upper $C]
+ switch -exact -- [string tolower $C] {
+ s { set res $sender }
+ l {
+ set addr [split $sender @]
+ if {[llength $addr] < 2} {
+ set res postmaster
+ } else {
+ set res [lindex $addr 0]
+ }
+ }
+ o {
+ set addr [split $sender @]
+ if {[llength $addr] < 2} {
+ set res $sender
+ } else {
+ set res [lindex $addr 1]
+ }
+ }
+ h - d { set res $domain }
+ i {
+ set res [ip::normalize $ip]
+ if {[ip::is ipv6 $res]} {
+ # Convert 0000:0001 to 0.1
+ set t {}
+ binary scan [ip::Normalize $ip 6] c* octets
+ foreach octet $octets {
+ set hi [expr {($octet & 0xF0) >> 4}]
+ set lo [expr {$octet & 0x0F}]
+ lappend t [format %x $hi] [format %x $lo]
+ }
+ set res [join $t .]
+ }
+ }
+ v {
+ if {[ip::is ipv6 $ip]} {
+ set res ip6
+ } else {
+ set res "in-addr"
+ }
+ }
+ c {
+ set res [ip::normalize $ip]
+ if {[ip::is ipv6 $res]} {
+ set res [ip::contract $res]
+ }
+ }
+ r {
+ set s [socket -server {} -myaddr [info host] 0]
+ set res [lindex [fconfigure $s -sockname] 1]
+ close $s
+ }
+ t { set res [clock seconds] }
+ }
+ if {$T != {} || $R || $D != {}} {
+ if {$D == {}} {set D .}
+ set res [split $res $D]
+ if {$R} {
+ set res [struct::list::Lreverse $res]
+ }
+ if {$T != {}} {
+ incr T -1
+ set res [join [lrange $res end-$T end] $D]
+ }
+ set res [join $res .]
+ }
+ if {$enc} {
+ # URI encode the result.
+ set res [uri::urn::quote $res]
+ }
+ }
+ return $res
+}
+
+# -------------------------------------------------------------------------
+#
+# DNS helper procedures.
+#
+# -------------------------------------------------------------------------
+
+proc ::spf::Resolve {domain type resultproc} {
+ if {[info command $resultproc] == {}} {
+ return -code error "invalid arg: \"$resultproc\" must be a command"
+ }
+ set tok [dns::resolve $domain -type $type]
+ dns::wait $tok
+ set errorcode NONE
+ if {[string equal [dns::status $tok] "ok"]} {
+ set result [$resultproc $tok]
+ set code ok
+ } else {
+ set result [dns::error $tok]
+ set errorcode [dns::errorcode $tok]
+ set code error
+ }
+ dns::cleanup $tok
+ return -code $code -errorcode $errorcode $result
+}
+
+# 3.4: Record lookup
+proc ::spf::SPF {domain} {
+ set txt ""
+ if {[catch {Resolve $domain SPF ::dns::result} spf]} {
+ set code $::errorCode
+ ${log}::debug "error fetching SPF record: $r"
+ switch -exact -- $code {
+ 3 { return -code return [list - "Domain Does Not Exist"] }
+ 2 { return -code error -errorcode temporary $spf }
+ }
+ set txt none
+ } else {
+ foreach res $spf {
+ set ndx [lsearch $res rdata]
+ incr ndx
+ if {$ndx != 0} {
+ append txt [string range [lindex $res $ndx] 1 end]
+ }
+ }
+ }
+ return $txt
+}
+
+proc ::spf::TXT {domain} {
+ set r [Resolve $domain TXT ::dns::result]
+ set txt ""
+ foreach res $r {
+ set ndx [lsearch $res rdata]
+ incr ndx
+ if {$ndx != 0} {
+ append txt [string range [lindex $res $ndx] 1 end]
+ }
+ }
+ return $txt
+}
+
+proc ::spf::A {name} {
+ return [Resolve $name A ::dns::address]
+}
+
+
+proc ::spf::AAAA {name} {
+ return [Resolve $name AAAA ::dns::address]
+}
+
+proc ::spf::PTR {addr} {
+ return [Resolve $addr A ::dns::name]
+}
+
+proc ::spf::MX {domain} {
+ set r [Resolve $domain MX ::dns::name]
+ return [lsort -index 0 $r]
+}
+
+
+# -------------------------------------------------------------------------
+
+package provide spf $::spf::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+# irc.tcl --
+#
+# irc implementation for Tcl.
+#
+# Copyright (c) 2001-2003 by David N. Welton <davidw@dedasys.com>.
+# This code may be distributed under the same terms as Tcl.
+#
+# $Id: irc.tcl,v 1.26 2006/04/23 22:35:57 patthoyts Exp $
+
+package require Tcl 8.3
+
+namespace eval ::irc {
+ variable version 0.6
+
+ # counter used to differentiate connections
+ variable conn 0
+ variable config
+ variable irctclfile [info script]
+ array set config {
+ debug 0
+ logger 0
+ }
+}
+
+# ::irc::config --
+#
+# Set global configuration options.
+#
+# Arguments:
+#
+# key name of the configuration option to change.
+#
+# value value of the configuration option.
+
+proc ::irc::config { args } {
+ variable config
+ if { [llength $args] == 0 } {
+ return [array get config]
+ } elseif { [llength $args] == 1 } {
+ return $config($key)
+ } elseif { [llength $args] > 2 } {
+ error "wrong # args: should be \"config key ?val?\""
+ }
+ set key [lindex $args 0]
+ set value [lindex $args 1]
+ foreach ns [namespace children] {
+ if { [info exists config($key)] && [info exists ${ns}::config($key)] \
+ && [set ${ns}::config($key)] == $config($key)} {
+ ${ns}::cmd-config $key $value
+ }
+ }
+ set config($key) $value
+}
+
+
+# ::irc::connections --
+#
+# Return a list of handles to all existing connections
+
+proc ::irc::connections { } {
+ set r {}
+ foreach ns [namespace children] {
+ lappend r ${ns}::network
+ }
+ return $r
+}
+
+# ::irc::reload --
+#
+# Reload this file, and merge the current connections into
+# the new one.
+
+proc ::irc::reload { } {
+ variable conn
+ set oldconn $conn
+ namespace eval :: {
+ source [set ::irc::irctclfile]
+ }
+ foreach ns [namespace children] {
+ foreach var {sock logger host port} {
+ set $var [set ${ns}::$var]
+ }
+ array set dispatch [array get ${ns}::dispatch]
+ array set config [array get ${ns}::config]
+ # make sure our new connection uses the same namespace
+ set conn [string range $ns 10 end]
+ ::irc::connection
+ foreach var {sock logger host port} {
+ set ${ns}::$var [set $var]
+ }
+ array set ${ns}::dispatch [array get dispatch]
+ array set ${ns}::config [array get config]
+ }
+ set conn $oldconn
+}
+
+# ::irc::connection --
+#
+# Create an IRC connection namespace and associated commands.
+
+proc ::irc::connection { args } {
+ variable conn
+ variable config
+
+ # Create a unique namespace of the form irc$conn::$host
+
+ set name [format "%s::irc%s" [namespace current] $conn]
+
+ namespace eval $name {
+ set sock {}
+ array set dispatch {}
+ array set linedata {}
+ array set config [array get ::irc::config]
+ if { $config(logger) || $config(debug)} {
+ package require logger
+ set logger [logger::init [namespace tail [namespace current]]]
+ if { !$config(debug) } { ${logger}::disable debug }
+ }
+
+
+ # ircsend --
+ # send text to the IRC server
+
+ proc ircsend { msg } {
+ variable sock
+ variable dispatch
+ if { $sock == "" } { return }
+ cmd-log debug "ircsend: '$msg'"
+ if { [catch {puts $sock $msg} err] } {
+ catch { close $sock }
+ set sock {}
+ if { [info exists dispatch(EOF)] } {
+ eval $dispatch(EOF)
+ }
+ cmd-log error "Error in ircsend: $err"
+ }
+ }
+
+
+ #########################################################
+ # Implemented user-side commands, meaning that these commands
+ # cause the calling user to perform the given action.
+ #########################################################
+
+
+ # cmd-config --
+ #
+ # Set or return per-connection configuration options.
+ #
+ # Arguments:
+ #
+ # key name of the configuration option to change.
+ #
+ # value value (optional) of the configuration option.
+
+ proc cmd-config { args } {
+ variable config
+ variable logger
+
+ if { [llength $args] == 0 } {
+ return [array get config]
+ } elseif { [llength $args] == 1 } {
+ return $config($key)
+ } elseif { [llength $args] > 2 } {
+ error "wrong # args: should be \"config key ?val?\""
+ }
+ set key [lindex $args 0]
+ set value [lindex $args 1]
+ if { $key == "debug" } {
+ if {$value} {
+ if { !$config(logger) } { cmd-config logger 1 }
+ ${logger}::enable debug
+ } elseif { [info exists logger] } {
+ ${logger}::disable debug
+ }
+ }
+ if { $key == "logger" } {
+ if { $value && !$config(logger)} {
+ package require logger
+ set logger [logger::init [namespace tail [namespace current]]]
+ } elseif { [info exists logger] } {
+ ${logger}::delete
+ unset logger
+ }
+ }
+ set config($key) $value
+ }
+
+ proc cmd-log {level text} {
+ variable logger
+ if { ![info exists logger] } return
+ ${logger}::$level $text
+ }
+
+ proc cmd-logname { } {
+ variable logger
+ if { ![info exists logger] } return
+ return $logger
+ }
+
+ # cmd-destroy --
+ #
+ # destroys the current connection and its namespace
+
+ proc cmd-destroy { } {
+ variable logger
+ variable sock
+ if { [info exists logger] } { ${logger}::delete }
+ catch {close $sock}
+ namespace delete [namespace current]
+ }
+
+ proc cmd-connected { } {
+ variable sock
+ if { $sock == "" } { return 0 }
+ return 1
+ }
+
+ proc cmd-user { username hostname servername {userinfo ""} } {
+ if { $userinfo == "" } {
+ ircsend "USER $username $hostname server :$servername"
+ } else {
+ ircsend "USER $username $hostname $servername :$userinfo"
+ }
+ }
+
+ proc cmd-nick { nk } {
+ ircsend "NICK $nk"
+ }
+
+ proc cmd-ping { target } {
+ ircsend "PRIVMSG $target :\001PING [clock seconds]\001"
+ }
+
+ proc cmd-serverping { } {
+ ircsend "PING [clock seconds]"
+ }
+
+ proc cmd-ctcp { target line } {
+ ircsend "PRIVMSG $target :\001$line\001"
+ }
+
+ proc cmd-join { chan {key {}} } {
+ ircsend "JOIN $chan $key"
+ }
+
+ proc cmd-part { chan {msg ""} } {
+ if { $msg == "" } {
+ ircsend "PART $chan"
+ } else {
+ ircsend "PART $chan :$msg"
+ }
+ }
+
+ proc cmd-quit { {msg {tcllib irc module - http://tcllib.sourceforge.net/}} } {
+ ircsend "QUIT :$msg"
+ }
+
+ proc cmd-privmsg { target msg } {
+ ircsend "PRIVMSG $target :$msg"
+ }
+
+ proc cmd-notice { target msg } {
+ ircsend "NOTICE $target :$msg"
+ }
+
+ proc cmd-kick { chan target {msg {}} } {
+ ircsend "KICK $chan $target :$msg"
+ }
+
+ proc cmd-mode { target args } {
+ ircsend "MODE $target [join $args]"
+ }
+
+ proc cmd-topic { chan msg } {
+ ircsend "TOPIC $chan :$msg"
+ }
+
+ proc cmd-invite { chan target } {
+ ircsend "INVITE $target $chan"
+ }
+
+ proc cmd-send { line } {
+ ircsend $line
+ }
+
+ proc cmd-peername { } {
+ variable sock
+ if { $sock == "" } { return {} }
+ return [fconfigure $sock -peername]
+ }
+
+ proc cmd-sockname { } {
+ variable sock
+ if { $sock == "" } { return {} }
+ return [fconfigure $sock -sockname]
+ }
+
+ proc cmd-socket { } {
+ variable sock
+ return $sock
+ }
+
+ proc cmd-disconnect { } {
+ variable sock
+ if { $sock == "" } { return -1 }
+ catch { close $sock }
+ set sock {}
+ return 0
+ }
+
+ # Connect --
+ # Create the actual tcp connection.
+
+ proc cmd-connect { h {p 6667} } {
+ variable sock
+ variable host
+ variable port
+
+ set host $h
+ set port $p
+
+ if { $sock == "" } {
+ set sock [socket $host $port]
+ fconfigure $sock -translation crlf -buffering line
+ fileevent $sock readable [namespace current]::GetEvent
+ }
+ return 0
+ }
+
+ # Callback API:
+
+ # These are all available from within callbacks, so as to
+ # provide an interface to provide some information on what is
+ # coming out of the server.
+
+ # action --
+
+ # Action returns the action performed, such as KICK, PRIVMSG,
+ # MODE etc, including numeric actions such as 001, 252, 353,
+ # and so forth.
+
+ proc action { } {
+ variable linedata
+ return $linedata(action)
+ }
+
+ # msg --
+
+ # The last argument of the line, after the last ':'.
+
+ proc msg { } {
+ variable linedata
+ return $linedata(msg)
+ }
+
+ # who --
+
+ # Who performed the action. If the command is called as [who address],
+ # it returns the information in the form
+ # nick!ident@host.domain.net
+
+ proc who { {address 0} } {
+ variable linedata
+ if { $address == 0 } {
+ return [lindex [split $linedata(who) !] 0]
+ } else {
+ return $linedata(who)
+ }
+ }
+
+ # target --
+
+ # To whom was this action done.
+
+ proc target { } {
+ variable linedata
+ return $linedata(target)
+ }
+
+ # additional --
+
+ # Returns any additional header elements beyond the target as a list.
+
+ proc additional { } {
+ variable linedata
+ return $linedata(additional)
+ }
+
+ # header --
+
+ # Returns the entire header in list format.
+
+ proc header { } {
+ variable linedata
+ return [concat [list $linedata(who) $linedata(action) \
+ $linedata(target)] $linedata(additional)]
+ }
+
+ # GetEvent --
+
+ # Get a line from the server and dispatch it.
+
+ proc GetEvent { } {
+ variable linedata
+ variable sock
+ variable dispatch
+ array set linedata {}
+ set line "eof"
+ if { [eof $sock] || [catch {gets $sock} line] } {
+ close $sock
+ set sock {}
+ cmd-log error "Error receiving from network: $line"
+ if { [info exists dispatch(EOF)] } {
+ eval $dispatch(EOF)
+ }
+ return
+ }
+ cmd-log debug "Recieved: $line"
+ if { [set pos [string first " :" $line]] > -1 } {
+ set header [string range $line 0 [expr {$pos - 1}]]
+ set linedata(msg) [string range $line [expr {$pos + 2}] end]
+ } else {
+ set header [string trim $line]
+ set linedata(msg) {}
+ }
+
+ if { [string match :* $header] } {
+ set header [split [string trimleft $header :]]
+ } else {
+ set header [linsert [split $header] 0 {}]
+ }
+ set linedata(who) [lindex $header 0]
+ set linedata(action) [lindex $header 1]
+ set linedata(target) [lindex $header 2]
+ set linedata(additional) [lrange $header 3 end]
+ if { [info exists dispatch($linedata(action))] } {
+ eval $dispatch($linedata(action))
+ } elseif { [string match {[0-9]??} $linedata(action)] } {
+ eval $dispatch(defaultnumeric)
+ } elseif { $linedata(who) == "" } {
+ eval $dispatch(defaultcmd)
+ } else {
+ eval $dispatch(defaultevent)
+ }
+ }
+
+ # registerevent --
+
+ # Register an event in the dispatch table.
+
+ # Arguments:
+ # evnt: name of event as sent by IRC server.
+ # cmd: proc to register as the event handler
+
+ proc cmd-registerevent { evnt cmd } {
+ variable dispatch
+ set dispatch($evnt) $cmd
+ if { $cmd == "" } {
+ unset dispatch($evnt)
+ }
+ }
+
+ # getevent --
+
+ # Return the currently registered handler for the event.
+
+ # Arguments:
+ # evnt: name of event as sent by IRC server.
+
+ proc cmd-getevent { evnt } {
+ variable dispatch
+ if { [info exists dispatch($evnt)] } {
+ return $dispatch($evnt)
+ }
+ return {}
+ }
+
+ # eventexists --
+
+ # Return a boolean value indicating if there is a handler
+ # registered for the event.
+
+ # Arguments:
+ # evnt: name of event as sent by IRC server.
+
+ proc cmd-eventexists { evnt } {
+ variable dispatch
+ return [info exists dispatch($evnt)]
+ }
+
+ # network --
+
+ # Accepts user commands and dispatches them.
+
+ # Arguments:
+ # cmd: command to invoke
+ # args: arguments to the command
+
+ proc network { cmd args } {
+ eval [linsert $args 0 [namespace current]::cmd-$cmd]
+ }
+
+ # Create default handlers.
+
+ set dispatch(PING) {network send "PONG :[msg]"}
+ set dispatch(defaultevent) #
+ set dispatch(defaultcmd) #
+ set dispatch(defaultnumeric) #
+ }
+
+ set returncommand [format "%s::irc%s::network" [namespace current] $conn]
+ incr conn
+ return $returncommand
+}
+
+# -------------------------------------------------------------------------
+
+package provide irc $::irc::version
+
+# -------------------------------------------------------------------------
--- /dev/null
+# Based upon the picoirc code by Salvatore Sanfillipo and Richard Suchenwirth
+# See http://wiki.tcl.tk/13134 for the original standalone version.
+#
+# This package provides a general purpose minimal IRC client suitable for
+# embedding in other applications. All communication with the parent
+# application is done via an application provided callback procedure.
+#
+# Copyright (c) 2004 Salvatore Sanfillipo
+# Copyright (c) 2004 Richard Suchenwirth
+# Copyright (c) 2007 Patrick Thoyts
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: picoirc.tcl,v 1.3 2007/10/24 10:38:57 patthoyts Exp $
+
+namespace eval ::picoirc {
+ variable version 0.5
+ variable uid; if {![info exists uid]} { set uid 0 }
+ variable defaults {
+ server "irc.freenode.net"
+ port 6667
+ channel ""
+ callback ""
+ motd {}
+ users {}
+ }
+ namespace export connect send post splituri
+}
+
+proc ::picoirc::splituri {uri} {
+ foreach {server port channel} {{} {} {}} break
+ if {![regexp {^irc://([^:/]+)(?::([^/]+))?(?:/([^,]+))?} $uri -> server port channel]} {
+ regexp {^(?:([^@]+)@)?([^:]+)(?::(\d+))?} $uri -> channel server port
+ }
+ if {$port eq {}} { set port 6667 }
+ return [list $server $port $channel]
+}
+
+proc ::picoirc::connect {callback nick args} {
+ if {[llength $args] > 2} {
+ return -code error "wrong # args: must be \"callback nick ?passwd? url\""
+ } elseif {[llength $args] == 1} {
+ set url [lindex $args 0]
+ } else {
+ foreach {passwd url} $args break
+ }
+ variable defaults
+ variable uid
+ set context [namespace current]::irc[incr uid]
+ upvar #0 $context irc
+ array set irc $defaults
+ foreach {server port channel} [splituri $url] break
+ if {[info exists channel] && $channel ne ""} {set irc(channel) $channel}
+ if {[info exists server] && $server ne ""} {set irc(server) $server}
+ if {[info exists port] && $port ne ""} {set irc(port) $port}
+ if {[info exists passwd] && $passwd ne ""} {set irc(passwd) $passwd}
+ set irc(callback) $callback
+ set irc(nick) $nick
+ Callback $context init
+ set irc(socket) [socket -async $irc(server) $irc(port)]
+ fileevent $irc(socket) readable [list [namespace origin Read] $context]
+ fileevent $irc(socket) writable [list [namespace origin Write] $context]
+ return $context
+}
+
+proc ::picoirc::Callback {context state args} {
+ upvar #0 $context irc
+ if {[llength $irc(callback)] > 0
+ && [llength [info commands [lindex $irc(callback) 0]]] == 1} {
+ if {[catch {eval $irc(callback) [list $context $state] $args} err]} {
+ puts stderr "callback error: $err"
+ }
+ }
+}
+
+proc ::picoirc::Version {context} {
+ if {[catch {Callback $context version} ver]} { set ver {} }
+ if {$ver eq {}} {
+ set ver "PicoIRC:[package provide picoirc]:Tcl [info patchlevel]"
+ }
+ return $ver
+}
+
+proc ::picoirc::Write {context} {
+ upvar #0 $context irc
+ fileevent $irc(socket) writable {}
+ if {[set err [fconfigure $irc(socket) -error]] ne ""} {
+ Callback $context close $err
+ close $irc(socket)
+ unset irc
+ return
+ }
+ fconfigure $irc(socket) -blocking 0 -buffering line -translation crlf -encoding utf-8
+ Callback $context connect
+ if {[info exists irc(passwd)]} {
+ send $context "PASS $irc(passwd)"
+ }
+ set ver [join [lrange [split [Version $context] :] 0 1] " "]
+ send $context "NICK $irc(nick)"
+ send $context "USER $::tcl_platform(user) 0 * :$ver user"
+ if {$irc(channel) ne {}} {
+ after idle [list [namespace origin send] $context "JOIN $irc(channel)"]
+ }
+ return
+}
+
+proc ::picoirc::Splitirc {s} {
+ foreach v {nick flags user host} {set $v {}}
+ regexp {^([^!]*)!([^=]*)=([^@]+)@(.*)} $s -> nick flags user host
+ return [list $nick $flags $user $host]
+}
+
+proc ::picoirc::Read {context} {
+ upvar #0 $context irc
+ if {[eof $irc(socket)]} {
+ fileevent $irc(socket) readable {}
+ Callback $context close
+ close $irc(socket)
+ unset irc
+ return
+ }
+ if {[gets $irc(socket) line] != -1} {
+ if {[string match "PING*" $line]} {
+ send $context "PONG [info hostname] [lindex [split $line] 1]"
+ return
+ }
+ # the callback can return -code break to prevent processing the read
+ if {[catch {Callback $context debug read $line}] == 3} {
+ return
+ }
+ if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +:(.*)} $line -> \
+ nick target msg]} {
+ set type ""
+ if {[regexp {\001(\S+)(.*)?\001} $msg -> ctcp data]} {
+ switch -- $ctcp {
+ ACTION { set type ACTION ; set msg $data }
+ VERSION {
+ send $context "PRIVMSG $nick :\001VERSION [Version $context]\001"
+ return
+ }
+ default {
+ send $context "PRIVMSG $nick :\001ERRMSG $msg : unknown query"
+ return
+ }
+ }
+ }
+ if {[lsearch -exact {azbridge ijchain} $nick] != -1} {
+ if {$type eq "ACTION"} {
+ regexp {(\S+) (.+)} $msg -> nick msg
+ } else {
+ regexp {<([^>]+)> (.+)} $msg -> nick msg
+ }
+ }
+ Callback $context chat $target $nick $msg $type
+ } elseif {[regexp {^:((?:([^ ]+) +){1,}?):(.*)$} $line -> parts junk rest]} {
+ foreach {server code target fourth fifth} [split $parts] break
+ switch -- $code {
+ 001 - 002 - 003 - 004 - 005 - 250 - 251 - 252 -
+ 254 - 255 - 265 - 266 { return }
+ 433 {
+ variable nickid ; if {![info exists nickid]} {set nickid 0}
+ set seqlen [string length [incr nickid]]
+ set irc(nick) [string range $irc(nick) 0 [expr 8-$seqlen]]$nickid
+ send $context "NICK $irc(nick)"
+ }
+ 353 { set irc(users) [concat $irc(users) $rest]; return }
+ 366 {
+ Callback $context userlist $fourth $irc(users)
+ set irc(users) {}
+ return
+ }
+ 332 { Callback $context topic $fourth $rest; return }
+ 333 { return }
+ 375 { set irc(motd) {} ; return }
+ 372 { append irc(motd) $rest ; return}
+ 376 { return }
+ 311 {
+ foreach {server code target nick name host x} [split $parts] break
+ set irc(whois,$fourth) [list name $name host $host userinfo $rest]
+ return
+ }
+ 301 - 312 - 317 - 320 { return }
+ 319 { lappend irc(whois,$fourth) channels $rest; return }
+ 318 {
+ if {[info exists irc(whois,$fourth)]} {
+ Callback $context userinfo $fourth $irc(whois,$fourth)
+ unset irc(whois,$fourth)
+ }
+ return
+ }
+ JOIN {
+ foreach {n f u h} [Splitirc $server] break
+ Callback $context traffic entered $rest $n
+ return
+ }
+ NICK {
+ foreach {n f u h} [Splitirc $server] break
+ Callback $context traffic nickchange {} $n $rest
+ return
+ }
+ QUIT - PART {
+ foreach {n f u h} [Splitirc $server] break
+ Callback $context traffic left $target $n
+ return
+ }
+ }
+ Callback $context system "" "[lrange [split $parts] 1 end] $rest"
+ } else {
+ Callback $context system "" $line
+ }
+ }
+}
+
+proc ::picoirc::post {context channel msg} {
+ upvar #0 $context irc
+ set type ""
+ if [regexp {^/([^ ]+) *(.*)} $msg -> cmd msg] {
+ regexp {^([^ ]+)?(?: +(.*))?} $msg -> first rest
+ switch -- $cmd {
+ me {set msg "\001ACTION $msg\001";set type ACTION}
+ nick {send $context "NICK $msg"; set $irc(nick) $msg}
+ quit {send $context "QUIT" }
+ part {send $context "PART $channel" }
+ names {send $context "NAMES $channel"}
+ whois {send $context "WHOIS $channel $msg"}
+ kick {send $context "KICK $channel $first :$rest"}
+ mode {send $context "MODE $msg"}
+ topic {send $context "TOPIC $channel :$msg" }
+ quote {send $context $msg}
+ join {send $context "JOIN $msg" }
+ version {send $context "PRIVMSG $first :\001VERSION\001"}
+ msg {
+ if {[regexp {([^ ]+) +(.*)} $msg -> target querymsg]} {
+ send $context "PRIVMSG $target :$msg"
+ Callback $context chat $target $target $querymsg ""
+ }
+ }
+ default {Callback $context system $channel "unknown command /$cmd"}
+ }
+ if {$cmd ne {me} || $cmd eq {msg}} return
+ }
+ foreach line [split $msg \n] {send $context "PRIVMSG $channel :$line"}
+ Callback $context chat $channel $irc(nick) $msg $type
+}
+
+proc ::picoirc::send {context line} {
+ upvar #0 $context irc
+ # the callback can return -code break to prevent writing to socket
+ if {[catch {Callback $context debug write $line}] != 3} {
+ puts $irc(socket) $line
+ }
+}
+
+# -------------------------------------------------------------------------
+
+package provide picoirc $::picoirc::version
+
+# -------------------------------------------------------------------------
--- /dev/null
+# pkgIndex.tcl -*- tcl -*-
+# $Id: pkgIndex.tcl,v 1.8 2007/10/19 21:17:13 patthoyts Exp $
+if { ![package vsatisfies [package provide Tcl] 8.3] } {
+ # PRAGMA: returnok
+ return
+}
+package ifneeded irc 0.6 [list source [file join $dir irc.tcl]]
+package ifneeded picoirc 0.5 [list source [file join $dir picoirc.tcl]]
--- /dev/null
+package require xml
+
+set _wspc {[ \t\n\r]*}
+proc CData {data args} {
+ global indent _wspc
+
+ if {![regexp "^${_wspc}$" $data]} {
+ puts "$indent $data"
+ }
+}
+proc EStart {name attlist args} {
+ global indent
+
+ set attrs {}
+ foreach {key value} $attlist {
+ lappend attrs "$key='$value'"
+ }
+ puts "${indent}<$name $attrs>"
+ append indent { }
+}
+proc EEnd {name args} {
+ global indent
+
+ set indent [string range $indent 0 end-4]
+ puts "${indent}</$name>"
+}
+
+set indent {}
+set parser [::xml::parser -characterdatacommand CData -elementstartcommand EStart \
+ -elementendcommand EEnd]
+
+proc Format {} {
+ global parser
+
+ set fileName [tk_getOpenFile]
+ set fd [open $fileName]
+ $parser parse [read $fd]
+ close $fd
+}
+Format
+
--- /dev/null
+# avatar.tcl --
+#
+# This file is part of the jabberlib.
+# It provides support for avatars (XEP-0008: IQ-Based Avatars)
+# and vCard based avatars as XEP-0153.
+# Note that this XEP is "historical" only but is easy to adapt to
+# a future pub-sub method.
+#
+# Copyright (c) 2005-2006 Mats Bengtsson
+# Copyright (c) 2006 Antonio Cano Damas
+#
+# This file is distributed under BSD style license.
+#
+# $Id: avatar.tcl,v 1.27 2007/11/10 15:44:59 matben Exp $
+#
+############################# USAGE ############################################
+#
+# NAME
+# avatar - convenience command library for avatars.
+#
+# SYNOPSIS
+# jlib::avatar::init jlibname
+#
+# OPTIONS
+# -announce 0|1
+# -share 0|1
+# -command tclProc invoked when hash changed
+# -cache 0|1
+#
+# INSTANCE COMMANDS
+# jlibName avatar configure ?-key value...?
+# jlibName avatar set_data data mime
+# jlibName avatar unset_data
+# jlibName avatar store command
+# jlibName avatar store_remove command
+# jlibName avatar get_async jid command
+# jlibName avatar send_get jid command
+# jlibName avatar send_get_storage jid command
+# jlibName avatar get_data jid2
+# jlibName avatar get_hash jid2
+# jlibName avatar get_mime jid2
+# jlibName avatar have_data jid2
+# jlibName avatar have_hash jid2
+#
+# Note that all internal storage refers to bare (2-tier) JIDs!
+# @@@ It is unclear if this is correct. Perhaps the full JIDs shall be used.
+# The problem is with XEP-0008 mixing JID2 with JID3.
+# Note that all vCards are defined per JID2, bare JID.
+#
+# @@@ And what happens for groupchat members?
+#
+# No automatic presence or server storage is made when reconfiguring or
+# changing own avatar. This is up to the client layer to do.
+# It is callback based which means that the -command is only invoked when
+# getting hashes and not else.
+#
+################################################################################
+# TODO:
+# 1) Update to XEP-0084: User Avatar 1.0, 2007-11-07, using PEP
+
+package require base64 ; # tcllib
+package require sha1 ; # tcllib
+package require jlib
+package require jlib::disco
+package require jlib::vcard
+
+package provide jlib::avatar 0.1
+
+namespace eval jlib::avatar {
+ variable inited 0
+ variable xmlns
+ set xmlns(x-avatar) "jabber:x:avatar"
+ set xmlns(iq-avatar) "jabber:iq:avatar"
+ set xmlns(storage) "storage:client:avatar"
+ set xmlns(vcard-temp) "vcard-temp:x:update"
+
+ jlib::ensamble_register avatar \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+
+ jlib::disco::registerfeature $xmlns(iq-avatar)
+
+ # Note: jlib::ensamble_register is last in this file!
+}
+
+proc jlib::avatar::init {jlibname args} {
+
+ variable xmlns
+
+ # Instance specific arrays:
+ # avatar stores our own avatar
+ # state stores other avatars
+ namespace eval ${jlibname}::avatar {
+ variable avatar
+ variable state
+ variable options
+ }
+ upvar ${jlibname}::avatar::avatar avatar
+ upvar ${jlibname}::avatar::state state
+ upvar ${jlibname}::avatar::options options
+
+ array set options {
+ -announce 0
+ -share 0
+ -cache 1
+ -command ""
+ }
+ eval {configure $jlibname} $args
+
+ # Register some standard iq handlers that are handled internally.
+ $jlibname iq_register get $xmlns(iq-avatar) [namespace current]::iq_handler
+ $jlibname presence_register_int available \
+ [namespace current]::presence_handler
+
+ $jlibname register_reset [namespace current]::reset
+
+ return
+}
+
+proc jlib::avatar::reset {jlibname} {
+ upvar ${jlibname}::avatar::state state
+ upvar ${jlibname}::avatar::options options
+
+ # Do not unset our own avatar.
+ if {!$options(-cache)} {
+ unset -nocomplain state
+ }
+}
+
+# jlib::avatar::cmdproc --
+#
+# Just dispatches the command to the right procedure.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# cmd:
+# args: all args to the cmd procedure.
+#
+# Results:
+# none.
+
+proc jlib::avatar::cmdproc {jlibname cmd args} {
+
+ # Which command? Just dispatch the command to the right procedure.
+ return [eval {$cmd $jlibname} $args]
+}
+
+proc jlib::avatar::configure {jlibname args} {
+
+ upvar ${jlibname}::avatar::options options
+
+ set opts [lsort [array names options -*]]
+ set usage [join $opts ", "]
+ if {[llength $args] == 0} {
+ set result {}
+ foreach name $opts {
+ lappend result $name $options($name)
+ }
+ return $result
+ }
+ regsub -all -- - $opts {} opts
+ set pat ^-([join $opts |])$
+ if {[llength $args] == 1} {
+ set flag [lindex $args 0]
+ if {[regexp -- $pat $flag]} {
+ return $options($flag)
+ } else {
+ return -code error "Unknown option $flag, must be: $usage"
+ }
+ } else {
+ array set oldopts [array get options]
+ foreach {flag value} $args {
+ if {[regexp -- $pat $flag]} {
+ set options($flag) $value
+ } else {
+ return -code error "Unknown option $flag, must be: $usage"
+ }
+ }
+ if {$options(-announce) != $oldopts(-announce)} {
+ if {$options(-announce)} {
+ # @@@ ???
+ } else {
+ $jlibname deregister_presence_stanza x $xmlns(x-avatar)
+ $jlibname deregister_presence_stanza x $xmlns(vcard-temp)
+ }
+ }
+ }
+}
+
+#+++ Two sections: First part deals with our own avatar ------------------------
+
+# jlib::avatar::set_data --
+#
+# Sets our own avatar data and shares it by default.
+# Registers new hashes but does not send updated presence.
+# You have to send presence yourself.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# data: raw binary image data.
+# mime: the mime type: image/gif or image/png
+#
+# Results:
+# none.
+
+proc jlib::avatar::set_data {jlibname data mime} {
+ variable xmlns
+ upvar ${jlibname}::avatar::avatar avatar
+ upvar ${jlibname}::avatar::options options
+
+ set options(-announce) 1
+ set options(-share) 1
+
+ if {[info exists avatar(hash)]} {
+ set oldHash $avatar(hash)
+ } else {
+ set oldHash ""
+ }
+ set avatar(data) $data
+ set avatar(mime) $mime
+ set avatar(hash) [::sha1::sha1 $data]
+ set avatar(base64) [::base64::encode $data]
+
+ set hashElem [wrapper::createtag hash -chdata $avatar(hash)]
+ set xElem [wrapper::createtag x \
+ -attrlist [list xmlns $xmlns(x-avatar)] \
+ -subtags [list $hashElem]]
+
+ $jlibname deregister_presence_stanza x $xmlns(x-avatar)
+ $jlibname register_presence_stanza $xElem -type available
+
+ #-- vCard-temp presence stanza --
+ set photoElem [wrapper::createtag photo -chdata $avatar(hash)]
+ set xVCardElem [wrapper::createtag x \
+ -attrlist [list xmlns $xmlns(vcard-temp)] \
+ -subtags [list $photoElem]]
+
+ $jlibname deregister_presence_stanza x $xmlns(vcard-temp)
+ $jlibname register_presence_stanza $xVCardElem -type available
+
+ return
+}
+
+proc jlib::avatar::get_my_data {jlibname what} {
+ upvar ${jlibname}::avatar::avatar avatar
+
+ return $avatar($what)
+}
+
+# jlib::avatar::unset_data --
+#
+# Unsets our avatar and does not share it anymore.
+# You have to send presence yourself with empty hashes.
+
+proc jlib::avatar::unset_data {jlibname} {
+ variable xmlns
+ upvar ${jlibname}::avatar::avatar avatar
+ upvar ${jlibname}::avatar::options options
+
+ unset -nocomplain avatar
+ set options(-announce) 0
+ set options(-share) 0
+
+ $jlibname deregister_presence_stanza x $xmlns(x-avatar)
+ $jlibname deregister_presence_stanza x $xmlns(vcard-temp)
+
+ return
+}
+
+# jlib::avatar::store --
+#
+# Stores our avatar at the server.
+# Must store as bare jid.
+
+proc jlib::avatar::store {jlibname cmd} {
+ variable xmlns
+ upvar ${jlibname}::avatar::avatar avatar
+
+ if {![array exists avatar]} {
+ return -code error "no avatar set"
+ }
+ set dataElem [wrapper::createtag data \
+ -attrlist [list mimetype $avatar(mime)] \
+ -chdata $avatar(base64)]
+
+ set jid2 [$jlibname getthis myjid2]
+ $jlibname iq_set $xmlns(storage) \
+ -to $jid2 -command $cmd -sublists [list $dataElem]
+}
+
+proc jlib::avatar::store_remove {jlibname cmd} {
+ variable xmlns
+
+ set jid2 [$jlibname getthis myjid2]
+ $jlibname iq_set $xmlns(storage) -to $jid2 -command $cmd
+}
+
+# jlib::avatar::iq_handler --
+#
+# Handles incoming iq requests for our avatar.
+
+proc jlib::avatar::iq_handler {jlibname from queryElem args} {
+ variable xmlns
+ upvar ${jlibname}::avatar::options options
+ upvar ${jlibname}::avatar::avatar avatar
+
+ array set argsArr $args
+ if {[info exists argsArr(-xmldata)]} {
+ set xmldata $argsArr(-xmldata)
+ set from [wrapper::getattribute $xmldata from]
+ set id [wrapper::getattribute $xmldata id]
+ } else {
+ return 0
+ }
+
+ if {$options(-share)} {
+ set dataElem [wrapper::createtag data \
+ -attrlist [list mimetype $avatar(mime)] \
+ -chdata $avatar(base64)]
+ set qElem [wrapper::createtag query \
+ -attrlist [list xmlns $xmlns(iq-avatar)] \
+ -subtags [list $dataElem]]
+ $jlibname send_iq result [list $qElem] -to $from -id $id
+ return 1
+ } else {
+ $jlibname send_iq_error $from $id 404 cancel service-unavailable
+ return 1
+ }
+}
+
+#+++ Second part deals with getting other avatars ------------------------------
+
+proc jlib::avatar::get_data {jlibname jid2} {
+ upvar ${jlibname}::avatar::state state
+
+ set mjid2 [jlib::jidmap $jid2]
+ if {[info exists state($mjid2,data)]} {
+ return $state($mjid2,data)
+ } else {
+ return ""
+ }
+}
+
+proc jlib::avatar::get_mime {jlibname jid2} {
+ upvar ${jlibname}::avatar::state state
+
+ set mjid2 [jlib::jidmap $jid2]
+ if {[info exists state($mjid2,mime)]} {
+ return $state($mjid2,mime)
+ } else {
+ return ""
+ }
+}
+
+proc jlib::avatar::have_data {jlibname jid2} {
+ upvar ${jlibname}::avatar::state state
+
+ set mjid2 [jlib::jidmap $jid2]
+ return [info exists state($mjid2,data)]
+}
+
+proc jlib::avatar::get_hash {jlibname jid2} {
+ upvar ${jlibname}::avatar::state state
+
+ set mjid2 [jlib::jidmap $jid2]
+ if {[info exists state($mjid2,hash)]} {
+ return $state($mjid2,hash)
+ } else {
+ return ""
+ }
+}
+
+proc jlib::avatar::have_hash {jlibname jid2} {
+ upvar ${jlibname}::avatar::state state
+
+ set mjid2 [jlib::jidmap $jid2]
+ return [info exists state($mjid2,hash)]
+}
+
+proc jlib::avatar::have_hash_protocol {jlibname jid2 protocol} {
+ upvar ${jlibname}::avatar::state state
+
+ set mjid2 [jlib::jidmap $jid2]
+ return [info exists state($mjid2,protocol,$protocol)]
+}
+
+proc jlib::avatar::get_protocols {jlibname jid2} {
+ upvar ${jlibname}::avatar::state state
+
+ set protocols {}
+ set mjid2 [jlib::jidmap $jid2]
+ foreach p {avatar vcard} {
+ if {[info exists state($mjid2,protocol,$p)]} {
+ lappend protocols $p
+ }
+ }
+ return $protocols
+}
+
+# jlib::avatar::get_full_jid --
+#
+# This is the jid3 associated with 'avatar' or jid2 if 'vcard',
+# else we just return the jid2.
+
+proc jlib::avatar::get_full_jid {jlibname jid2} {
+ upvar ${jlibname}::avatar::state state
+
+ set mjid2 [jlib::jidmap $jid2]
+ if {[info exists state($mjid2,jid3)]} {
+ return $state($mjid2,jid3)
+ } else {
+ return $jid2
+ }
+}
+
+# jlib::avatar::get_all_avatar_jids --
+#
+# Gets a list of all jids with avatar support.
+# Actually, everyone that has sent us a presence jabber:x:avatar element.
+
+proc jlib::avatar::get_all_avatar_jids {jlibname} {
+ upvar ${jlibname}::avatar::state state
+
+ debug "jlib::avatar::get_all_avatar_jids"
+
+ set jids {}
+ set len [string length ",hash"]
+ foreach {key hash} [array get state *,hash] {
+ if {$hash ne ""} {
+ set jid2 [string range $key 0 end-$len]
+ lappend jids $jid2
+ }
+ }
+ return $jids
+}
+
+proc jlib::avatar::uptodate {jlibname jid2} {
+ upvar ${jlibname}::avatar::state state
+
+ set mjid2 [jlib::jidmap $jid2]
+ if {[info exists state($mjid2,uptodate)]} {
+ return $state($mjid2,uptodate)
+ } else {
+ return 0
+ }
+}
+
+# jlib::avatar::presence_handler --
+#
+# We must handle both 'avatar' and 'vcard' from one place
+# since we don't want separate callbacks if both are supplied.
+# It is assumed that hash from any are identical.
+# Invokes any -command if hash changed.
+
+proc jlib::avatar::presence_handler {jlibname xmldata} {
+ upvar ${jlibname}::avatar::options options
+ upvar ${jlibname}::avatar::state state
+
+ set from [wrapper::getattribute $xmldata from]
+ set mjid [jlib::jidmap $from]
+ set mjid2 [jlib::barejid $mjid]
+
+ if {[info exists state($mjid2,hash)]} {
+ set new 0
+ set oldhash $state($mjid2,hash)
+ } else {
+ set new 1
+ }
+ set gotAvaHash [PresenceAvatar $jlibname $xmldata]
+ set gotVcardHash [PresenceVCard $jlibname $xmldata]
+
+ if {($gotAvaHash || $gotVcardHash)} {
+
+ # 'uptodate' tells us if we need to request new avatar.
+ # If new, or not identical to previous, unless empty.
+ if {$new || ($state($mjid2,hash) ne $oldhash)} {
+ set hash $state($mjid2,hash)
+
+ # hash can be empty.
+ if {$hash eq ""} {
+ set state($mjid2,uptodate) 1
+ unset -nocomplain state($mjid2,data)
+ } else {
+ set state($mjid2,uptodate) 0
+ }
+ if {[string length $options(-command)]} {
+ uplevel #0 $options(-command) [list $from]
+ }
+ }
+ } else {
+
+ # Must be sure that nothing there.
+ if {[info exists state($mjid2,hash)]} {
+ array unset state [jlib::ESC $mjid2],*
+ }
+ }
+}
+
+# jlib::avatar::PresenceAvatar --
+#
+# Caches incoming <x xmlns='jabber:x:avatar'> presence elements.
+# "To disable the avatar, the avatar-generating user's client will send
+# a presence packet with the jabber:x:avatar namespace but with no hash
+# information"
+
+proc jlib::avatar::PresenceAvatar {jlibname xmldata} {
+ variable xmlns
+ upvar ${jlibname}::avatar::state state
+
+ set gotHash 0
+ set elems [wrapper::getchildswithtagandxmlns $xmldata x $xmlns(x-avatar)]
+ if {[llength $elems]} {
+ set hashElem [wrapper::getfirstchildwithtag [lindex $elems 0] hash]
+ set hash [wrapper::getcdata $hashElem]
+ set from [wrapper::getattribute $xmldata from]
+ set mjid2 [jlib::jidmap [jlib::barejid $from]]
+
+ # hash can be empty.
+ set state($mjid2,hash) $hash
+ set state($mjid2,jid3) $from
+ set state($mjid2,protocol,avatar) 1
+ set gotHash 1
+ }
+ return $gotHash
+}
+
+proc jlib::avatar::PresenceVCard {jlibname xmldata} {
+ variable xmlns
+ upvar ${jlibname}::avatar::state state
+
+ set gotHash 0
+ set elems [wrapper::getchildswithtagandxmlns $xmldata x $xmlns(vcard-temp)]
+ if {[llength $elems]} {
+ set hashElem [wrapper::getfirstchildwithtag [lindex $elems 0] photo]
+ set hash [wrapper::getcdata $hashElem]
+ set from [wrapper::getattribute $xmldata from]
+ set mjid2 [jlib::jidmap [jlib::barejid $from]]
+
+ # Note that all vCards are defined per jid2, bare JID.
+ set state($mjid2,hash) $hash
+ set state($mjid2,jid3) $from
+ set state($mjid2,protocol,vcard) 1
+ set gotHash 1
+ }
+ return $gotHash
+}
+
+# jlib::avatar::get_async --
+#
+# The economical way of obtaining a users avatar.
+# If uptodate no query made, else it sends at most one query per user
+# to get the avatar.
+
+proc jlib::avatar::get_async {jlibname jid cmd} {
+ upvar ${jlibname}::avatar::state state
+
+ set mjid2 [jlib::jidmap [jlib::barejid $jid]]
+ if {[uptodate $jlibname $mjid2]} {
+ uplevel #0 $cmd [list result $mjid2]
+ } elseif {[info exists state($mjid2,pending)]} {
+ lappend state($mjid2,invoke) $cmd
+ } else {
+ send_get $jlibname $jid \
+ [list [namespace current]::get_async_cb $jlibname $mjid2 $cmd]
+ }
+}
+
+proc jlib::avatar::get_async_cb {jlibname jid2 cmd type subiq args} {
+ upvar ${jlibname}::avatar::state state
+
+ uplevel #0 $cmd [list $type $jid2]
+}
+
+# jlib::avatar::send_get --
+#
+# Initiates a request for avatar to the full jid.
+# If fails we try to get avatar from server storage of the bare jid.
+
+proc jlib::avatar::send_get {jlibname jid cmd} {
+ variable xmlns
+ upvar ${jlibname}::avatar::state state
+
+ debug "jlib::avatar::send_get jid=$jid"
+
+ set mjid2 [jlib::jidmap [jlib::barejid $jid]]
+ set state($mjid2,pending) 1
+ $jlibname iq_get $xmlns(iq-avatar) -to $jid \
+ -command [list [namespace current]::send_get_cb $jid $cmd]
+}
+
+proc jlib::avatar::send_get_cb {jid cmd jlibname type subiq args} {
+ variable xmlns
+ upvar ${jlibname}::avatar::state state
+
+ debug "jlib::avatar::send_get_cb jid=$jid"
+
+ set jid2 [jlib::barejid $jid]
+ set mjid2 [jlib::jidmap $jid2]
+ unset -nocomplain state($mjid2,pending)
+
+ if {$type eq "error"} {
+
+ # XEP-0008: "If the first method fails, the second method that should
+ # be attempted by sending a request to the server..."
+ send_get_storage $jlibname $mjid2 $cmd
+ } elseif {$type eq "result"} {
+ set ok [SetDataFromQueryElem $jlibname $mjid2 $subiq $xmlns(iq-avatar)]
+ InvokeStacked $jlibname $type $jid2
+ uplevel #0 $cmd [list $type $subiq] $args
+ }
+}
+
+# jlib::avatar::SetDataFromQueryElem --
+#
+# Extracts and sets internal avtar storage for the BARE jid
+# from a query element.
+#
+# Results:
+# 1 if there was data to store, 0 else.
+
+proc jlib::avatar::SetDataFromQueryElem {jlibname mjid2 queryElem ns} {
+ upvar ${jlibname}::avatar::state state
+
+ # Data may be empty from xmlns='storage:client:avatar' !
+
+ set ans 0
+ if {[wrapper::getattribute $queryElem xmlns] eq $ns} {
+ set dataElem [wrapper::getfirstchildwithtag $queryElem data]
+ if {$dataElem ne {}} {
+
+ # Mime type can be empty.
+ set state($mjid2,mime) [wrapper::getattribute $dataElem mimetype]
+
+ # We keep data in base64 format. This seems to be ok for image
+ # handlers.
+ set data [wrapper::getcdata $dataElem]
+ if {[string length $data]} {
+ set state($mjid2,data) $data
+ set state($mjid2,uptodate) 1
+ set ans 1
+ }
+ }
+ }
+ return $ans
+}
+
+proc jlib::avatar::send_get_storage {jlibname jid2 cmd} {
+ variable xmlns
+ upvar ${jlibname}::avatar::state state
+
+ debug "jlib::avatar::send_get_storage jid2=$jid2"
+
+ set mjid2 [jlib::jidmap $jid2]
+ set state($mjid2,pending) 1
+ $jlibname iq_get $xmlns(storage) -to $jid2 \
+ -command [list [namespace current]::send_get_storage_cb $jid2 $cmd]
+}
+
+proc jlib::avatar::send_get_storage_cb {jid2 cmd jlibname type subiq args} {
+ variable xmlns
+ upvar ${jlibname}::avatar::state state
+
+ debug "jlib::avatar::send_get_storage_cb type=$type"
+
+ set mjid2 [jlib::jidmap $jid2]
+ unset -nocomplain state($mjid2,pending)
+ if {$type eq "result"} {
+ set ok [SetDataFromQueryElem $jlibname $mjid2 $subiq $xmlns(storage)]
+ }
+ InvokeStacked $jlibname $type $jid2
+ uplevel #0 $cmd [list $type $subiq] $args
+}
+
+proc jlib::avatar::InvokeStacked {jlibname type jid2} {
+ upvar ${jlibname}::avatar::state state
+
+ set mjid2 [jlib::jidmap $jid2]
+ if {[info exists state($jid2,invoke)]} {
+ foreach cmd $state($jid2,invoke) {
+ uplevel #0 $cmd [list $type $jid2]
+ }
+ unset -nocomplain state($jid2,invoke)
+ }
+}
+
+#--- vCard support -------------------------------------------------------------
+
+proc jlib::avatar::get_vcard_async {jlibname jid2 cmd} {
+ upvar ${jlibname}::avatar::state state
+
+ debug "jlib::avatar::get_vcard_async jid=$jid2"
+
+ set mjid2 [jlib::jidmap $jid2]
+ if {[uptodate $jlibname $mjid2]} {
+ uplevel #0 $cmd [list result $jid2]
+ } else {
+
+ # Need to clear vcard cache to trigger sending a request.
+ # The photo is anyway not up-to-date.
+ $jlibname vcard clear $jid2
+ $jlibname vcard get_async $jid2 \
+ [list [namespace current]::get_vcard_async_cb $jid2 $cmd]
+ }
+}
+
+proc jlib::avatar::get_vcard_async_cb {jid2 cmd jlibname type subiq args} {
+
+ debug "jlib::avatar::get_vcard_async_cb jid=$jid2"
+
+ if {$type eq "result"} {
+ set mjid2 [jlib::jidmap $jid2]
+ SetDataFromVCardElem $jlibname $mjid2 $subiq
+ }
+ uplevel #0 $cmd [list $type $jid2]
+}
+
+# jlib::avatar::send_get_vcard --
+#
+# Support for vCard based avatars as XEP-0153.
+# We must get vcard avatars from here since the result shall be cached.
+# Note that all vCards are defined per jid2, bare JID.
+# This method is more sane compared to iq-based avatars since it is
+# based on bare jids and thus not client instance specific.
+# Therefore it also handles offline users.
+
+proc jlib::avatar::send_get_vcard {jlibname jid2 cmd} {
+
+ debug "jlib::avatar::send_get_vcard jid2=$jid2"
+
+ $jlibname vcard send_get $jid2 \
+ -command [list [namespace current]::send_get_vcard_cb $jid2 $cmd]
+}
+
+proc jlib::avatar::send_get_vcard_cb {jid2 cmd jlibname type subiq args} {
+
+ debug "jlib::avatar::send_get_vcard_cb"
+
+ if { $type eq "result" } {
+ set mjid2 [jlib::jidmap $jid2]
+ SetDataFromVCardElem $jlibname $mjid2 $subiq
+ uplevel #0 $cmd [list $type $subiq] $args
+ }
+}
+
+# jlib::avatar::SetDataFromVCardElem --
+#
+# Extracts and sets internal avtar storage for the BARE jid
+# from a vcard element.
+#
+# Results:
+# 1 if there was data to store, 0 else.
+
+proc jlib::avatar::SetDataFromVCardElem {jlibname mjid2 subiq} {
+ upvar ${jlibname}::avatar::state state
+
+ set ans 0
+ set photoElem [wrapper::getfirstchildwithtag $subiq PHOTO]
+ if {$photoElem ne {}} {
+ set dataElem [wrapper::getfirstchildwithtag $photoElem BINVAL]
+ set mimeElem [wrapper::getfirstchildwithtag $photoElem TYPE]
+ if {$dataElem ne {}} {
+
+ # We keep data in base64 format. This seems to be ok for image
+ # handlers.
+ set state($mjid2,data) [wrapper::getcdata $dataElem]
+ set state($mjid2,mime) [wrapper::getcdata $mimeElem]
+ set state($mjid2,uptodate) 1
+ set ans 1
+ }
+ }
+ return $ans
+}
+
+proc jlib::avatar::debug {msg} {
+ if {0} {
+ puts "\t $msg"
+ }
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::avatar {
+
+ jlib::ensamble_register avatar \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+if {0} {
+ # Test.
+ set f "/Users/matben/Desktop/glaze/32x32/apps/clanbomber.png"
+ set fd [open $f]
+ fconfigure $fd -translation binary
+ set data [read $fd]
+ close $fd
+
+ set data "0123456789"
+
+ set jlib jlib::jlib1
+ proc cb {args} {puts "--- cb"}
+ $jlib avatar set_data $data image/png
+ $jlib avatar store cb
+ $jlib avatar send_get [$jlib getthis myjid] cb
+ $jlib avatar send_get_storage [$jlib getthis myjid2] cb
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# bind.tcl --
+#
+# This file is part of the jabberlib.
+# It implements the bind resource mechanism and establish a session.
+#
+# Copyright (c) 2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: bind.tcl,v 1.1 2007/07/23 15:11:43 matben Exp $
+
+package require jlib
+
+package provide jlib::bind 0.1
+
+namespace eval jlib::bind {}
+
+proc jlib::bind::resource {jlibname resource cmd} {
+ upvar ${jlibname}::state state
+
+ set state(resource) $resource
+ set state(cmd) $cmd
+
+ if {[$jlibname have_feature bind]} {
+ $jlibname bind_resource $state(resource) [namespace code resource_bind_cb]
+ } else {
+ $jlibname trace_stream_features [namespace code features]
+ }
+}
+
+proc jlib::bind::features {jlibname} {
+ upvar ${jlibname}::state state
+
+ if {[$jlibname have_feature bind]} {
+ $jlibname bind_resource $state(resource) [namespace code resource_bind_cb]
+ } else {
+ establish_session $jlibname
+ }
+}
+
+proc jlib::bind::resource_bind_cb {jlibname type subiq} {
+
+ if {$type eq "error"} {
+ final $jlibname error $subiq
+ } else {
+ establish_session $jlibname
+ }
+}
+
+proc jlib::bind::establish_session {jlibname} {
+ upvar jlib::xmppxmlns xmppxmlns
+
+ # Establish the session.
+ set xmllist [wrapper::createtag session \
+ -attrlist [list xmlns $xmppxmlns(session)]]
+ $jlibname send_iq set [list $xmllist] \
+ -command [namespace code [list send_session_cb $jlibname]]
+}
+
+proc jlib::bind::send_session_cb {jlibname type subiq args} {
+ final $jlibname $type $subiq
+}
+
+proc jlib::bind::final {jlibname type subiq} {
+ upvar ${jlibname}::state state
+
+ uplevel #0 $state(cmd) [list $jlibname $type $subiq]
+ unset -nocomplain state
+}
+
+
+
--- /dev/null
+# bytestreams.tcl --
+#
+# This file is part of the jabberlib.
+# It provides support for the bytestreams protocol (XEP-0065).
+#
+# Copyright (c) 2005-2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: bytestreams.tcl,v 1.33 2007/11/30 14:38:34 matben Exp $
+#
+############################# USAGE ############################################
+#
+# NAME
+# bytestreams - implements the socks5 bytestream stream protocol.
+#
+# SYNOPSIS
+#
+#
+# OPTIONS
+#
+#
+# INSTANCE COMMANDS
+#
+# jlibName bytestream configure ?-address -port -timeout ms -proxyhost?
+# jlibName bytestream send_initiate to sid cmd ?-streamhosts -fastmode?
+#
+#
+############################# CHANGES ##########################################
+#
+# 0.1 first version
+# 0.2 timeouts + fast mode
+# 0.3 connector object
+# 0.4 proxy support
+#
+# FAST MODE:
+# Some details:
+# "This is done by sending an additional [CR] character across the
+# bytestream to indicate its selection."
+# The character is sent after socks5 authorization, and even after
+# iq-streamhost-used, since the initiator must pick only a working stream.
+# If the desired stream is offered by the initiator, it would send the
+# character only after receiving iq-streamhost-used from the target.
+# If the desired stream is offered by the target, then the initiator
+# would send the character after it sends iq-streamhost-used to the target.
+#
+# When do we know to use the fast mode protocol?
+# (initiator): received streamhost with sid we have initiated
+# (target): receiving streamhost+fast and sent streamhost
+#
+# initiator target
+# --------- ------
+#
+# streamhosts + fast
+# --------------------------->
+#
+# streamhosts (fastmode)
+# <---------------------------
+#
+# connector (s5)
+# <---------------------------
+#
+# connector (s5) (fastmode)
+# --------------------------->
+#
+# streamhost-used
+# sock <---------------------------
+#
+# streamhost-used (fastmode)
+# sock_fast --------------------------->
+#
+# Initiator picks one of 0-2 sockets and fastmode sends a CR.
+#
+# HASH:
+# SHA1(SID + Initiator JID + Target JID)
+# The JIDs provided MUST be the JIDs used for the IQ exchange;
+# furthermore, in order to ensure proper results, the appropriate
+# stringprep profiles.
+#
+# INITIATOR FLOW:
+# There are two different flows:
+# (1) iq query/response
+# (2) socks5 connections and negotiations, denoted s5 here
+# They interact and depend on each other. (f) means fast mode only.
+# As seen from the initiator:
+#
+# (a) iq-stream initiate (send)
+# (f) (b) iq-stream target provides streamhosts to initiator (recv)
+# (1) s5 socket to initiators server
+# (f) (2) s5 fast socket to targets streamhost
+# (3) s5 socket initiator to proxy
+#
+# iq-stream (a) controls (1) and (3)
+# iq-stream (b) controls (2)
+#
+# There are three possible s5 streams:
+#
+# (A) s5 (server) initiator <--- s5 (client) target
+# (f) (B) s5 (client) initiator ---> s5 (server) target
+# (C) s5 (client) initiator ---> s5 (server) proxy
+#
+# The first succesful stream wins and kills the other.
+#
+# TARGET:
+# The target handles the (intiators) proxy like any other streamhost
+# and proxies are therefore transparent to the target.
+#
+#
+# NOTES:
+# o If yoy are trying to follow this code, focus on one side alone,
+# initiator or target, else you are likely to get insane.
+
+package require sha1
+package require jlib
+package require jlib::disco
+package require jlib::si
+
+package provide jlib::bytestreams 0.4
+
+#--- generic bytestreams -------------------------------------------------------
+
+namespace eval jlib::bytestreams {
+
+ variable xmlns
+ set xmlns(bs) "http://jabber.org/protocol/bytestreams"
+ set xmlns(fast) "http://affinix.com/jabber/stream"
+
+ jlib::si::registertransport $xmlns(bs) $xmlns(bs) 40 \
+ [namespace current]::si_open \
+ [namespace current]::si_close
+
+ jlib::disco::registerfeature $xmlns(bs)
+
+ # Support for http://affinix.com/jabber/stream.
+ variable fastmode 1
+
+ # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::bytestreams::init --
+#
+# Instance init procedure.
+
+proc jlib::bytestreams::init {jlibname args} {
+ variable xmlns
+
+ # Keep different state arrays for initiator (i) and receiver (t).
+ namespace eval ${jlibname}::bytestreams {
+ variable istate
+ variable tstate
+
+ # Mapper from SOCKS5 hash to sid.
+ variable hash2sid
+
+ # Independent of sid variables.
+ variable static
+
+ # Server port 0 says that arbitrary port can be chosen.
+ set static(-address) ""
+ set static(-block-size) 4096
+ set static(-port) 0
+ set static(-s5timeoutms) 8000 ;# TODO
+ set static(-timeoutms) 30000
+ set static(-proxyhost) [list]
+ set static(-targetproxy) 0 ;# Not implemented
+ }
+
+ # Register standard iq handler that is handled internally.
+ $jlibname iq_register set $xmlns(bs) [namespace current]::handle_set
+ eval {configure $jlibname} $args
+
+ return
+}
+
+proc jlib::bytestreams::cmdproc {jlibname cmd args} {
+
+ # Which command? Just dispatch the command to the right procedure.
+ return [eval {$cmd $jlibname} $args]
+}
+
+proc jlib::bytestreams::configure {jlibname args} {
+
+ upvar ${jlibname}::bytestreams::static static
+
+ if {![llength $args]} {
+ return [array get static -*]
+ } else {
+ foreach {key value} $args {
+
+ switch -- $key {
+ -address {
+ set static($key) $value
+ }
+ -port - -timeoutms {
+ if {![string is integer -strict $value]} {
+ return -code error "$key must be integer number"
+ }
+ set static($key) $value
+ }
+ -proxyhost {
+ if {[llength $value]} {
+ if {[llength $value] != 3} {
+ return -code error "$key must be a list {jid ip port}"
+ }
+ if {![string is integer -strict [lindex $value 2]]} {
+ return -code error "port must be an integer number"
+ }
+ }
+ set static($key) $value
+ }
+ -targetproxy {
+ if {![string is boolean -strict $value]} {
+ return -code error "$key must be integer number"
+ }
+ set static($key) $value
+ }
+ default {
+ return -code error "unknown option \"$key\""
+ }
+ }
+ }
+ }
+ return
+}
+
+# Common code for both initiator and target.
+
+# jlib::bytestreams::i_or_t --
+#
+# In some situations we must know if we are the initiator or target
+# using just the sid.
+
+proc jlib::bytestreams::i_or_t {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ upvar ${jlibname}::bytestreams::tstate tstate
+ debug "jlib::bytestreams::i_or_t"
+
+ if {[info exists istate($sid,state)]} {
+ return "i"
+ } elseif {[info exists tstate($sid,state)]} {
+ return "t"
+ } else {
+ return ""
+ }
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a initiator (sender).
+
+# si_open, si_close --
+#
+# Bindings for si.
+
+# jlib::bytestreams::si_open --
+#
+# Constructor for an initiator object.
+
+proc jlib::bytestreams::si_open {jlibname jid sid args} {
+
+ variable fastmode
+ upvar ${jlibname}::bytestreams::istate istate
+ upvar ${jlibname}::bytestreams::static static
+ upvar ${jlibname}::bytestreams::hash2sid hash2sid
+ debug "jlib::bytestreams::si_open (i)"
+
+ set jid [jlib::jidmap $jid]
+ set istate($sid,jid) $jid
+
+ if {![info exists static(sock)]} {
+
+ # Protect against server failure.
+ if {[catch {s5i_server $jlibname}]} {
+ si_open_report $jlibname $sid error \
+ {error "Failed starting our streamhost"}
+ return
+ }
+ }
+
+ # Provide our streamhosts.
+ # First, the local one.
+ if {$static(-address) ne ""} {
+ set ip $static(-address)
+ } else {
+ set ip [jlib::getip $jlibname]
+ }
+ set myjid [jlib::myjid $jlibname]
+ set hash [::sha1::sha1 $sid$myjid$jid]
+
+ set istate($sid,ip) $ip
+ set istate($sid,state) open
+ set istate($sid,fast) 0
+ set istate($sid,hash) $hash
+ set istate($sid,used-proxy) 0 ;# Set if target picks our proxy host
+ set istate($sid,proxy,state) ""
+
+ set hash2sid($hash) $sid
+ set host [list $myjid -host $ip -port $static(port)]
+ set streamhosts [list $host]
+ set opts [list]
+ lappend opts -fastmode $fastmode
+
+ # Second, the proxy host if any.
+ if {[llength $static(-proxyhost)]} {
+ lassign $static(-proxyhost) pjid pip pport
+ set proxyhost [list $pjid -host $pip -port $pport]
+ lappend streamhosts $proxyhost
+ lappend opts -proxyjid $pjid
+ }
+ lappend opts -streamhosts $streamhosts
+
+ # Schedule a timeout until we get a streamhost-used returned.
+ set istate($sid,timeoutid) [after $static(-timeoutms) \
+ [list [namespace current]::si_timeout_cb $jlibname $sid]]
+
+ # Initiate the stream to the target.
+ set si_open_cb [list [namespace current]::si_open_cb $jlibname $sid]
+ eval {send_initiate $jlibname $jid $sid $si_open_cb} $opts
+
+ return
+}
+
+proc jlib::bytestreams::si_timeout_cb {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::si_timeout_cb (i)"
+
+ si_open_report $jlibname $sid "error" {timeout "Timeout"}
+ ifinish $jlibname $sid
+}
+
+# jlib::bytestreams::si_open_cb --
+#
+# This is the iq-response we get as an initiator when sent our streamhosts
+# to the target. We expect that it either returns a 'streamhost-used'
+# or an error.
+# We shall not return any iq as a response to this response.
+#
+# The target either returns an error if it failed to connect any
+# streamhost, else it replies eith a 'streamhost-used' element.
+#
+# This is the main event handler for the initiator where it manages
+# both open iq-streams as well as all sockets.
+#
+# See also 'i_connect_cb' for the fastmode side.
+
+proc jlib::bytestreams::si_open_cb {jlibname sid type subiq args} {
+
+ variable xmlns
+ upvar ${jlibname}::bytestreams::istate istate
+ upvar ${jlibname}::bytestreams::static static
+ debug "jlib::bytestreams::si_open_cb (i) type=$type"
+
+ # In fast mode we may get this callback after we have finished.
+ # Or after a timeout or something.
+ if {![info exists istate($sid,state)]} {
+ return
+ }
+
+ # 'result' is normally the iq type but we add more error checking.
+ # Try to catch possible error situations.
+ set result $type
+ set istate($sid,type) $type
+ set istate($sid,subiq) $subiq
+
+ # Collect streamhost used. If this fails we need to catch it below.
+ if {$type eq "result"} {
+ if {[wrapper::gettag $subiq] eq "query" \
+ && [wrapper::getattribute $subiq xmlns] eq $xmlns(bs)} {
+ set usedE [wrapper::getfirstchildwithtag $subiq "streamhost-used"]
+ if {[llength $usedE]} {
+ set jidused [wrapper::getattribute $usedE "jid"]
+ set istate($sid,streamhost-used) $jidused
+
+ # Need to know if target picked our proxy streamhost.
+ set jidproxy [lindex $static(-proxyhost) 0]
+ if {[jlib::jidequal $jidused $jidproxy]} {
+ set istate($sid,used-proxy) 1
+ }
+ }
+ }
+ }
+ debug "\t used-proxy=$istate($sid,used-proxy)"
+
+ # Must end the normal path if the target sent us weird response.
+ if {![info exists istate($sid,streamhost-used)]} {
+ set istate($sid,state) error
+ set istate($sid,subiq) {error "missing streamhost-used"}
+ }
+ if {$result eq "error"} {
+ set istate($sid,state) error
+ }
+
+ # NB1: We may already have picked fast mode and istate($sid,state) = error
+ # Even if the normal path succeded!
+ # NB2: We can never pick fast mode from this proc!
+
+ # Fastmode only:
+ if {$istate($sid,fast)} {
+ if {$istate($sid,state) eq "error"} {
+ ifast_error_normal $jlibname $sid
+ } else {
+ if {$istate($sid,used-proxy)} {
+
+ # Now its time to start up and activate our proxy host.
+ iproxy_connect $jlibname $sid
+ } else {
+ ifast_select_normal $jlibname $sid
+ ifast_end_fast $jlibname $sid
+ }
+ }
+ } else {
+
+ # Normal non-fastmode execution path.
+ if {$result eq "error"} {
+ if {[info exists istate($sid,sock)]} {
+ debug_sock "close $istate($sid,sock)"
+ catch {close $istate($sid,sock)}
+ unset istate($sid,sock)
+ }
+ si_open_report $jlibname $sid $type $istate($sid,subiq)
+ } else {
+
+ if {$istate($sid,used-proxy)} {
+
+ # Now its time to start up and activate our proxy host.
+ iproxy_connect $jlibname $sid
+ } else {
+
+ # One last check that we actually got a socket connection.
+ # Try to catch possible error situations.
+ if {![info exists istate($sid,sock)]} {
+ set istate($sid,state) error
+ si_open_report $jlibname $sid error {error "Network Error"}
+ } else {
+
+ # Everything is fine.
+ set istate($sid,state) streamhost-used
+ set istate($sid,active,sock) $istate($sid,sock)
+ si_open_report $jlibname $sid $type $subiq
+ }
+ }
+ }
+ }
+}
+
+# jlib::bytestreams::ifast_* --
+#
+# A number of methods to handle execution paths for the fast mode.
+# They are normally called for iq-responses, but for the proxy they are
+# called after activate response.
+# Selects the first succesful stream and kills the others.
+# If all streams have failed we report the error to si.
+#
+# NB1: ifast_* means that we are in fast mode; the suffix normally
+# indicates which stream we are dealing with.
+# NB2: we do not send any iq response here, which should only be done when
+# calling 'ifast_select_fast'.
+
+proc jlib::bytestreams::ifast_error_normal {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::ifast_error_normal (i)"
+
+ # The target failed the 'normal' s5 connection.
+ # Be sure to close normal and proxy sockets, (1) and (3) above.
+ set istate($sid,state) error
+ if {[info exists istate($sid,sock)]} {
+ debug_sock "close $istate($sid,sock)"
+ catch {close $istate($sid,sock)}
+ unset istate($sid,sock)
+ }
+ if {$istate($sid,used-proxy)} {
+ connector_reset $jlibname $sid p
+ if {[info exists istate($sid,proxy,sock)]} {
+ debug_sock "close $istate($sid,proxy,sock)"
+ catch {close $istate($sid,proxy,sock)}
+ unset istate($sid,proxy,sock)
+ }
+ }
+
+ # If also the 'fast' way failed we are done.
+ if {$istate($sid,fast,state) eq "error"} {
+ si_open_report $jlibname $sid error $istate($sid,subiq)
+ }
+
+ # At this stage we may already have activated the fast stream.
+}
+
+proc jlib::bytestreams::ifast_select_normal {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::ifast_select_normal (i)"
+
+ # Activate the 'normal' stream:
+ # Protect us from failed socks5 connections.
+ # This can be our own streamhost or the proxy host. Handle both here!
+ # Normally the target picks the one it wants.
+
+ debug "\t used-proxy=$istate($sid,used-proxy), proxy,state=$istate($sid,proxy,state)"
+ set have_s5 0
+ if {$istate($sid,used-proxy) && $istate($sid,proxy,state) eq "result"} {
+ set sock $istate($sid,proxy,sock)
+ set have_s5 1
+ } elseif {[info exists istate($sid,sock)]} {
+ set sock $istate($sid,sock)
+ set have_s5 1
+ }
+ if {$have_s5} {
+ set istate($sid,state) activated
+ debug "\t select normal, send CR"
+ if {[catch {
+ puts -nonewline $sock "\r"
+ flush $sock
+ }]} {
+ set have_s5 0
+ }
+ }
+ if {$have_s5} {
+ set istate($sid,active,sock) $sock
+ si_open_report $jlibname $sid result $istate($sid,subiq)
+ } else {
+ debug "\t error missing s5 stream or failed send CR"
+ set istate($sid,state) error
+ si_open_report $jlibname $sid error {error "Network Error"}
+ }
+}
+
+proc jlib::bytestreams::ifast_end_fast {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::ifast_end_fast (i)"
+
+ # Put an end to any 'fast' stream. Both socket and iq-stream.
+ set istate($sid,fast,state) error
+ connector_reset $jlibname $sid f
+ if {[info exists istate($sid,fast,sock)]} {
+ debug_sock "close $istate($sid,fast,sock)"
+ catch {close $istate($sid,fast,sock)}
+ unset istate($sid,fast,sock)
+ }
+
+ # This just informs the target that our 'fast' stream is shut down.
+ if {[info exists istate($sid,fast,id)]} {
+ isend_error $jlibname $sid 404 cancel item-not-found
+ }
+}
+
+proc jlib::bytestreams::ifast_select_fast {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::ifast_select_fast (i)"
+
+
+ # Activate the fast stream. Set normal stream to error so we wont use it.
+ debug "\t select fast, send CR"
+ set sock $istate($sid,fast,sock)
+ set istate($sid,active,sock) $sock
+ set istate($sid,fast,state) activated
+ if {[catch {
+ puts -nonewline $sock "\r"
+ flush $sock
+ }]} {
+ debug "\t failed sending CR"
+ si_open_report $jlibname $sid error {error "Network Failure"}
+ } else {
+
+ # Shut down the 'normal' stream:
+ # Must close down any connections to our own streamhost.
+ set istate($sid,state) error
+ if {[info exists istate($sid,sock)]} {
+ debug_sock "close $istate($sid,sock)"
+ catch {close $istate($sid,sock)}
+ unset istate($sid,sock)
+ }
+ si_open_report $jlibname $sid result {ok OK}
+ }
+}
+
+#...............................................................................
+
+# jlib::bytestreams::si_open_report --
+#
+# This prepares the callback to 'si' as a response to 'si_open.
+
+proc jlib::bytestreams::si_open_report {jlibname sid type subiq} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ upvar ${jlibname}::bytestreams::static static
+ debug "jlib::bytestreams::si_open_report (i)"
+
+ if {[info exists istate($sid,timeoutid)]} {
+ after cancel $istate($sid,timeoutid)
+ unset istate($sid,timeoutid)
+ }
+ jlib::si::transport_open_cb $jlibname $sid $type $subiq
+
+ # If all went well this far we initiate the read/write data process.
+ if {$type eq "result"} {
+
+ # Tell the profile to prepare to read data (open file).
+ jlib::si::open_data $jlibname $sid
+
+ # Initiate the transport when socket is ready for writing.
+ set sock $istate($sid,active,sock)
+ setwritable $jlibname $sid $sock
+ }
+}
+
+# jlib::bytestreams::si_read --
+#
+# Read data from the profile via 'si' using its registered reader.
+
+proc jlib::bytestreams::si_read {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::si_read (i)"
+
+ # NB: This should be safe to do since if we have been reset also
+ # the fileevent handler is removed when socket is closed.
+ set s $istate($sid,active,sock)
+
+ fileevent $s writable {}
+ if {[catch {eof $s} iseof] || $iseof} {
+ jlib::si::close_data $jlibname $sid error
+ return
+ }
+ set data [jlib::si::read_data $jlibname $sid]
+ set len [string length $data]
+
+ if {$len > 0} {
+ if {[catch {puts -nonewline $s $data}]} {
+ debug "\t failed"
+ jlib::si::close_data $jlibname $sid error
+ return
+ }
+
+ # Trick to avoid UI blocking.
+ after idle [list after 0 [list \
+ [namespace current]::setwritable $jlibname $sid $s]]
+ } else {
+
+ # Empty data from the reader means that we are done.
+ jlib::si::close_data $jlibname $sid
+ }
+}
+
+proc jlib::bytestreams::setwritable {jlibname sid sock} {
+
+ # We could have been closed since this event comes async.
+ if {[lsearch [file channels] $sock] >= 0} {
+ fileevent $sock writable \
+ [list [namespace current]::si_read $jlibname $sid]
+ }
+}
+
+# jlib::bytestreams::si_close --
+#
+# Destroys an initiator object.
+
+proc jlib::bytestreams::si_close {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::si_close (i)"
+
+ # We don't have any particular to do here as 'ibb' has.
+ jlib::si::transport_close_cb $jlibname $sid result {}
+ ifinish $jlibname $sid
+}
+
+proc jlib::bytestreams::is_initiator {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::is_initiator [info exists istate($sid,state)]"
+
+ return [info exists istate($sid,state)]
+}
+
+#--- Generic initiator code ----------------------------------------------------
+
+# jlib::bytestreams::send_initiate --
+#
+# -streamhosts {{jid (-host -port | -zeroconf)} {...} ...}
+# -fastmode
+#
+# Stateless code that never access the istate array.
+
+proc jlib::bytestreams::send_initiate {jlibname to sid cmd args} {
+ variable xmlns
+ debug "jlib::bytestreams::initiate"
+
+ set attrlist [list xmlns $xmlns(bs) sid $sid mode tcp]
+ set sublist [list]
+ set opts [list]
+ set proxyjid ""
+ foreach {key value} $args {
+
+ switch -- $key {
+ -streamhosts {
+ set streamhosts $value
+ }
+ -fastmode {
+ if {$value} {
+
+ # <fast xmlns="http://affinix.com/jabber/stream"/>
+ lappend sublist [wrapper::createtag "fast" \
+ -attrlist [list xmlns $xmlns(fast)]]
+ }
+ }
+ -proxyjid {
+ # Mark proxy: <proxy xmlns="http://affinix.com/jabber/stream"/>
+ set proxyjid $value
+ }
+ default {
+ return -code error "unknown option \"$key\""
+ }
+ }
+ }
+
+ # Need to do it here in order to handle any proxy element.
+ if {[info exists streamhosts]} {
+ foreach hostspec $streamhosts {
+ set jid [lindex $hostspec 0]
+ set hostattr [list jid $jid]
+ foreach {hkey hvalue} [lrange $hostspec 1 end] {
+ lappend hostattr [string trimleft $hkey -] $hvalue
+ }
+ set ssub [list]
+ if {[jlib::jidequal $proxyjid $jid]} {
+ set ssub [list [wrapper::createtag proxy \
+ -attrlist [list xmlns $xmlns(fast)]]]
+ }
+ lappend sublist [wrapper::createtag "streamhost" \
+ -attrlist $hostattr -subtags $ssub]
+ }
+ }
+
+ set xmllist [wrapper::createtag "query" \
+ -attrlist $attrlist -subtags $sublist]
+ eval {$jlibname send_iq "set" [list $xmllist] -to $to -command $cmd} $opts
+ return
+}
+
+proc jlib::bytestreams::get_proxy {jlibname to cmd} {
+ variable xmlns
+ debug "jlib::bytestreams::get_proxy (i)"
+
+ $jlibname iq_get $xmlns(bs) -to $to -command $cmd
+}
+
+# jlib::bytestreams::activate --
+#
+# Initiator requests activation of bytestream.
+# This is only necessary for proxy streamhosts.
+
+proc jlib::bytestreams::activate {jlibname sid to targetjid args} {
+ variable xmlns
+ debug "jlib::bytestreams::activate (i)"
+
+ set opts [list]
+ foreach {key value} $args {
+ switch -- $key {
+ -command {
+ set opts [list -command $value]
+ }
+ default {
+ return -code error "unknown option \"$key\""
+ }
+ }
+ }
+ set activateE [wrapper::createtag "activate" -chdata $targetjid]
+ set xmllist [wrapper::createtag "query" \
+ -attrlist [list xmlns $xmlns(bs) sid $sid] \
+ -subtags [list $activateE]]
+
+ eval {$jlibname send_iq "set" [list $xmllist] -to $to} $opts
+}
+
+#--- Fastmode: handle targets streamhosts --------------------------------------
+
+# jlib::bytestreams::i_handle_set --
+#
+# This is the initiators handler when provided streamhosts by the
+# target which only happens in fastmode.
+# Fastmode only!
+
+proc jlib::bytestreams::i_handle_set {jlibname sid id jid hosts queryE} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::i_handle_set (i)"
+
+ # We have already initiated this sid and must have fastmode.
+ # At this stage we run in the fast mode!
+ set istate($sid,fast) 1
+ set istate($sid,fast,id) $id
+ set istate($sid,fast,jid) $jid
+ set istate($sid,fast,state) inited
+ set istate($sid,fast,hosts) $hosts
+ set istate($sid,fast,queryE) $queryE
+
+ set myjid [$jlibname myjid]
+ set hash [::sha1::sha1 $sid$jid$myjid]
+
+ # Try connecting the host(s) in turn.
+ set cb [list [namespace current]::i_connect_cb $jlibname $sid]
+ connector $jlibname $sid f $hash $hosts $cb
+}
+
+# jlib::bytestreams::i_connect_cb --
+#
+# The 'connector' callback when tried to connect to the targets streamhosts.
+# We shall return an iq response to the targets iq streamhost offer.
+# Fastmode only!
+
+proc jlib::bytestreams::i_connect_cb {jlibname sid result args} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::i_connect_cb $result (i)"
+
+ array set argsA $args
+
+ if {$result eq "error"} {
+ set istate($sid,fast,state) error
+
+ # Deliver error to target.
+ isend_error $jlibname $sid 404 cancel item-not-found
+
+ # In fastmode we are not done until the target also fails connecting.
+ if {!$istate($sid,fast) || ($istate($sid,state) eq "error")} {
+
+ # Deliver error to target profile.
+ si_open_report $jlibname $sid error {error "Network Failure"}
+ }
+ } elseif {$istate($sid,fast,state) ne "error"} {
+
+ # Must be sure that the normal stream hasn't already put a stop at fast.
+ # Shouldn't be needed since it should do connector_reset.
+ set sock $argsA(-socket)
+ set host $argsA(-streamhost)
+ set hostjid [lindex $host 0]
+
+ # Deliver 'streamhost-used' to the target.
+ set id $istate($sid,fast,id)
+ set jid $istate($sid,fast,jid)
+ send_used $jlibname $jid $id $hostjid
+
+ set istate($sid,fast,sock) $sock
+ set istate($sid,fast,host) $host
+ set istate($sid,fast,hostjid) $hostjid
+
+ ifast_select_fast $jlibname $sid
+ }
+}
+
+# Proxy handling ---------------------------------------------------------------
+
+# This is done as a response that the target has selected the proxy streamhost.
+# There are two steps here:
+# 1) initiator make a complete socks5 connection to the proxy
+# 2) the stream is activated by the initiator
+
+proc jlib::bytestreams::iproxy_connect {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ upvar ${jlibname}::bytestreams::static static
+ debug "jlib::bytestreams::iproxy_connect (i)"
+
+ set istate($sid,state) connecting
+ set myjid [$jlibname myjid]
+ set jid $istate($sid,jid)
+ set hash [::sha1::sha1 $sid$myjid$jid]
+ set hosts [list $static(-proxyhost)]
+
+ set cb [list [namespace current]::iproxy_s5_cb $jlibname $sid]
+ connector $jlibname $sid p $hash $hosts $cb
+}
+
+proc jlib::bytestreams::iproxy_s5_cb {jlibname sid result args} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ upvar ${jlibname}::bytestreams::static static
+ debug "jlib::bytestreams::iproxy_s5_cb (i) $result $args"
+
+ array set argsA $args
+
+ if {$result eq "error"} {
+ if {$istate($sid,fast)} {
+ ifast_error_normal $jlibname $sid
+ } else {
+
+ # If not fastmode we are finito.
+ set istate($sid,state) error
+ if {[info exists istate($sid,sock)]} {
+ debug_sock "close $istate($sid,sock)"
+ catch {close $istate($sid,sock)}
+ unset istate($sid,sock)
+ }
+ si_open_report $jlibname $sid error {error "Network Error"}
+ }
+ } else {
+
+ # Allright so far, cache socket.
+ # Note that we need a specific variable for this since the target can
+ # connect our server: istate($sid,sock).
+ set istate($sid,proxy,sock) $argsA(-socket)
+ set proxyjid [lindex $static(-proxyhost) 0]
+ set jid $istate($sid,jid)
+ set cb [list [namespace current]::iproxy_activate_cb $jlibname $sid]
+ activate $jlibname $sid $proxyjid $jid -command $cb
+ }
+}
+
+proc jlib::bytestreams::iproxy_activate_cb {jlibname sid type subiq args} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::iproxy_activate_cb (i) type=$type"
+
+ set istate($sid,proxy,state) $type
+ set istate($sid,type) $type
+ set istate($sid,subiq) $subiq
+
+ if {$istate($sid,fast)} {
+
+ # When we get this response the fast mode may already have succeded.
+ if {$istate($sid,state) eq "error"} {
+ ifast_error_normal $jlibname $sid
+ } else {
+ ifast_select_normal $jlibname $sid
+ ifast_end_fast $jlibname $sid
+ }
+ } else {
+ if {$type eq "error"} {
+
+ # If not fastmode we are finito.
+ set istate($sid,state) error
+ } else {
+
+ # Everything is fine.
+ set istate($sid,state) streamhost-used
+ set istate($sid,active,sock) $istate($sid,proxy,sock)
+ }
+ si_open_report $jlibname $sid $type $subiq
+ }
+}
+
+# Server side socks5 functions -------------------------------------------------
+#
+# Normally used by the initiator except in fastmode where it is also used by
+# the target.
+# This is stateless code that never directly access the istate array.
+# Think of it like an object:
+# [in]: sock, addr, port
+# [out]: sid, sock
+#
+# NB: We don't return any errors on the server side; this is up to the client.
+
+# jlib::bytestreams::s5i_server --
+#
+# Start socks5 server. We use the server for the streams and keep it
+# running for the lifetime of the application.
+
+proc jlib::bytestreams::s5i_server {jlibname} {
+
+ upvar ${jlibname}::bytestreams::static static
+ debug "jlib::bytestreams::s5i_server (i)"
+
+ # Note the difference between static(-port) and static(port) !
+ set connectProc [list [namespace current]::s5i_accept $jlibname]
+ set sock [socket -server $connectProc $static(-port)]
+ set static(sock) $sock
+ set static(port) [lindex [fconfigure $sock -sockname] 2]
+
+ # Test fast mode or proxy host...
+ #close $sock
+ return $static(port)
+}
+
+# jlib::bytestreams::s5i_accept --
+#
+# The server socket callback when connected.
+# We keep a single server socket for all transfers and distinguish
+# them when they do the SOCKS5 authentication using the mapping
+# hash (sha1 sid+jid+myjid) -> sid
+
+proc jlib::bytestreams::s5i_accept {jlibname sock addr port} {
+
+ debug "jlib::bytestreams::s5i_accept (i)"
+ debug_sock "open $sock"
+
+ fconfigure $sock -translation binary -blocking 0
+ fileevent $sock readable \
+ [list [namespace current]::s5i_read_methods $jlibname $sock]
+}
+
+proc jlib::bytestreams::s5i_read_methods {jlibname sock} {
+
+ debug "jlib::bytestreams::s5i_read_methods (i)"
+ # For testing...
+ #after 50
+
+ fileevent $sock readable {}
+ if {[catch {read $sock} data] || [eof $sock]} {
+ debug_sock "close $sock"
+ catch {close $sock}
+ return
+ }
+ debug "\t read [string length $data]"
+
+ # Pick method. Must be \x00
+ binary scan $data ccc* ver nmethods methods
+ if {($ver != 5) || ([lsearch -exact $methods 0] < 0)} {
+ catch {
+ debug_sock "close $sock"
+ puts -nonewline $sock "\x05\xff"
+ close $sock
+ }
+ return
+ }
+ if {[catch {
+ puts -nonewline $sock "\x05\x00"
+ flush $sock
+ debug "\t wrote 2: 'x05x00'"
+ }]} {
+ return
+ }
+ fileevent $sock readable \
+ [list [namespace current]::s5i_read_auth $jlibname $sock]
+}
+
+proc jlib::bytestreams::s5i_read_auth {jlibname sock} {
+
+ upvar ${jlibname}::bytestreams::hash2sid hash2sid
+ debug "jlib::bytestreams::s5i_read_auth (i)"
+
+ fileevent $sock readable {}
+ if {[catch {read $sock} data] || [eof $sock]} {
+ debug_sock "close $sock"
+ catch {close $sock}
+ return
+ }
+ debug "\t read [string length $data]"
+
+ binary scan $data ccccc ver cmd rsv atyp len
+ if {$ver != 5 || $cmd != 1 || $atyp != 3} {
+ set reply [string replace $data 1 1 \x07]
+ catch {
+ debug_sock "close $sock"
+ puts -nonewline $sock $reply
+ close $sock
+ }
+ return
+ }
+
+ binary scan $data @5a${len} hash
+
+ # At this stage we are in a position to find the sid.
+ if {[info exists hash2sid($hash)]} {
+ set sid $hash2sid($hash)
+
+ # This is the way the initiator knows the socket.
+ s5i_register_socket $jlibname $sid $sock
+
+ set reply [string replace $data 1 1 \x00]
+ catch {
+ puts -nonewline $sock $reply
+ flush $sock
+ }
+ debug "\t wrote [string length $reply]"
+ } else {
+ debug "\t missing sid"
+ set reply [string replace $data 1 1 \x02]
+ catch {
+ debug_sock "close $sock"
+ puts -nonewline $sock $reply
+ close $sock
+ }
+ return
+ }
+}
+
+# jlib::bytestreams::s5i_register_socket --
+#
+# This is a callback when a client has connected and authentized
+# with our server. Normally we are the initiator but in fastmode
+# we may also be the target.
+# Since the server handles connections async it needs this method to
+# communicate.
+
+proc jlib::bytestreams::s5i_register_socket {jlibname sid sock} {
+
+ variable fastmode
+ upvar ${jlibname}::bytestreams::istate istate
+ upvar ${jlibname}::bytestreams::tstate tstate
+ debug "jlib::bytestreams::s5i_register_socket"
+
+ if {$fastmode && [info exists tstate($sid,fast,state)]} {
+ debug "\t (t)"
+ if {$tstate($sid,fast,state) ne "error"} {
+ set tstate($sid,fast,sock) $sock
+ set tstate($sid,fast,state) connected
+ }
+ } elseif {[info exists istate($sid,state)]} {
+ debug "\t (i)"
+ if {$istate($sid,state) ne "error"} {
+ set istate($sid,sock) $sock
+ set istate($sid,state) connected
+ }
+ } else {
+ debug "\t empty"
+ # We may have been reset (timeout) or something.
+ }
+}
+
+# End s5i ----------------------------------------------------------------------
+
+# jlib::bytestreams::isend_error --
+#
+# Deliver iq error to target as a response to the targets streamhosts.
+# Fastmode only!
+
+proc jlib::bytestreams::isend_error {jlibname sid errcode errtype stanza} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::isend_error (i)"
+
+ set id $istate($sid,fast,id)
+ set jid $istate($sid,fast,jid)
+ set qE $istate($sid,fast,queryE)
+ jlib::send_iq_error $jlibname $jid $id $errcode $errtype $stanza $qE
+}
+
+# jlib::bytestreams::ifinish --
+#
+# Close all sockets and make sure to free all memory.
+
+proc jlib::bytestreams::ifinish {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ debug "jlib::bytestreams::ifinish (i)"
+
+ # Skip any ongoing socks5 connections.
+ if {$istate($sid,used-proxy)} {
+ connector_reset $jlibname $sid p
+ }
+ if {$istate($sid,fast)} {
+ connector_reset $jlibname $sid f
+ }
+
+ # Close socket.
+ if {[info exists istate($sid,sock)]} {
+ debug_sock "close $istate($sid,sock)"
+ catch {close $istate($sid,sock)}
+ }
+ if {[info exists istate($sid,fast,sock)]} {
+ debug_sock "close $istate($sid,fast,sock)"
+ catch {close $istate($sid,fast,sock)}
+ }
+ if {[info exists istate($sid,proxy,sock)]} {
+ debug_sock "close $istate($sid,proxy,sock)"
+ catch {close $istate($sid,proxy,sock)}
+ }
+ ifree $jlibname $sid
+}
+
+# jlib::bytestreams::ifree --
+#
+# Releases all memory for an initiator object.
+
+proc jlib::bytestreams::ifree {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::istate istate
+ upvar ${jlibname}::bytestreams::hash2sid hash2sid
+ debug "jlib::bytestreams::ifree (i)"
+
+ if {[info exists istate($sid,hash)]} {
+ set hash $istate($sid,hash)
+ unset -nocomplain hash2sid($hash)
+ }
+ array unset istate $sid,*
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a target (receiver) of a stream.
+
+# jlib::bytestreams::handle_set --
+#
+# Handler for incoming iq-set element with xmlns
+# "http://jabber.org/protocol/bytestreams".
+#
+# Initiator sends IQ-set to Target specifying the full JID and network
+# address of StreamHost/Initiator as well as the StreamID (SID) of the
+# proposed bytestream.
+#
+# For fastmode this can be either initiator or target.
+# It is stateless and only dispatches the iq to the target normally,
+# but can also be the initiator in case of fastmode.
+#
+# Result:
+# MUST return 0 or 1!
+
+proc jlib::bytestreams::handle_set {jlibname from queryE args} {
+ variable xmlns
+ variable fastmode
+
+ debug "jlib::bytestreams::handle_set (t+i)"
+
+ array set argsA $args
+ array set attr [wrapper::getattrlist $queryE]
+ if {![info exists argsA(-id)]} {
+ # We cannot handle this since missing id-attribute.
+ return 0
+ }
+ if {![info exists attr(sid)]} {
+ eval {return_error $jlibname $queryE 400 modify bad-request} $args
+ return 1
+ }
+ set id $argsA(-id)
+ set sid $attr(sid)
+ set jid $from
+
+ # We make sure that we have already got a si with this sid.
+ if {![jlib::si::havesi $jlibname $sid]} {
+ eval {return_error $jlibname $queryE 406 cancel not-acceptable} $args
+ return 1
+ }
+
+ # Get streamhosts keeping their order.
+ set hosts [list]
+ foreach elem [wrapper::getchildswithtag $queryE "streamhost"] {
+ array unset sattr
+ array set sattr [wrapper::getattrlist $elem]
+ if {[info exists sattr(jid)] \
+ && [info exists sattr(host)] \
+ && [info exists sattr(port)]} {
+ lappend hosts [list $sattr(jid) $sattr(host) $sattr(port)]
+ }
+ }
+ debug "\t hosts=$hosts"
+ if {![llength $hosts]} {
+ eval {return_error $jlibname $queryE 400 modify bad-request} $args
+ return 1
+ }
+
+ # In fastmode we may get a streamhosts offer for reversed socks5 connections.
+ if {[is_initiator $jlibname $sid]} {
+ if {$fastmode} {
+ i_handle_set $jlibname $sid $id $jid $hosts $queryE
+ } else {
+ # @@@ inconsistency!
+ return 0
+ }
+ } else {
+
+ # This is the normal execution path.
+ t_handle_set $jlibname $sid $id $jid $hosts $queryE
+ }
+ return 1
+}
+
+# jlib::bytestreams::t_handle_set --
+#
+# This is like the constructor of a target sid object.
+
+proc jlib::bytestreams::t_handle_set {jlibname sid id jid hosts queryE} {
+ variable fastmode
+ variable xmlns
+
+ upvar ${jlibname}::bytestreams::tstate tstate
+ upvar ${jlibname}::bytestreams::static static
+ upvar ${jlibname}::bytestreams::hash2sid hash2sid
+ debug "jlib::bytestreams::t_handle_set (t)"
+
+ set tstate($sid,id) $id
+ set tstate($sid,jid) $jid
+ set tstate($sid,fast) 0
+ set tstate($sid,state) open
+ set tstate($sid,hosts) $hosts
+ set tstate($sid,queryE) $queryE
+
+ if {$fastmode} {
+ set fastE [wrapper::getchildswithtagandxmlns $queryE "fast" $xmlns(fast)]
+ if {[llength $fastE]} {
+
+ set haveserver 1
+ if {![info exists static(sock)]} {
+
+ # Protect against server failure.
+ if {[catch {s5i_server $jlibname}]} {
+ set haveserver 0
+ }
+ }
+
+ # At this stage we switch to use the fast mode protocol.
+ if {$haveserver} {
+ set tstate($sid,fast) 1
+ set tstate($sid,fast,state) initiate
+
+ # Provide our streamhosts.
+ # First, the local one.
+ if {$static(-address) ne ""} {
+ set ip $static(-address)
+ } else {
+ set ip [jlib::getip $jlibname]
+ }
+ set myjid [jlib::myjid $jlibname]
+ set hash [::sha1::sha1 $sid$myjid$jid]
+ set tstate($sid,hash) $hash
+ set hash2sid($hash) $sid
+
+ # @@@ Is there a point that also the target provides a
+ # proxy streamhost?
+ # If the clients are using different servers, one may have a
+ # proxy while the other has not.
+ # Keep it optional (-targetproxy).
+ set host [list $myjid -host $ip -port $static(port)]
+ set streamhosts [list $host]
+
+ # Second, the proxy host if any.
+ if {$static(-targetproxy) && [llength $static(-proxyhost)]} {
+ lassign $static(-proxyhost) pjid pip pport
+ set proxyhost [list $pjid -host $pip -port $pport]
+ lappend streamhosts $proxyhost
+ }
+
+ set t_initiate_cb \
+ [list [namespace current]::t_initiate_cb $jlibname $sid]
+ send_initiate $jlibname $jid $sid $t_initiate_cb \
+ -streamhosts $streamhosts
+ }
+ }
+ }
+
+ # Try connecting the host(s) in turn.
+ set tstate($sid,state) connecting
+ set myjid [$jlibname myjid]
+ set hash [::sha1::sha1 $sid$jid$myjid]
+
+ set cb [list [namespace current]::connect_cb $jlibname $sid]
+ connector $jlibname $sid t $hash $hosts $cb
+}
+
+# jlib::bytestreams::connect_cb --
+#
+# Callback command from 'connector' object when tried socks5 connections
+# to initiators streamhosts.
+
+proc jlib::bytestreams::connect_cb {jlibname sid result args} {
+
+ upvar ${jlibname}::bytestreams::tstate tstate
+ debug "jlib::bytestreams::connect_cb (t)"
+
+ array set argsA $args
+
+ if {$result eq "error"} {
+ set tstate($sid,state) error
+
+ # Deliver error to initiator.
+ tsend_error $jlibname $sid 404 cancel item-not-found
+
+ # In fastmode we are not done until the fast mode also fails.
+ if {!$tstate($sid,fast) || ($tstate($sid,fast,state) eq "error")} {
+
+ # Deliver error to target profile.
+ jlib::si::stream_error $jlibname $sid item-not-found
+ tfinish $jlibname $sid
+ }
+ } else {
+ set sock $argsA(-socket)
+ set host $argsA(-streamhost)
+ set hostjid [lindex $host 0]
+
+ set tstate($sid,sock) $sock
+ set tstate($sid,host) $host
+ set tstate($sid,hostjid) $hostjid
+
+ set jid $tstate($sid,jid)
+ set id $tstate($sid,id)
+ send_used $jlibname $jid $id $hostjid
+
+ # If fast mode we must wait for a CR before start reading.
+ if {$tstate($sid,fast)} {
+
+ # Wait for initiator send a CR for selection or just close it.
+ set tstate($sid,state) waiting-cr
+ set cmd_cr [list [namespace current]::read_CR_cb $jlibname $sid]
+ fileevent $sock readable \
+ [list [namespace current]::read_CR $sock $cmd_cr]
+
+ } else {
+ start_read_data $jlibname $sid $sock
+ }
+ }
+}
+
+proc jlib::bytestreams::t_initiate_cb {jlibname sid type subiq args} {
+
+ upvar ${jlibname}::bytestreams::tstate tstate
+ debug "jlib::bytestreams::t_initiate_cb (t) type=$type"
+
+ # In fast mode we may get this callback after we have finished.
+ # Or after a timeout or something.
+ if {![info exists tstate($sid,state)]} {
+ return
+ }
+
+ if {$type eq "error"} {
+
+ # Cleanup and close any fast socks5 connection.
+ set tstate($sid,fast,state) error
+ if {[info exists tstate($sid,fast,sock)]} {
+ debug_sock "close $tstate($sid,fast,sock)"
+ catch {close $tstate($sid,fast,sock)}
+ unset tstate($sid,fast,sock)
+ }
+
+ # If also the standard way failed we are done.
+ if {$tstate($sid,state) eq "error"} {
+ jlib::si::stream_error $jlibname $sid item-not-found
+ tfinish $jlibname $sid
+ }
+ } else {
+
+ # Wait for initiator send a CR for selction or just close it.
+ debug "\t waiting CR"
+ set tstate($sid,fast,state) waiting-cr
+ set sock $tstate($sid,fast,sock)
+ set cmd_cr [list [namespace current]::fast_read_CR_cb $jlibname $sid]
+ fileevent $sock readable \
+ [list [namespace current]::read_CR $sock $cmd_cr]
+ }
+}
+
+proc jlib::bytestreams::read_CR {sock cmd} {
+
+ debug "jlib::bytestreams::read_CR (t)"
+
+ fileevent $sock readable {}
+ if {[catch {read $sock 1} data] || [eof $sock]} {
+ debug "\t eof"
+ catch {close $sock}
+ eval $cmd error
+ } elseif {$data ne "\r"} {
+ debug "\t not CR"
+ catch {close $sock}
+ eval $cmd error
+ } else {
+ debug "\t got CR"
+ eval $cmd
+ }
+}
+
+proc jlib::bytestreams::fast_read_CR_cb {jlibname sid {error ""}} {
+
+ upvar ${jlibname}::bytestreams::tstate tstate
+ debug "jlib::bytestreams::fast_read_CR_cb (t) error=$error"
+
+ if {$error ne ""} {
+ set tstate($sid,fast,state) error
+ unset -nocomplain tstate($sid,fast,sock)
+
+ # If also the standard way failed we are done.
+ if {$tstate($sid,state) eq "error"} {
+ jlib::si::stream_error $jlibname $sid item-not-found
+ tfinish $jlibname $sid
+ }
+ } else {
+
+ # At this stage we are using reversed transport (fast mode).
+ # We are using the targets (our own) streamhost.
+ connector_reset $jlibname $sid t
+ if {[info exists tstate($sid,sock)]} {
+ debug_sock "close $tstate($sid,sock)"
+ catch {close $tstate($sid,sock)}
+ unset tstate($sid,sock)
+ }
+
+ # Deliver error to initiator unless not done so.
+ if {$tstate($sid,state) ne "error"} {
+ tsend_error $jlibname $sid 404 cancel item-not-found
+ }
+ set tstate($sid,state) error
+ set tstate($sid,fast,selected) fast
+ set tstate($sid,fast,state) read
+
+ start_read_data $jlibname $sid $tstate($sid,fast,sock)
+ }
+}
+
+#...............................................................................
+
+proc jlib::bytestreams::read_CR_cb {jlibname sid {error ""}} {
+
+ upvar ${jlibname}::bytestreams::tstate tstate
+ debug "jlib::bytestreams::read_CR_cb (t) error=$error"
+
+ if {$error ne ""} {
+ set tstate($sid,state) error
+ unset -nocomplain tstate($sid,sock)
+
+ # If also the fast mode failed this is The End.
+ if {$tstate($sid,fast) && ($tstate($sid,fast,state) eq "error")} {
+ jlib::si::stream_error $jlibname $sid item-not-found
+ tfinish $jlibname $sid
+ }
+ } else {
+ if {[info exists tstate($sid,fast,sock)]} {
+ debug_sock "close $tstate($sid,fast,sock)"
+ catch {close $tstate($sid,fast,sock)}
+ unset tstate($sid,fast,sock)
+ }
+ set sock $tstate($sid,sock)
+
+ set tstate($sid,fast,selected) normal
+ set tstate($sid,state) read
+
+ start_read_data $jlibname $sid $sock
+ }
+}
+
+proc jlib::bytestreams::start_read_data {jlibname sid sock} {
+
+ upvar ${jlibname}::bytestreams::static static
+
+ fconfigure $sock -buffersize $static(-block-size) -buffering full
+ fileevent $sock readable \
+ [list [namespace current]::readable $jlibname $sid $sock]
+}
+
+# End connect_socks ------------------------------------------------------------
+
+# jlib::bytestreams::readable --
+#
+# Reads channel and delivers data up to si.
+
+proc jlib::bytestreams::readable {jlibname sid sock} {
+
+ upvar ${jlibname}::bytestreams::tstate tstate
+ upvar ${jlibname}::bytestreams::static static
+ debug "jlib::bytestreams::readable (t)"
+
+ fileevent $sock readable {}
+
+ # We may have been reset or something.
+ if {![jlib::si::havesi $jlibname $sid]} {
+ tfinish $jlibname $sid
+ return
+ }
+
+ if {[catch {eof $sock} iseof] || $iseof} {
+ debug "\t eof"
+ # @@@ Perhaps we should check number of bytes reveived or something???
+ # If the initiator closes socket before transfer is complete
+ # we wont notice this otherwise.
+ jlib::si::stream_closed $jlibname $sid
+ tfinish $jlibname $sid
+ } else {
+
+ # @@@ Keep tranck of number bytes read?
+ set data [read $sock $static(-block-size)]
+ set len [string length $data]
+ debug "\t len=$len"
+
+ # Deliver to si for further processing.
+ jlib::si::stream_recv $jlibname $sid $data
+
+ # This is a trick to put this event at the back of the queue to
+ # avoid using any 'update'.
+ after idle [list after 0 [list \
+ [namespace current]::setreadable $jlibname $sid $sock]]
+ }
+}
+
+proc jlib::bytestreams::setreadable {jlibname sid sock} {
+
+ # We could have been closed since this event comes async.
+ if {[lsearch [file channels] $sock] >= 0} {
+ fileevent $sock readable \
+ [list [namespace current]::readable $jlibname $sid $sock]
+ }
+}
+
+# jlib::bytestreams::send_used --
+#
+# Target (also initiator in fast mode) notifies initiator of connection.
+
+proc jlib::bytestreams::send_used {jlibname to id hostjid} {
+ variable xmlns
+
+ set usedE [wrapper::createtag "streamhost-used" \
+ -attrlist [list jid $hostjid]]
+ set xmllist [wrapper::createtag "query" \
+ -attrlist [list xmlns $xmlns(bs)] \
+ -subtags [list $usedE]]
+
+ $jlibname send_iq "result" [list $xmllist] -to $to -id $id
+}
+
+# The client socks5 functions --------------------------------------------------
+#
+# Normally used by the target but in fastmode also used by the initiator.
+#
+# This object handles everything to make a single socks5 connection +
+# authentication.
+# [in]: addr, port, hash, cmd
+# [out]: sock, result
+
+# jlib::bytestreams::socks5 --
+#
+# Open a client socket to the specified host and port and announce method.
+# This must be kept stateless.
+
+proc jlib::bytestreams::socks5 {addr port hash cmd} {
+
+ debug "jlib::bytestreams::socks5 (t)"
+
+ if {[catch {
+ set sock [socket -async $addr $port]
+ } err]} {
+ return -code error $err
+ }
+ debug_sock "open $sock"
+ fconfigure $sock -translation binary -blocking 0
+ fileevent $sock writable \
+ [list [namespace current]::s5t_write_method $hash $sock $cmd]
+ return $sock
+}
+
+proc jlib::bytestreams::s5t_write_method {hash sock cmd} {
+
+ debug "jlib::bytestreams::s5t_write_method (t)"
+ fileevent $sock writable {}
+
+ # Announce method (\x00).
+ if {[catch {
+ puts -nonewline $sock "\x05\x01\x00"
+ flush $sock
+ debug "\t wrote 3: 'x05x01x00'"
+ } err]} {
+ catch {close $sock}
+ eval $cmd error-network-write
+ return
+ }
+ fileevent $sock readable \
+ [list [namespace current]::s5t_method_result $hash $sock $cmd]
+}
+
+proc jlib::bytestreams::s5t_method_result {hash sock cmd} {
+
+ debug "jlib::bytestreams::s5t_method_result (t)"
+
+ fileevent $sock readable {}
+ if {[catch {read $sock} data] || [eof $sock]} {
+ catch {close $sock}
+ eval $cmd error-network-read
+ return
+ }
+ debug "\t read [string length $data]"
+ binary scan $data cc ver method
+ if {($ver != 5) || ($method != 0)} {
+ catch {close $sock}
+ eval $cmd error-socks5
+ return
+ }
+ set len [binary format c [string length $hash]]
+ if {[catch {
+ puts -nonewline $sock "\x05\x01\x00\x03$len$hash\x00\x00"
+ flush $sock
+ debug "\t wrote [string length "\x05\x01\x00\x03$len$hash\x00\x00"]: 'x05x01x00x03${len}${hash}x00x00'"
+ } err]} {
+ catch {close $sock}
+ eval $cmd error-network-write
+ return
+ }
+ fileevent $sock readable \
+ [list [namespace current]::s5t_auth_result $sock $cmd]
+}
+
+proc jlib::bytestreams::s5t_auth_result {sock cmd} {
+
+ debug "jlib::bytestreams::s5t_auth_result (t)"
+
+ fileevent $sock readable {}
+ if {[catch {read $sock} data] || [eof $sock]} {
+ catch {close $sock}
+ eval $cmd error-network-read
+ return
+ }
+ debug "\t read [string length $data]"
+ binary scan $data cc ver method
+ if {($ver != 5) || ($method != 0)} {
+ catch {close $sock}
+ eval $cmd error-socks5
+ return
+ }
+
+ # Here we should be finished.
+ eval $cmd
+}
+
+# End s5t ----------------------------------------------------------------------
+
+# jlib::bytestreams::return_error, tsend_error --
+#
+# Various helper functions to return errors.
+
+proc jlib::bytestreams::return_error {jlibname qElem errcode errtype stanza args} {
+
+ array set attr $args
+ set id $attr(-id)
+ set jid $attr(-from)
+ jlib::send_iq_error $jlibname $jid $id $errcode $errtype $stanza $qElem
+}
+
+proc jlib::bytestreams::tsend_error {jlibname sid errcode errtype stanza} {
+
+ upvar ${jlibname}::bytestreams::tstate tstate
+ debug "jlib::bytestreams::tsend_error (t)"
+
+ set id $tstate($sid,id)
+ set jid $tstate($sid,jid)
+ set qE $tstate($sid,queryE)
+ jlib::send_iq_error $jlibname $jid $id $errcode $errtype $stanza $qE
+}
+
+proc jlib::bytestreams::tfinish {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::tstate tstate
+ debug "jlib::bytestreams::tfinish (t)"
+
+ # Close socket.
+ if {[info exists tstate($sid,sock)]} {
+ debug_sock "close $tstate($sid,sock)"
+ catch {close $tstate($sid,sock)}
+ }
+ if {[info exists tstate($sid,fast,sock)]} {
+ debug_sock "close $tstate($sid,fast,sock)"
+ catch {close $tstate($sid,fast,sock)}
+ }
+ if {[info exists tstate($sid,timeoutid)]} {
+ after cancel $tstate($sid,timeoutid)
+ }
+ tfree $jlibname $sid
+}
+
+proc jlib::bytestreams::tfree {jlibname sid} {
+
+ upvar ${jlibname}::bytestreams::tstate tstate
+ upvar ${jlibname}::bytestreams::hash2sid hash2sid
+ debug "jlib::bytestreams::tfree (t)"
+
+ if {[info exists tstate($sid,hash)]} {
+ set hash $tstate($sid,hash)
+ unset -nocomplain hash2sid($hash)
+ }
+ array unset tstate $sid,*
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::bytestreams {
+
+ jlib::ensamble_register bytestreams \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+# connector --------------------------------------------------------------------
+
+# jlib::bytestreams::connector --
+#
+# Standalone object which is target and initiator agnostic that tries
+# to make socks5 connections to the hosts in turn. Invokes the callback
+# for the first succesful connection or an error if none worked.
+# The 'sid' is the characteristic identifier of an object.
+# It sets its own timeouts. Needs also a unique 'key' if using multiple
+# connectors for one sid.
+#
+# NB1: SHA1(SID + Initiator JID + Target JID)
+# NB2: the initiator may have two connector objects if fast + proxy.
+#
+# [in]: sid, key, hash, hosts, cmd
+# [out]: result (-error | -host -socket)
+
+proc jlib::bytestreams::connector {jlibname sid key hash hosts cmd} {
+
+ upvar ${jlibname}::bytestreams::conn conn
+ debug "jlib::bytestreams::connector $key"
+
+ set x $sid,$key
+ set conn($x,hosts) $hosts
+ set conn($x,cmd) $cmd
+ set conn($x,hash) $hash
+ set conn($x,idx) [expr {[llength $hosts]-1}]
+
+ connector_sock $jlibname $sid $key
+ return
+}
+
+# jlib::bytestreams::connector_sock --
+#
+# Tries to make a socks5 connection to streamhost with 'idx' index.
+# If 'idx' goes negative we report an error.
+
+proc jlib::bytestreams::connector_sock {jlibname sid key} {
+
+ upvar ${jlibname}::bytestreams::conn conn
+ upvar ${jlibname}::bytestreams::static static
+ debug "jlib::bytestreams::connector_sock $key"
+
+ set x $sid,$key
+ if {[info exists conn($x,timeoutid)]} {
+ after cancel $conn($x,timeoutid)
+ unset conn($x,timeoutid)
+ }
+ if {$conn($x,idx) < 0} {
+ connector_final $jlibname $sid $key "error"
+ return
+ }
+ set conn($x,timeoutid) [after $static(-s5timeoutms) \
+ [list [namespace current]::connector_timeout_cb $jlibname $sid $key]]
+
+ set host [lindex $conn($x,hosts) $conn($x,idx)]
+ lassign $host hostjid addr port
+ debug "\t host=$host"
+ set s5_cb [list [namespace current]::connector_s5_cb $jlibname $sid $key]
+ if {[catch {
+ set conn($x,sock) [socks5 $addr $port $conn($x,hash) $s5_cb]
+ }]} {
+
+ # Retry with next streamhost if any.
+ incr conn($x,idx) -1
+ connector_sock $jlibname $sid $key
+ }
+}
+
+proc jlib::bytestreams::connector_s5_cb {jlibname sid key {err ""}} {
+
+ upvar ${jlibname}::bytestreams::conn conn
+ debug "jlib::bytestreams::connector_s5_cb $key err=$err"
+
+ set x $sid,$key
+ if {$err eq ""} {
+ connector_final $jlibname $sid $key
+ } else {
+ incr conn($x,idx) -1
+ connector_sock $jlibname $sid $key
+ }
+}
+
+proc jlib::bytestreams::connector_timeout_cb {jlibname sid key} {
+
+ upvar ${jlibname}::bytestreams::conn conn
+ debug "jlib::bytestreams::connector_timeout_cb $key"
+
+ # On timeouts we are responsible for closing the socket.
+ set x $sid,$key
+ unset conn($x,timeoutid)
+ if {[info exists conn($x,sock)]} {
+ debug_sock "close $conn($x,sock)"
+ catch {close $conn($x,sock)}
+ unset conn($x,sock)
+ }
+ incr conn($x,idx) -1
+ connector_sock $jlibname $sid $key
+}
+
+proc jlib::bytestreams::connector_reset {jlibname sid key} {
+
+ upvar ${jlibname}::bytestreams::conn conn
+ debug "jlib::bytestreams::connector_reset $key"
+
+ # Protect for nonexisting connector object.
+ set x $sid,$key
+ if {![info exists conn($x,cmd)]} {
+ return
+ }
+ if {[info exists conn($x,timeoutid)]} {
+ after cancel $conn($x,timeoutid)
+ unset conn($x,timeoutid)
+ }
+ if {[info exists conn($x,sock)]} {
+ debug_sock "close $conn($x,sock)"
+ catch {close $conn($x,sock)}
+ unset conn($x,sock)
+ }
+ connector_final $jlibname $sid $key "reset"
+}
+
+proc jlib::bytestreams::connector_final {jlibname sid key {err ""}} {
+
+ upvar ${jlibname}::bytestreams::conn conn
+ debug "jlib::bytestreams::connector_final err=$err"
+
+ set x $sid,$key
+ if {[info exists conn($x,timeoutid)]} {
+ after cancel $conn($x,timeoutid)
+ unset conn($x,timeoutid)
+ }
+ set cmd $conn($x,cmd)
+ if {$err eq ""} {
+ set host [lindex $conn($x,hosts) $conn($x,idx)]
+ eval $cmd ok -streamhost $host -socket $conn($x,sock)
+ } else {
+
+ # Skip callback when we have reset. ?
+ if {$err ne "reset"} {
+ eval $cmd error -error $err
+ }
+ }
+ array unset conn $x,*
+}
+
+proc jlib::bytestreams::debug {msg} {if {0} {puts $msg}}
+
+proc jlib::bytestreams::debug_sock {msg} {if {0} {puts $msg}}
+
+#-------------------------------------------------------------------------------
+
+if {0} {
+ # Testing the 'connector'
+ set jlib ::jlib::jlib1
+ set port [$jlib bytestreams s5i_server]
+ set hosts [list \
+ [list proxy.localhost junk.se 8237] \
+ [list matben@localhost 127.0.0.1 $port]]
+ proc cb {args} {puts "---> $args"}
+ set sid [jlib::generateuuid]
+ set myjid [$jlib myjid]
+ set jid killer@localhost/coccinella
+ set hash [::sha1::sha1 $sid$myjid$jid]
+ $jlib bytestreams connector $sid $hash $hosts cb
+
+ # Testing proxy:
+ # 1) get proxy
+ set jlib ::jlib::jlib1
+ proc pcb {jlib type queryE} {
+ puts "---> $jlib $type $queryE"
+ set hostE [wrapper::getfirstchildwithtag $queryE "streamhost"]
+ array set attr [wrapper::getattrlist $hostE]
+ set ::proxyHost $attr(host)
+ set ::proxyPort $attr(port)
+ }
+ set proxy proxy.jabber.se
+ $jlib bytestreams get_proxy $proxy pcb
+ $jlib bytestreams configure -proxyhost [list $proxy $proxyHost $proxyPort]
+
+ # 2) socks5 connection
+ set sid [jlib::generateuuid]
+ set myjid [$jlib myjid]
+ set jid killer@jabber.se/coccinella
+ set hash [::sha1::sha1 $sid$myjid$jid]
+ set hosts [list [list $proxy $proxyHost $proxyPort]]
+ $jlib bytestreams connector $sid $hash $hosts cb
+
+ # 3) activate
+ $jlib bytestreams activate $sid $proxy $jid
+
+}
+
+
--- /dev/null
+# caps.tcl --
+#
+# This file is part of the jabberlib. It handles the internal cache
+# for caps (xmlns='http://jabber.org/protocol/caps') XEP-0115.
+# It is updated to version 1.3 of XEP-0115.
+#
+# A typical caps element looks like:
+#
+# <presence>
+# <c xmlns='http://jabber.org/protocol/caps'
+# node='http://exodus.jabberstudio.org/caps'
+# ver='0.9'
+# ext='tins ftrans xhtml'/>
+# </presence>
+#
+# The core function of caps is a mapping:
+#
+# jid -> node+ver -> disco info
+# jid -> node+ext -> disco info
+#
+# NB: The ext must be consistent over all versions (ver).
+#
+# UPDATE version 1.4: ---------------------------------------------------------
+#
+# <presence from='romeo@montague.lit/orchard'>
+# <c xmlns='http://jabber.org/protocol/caps'
+# node='http://exodus.jabberstudio.org/#0.9.1'
+# ver='8RovUdtOmiAjzj+xI7SK5BCw3A8='/>
+# </presence>
+#
+# The 'ver' map to a unique combination of disco identities+features.
+#
+# -----------------------------------------------------------------------------
+#
+# Copyright (c) 2005-2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: caps.tcl,v 1.25 2007/10/04 14:01:07 matben Exp $
+#
+############################# USAGE ############################################
+#
+# NAME
+# caps - convenience command library for caps: Entity Capabilities
+#
+# INSTANCE COMMANDS
+# jlibname caps register name xmllist features
+# jlibname caps configure ?-autodisco 0|1? -command tclProc
+# jlibname caps getexts
+# jlibname caps getxmllist name
+# jlibname caps getallfeatures
+# jlibname caps getfeatures name
+#
+# The 'name' is here the ext token.
+
+# TODO: make a static cache (variable cache) which maps the hashed ver attribute
+# to a list of disco identities and features.
+
+package require base64 ; # tcllib
+package require sha1 ; # tcllib
+package require jlib::disco
+package require jlib::roster
+
+package provide jlib::caps 0.3
+
+namespace eval jlib::caps {
+
+ variable xmlns
+ set xmlns(caps) "http://jabber.org/protocol/caps"
+
+ # Note: jlib::ensamble_register is last in this file!
+}
+
+proc jlib::caps::init {jlibname args} {
+
+ # Instance specific arrays.
+ namespace eval ${jlibname}::caps {
+ variable ext
+ variable options
+ }
+
+ upvar ${jlibname}::caps::options options
+ array set options {
+ -autodisco 0
+ -command {}
+ }
+ eval {configure $jlibname} $args
+
+ # Since the caps element from a JID is globally defined there is no need
+ # to keep its state instance specific (per jlibname).
+
+ # The cache for disco results. Must not be instance specific.
+ variable caps
+
+ # This collects various mappings and states:
+ # o It keeps track of mapping jid -> node+ver+exts
+ # o
+ variable state
+
+ jlib::presence_register_int $jlibname available \
+ [namespace current]::avail_cb
+ jlib::presence_register_int $jlibname unavailable \
+ [namespace current]::unavail_cb
+
+ jlib::register_reset $jlibname [namespace current]::reset
+}
+
+proc jlib::caps::configure {jlibname args} {
+ upvar ${jlibname}::caps::options options
+
+ if {[llength $args]} {
+ foreach {key value} $args {
+ switch -- $key {
+ -autodisco {
+ if {[string is boolean -strict $value]} {
+ set options(-autodisco) $value
+ } else {
+ return -code error "expected boolean for -autodisco"
+ }
+ }
+ -command {
+ set options(-command) $value
+ }
+ default {
+ return -code error "unrecognized option \"$key\""
+ }
+ }
+ }
+ } else {
+ return [array get options]
+ }
+}
+
+proc jlib::caps::cmdproc {jlibname cmd args} {
+
+ # Just dispatch the command to the right procedure.
+ return [eval {$cmd $jlibname} $args]
+}
+
+#--- First, handle our own caps stuff ------------------------------------------
+
+# jlib::caps::register --
+#
+# Register an 'ext' token and associated disco#info element.
+# The 'name' is the ext token.
+# The 'features' must be the 'var' attributes in 'xmllist'.
+# <feature var='http://jabber.org/protocol/disco#info'/>
+
+proc jlib::caps::register {jlibname name xmllist features} {
+ upvar ${jlibname}::caps::ext ext
+
+ set ext(name,$name) $name
+ set ext(xmllist,$name) $xmllist
+ set ext(features,$name) $features
+}
+
+proc jlib::caps::getallidentities {jlibname} {
+ upvar ${jlibname}::caps::ext ext
+
+ return $ext(identities)
+}
+
+proc jlib::caps::getexts {jlibname} {
+ upvar ${jlibname}::caps::ext ext
+
+ set exts [list]
+ foreach {key name} [array get ext name,*] {
+ lappend exts $name
+ }
+ return [lsort $exts]
+}
+
+proc jlib::caps::getxmllist {jlibname name} {
+ upvar ${jlibname}::caps::ext ext
+
+ if {[info exists ext(xmllist,$name)]} {
+ return $ext(xmllist,$name)
+ } else {
+ return
+ }
+}
+
+proc jlib::caps::getfeatures {jlibname name} {
+ upvar ${jlibname}::caps::ext ext
+
+ if {[info exists ext(features,$name)]} {
+ return $ext(features,$name)
+ } else {
+ return
+ }
+}
+
+proc jlib::caps::getallfeatures {jlibname} {
+ upvar ${jlibname}::caps::ext ext
+
+ set featureL [list]
+ foreach {key features} [array get ext features,*] {
+ set featureL [concat $featureL $features]
+ }
+ return [lsort -unique $featureL]
+}
+
+# jlib::caps::generate_ver --
+#
+# This just takes the internal identities and features into account.
+# NB: A client MUST synchronize the disco identity amd feature elements
+# here else we respond with a false ver attribute!
+
+proc jlib::caps::generate_ver {jlibname} {
+
+ set identities [jlib::disco::getidentities $jlibname]
+ set features [concat [getallfeatures $jlibname] \
+ [jlib::disco::getregisteredfeatures]]
+ return [create_ver $identities $features]
+}
+
+proc jlib::caps::create_ver {identityL featureL} {
+
+ set ver ""
+ append ver [join [lsort -unique $identityL] <]
+ append ver <
+ append ver [join [lsort -unique $featureL] <]
+ append ver <
+ set hex [::sha1::sha1 $ver]
+
+ # Inverse to: [format %0.8x%0.8x%0.8x%0.8x%0.8x $H0 $H1 $H2 $H3 $H4]
+ set parts ""
+ for {set i 0} {$i < 5} {incr i} {
+ append parts "0x"
+ append parts [string range $hex [expr {8*$i}] [expr {8*$i + 7}]]
+ append parts " "
+ }
+ # Works independent on machine Endian order!
+ set bin [eval binary format IIIII $parts]
+ return [::base64::encode $bin]
+}
+
+# Test case:
+if {0} {
+ set S "client/pc<http://jabber.org/protocol/disco#info<http://jabber.org/protocol/disco#items<http://jabber.org/protocol/muc<"
+ # 8RovUdtOmiAjzj+xI7SK5BCw3A8=
+
+ set identityL {client/pc}
+ set featureL {
+ "http://jabber.org/protocol/disco#info"
+ "http://jabber.org/protocol/disco#items"
+ "http://jabber.org/protocol/muc"
+ }
+ jlib::caps::create_ver $identityL $featureL
+}
+
+#--- Second, handle all users caps stuff ---------------------------------------
+
+# jlib::caps::disco_ver --
+#
+# Disco#info request for client#version
+#
+# <iq type='get' to='randomuser1@capulet.com/resource'>
+# <query xmlns='http://jabber.org/protocol/disco#info'
+# node='http://exodus.jabberstudio.org/caps#0.9'/>
+# </iq>
+#
+# We MUST have got a presence caps element for this user.
+#
+# The client that received the annotated presence sends a disco#info
+# request to exactly one of the users that sent a particular presenece
+# element caps combination of node and ver.
+
+proc jlib::caps::disco_ver {jlibname jid} {
+
+ set ver [$jlibname roster getcapsattr $jid ver]
+ disco $jlibname $jid ver $ver
+}
+
+# jlib::caps::disco_ext --
+#
+# Disco the 'ext' via the caps node+ext cache.
+#
+# We MUST have got a presence caps element for this user with the
+# corresponding 'ext' token.
+
+proc jlib::caps::disco_ext {jlibname jid ext} {
+
+ disco $jlibname $jid ext $ext
+}
+
+# jlib::caps::disco --
+#
+# Internal use only. See disco_ver and disco_ext.
+#
+# Arguments:
+# what: "ver" or "ext"
+# value: value for 'ver' or the name of the 'ext'.
+
+proc jlib::caps::disco {jlibname jid what value} {
+ variable state
+ variable caps
+
+ set node [$jlibname roster getcapsattr $jid node]
+ set key $what,$node,$value
+
+ # Mark that we have a pending node+ver or node+ext request.
+ set state(pending,$key) 1
+
+ # It should be safe to use 'disco get_async' here.
+ # Need to provide node+ver for error recovery.
+ set cb [list [namespace current]::disco_cb $node $what $value]
+ $jlibname disco get_async info $jid $cb -node ${node}#${value}
+}
+
+# jlib::caps::disco_cb --
+#
+# Callback for 'disco get_async'.
+# We must take care of a situation where the jid went unavailable,
+# or otherwise returns an error, and try to use another jid.
+
+proc jlib::caps::disco_cb {node what value jlibname type from queryE args} {
+ upvar ${jlibname}::caps::options options
+ variable state
+ variable caps
+
+ set key $what,$node,$value
+ unset -nocomplain state(pending,$key)
+
+ if {$type eq "error"} {
+
+ # If one client with a certain 'key' fails it is likely all will
+ # fail since they are assumed to be identical, unless it failed
+ # because it went offline.
+ # @@@ Risk for infinite loop?
+ if {$options(-autodisco) && ![$jlibname roster isavailable $from]} {
+ set rjid [get_random_jid $what $node $value]
+ if {$rjid ne ""} {
+ disco $jlibname $rjid $what $value
+ }
+ }
+ } else {
+ set jid [jlib::jidmap $from]
+
+ # Cache the returned element to be reused for all node+ver combinations.
+ set caps(queryE,$key) $queryE
+ if {[llength $options(-command)]} {
+ uplevel #0 $options(-command) [list $jlibname $from $queryE]
+ }
+ }
+}
+
+# OBSOLETE IN 1.4
+
+# jlib::caps::avail_cb --
+#
+# Registered available presence callback.
+# Keeps track of all jid <-> node+ver combinations.
+# The exts may be different for identical node+ver and must be
+# obtained for individual jids using 'roster getcapsattr'.
+
+proc jlib::caps::avail_cb {jlibname xmldata} {
+ upvar ${jlibname}::caps::options options
+ variable state
+ variable caps
+
+ set jid [wrapper::getattribute $xmldata from]
+ set jid [jlib::jidmap $jid]
+
+ set node [$jlibname roster getcapsattr $jid node]
+
+ # Skip if the client doesn't have a caps presence element.
+ if {$node eq ""} {
+ return
+ }
+ set ver [$jlibname roster getcapsattr $jid ver]
+ set ext [$jlibname roster getcapsattr $jid ext]
+
+ # Map jid -> node+ver+ext. Note that 'ext' may be empty.
+ set state(jid,node,$jid) $node
+ set state(jid,ver,$jid) $ver
+ set state(jid,ext,$jid) $ext
+
+ # For each combinations node+ver and node+ext we must be able to collect
+ # a list of JIDs where we shall pick a random one to disco.
+ # Avoid a linear search. Better to use the array hash mechanism.
+
+ set state(jids,ver,$ver,$node,$jid) $jid
+ foreach e $ext {
+ set state(jids,ext,$e,$node,$jid) $jid
+ }
+
+ # If auto disco then try to disco all node+ver and node+exts which we
+ # don't have and aren't waiting for.
+ if {$options(-autodisco)} {
+ set key ver,$node,$ver
+ if {![info exists caps(queryE,$key)]} {
+ if {![info exists state(pending,$key)]} {
+ set rjid [get_random_jid ver $node $ver]
+ if {$rjid ne ""} {
+ disco $jlibname $rjid ver $ver
+ }
+ }
+ }
+ foreach e $ext {
+ set key ext,$node,$e
+ if {![info exists caps(queryE,$key)]} {
+ if {![info exists state(pending,$key)]} {
+ set rjid [get_random_jid ext $node $e]
+ if {$rjid ne ""} {
+ disco $jlibname $rjid ext $e
+ }
+ }
+ }
+ }
+ }
+ return 0
+}
+
+# OBSOLETE IN 1.4
+
+# jlib::caps::get_random_jid_ver, get_random_jid_ext --
+#
+# Methods to pick a random JID from node+ver or node+ext.
+
+proc jlib::caps::get_random_jid {what node value} {
+ get_random_jid_$what $node $value
+}
+
+proc jlib::caps::get_random_jid_ver {node ver} {
+ variable state
+
+ set keys [array names state jids,ver,$ver,$node,*]
+ if {[llength $keys]} {
+ set idx [expr {int(rand()*[llength $keys])}]
+ return $state([lindex $keys $idx])
+ } else {
+ return
+ }
+}
+
+proc jlib::caps::get_random_jid_ext {node ext} {
+ variable state
+
+ set keys [array names state jids,ext,$ext,$node,*]
+ if {[llength $keys]} {
+ set idx [expr {int(rand()*[llength $keys])}]
+ return $state([lindex $keys $idx])
+ } else {
+ return
+ }
+}
+
+# OBSOLETE IN 1.4
+
+# jlib::caps::unavail_cb --
+#
+# Registered unavailable presence callback.
+# Frees internal cache related to this jid.
+
+proc jlib::caps::unavail_cb {jlibname xmldata} {
+ variable state
+
+ set jid [wrapper::getattribute $xmldata from]
+ set jid [jlib::jidmap $jid]
+
+ # JID may not have caps.
+ if {![info exists state(jid,node,$jid)]} {
+ return
+ }
+ set node $state(jid,node,$jid)
+ set ver $state(jid,ver,$jid)
+ set ext $state(jid,ext,$jid)
+
+ set jidESC [jlib::ESC $jid]
+ array unset state jid,node,$jidESC
+ array unset state jid,ver,$jidESC
+ array unset state jid,ext,$jidESC
+ array unset state jids,*,$jidESC
+
+ return 0
+}
+
+proc jlib::caps::reset {jlibname} {
+ variable state
+
+ unset -nocomplain state
+}
+
+# OBSOLETE IN 1.4
+
+proc jlib::caps::writecache {fileName} {
+ variable caps
+
+ set fd [open $fileName w]
+ fconfigure $fd -encoding utf-8
+ foreach {key value} [array get caps] {
+ puts $fd [list set caps($key) $value]
+ }
+ close $fd
+}
+
+proc jlib::caps::readcache {fileName} {
+ variable caps
+
+ source $fileName
+}
+
+proc jlib::caps::freecache {} {
+ variable caps
+
+ unset -nocomplain caps
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::caps {
+
+ jlib::ensamble_register caps \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+# Tests
+if {0} {
+
+ proc cb {args} {}
+ set jlib ::jlib::jlib1
+ set jid matben@localhost/coccinella
+ set caps "http://coccinella.sourceforge.net/protocol/caps"
+ set ver 0.95.17
+ $jlib disco send_get info $jid cb -node $caps#$ver
+ $jlib disco send_get info $jid cb -node $caps#whiteboard
+ $jlib disco send_get info $jid cb -node $caps#iax
+}
--- /dev/null
+# compress.tcl --
+#
+# This file is part of jabberlib.
+# It implements stream compression as defined in XEP-0138:
+# Stream Compression
+#
+# Copyright (c) 2006-2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# NB: There are several zlib packages floating around the net with the same
+# name!. But we must have the one implemented for TIP 234, see
+# http://www.tcl.tk/cgi-bin/tct/tip/234.html.
+# This is currently of version 2.0.1 so we rely on this when doing
+# package require. Beware!
+#
+# $Id: compress.tcl,v 1.9 2008/01/04 13:41:32 matben Exp $
+
+package require jlib
+package require -exact zlib 2.0.1
+
+package provide jlib::compress 0.1
+
+namespace eval jlib::compress {
+
+ variable methods {zlib}
+
+ # NB: There are two namespaces:
+ # 'http://jabber.org/features/compress'
+ # 'http://jabber.org/protocol/compress'
+ variable xmlns
+ array set xmlns {
+ features/compress "http://jabber.org/features/compress"
+ protocol/compress "http://jabber.org/protocol/compress"
+ }
+ jlib::register_instance [namespace code instance]
+}
+
+proc jlib::compress::instance {jlibname} {
+ $jlibname register_reset [namespace code reset]
+}
+
+proc jlib::compress::start {jlibname cmd} {
+
+ variable xmlns
+ variable methods
+
+ # puts "jlib::compress::start"
+
+ # Instance specific namespace.
+ namespace eval ${jlibname}::compress {
+ variable state
+ }
+ upvar ${jlibname}::compress::state state
+
+ set state(cmd) $cmd
+ set state(-method) [lindex $methods 0]
+
+ # Set up the streams for zlib.
+ set state(compress) [zlib stream compress]
+ set state(decompress) [zlib stream decompress]
+
+ # Set up callback for the xmlns that is of interest to us.
+ $jlibname element_register $xmlns(protocol/compress) [namespace code parse]
+
+ if {[$jlibname have_feature]} {
+ compress $jlibname
+ } else {
+ $jlibname trace_stream_features [namespace code features_write]
+ }
+}
+
+proc jlib::compress::features_write {jlibname} {
+
+ # puts "jlib::compress::features_write"
+
+ $jlibname trace_stream_features {}
+ compress $jlibname
+}
+
+# jlib::compress::compress --
+#
+# Initiating Entity Requests Stream Compression.
+
+proc jlib::compress::compress {jlibname} {
+
+ variable methods
+ variable xmlns
+ upvar ${jlibname}::compress::state state
+
+ # puts "jlib::compress::compress"
+
+ # Note: If the initiating entity did not understand any of the advertised
+ # compression methods, it SHOULD ignore the compression option and
+ # proceed as if no compression methods were advertised.
+
+ set have_method [$jlibname have_feature compression $state(-method)]
+ if {!$have_method} {
+ finish $jlibname
+ return
+ }
+
+ # @@@ MUST match methods!!!
+ # A compliant implementation MUST implement the ZLIB compression method...
+
+ set methodE [wrapper::createtag method -chdata $state(-method)]
+
+ set xmllist [wrapper::createtag compress \
+ -attrlist [list xmlns $xmlns(protocol/compress)] -subtags [list $methodE]]
+ $jlibname send $xmllist
+
+ # Wait for 'compressed' or 'failure' element.
+}
+
+proc jlib::compress::parse {jlibname xmldata} {
+
+ # puts "jlib::compress::parse"
+
+ set tag [wrapper::gettag $xmldata]
+
+ switch -- $tag {
+ compressed {
+ compressed $jlibname $xmldata
+ }
+ failure {
+ failure $jlibname $xmldata
+ }
+ default {
+ finish $jlibname compress-protocol-error
+ }
+ }
+ return
+}
+
+proc jlib::compress::compressed {jlibname xmldata} {
+
+ # puts "jlib::compress::compressed"
+
+ # Example 5. Receiving Entity Acknowledges Stream Compression
+ # <compressed xmlns='http://jabber.org/protocol/compress'/>
+ # Both entities MUST now consider the previous stream to be null and void,
+ # just as with TLS negotiation and SASL negotiation
+ # Therefore the initiating entity MUST initiate a new stream to the
+ # receiving entity:
+
+ $jlibname wrapper_reset
+
+ # We must clear out any server info we've received so far.
+ $jlibname stream_reset
+
+ $jlibname set_socket_filter [namespace code out] [namespace code in]
+
+ if {[catch {
+ $jlibname sendstream -version 1.0
+ } err]} {
+ finish $jlibname network-failure $err
+ return
+ }
+ finish $jlibname
+}
+
+# jlib::compress::out, in --
+#
+# Actual compression takes place here.
+# XEP says:
+# When using ZLIB for compression, the sending application SHOULD
+# complete a partial flush of ZLIB when its current send is complete.
+
+proc jlib::compress::out {jlibname data} {
+ upvar ${jlibname}::compress::state state
+
+ $state(compress) put -flush $data
+ return [$state(compress) get]
+}
+
+proc jlib::compress::in {jlibname cdata} {
+ upvar ${jlibname}::compress::state state
+
+ $state(decompress) put $cdata
+ #$state(decompress) flush
+ return [$state(decompress) get]
+}
+
+proc jlib::compress::failure {jlibname xmldata} {
+
+ # puts "jlib::compress::failure"
+
+ set c [wrapper::getchildren $xmldata]
+ if {[llength $c]} {
+ set errcode [wrapper::gettag [lindex $c 0]]
+ } else {
+ set errcode unknown-failure
+ }
+ finish $jlibname $errcode
+}
+
+proc jlib::compress::finish {jlibname {errcode ""} {errmsg ""}} {
+
+ upvar ${jlibname}::compress::state state
+ variable xmlns
+
+ # puts "jlib::compress:finish errcode=$errcode, errmsg=$errmsg"
+
+ # NB: We must keep our state array for the lifetime of the stream.
+ $jlibname trace_stream_features {}
+ $jlibname element_deregister $xmlns(protocol/compress) [namespace code parse]
+
+ if {$errcode ne ""} {
+ uplevel #0 $state(cmd) $jlibname [list $errcode $errmsg]
+ } else {
+ uplevel #0 $state(cmd) $jlibname
+ }
+}
+
+proc jlib::compress::reset {jlibname} {
+
+ upvar ${jlibname}::compress::state state
+
+ # puts "jlib::compress::reset"
+
+ if {[info exists state(compress)]} {
+ $state(compress) close
+ unset state(compress)
+ }
+ if {[info exists state(decompress)]} {
+ $state(decompress) close
+ unset state(decompress)
+ }
+ unset -nocomplain state
+}
+
--- /dev/null
+# connect.tcl --
+#
+# This file is part of the jabberlib.
+# It provides a high level method to handle all the things to establish
+# a connection with a jabber server and do TLS, SASL, and authentication.
+#
+# Copyright (c) 2006-2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: connect.tcl,v 1.39 2008/03/27 15:15:26 matben Exp $
+#
+############################# USAGE ############################################
+#
+# jlib::connect::configure ?options?
+# jlibname connect connect jid password ?options? (constructor)
+# jlibname connect reset
+# jlibname connect register jid password
+# jlibname connect auth
+# jlibname connect free (destructor)
+# jlibname connect feature name
+#
+#### EXECUTION PATHS ###########################################################
+#
+# sections: callback status:
+#
+# o dns lookup (optional) dnsresolve
+# o transport initnetwork
+# o initialize xmpp stream initstream
+# o start tls (optional) starttls
+# o stream compression (untested) startcompress
+# o sasl authentication (or digest or plain) authenticate
+# o final ok | error
+#
+# error tokens:
+#
+# no-stream-id
+# no-stream-version-1
+# network-failure
+# tls-failure
+# starttls-nofeature
+# starttls-failure
+# starttls-protocol-error
+# sasl-no-mechanisms
+# sasl-protocol-error
+#
+# All SASL error elements according to RFC 3920 (XMPP Core)
+# not-authorized being the most common
+#
+# xmpp-streams-error
+#
+# And all stream error tags as defined in "4.7.3. Defined Conditions"
+# in RFC 3920 (XMPP Core) as:
+# xmpp-streams-error-TheTagName
+#
+### From: XEP-0170: Recommended Order of Stream Feature Negotiation ############
+#
+# The XMPP RFCs define an ordering for the features defined therein, namely:
+# 0. TLS
+# 1. SASL
+# 2. Resource binding
+# 3. IM session establishment
+#
+# Using Stream Compression:
+# 0. TLS
+# 1. SASL
+# 2. Stream compression
+# 3. Resource binding
+# 4. IM session establishment
+#
+################################################################################
+#
+# @@@ Note to myself: maybe it would be a good idea to make this more OO
+# like. jlib::connect returns a 'connector' object that is used as
+# an instance for invoking the methods. We make sure that each jlib
+# instance can make at most a single connector object at a time.
+# Make sure that any connector object gets deleted from the jlib
+# instance destructor.
+
+package require jlib
+package require sha1
+package require autosocks ;# wrapper for the 'socket' command.
+package require autoproxy ;# another wrapper for 'socket'
+
+package provide jlib::connect 0.1
+
+namespace eval jlib::connect {
+
+ variable inited 0
+ variable have
+ variable debug 0
+}
+
+proc jlib::connect::init {jlibname} {
+ variable inited
+
+ if {!$inited} {
+ init_static
+ }
+}
+
+proc jlib::connect::cmdproc {jlibname cmd args} {
+
+ # Just dispatch the command to the right procedure.
+ return [eval {$cmd $jlibname} $args]
+}
+
+proc jlib::connect::init_static {} {
+ variable inited
+ variable have
+
+ debug "jlib::connect::init_static"
+
+ # Loop through all packages we may need.
+ foreach name {
+ tls jlibsasl jlibtls
+ jlib::dns jlib::compress jlib::http
+ jlib::bind
+ } {
+ set have($name) 0
+ if {![catch {package require $name}]} {
+ set have($name) 1
+ }
+ }
+
+ autoproxy::init
+
+ # -method: ssl | tlssasl | sasl
+ # -transport tcp | http | tunnel
+
+ # Default options.
+ variable options
+ array set options {
+ -command ""
+ -compress 0
+ -defaulthttpurl http://%h:5280/http-poll/
+ -defaultport 5222
+ -defaultresource "default"
+ -defaultsslport 5223
+ -digest 1
+ -dnsprotocol udp
+ -dnssrv 1
+ -dnstxthttp 1
+ -dnstimeout 3000
+ -http 0
+ -httpurl ""
+ -ip ""
+ -method sasl
+ -minpollsecs 4
+ -noauth 0
+ -port ""
+ -saslthencomp 1
+ -secure 0
+ -timeout 30000
+ -transport tcp
+ }
+
+ # todo:
+ # -anonymous
+ set inited 1
+}
+
+# jlib::connect::filteroptions --
+#
+# Filter an arbitrary -key value list to receive options that can
+# typically be used by a client.
+
+proc jlib::connect::filteroptions {args} {
+ variable options
+
+ set opts [list]
+ foreach {key value} $args {
+ if {$key eq "-command"} { continue }
+ if {[info exists options($key)]} {
+ lappend opts $key $value
+ }
+ }
+ return $opts
+}
+
+# jlib::connect::configure --
+#
+#
+
+proc jlib::connect::configure {args} {
+ variable have
+ variable options
+
+ debug "jlib::connect::configure args=$args"
+
+ if {[llength $args] == 0} {
+ return [array get options]
+ } else {
+ foreach {key value} $args {
+ switch -- $key {
+ -compress {
+ if {!$have(jlib::compress)} {
+ return -code error "missing jlib::compress package"
+ }
+ }
+ -http {
+ if {!$have(jlib::http)} {
+ return -code error "missing jlib::http package"
+ }
+ }
+ -method {
+ if {($value eq "ssl") && !$have(tls)} {
+ return -code error "missing tls package"
+ } elseif {($value eq "tlssasl") \
+ && (!$have(jlibtls) || !$have(jlibsasl))} {
+ return -code error "missing jlibtls or jlibsasl package"
+ } elseif {($value eq "sasl") && !$have(jlibsasl)} {
+ return -code error "missing jlibsasl package"
+ }
+ }
+ -port {
+ if {![string is integer $state(-port)]} {
+ return -code error "the -port must be an integer"
+ }
+ }
+ }
+ set options($key) $value
+ }
+ }
+}
+
+proc jlib::connect::get_state {jlibname {name ""}} {
+ upvar ${jlibname}::connect::state state
+
+ if {$name eq ""} {
+ return [array get state]
+ } else {
+ if {[info exists state($name)]} {
+ return $state($name)
+ } else {
+ return ""
+ }
+ }
+}
+
+# jlib::connect::connect --
+#
+# Initiate the login process.
+#
+# Arguments:
+# jid
+# password
+# cmd callback command
+# args:
+# -command tclProc
+# -compress 0|1
+# -defaulthttpurl url
+# -defaultport 5222
+# -defaultresource
+# -defaultsslport 5223
+# -digest 0|1
+# -dnsprotocol tcp[udp
+# -dnssrv 0|1
+# -dnstxthttp 0|1
+# -dnstimeout millisecs
+# -http 0|1
+# -httpurl url
+# -ip
+# -secure 0|1 @@@ Change this to -xmpp ?
+# -method ssl|tlssasl|sasl
+# -noauth 0|1
+# -port
+# -saslthencomp 0|1 This is the normal order for compression
+# -timeout millisecs
+# -transport tcp|http|tunnel
+#
+# o Note the naming convention for -method!
+# ssl using direct tls socket connection
+# it corresponds to the original jabber method
+# tlssasl in stream tls negotiation + sasl, xmpp compliant
+# XMPP requires sasl after starttls!
+# sasl only sasl authentication
+#
+# o @@@ Perhaps a better way is to use a -xmpp switch that sets
+# the main mode of operation, and then use whatever as sub switches.
+#
+# o The http proxy is configured from the http package.
+# o The SOCKS proxy is configured from the autosocks package.
+#
+# Port priorites:
+# 1) -port
+# 2) DNS SRV resource record
+# 3) -defaultport
+#
+# Results:
+# jlibname
+
+proc jlib::connect::connect {jlibname jid password args} {
+ variable have
+ variable options
+
+ debug "jlib::connect::connect jid=$jid, args=$args"
+
+ # Instance specific namespace.
+ # 'state' only lives until connection finalized
+ # 'feature' lives until stream is closed
+
+ namespace eval ${jlibname}::connect {
+ variable state
+ variable feature
+ }
+ upvar ${jlibname}::connect::state state
+ upvar ${jlibname}::connect::feature feature
+
+ $jlibname register_reset [namespace code stream_reset]
+
+ jlib::splitjidex $jid username server resource
+
+ # Notes:
+ # o use "coccinella" as default resource
+ # o state(host) is the DNS SRV record or server if DNS failed
+ # o set one timeout on the complete sequence
+
+ set state(jid) $jid
+ set state(username) $username
+ set state(server) $server
+ set state(host) $server
+ set state(resource) $resource
+ set state(password) $password
+ set state(args) $args
+ set state(error) ""
+ set state(state) ""
+ set state(httpurl) ""
+ set state(dns_srv) [list] ; # list of {host port} DNS TXT records
+ set state(dns_srv_idx) 0 ; # index of dns_srv currently tried
+
+ foreach name {ssl tls sasl compress} {
+ set state(use$name) 0
+ set feature($name) 0
+ }
+
+ # Default options.
+ array set state [array get options]
+ array set state $args
+
+ if {$resource eq ""} {
+ set state(resource) $state(-defaultresource)
+ }
+
+ # Verify that we have the necessary packages.
+ if {[catch {verify $jlibname} err]} {
+ return -code error $err
+ }
+
+ if {$state(-http)} {
+ set state(-transport) http
+ }
+ if {$state(-secure)} {
+ switch -- $state(-method) {
+ sasl {
+ set state(usesasl) 1
+ }
+ tlssasl {
+ set state(usesasl) 1
+ set state(usetls) 1
+ }
+ ssl {
+ set state(usessl) 1
+ }
+ }
+ if {$state(-compress)} {
+ set state(usecompress) 1
+ }
+ }
+ if {$state(-compress) && ($state(usetls) || $state(usessl))} {
+ #return -code error "connot have -compress and tls at the same time"
+ }
+
+ # Any stream version. XMPP requires 1.0.
+ if {$state(usesasl) || $state(usetls) || $state(usecompress)} {
+ set state(version) 1.0
+ }
+
+ if {$state(-ip) ne ""} {
+ set state(host) $state(-ip)
+ }
+
+ # Actual port to connect to (tcp).
+ # May be changed by DNS lookup unless -port set.
+ if {[string is integer -strict $state(-port)]} {
+ set state(port) $state(-port)
+ } else {
+ if {$state(usessl)} {
+ set state(port) $state(-defaultsslport)
+ } else {
+ set state(port) $state(-defaultport)
+ }
+ }
+
+ # Schedule a timeout.
+ if {$state(-timeout) > 0} {
+ set state(after) [after $state(-timeout) \
+ [list jlib::connect::timeout $jlibname]]
+ }
+
+ # Start by doing a DNS lookup.
+ if {$state(-transport) eq "tcp" || $state(-transport) eq "tunnel"} {
+
+ # Do not do a DNS SRV lookup if we have an explicit ip address.
+ if {!$state(-dnssrv) || ($state(-ip) ne "")} {
+ tcp_connect $jlibname
+ } else {
+ set state(state) dnsresolve
+ set cb [list jlib::connect::dns_srv_cb $jlibname]
+ if {$state(-command) ne {}} {
+ uplevel #0 $state(-command) $jlibname dnsresolve
+ }
+ if {[catch {
+ set state(dnstoken) [jlib::dns::get_addr_port $server $cb \
+ -protocol $state(-dnsprotocol) -timeout $state(-dnstimeout)]
+ } err]} {
+ # @@@ We should reset the jlib::dns here but it's buggy!
+ unset -nocomplain state(dnstoken)
+ tcp_connect $jlibname
+ }
+ }
+ } elseif {$state(-transport) eq "http"} {
+
+ # Do not do a DNS TXT lookup if we have an explicit url address.
+ if {!$state(-dnstxthttp) || ($state(-httpurl) ne "")} {
+ set state(httpurl) $state(-httpurl)
+ http_init $jlibname
+ } else {
+ set state(state) dnsresolve
+ set cb [list jlib::connect::dns_http_cb $jlibname]
+ if {$state(-command) ne {}} {
+ uplevel #0 $state(-command) $jlibname dnsresolve
+ }
+ if {[catch {
+ set state(dnstoken) [jlib::dns::get_http_poll_url $server $cb]
+ } err]} {
+ # @@@ We should reset the jlib::dns here but it's buggy!
+ unset -nocomplain state(dnstoken)
+ http_init $jlibname
+ }
+ }
+ }
+ jlib::set_async_error_handler $jlibname [namespace code async_error]
+
+ return $jlibname
+}
+
+proc jlib::connect::verify {jlibname} {
+ variable have
+ upvar ${jlibname}::connect::state state
+
+ if {$state(-secure)} {
+ if {($state(-method) eq "sasl") && !$have(jlibsasl)} {
+ return -code error "missing jlibsasl package"
+ }
+ if {($state(-method) eq "ssl") && !$have(tls)} {
+ return -code error "missing tls package"
+ }
+ if {($state(-method) eq "tlssasl") \
+ && (!$have(jlibtls) || !$have(jlibsasl))} {
+ return -code error "missing jlibtls or jlibsasl package"
+ }
+ }
+ if {$state(-compress) && !$have(jlib::compress)} {
+ return -code error "missing jlib::compress package"
+ }
+}
+
+proc jlib::connect::async_error {jlibname err {msg ""}} {
+ upvar ${jlibname}::connect::state state
+
+ finish $jlibname $err $msg
+}
+
+# jlib::connect::dns_srv_cb --
+#
+# This is our callback from the jlib::dns call.
+#
+# addrPort: {{soumar.jabbim.cz 5222} {nezmar.jabbim.cz 5222} ...}
+
+proc jlib::connect::dns_srv_cb {jlibname addrPort {err ""}} {
+ upvar ${jlibname}::connect::state state
+
+ debug "jlib::connect::dns_srv_cb addrPort=$addrPort, err=$err"
+
+ if {![info exists state(state)]} {
+ # We do not exist. dns::reset seems to be buggy!
+ return
+ }
+
+ # dns doesn't seem to use the 'err' argument in this case.
+ set status [::dns::status $state(dnstoken)]
+ if {$status eq "reset"} {
+ return
+ }
+
+ # We never let a failure stop us here. Use host as fallback.
+ if {$err eq ""} {
+ set state(host) [lindex $addrPort 0 0]
+ set state(port) [lindex $addrPort 0 1]
+
+ # Collect multiple DNS TXT record responses so we may try them in order.
+ set state(dns_srv) $addrPort
+ set state(dns_srv_idx) 0
+
+ # Try ad-hoc method for port number for ssl connections (5223).
+ if {$state(usessl)} {
+ incr state(port)
+ }
+ }
+
+ # If -port set this always takes precedence.
+ if {[string is integer -strict $state(-port)]} {
+ set state(port) $state(-port)
+ }
+ unset -nocomplain state(dnstoken)
+ tcp_connect $jlibname
+}
+
+proc jlib::connect::dns_http_cb {jlibname url {err ""}} {
+ upvar ${jlibname}::connect::state state
+
+ debug "jlib::connect::dns_http_cb url=$url, err=$err"
+
+ if {![info exists state(state)]} {
+ # We do not exist. dns::reset seems to be buggy!
+ return
+ }
+
+ # dns doesn't seem to use the 'err' argument in this case.
+ set status [::dns::status $state(dnstoken)]
+ if {$status eq "reset"} {
+ return
+ }
+ unset -nocomplain state(dnstoken)
+ if {$err eq ""} {
+ set state(httpurl) $url
+ }
+
+ # If -httpurl set this always takes precedence.
+ if {$state(-httpurl) ne ""} {
+ set state(httpurl) $state(-httpurl)
+ }
+ http_init $jlibname
+}
+
+proc jlib::connect::http_init {jlibname} {
+ upvar ${jlibname}::connect::state state
+
+ debug "jlib::connect::http_init"
+
+ if {$state(httpurl) eq ""} {
+ set state(httpurl) \
+ [string map [list "%h" $state(server)] $state(-defaulthttpurl)]
+ }
+ jlib::http::new $jlibname $state(httpurl)
+ init_stream $jlibname
+}
+
+proc jlib::connect::tunnel_connect {jlibname} {
+ upvar ${jlibname}::connect::state state
+
+ debug "jlib::connect::tunnel_connect $state(host) $state(port)"
+
+ set state(state) initnetwork
+ if {$state(-command) ne {}} {
+ uplevel #0 $state(-command) $jlibname initnetwork
+ }
+ if {[catch {
+ set state(sock) [autoproxy::tunnel_connect $state(host) $state(port)]
+ tcp_writable $jlibname
+ } err]} {
+ puts stderr $::errorInfo
+ finish $jlibname network-failure $err
+ }
+}
+
+# jlib::connect::tcp_connect --
+#
+# Try make a TCP connection to state(host/port).
+
+proc jlib::connect::tcp_connect {jlibname} {
+ upvar ${jlibname}::connect::state state
+
+ if {$state(-transport) eq "tunnel"} {
+ return [tunnel_connect $jlibname]
+ }
+
+ debug "jlib::connect::tcp_connect $state(host) $state(port)"
+
+ set state(state) initnetwork
+ if {$state(-command) ne {}} {
+ uplevel #0 $state(-command) $jlibname initnetwork
+ }
+ if {[catch {
+ set state(sock) [autosocks::socket $state(host) $state(port) \
+ -command [list jlib::connect::tcp_cb $jlibname]]
+ } err]} {
+ tcp_cb $jlibname network-failure
+ }
+}
+
+proc jlib::connect::tcp_cb {jlibname status} {
+ upvar ${jlibname}::connect::state state
+
+ debug "jlib::connect::tcp_cb status=$status"
+
+ # If we have multiple DNS TXT records try them in order.
+ if {$status eq "ok"} {
+ tcp_writable $jlibname
+ } else {
+ set len [llength $state(dns_srv)]
+ set idx $state(dns_srv_idx)
+ if {$len && ($idx < [expr {$len-1}])} {
+ incr idx
+ set state(dns_srv_idx) $idx
+ set state(host) [lindex $state(dns_srv) $idx 0]
+ set state(port) [lindex $state(dns_srv) $idx 1]
+
+ # If -port set this always takes precedence.
+ if {[string is integer -strict $state(-port)]} {
+ set state(port) $state(-port)
+ }
+ tcp_connect $jlibname
+ } else {
+ finish $jlibname network-failure
+ }
+ }
+}
+
+proc jlib::connect::socks_cb {jlibname status} {
+
+ debug "jlib::connect::socks_cb status=$status"
+
+ if {$status eq "ok"} {
+ tcp_writable $jlibname
+ } else {
+ finish $jlibname proxy-failure $status
+ }
+}
+
+proc jlib::connect::tcp_writable {jlibname} {
+ upvar ${jlibname}::connect::state state
+
+ debug "jlib::connect::tcp_writable"
+
+ if {![info exists state(sock)]} {
+ return
+ }
+ set sock $state(sock)
+ fileevent $sock writable {}
+
+ if {[catch {eof $sock} iseof] || $iseof} {
+ finish $jlibname network-failure "connection eof"
+ return
+ }
+
+ # Check if something went wrong first.
+ if {[catch {fconfigure $sock -sockname} sockname]} {
+ finish $jlibname network-failure $sockname
+ return
+ }
+
+ # Configure socket.
+ fconfigure $sock -buffering line -blocking 0
+ catch {fconfigure $sock -encoding utf-8}
+
+ $jlibname setsockettransport $sock
+
+ # Do SSL handshake. See jlib::tls_handshake for a better way!
+ if {$state(usessl)} {
+
+ # Make it a SSL connection.
+ if {[catch {
+ tls::import $sock -cafile "" -certfile "" -keyfile "" \
+ -request 1 -server 0 -require 0 -ssl2 no -ssl3 yes -tls1 yes
+ } err]} {
+ close $sock
+ finish $jlibname tls-failure $err
+ return
+ }
+ set retry 0
+
+ # Do SSL handshake.
+ while {1} {
+ if {$retry > 100} {
+ close $sock
+ set err "too long retry to setup SSL connection"
+ finish $jlibname tls-failure $err
+ return
+ }
+ if {[catch {tls::handshake $sock} err]} {
+ if {[string match "*resource temporarily unavailable*" $err]} {
+ after 50
+ incr retry
+ } else {
+ close $sock
+ finish $jlibname tls-failure $err
+ return
+ }
+ } else {
+ break
+ }
+ }
+ fconfigure $sock -blocking 0 -encoding utf-8
+ }
+
+ # Send the init stream xml command.
+ init_stream $jlibname
+}
+
+proc jlib::connect::init_stream {jlibname} {
+ upvar ${jlibname}::connect::state state
+
+ debug "jlib::connect::init_stream"
+
+ set state(state) initstream
+ if {$state(-command) ne {}} {
+ uplevel #0 $state(-command) $jlibname initstream
+ }
+
+ set opts [list]
+ if {[info exists state(version)]} {
+ lappend opts -version $state(version)
+ }
+
+ # Initiate a new stream. We should wait for the server <stream>.
+ # openstream may throw error.
+ if {[catch {
+ eval {$jlibname openstream $state(server) \
+ -cmd [list jlib::connect::init_stream_cb]} $opts
+ } err]} {
+ finish $jlibname network-failure $err
+ return
+ }
+}
+
+proc jlib::connect::init_stream_cb {jlibname args} {
+ upvar ${jlibname}::connect::state state
+
+ if {![info exists state]} return
+
+ debug "jlib::connect::init_stream_cb args=$args"
+
+ array set argsA $args
+
+ # We require an 'id' attribute.
+ if {![info exists argsA(id)]} {
+ finish $jlibname no-stream-id
+ return
+ }
+ set state(streamid) $argsA(id)
+
+ # If we are trying to use sasl or tls indicated by version='1.0'
+ # we must also be sure to receive a version attribute larger or
+ # equal to 1.0.
+ set version1 0
+ if {[info exists argsA(version)]} {
+ set state(streamversion) $argsA(version)
+ if {[package vcompare $argsA(version) 1.0] >= 0} {
+ set version1 1
+ }
+ }
+ if {$state(usesasl) || $state(usetls)} {
+ if {!$version1} {
+ finish $jlibname no-stream-version-1
+ return
+ }
+ }
+
+ # This XEP is superseeded by XEP-0170
+ # XEP-0138: Stream Compression:
+ # If both TLS (whether including TLS compression or not) and stream
+ # compression are used, then TLS MUST be negotiated first, followed by
+ # negotiation of stream compression.
+
+ if {$state(usetls)} {
+ set state(state) starttls
+ if {$state(-command) ne {}} {
+ uplevel #0 $state(-command) $jlibname starttls
+ }
+ $jlibname starttls jlib::connect::starttls_cb
+
+ # This is the order ejabberd expects, compression before sasl.
+ } elseif {!$state(-saslthencomp) && $state(usecompress)} {
+ if {$state(-command) ne {}} {
+ uplevel #0 $state(-command) $jlibname startcompress
+ }
+ jlib::compress::start $jlibname [namespace code compress_cb]
+ } elseif {$state(-noauth)} {
+ finish $jlibname
+ } else {
+ auth $jlibname
+ }
+}
+
+proc jlib::connect::starttls_cb {jlibname type args} {
+ upvar ${jlibname}::connect::state state
+
+ if {![info exists state]} return
+
+ debug "jlib::connect::starttls_cb type=$type, args=$args"
+
+ if {$type eq "error"} {
+ foreach {errcode errmsg} [lindex $args 0] break
+ finish $jlibname $errcode $errmsg
+ } else {
+
+ # We have a new stream. XMPP Core:
+ # 12. If the TLS negotiation is successful, the initiating entity
+ # MUST continue with SASL negotiation.
+ set state(streamid) [$jlibname getstreamattr id]
+ if {$state(-noauth)} {
+ finish $jlibname
+ } else {
+ auth $jlibname
+ }
+ }
+}
+
+# jlib::connect::register --
+#
+# Typically used after registered a new account since JID and password
+# not known until registration succesful.
+
+proc jlib::connect::register {jlibname jid password} {
+ upvar ${jlibname}::connect::state state
+
+ jlib::splitjidex $jid username server resource
+
+ set state(jid) $jid
+ set state(username) $username
+ set state(password) $password
+ if {$resource eq ""} {
+ set state(resource) $state(-defaultresource)
+ }
+}
+
+# jlib::connect::auth --
+#
+# Initiates the authentication process using an existing connect instance,
+# typically when started using -noauth.
+# The user can modify the options from the initial ones.
+
+proc jlib::connect::auth {jlibname args} {
+ upvar ${jlibname}::connect::state state
+
+ debug "jlib::connect::auth"
+
+ array set state $args
+
+ if {[catch {verify $jlibname} err]} {
+ return -code error $err
+ }
+ set state(state) authenticate
+ if {$state(-command) ne {}} {
+ uplevel #0 $state(-command) $jlibname authenticate
+ }
+
+ set username $state(username)
+ set password $state(password)
+ set resource $state(resource)
+
+ if {$state(usesasl)} {
+ $jlibname auth_sasl $username $resource $password \
+ [namespace code auth_cb]
+ } elseif {$state(-digest)} {
+ set digested [::sha1::sha1 $state(streamid)$password]
+ $jlibname send_auth $username $resource \
+ [namespace code auth_cb] -digest $digested
+ } else {
+
+ # Plain password authentication.
+ $jlibname send_auth $username $resource \
+ [namespace code auth_cb] -password $password
+ }
+}
+
+proc jlib::connect::auth_cb {jlibname type queryE} {
+ upvar ${jlibname}::connect::state state
+
+ if {![info exists state]} return
+
+ debug "jlib::connect::auth_cb type=$type, queryE=$queryE"
+
+ if {$type eq "error"} {
+ lassign $queryE errcode errmsg
+ finish $jlibname $errcode $errmsg
+ } else {
+
+ # We have a new stream.
+ set state(streamid) [$jlibname getstreamattr id]
+ if {$state(-saslthencomp) && $state(usecompress)} {
+ if {$state(-command) ne {}} {
+ uplevel #0 $state(-command) $jlibname startcompress
+ }
+ jlib::compress::start $jlibname [namespace code compress_cb]
+ } elseif {$state(usesasl)} {
+ jlib::bind::resource $jlibname $state(resource) [namespace code bind_cb]
+ } else {
+ finish $jlibname
+ }
+ }
+}
+
+proc jlib::connect::compress_cb {jlibname {errcode ""} {errmsg ""}} {
+ upvar ${jlibname}::connect::state state
+
+ if {![info exists state]} return
+
+ debug "jlib::connect::compress_cb"
+
+ # Note: Failure of compression setup SHOULD NOT be treated as an
+ # unrecoverable error and therefore SHOULD NOT result in a stream error.
+ if {$errcode ne ""} {
+ finish $jlibname $errcode $errmsg
+ return
+ }
+
+ # We have a new stream.
+ set state(streamid) [$jlibname getstreamattr id]
+ if {$state(-saslthencomp)} {
+ jlib::bind::resource $jlibname $state(resource) [namespace code bind_cb]
+ } else {
+
+ # If we have taken compression before SASL then go back.
+ if {$state(-noauth)} {
+ finish $jlibname
+ } else {
+ auth $jlibname
+ }
+ }
+}
+
+proc jlib::connect::bind_cb {jlibname type queryE} {
+
+ debug "jlib::connect::bind_cb"
+
+ if {$type eq "error"} {
+ lassign $queryE errcode errmsg
+ finish $jlibname $errcode $errmsg
+ } else {
+ finish $jlibname
+ }
+}
+
+# jlib::connect::reset --
+#
+# This is kills any ongoing or nonexisting connect object.
+
+proc jlib::connect::reset {jlibname} {
+
+ debug "jlib::connect::reset"
+
+ if {[jlib::havesasl]} {
+ $jlibname sasl_reset
+ }
+ if {[jlib::havetls]} {
+ $jlibname tls_reset
+ }
+ if {[namespace exists ${jlibname}::connect]} {
+ finish $jlibname reset
+ }
+}
+
+proc jlib::connect::timeout {jlibname} {
+
+ if {[jlib::havesasl]} {
+ $jlibname sasl_reset
+ }
+ if {[jlib::havetls]} {
+ $jlibname tls_reset
+ }
+ finish $jlibname timeout
+}
+
+# jlib::connect::finish --
+#
+# Finalize the complete sequence, with or without any errors.
+#
+# Arguments:
+# errcode: one word error code, empty if ok
+# errmsg: an additional arbitrary error message with details that
+# typically gets reported by some component
+#
+# Results:
+# Callback made.
+
+proc jlib::connect::finish {jlibname {errcode ""} {errmsg ""}} {
+ upvar ${jlibname}::connect::state state
+ upvar ${jlibname}::connect::feature feature
+
+ debug "jlib::connect::finish errcode=$errcode, errmsg=$errmsg"
+
+ jlib::set_async_error_handler $jlibname
+
+ if {![info exists state(state)]} {
+ # We do not exist.
+ return
+ }
+ if {[info exists state(after)]} {
+ after cancel $state(after)
+ }
+ if {[info exists state(dnstoken)]} {
+ jlib::dns::reset $state(dnstoken)
+ }
+ if {$state(error) ne ""} {
+ set errcode $state(error)
+ }
+ if {$errcode ne ""} {
+ set status error
+
+ # We can be called before the socket has been registered with jlib.
+ if {[info exists state(sock)]} {
+ catch {close $state(sock)}
+ }
+
+ # This 'kills' the connection. Needed for both tcp and http!
+ # after idle seems necessary when resetting xml parser from callback
+ #after idle [list $jlibname closestream]
+ $jlibname kill
+ } else {
+ set status ok
+
+ # Copy the state(use*) to feature(*)
+ foreach name {ssl tls sasl compress} {
+ set feature($name) $state(use$name)
+ }
+
+ }
+
+ # Here status must be either 'ok' or 'error'.
+ if {$state(-command) ne {}} {
+ if {$errcode eq ""} {
+ uplevel #0 $state(-command) [list $jlibname $status]
+ } else {
+ uplevel #0 $state(-command) [list $jlibname $status $errcode $errmsg]
+ }
+ }
+}
+
+proc jlib::connect::feature {jlibname name} {
+ upvar ${jlibname}::connect::feature feature
+
+ if {[info exists feature($name)]} {
+ return $feature($name)
+ } else {
+ return 0
+ }
+}
+
+proc jlib::connect::free {jlibname} {
+
+ debug "jlib::connect::free"
+ if {[namespace exists ${jlibname}::connect]} {
+ upvar ${jlibname}::connect::state state
+ unset -nocomplain state
+ }
+}
+
+proc jlib::connect::stream_reset {jlibname} {
+ upvar ${jlibname}::connect::feature feature
+ debug "jlib::connect::stream_reset"
+ unset -nocomplain feature
+}
+
+proc jlib::connect::debug {str} {
+ variable debug
+
+ if {$debug} {
+ puts $str
+ }
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::connect {
+
+ jlib::ensamble_register connect \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+# Tests
+if {0} {
+ package require jlib::connect
+ proc cb {args} {
+ puts "---> $args"
+ #puts [jlib::connect::get_state ::jlib::jlib1]
+ }
+ set pw xxx
+ ::jlib::jlib1 connect connect matben@localhost $pw -command cb
+ ::jlib::jlib1 connect connect matben@devrieze.dyndns.org $pw \
+ -command cb -secure 1 -method tlssasl
+
+ ::jlib::jlib1 connect connect matben@sgi.se xxx -command cb \
+ -http 1 -httpurl http://sgi.se:5280/http-poll/
+
+ ::jlib::jlib1 connect connect openfire.matben@sgi.se $pw \
+ -command cb -compress 1 -secure 1 -method sasl
+
+ ::jlib::jlib1 connect connect matben@jabber.ru $pw \
+ -command cb -compress 1 -secure 1 -method sasl
+
+ jlib::jlib1 closestream
+}
+
+#-------------------------------------------------------------------------------
+
--- /dev/null
+# data.tcl --
+#
+# This file is part of the jabberlib. It contains support code
+# for XEP-0231: Data Element
+#
+# Copyright (c) 2008 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: data.tcl,v 1.1 2008/05/30 14:21:02 matben Exp $
+#
+############################# USAGE ############################################
+#
+# INSTANCE COMMANDS
+# jlibName data create
+#
+################################################################################
+
+package require jlib
+package require base64 ; # tcllib
+
+package provide jlib::data 0.1
+
+namespace eval jlib::data {
+
+ # Common xml namespaces.
+ variable xmlns
+ array set xmlns {
+ data "urn:xmpp:tmp:data-element"
+ }
+}
+
+# jlib::data::init --
+#
+# Creates a new instance of the data object.
+
+proc jlib::data::init {jlibname} {
+ variable xmlns
+
+ # Instance specifics arrays.
+ namespace eval ${jlibname}::data {
+ variable cache
+ }
+
+ # Register some standard iq handlers that are handled internally.
+ $jlibname iq_register get $xmlns(data) [namespace code iq_handler]
+}
+
+proc jlib::data::cmdproc {jlibname cmd args} {
+ return [eval {$cmd $jlibname} $args]
+}
+
+proc jlib::data::element {type data args} {
+ variable xmlns
+ upvar ${jlibname}::data::cache cache
+
+ set attrL [list xmlns $xmlns(data)]
+ foreach {key value} $args {
+ -alt - -cid {
+ set name [string trimleft $key -]
+ set $name $value
+ lappend attrL $name $value
+ }
+ }
+ set dataE [wrapper::createtag data \
+ -attrlist $attrL -chdata [::base64::encode $data]]
+ if {[info exists cid]} {
+ set cache($cid) $dataE
+ }
+ return $dataE
+}
+
+proc jlib::data::iq_handler {jlibname from dataE args} {
+ upvar ${jlibname}::data::cache cache
+
+ array set argsA $args
+ if {![info exists argsA(id)]} {
+ return 0
+ }
+ set cid [wrapper::getattribute $dataE cid]
+ if {![info exists cache($cid)]} {
+ # Should be <item-not-found/>
+ return 0
+ }
+
+ $jlibname send_iq result $cache($cid) -to $from -id $id
+ return 1
+}
+
+# We have to do it here since need the initProc before doing this.
+namespace eval jlib::data {
+
+ jlib::ensamble_register data \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+# Test:
+if {0} {
+ package require jlib::data
+ set jlibname ::jlib::jlib1
+
+
+}
+
--- /dev/null
+# disco.tcl --
+#
+# This file is part of the jabberlib.
+#
+# Copyright (c) 2004-2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: disco.tcl,v 1.57 2008/06/11 08:12:05 matben Exp $
+#
+############################# USAGE ############################################
+#
+# NAME
+# disco - convenience command library for the disco part of XMPP.
+#
+# SYNOPSIS
+# jlib::disco::init jlibName ?-opt value ...?
+#
+# OPTIONS
+# -command tclProc
+#
+# INSTANCE COMMANDS
+# jlibname disco children jid
+# jlibname disco childs jid ?node?
+# jlibname disco send_get discotype jid cmd ?-opt value ...?
+# jlibname disco isdiscoed discotype jid ?node?
+# jlibname disco get discotype key jid ?node?
+# jlibname disco getallcategories pattern
+# jlibname disco get_async discotype jid cmd ?-node node?
+# jlibname disco getconferences
+# jlibname disco getjidsforcategory pattern
+# jlibname disco getjidsforfeature feature
+# jlibname disco getxml jid ?node?
+# jlibname disco features jid ?node?
+# jlibname disco hasfeature feature jid ?node?
+# jlibname disco isroom jid
+# jlibname disco iscategorytype category/type jid ?node?
+# jlibname disco name jid ?node?
+# jlibname disco nodes jid ?node?
+# jlibname disco types jid ?node?
+# jlibname disco reset ?jid ?node??
+#
+# where discotype = (items|info)
+#
+################################################################################
+#
+# Structures:
+# items(jid,node,children) list of any children JIDs
+# items(jid,node,childs) list of {JID node}
+#
+# jid must always be nonempty while node may be empty.
+#
+# rooms(jid,node) exists if children of 'conference'
+
+# NEW: In order to manage the complex jid/node structure it is best to
+# keep an internal structure always using a pair JID+node.
+# As array index: ($jid,$node,..) or list of childs:
+# {{JID1 node1} {JID2 node2} ..} where any of JID or node can be
+# empty but not both.
+#
+# This reflects the disco xml structure (node can be empty):
+#
+# JID node
+# JID node
+# JID node
+# ...
+#
+# @@@ While 'parent -> child' is uniquely defined 'parent <- child' is NOT!
+# A certain JID+node can appear in more than one place in the disco tree!
+# It is better to use another data structure to store this.
+
+package require jlib
+
+package provide jlib::disco 0.1
+
+namespace eval jlib::disco {
+
+ # Globals same for all instances of this jlib.
+ variable debug 0
+ if {[info exists ::debugLevel] && ($::debugLevel > 1) && ($debug == 0)} {
+ set debug 2
+ }
+
+ variable version 0.1
+
+ # Common xml namespaces.
+ variable xmlns
+ array set xmlns {
+ disco "http://jabber.org/protocol/disco"
+ items "http://jabber.org/protocol/disco#items"
+ info "http://jabber.org/protocol/disco#info"
+ muc "http://jabber.org/protocol/muc"
+ }
+
+ # Components register their feature elements for disco/info.
+ variable features [list]
+
+ # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::disco::init --
+#
+# Creates a new instance of the disco object.
+#
+# Arguments:
+# jlibname: name of existing jabberlib instance
+# args:
+#
+# Results:
+# namespaced instance command
+
+proc jlib::disco::init {jlibname args} {
+
+ variable xmlns
+
+ # Instance specific arrays.
+ namespace eval ${jlibname}::disco {
+ variable items
+ variable info
+ variable rooms
+ variable handler
+ variable state
+ variable identities [list]
+ }
+ upvar ${jlibname}::disco::items items
+ upvar ${jlibname}::disco::info info
+ upvar ${jlibname}::disco::rooms rooms
+
+ # Register service.
+ $jlibname service register disco disco
+
+ # Register some standard iq handlers that is handled internally.
+ $jlibname iq_register get $xmlns(items) \
+ [list [namespace current]::handle_get items]
+ $jlibname iq_register get $xmlns(info) \
+ [list [namespace current]::handle_get info]
+
+ # Clear any cache info we may have collected since likely invalid offline.
+ $jlibname presence_register_int unavailable [namespace current]::unavail_cb
+
+ # Register our own features.
+ registerfeature $xmlns(disco)
+ registerfeature $xmlns(items)
+ registerfeature $xmlns(info)
+
+ set info(conferences) [list]
+
+ return
+}
+
+# jlib::disco::cmdproc --
+#
+# Just dispatches the command to the right procedure.
+#
+# Arguments:
+# jlibname: name of existing jabberlib instance
+# cmd:
+# args: all args to the cmd procedure.
+#
+# Results:
+# none.
+
+proc jlib::disco::cmdproc {jlibname cmd args} {
+
+ # Which command? Just dispatch the command to the right procedure.
+ return [eval {$cmd $jlibname} $args]
+}
+
+# jlib::disco::registerfeature --
+#
+# @@@ Make instance specific instead!
+#
+# Components register their feature elements for disco#info.
+# Clients must handle this using the disco handler.
+# NB1: This is only for 'basic' features not associated with a caps ext
+# token. Those are handled by jlib::caps::register.
+# NB2: We consider everything inside jlib to be 'basic' but also client
+# level features can be basic.
+# NB3: Features registered here MUST NEVER change within a certain version.
+
+proc jlib::disco::registerfeature {feature} {
+ variable features
+
+ lappend features $feature
+ set features [lsort -unique $features]
+}
+
+proc jlib::disco::getregisteredfeatures {} {
+ variable features
+
+ return $features
+}
+
+# jlib::disco::registeridentity --
+#
+# <identity category='client' type='pc' name='Coccinella'/>
+# as 'category type ?name?'
+
+proc jlib::disco::registeridentity {jlibname category type {name ""}} {
+ upvar ${jlibname}::identities identities
+
+ lappend identities [list $category $type $name]
+}
+
+proc jlib::disco::getidentities {jlibname} {
+ upvar ${jlibname}::identities identities
+
+ return $identities
+}
+
+# jlib::disco::registerhandler --
+#
+# Register handler to deliver incoming disco queries.
+
+proc jlib::disco::registerhandler {jlibname cmdProc} {
+
+ upvar ${jlibname}::disco::handler handler
+
+ set handler $cmdProc
+}
+
+# jlib::disco::send_get --
+#
+# Sends a get request within the disco namespace.
+#
+# Arguments:
+# jlibname: name of existing jabberlib instance
+# type: items|info
+# jid: to jid
+# cmd: callback tcl proc
+# args: -node chdata
+#
+# Results:
+# none.
+
+proc jlib::disco::send_get {jlibname type jid cmd args} {
+
+ variable xmlns
+ upvar ${jlibname}::disco::state state
+
+ set jid [jlib::jidmap $jid]
+ set node ""
+ set opts [list]
+ if {[set idx [lsearch -exact $args -node]] >= 0} {
+ set node [lindex $args [incr idx]]
+ set opts [list -node $node]
+ }
+ set state(pending,$type,$jid,$node) 1
+
+ eval {$jlibname iq_get $xmlns($type) -to $jid \
+ -command [list [namespace current]::send_get_cb $type $jid $cmd]} $opts
+}
+
+# jlib::disco::get_async --
+#
+# Do disco async using 'cmd' callback.
+# If cached it is returned directly using 'cmd', if pending the cmd
+# is invoked when getting result, else we do a send_get.
+
+proc jlib::disco::get_async {jlibname type jid cmd args} {
+
+ upvar ${jlibname}::disco::items items
+ upvar ${jlibname}::disco::info info
+ upvar ${jlibname}::disco::state state
+
+ set jid [jlib::jidmap $jid]
+ set node ""
+ set opts [list]
+ if {[set idx [lsearch -exact $args -node]] >= 0} {
+ set node [lindex $args [incr idx]]
+ set opts [list -node $node]
+ }
+ set var ${type}($jid,$node,xml)
+ if {[info exists $var]} {
+ set xml [set $var]
+ set etype [wrapper::getattribute $xml type]
+
+ # Errors are reported specially!
+ # @@@ BAD!!!
+ if {$etype eq "error"} {
+ set xml [lindex [wrapper::getchildren $xml] 0]
+ }
+ uplevel #0 $cmd [list $jlibname $etype $jid $xml]
+ } elseif {[info exists state(pending,$type,$jid,$node)]} {
+ lappend state(invoke,$type,$jid,$node) $cmd
+ } else {
+ eval {send_get $jlibname $type $jid $cmd} $opts
+ }
+ return
+}
+
+# jlib::disco::send_get_cb --
+#
+# Fills in the internal state arrays, and invokes any callback.
+
+proc jlib::disco::send_get_cb {ditype from cmd jlibname type queryE args} {
+
+ upvar ${jlibname}::disco::items items
+ upvar ${jlibname}::disco::info info
+ upvar ${jlibname}::disco::state state
+
+ # We need to use both jid and any node for addressing since
+ # each item may have identical jid's but different node's.
+
+ # Do STRINGPREP.
+ set from [jlib::jidmap $from]
+ set node [wrapper::getattribute $queryE "node"]
+
+ unset -nocomplain state(pending,$ditype,$from,$node)
+
+ if {[string equal $type "error"]} {
+
+ # Cache xml for later retrieval.
+ set var ${ditype}($from,$node,xml)
+ set $var [eval {getfulliq $type $queryE} $args]
+ } else {
+ switch -- $ditype {
+ items {
+ parse_get_items $jlibname $from $queryE
+ }
+ info {
+ parse_get_info $jlibname $from $queryE
+ }
+ }
+ }
+ invoke_stacked $jlibname $ditype $type $from $queryE
+
+ # Invoke callback for this get.
+ uplevel #0 $cmd [list $jlibname $type $from $queryE] $args
+}
+
+proc jlib::disco::invoke_stacked {jlibname ditype type jid queryE} {
+
+ upvar ${jlibname}::disco::state state
+
+ set node [wrapper::getattribute $queryE "node"]
+ if {[info exists state(invoke,$ditype,$jid,$node)]} {
+ foreach cmd $state(invoke,$ditype,$jid,$node) {
+ uplevel #0 $cmd [list $jlibname $type $jid $queryE]
+ }
+ unset -nocomplain state(invoke,$ditype,$jid,$node)
+ }
+}
+
+proc jlib::disco::getfulliq {type queryE args} {
+
+ # Errors are reported specially!
+ # @@@ BAD!!!
+ # If error queryE is just a two element list {errtag text}
+ set attr [list type $type]
+ foreach {key value} $args {
+ lappend attr [string trimleft $key "-"] $value
+ }
+ return [wrapper::createtag iq -attrlist $attr -subtags [list $queryE]]
+}
+
+# jlib::disco::parse_get_items --
+#
+# Fills the internal records with this disco items query result.
+# There are four parent-childs combinations:
+#
+# (0) JID1
+# JID JID1 != JID
+#
+# (1) JID1
+# JID1+node JID equal
+#
+# (2) JID1+node1
+# JID JID1 != JID
+#
+# (3) JID1+node1
+# JID+node JID1 != JID
+#
+# Typical xml:
+# <iq type='result' ...>
+# <query xmlns='http://jabber.org/protocol/disco#items'
+# node='music'>
+# <item jid='catalog.shakespeare.lit'
+# node='music/A'/>
+# ...
+#
+# Any of the following scenarios is perfectly acceptable:
+#
+# (0) Upon querying an entity (JID1) for items, one receives a list of items
+# that can be addressed as JIDs; each associated item has its own JID,
+# but no such JID equals JID1.
+#
+# (1) Upon querying an entity (JID1) for items, one receives a list of items
+# that cannot be addressed as JIDs; each associated item has its own
+# JID+node, where each JID equals JID1 and each NodeID is unique.
+#
+# (2) Upon querying an entity (JID1+NodeID1) for items, one receives a list
+# of items that can be addressed as JIDs; each associated item has its
+# own JID, but no such JID equals JID1.
+#
+# (3) Upon querying an entity (JID1+NodeID1) for items, one receives a list
+# of items that cannot be addressed as JIDs; each associated item has
+# its own JID+node, but no such JID equals JID1 and each NodeID is
+# unique in the context of the associated JID.
+#
+# In addition, the results MAY also be mixed, so that a query to a JID or a
+# JID+node could yield both (1) items that are addressed as JIDs and (2)
+# items that are addressed as JID+node combinations.
+
+proc jlib::disco::parse_get_items {jlibname from queryE} {
+
+ upvar ${jlibname}::disco::items items
+ upvar ${jlibname}::disco::info info
+ upvar ${jlibname}::disco::rooms rooms
+
+ # Parents node if any.
+ set pnode [wrapper::getattribute $queryE "node"]
+ set pitem [list $from $pnode]
+
+ set items($from,$pnode,xml) [getfulliq result $queryE -from $from]
+ unset -nocomplain items($from,$pnode,children) items($from,$pnode,nodes)
+ unset -nocomplain items($from,$pnode,childs)
+
+ # This is perhaps not a robust way.
+ if {0} {
+ if {![info exists items($from,parent)]} {
+ set items($from,parent) [list]
+ set items($from,parents) [list]
+ }
+ if {![info exists items($from,$pnode,parent2)]} {
+ set items($from,$pnode,parent2) [list]
+ set items($from,$pnode,parents2) [list]
+ }
+ }
+ if {![info exists items($from,$pnode,paL)]} {
+ set items($from,$pnode,paL) [list]
+ }
+
+ # Cache children of category='conference' as rooms.
+ if {[lsearch -exact $info(conferences) $from] >= 0} {
+ set isrooms 1
+ } else {
+ set isrooms 0
+ }
+
+ foreach c [wrapper::getchildren $queryE] {
+ if {![string equal [wrapper::gettag $c] "item"]} {
+ continue
+ }
+ unset -nocomplain attr
+ array set attr [wrapper::getattrlist $c]
+
+ # jid is a required attribute!
+ set jid [jlib::jidmap $attr(jid)]
+ set node ""
+
+ # Children--->
+ # Only 'childs' gives the full picture.
+ if {$jid ne $from} {
+ lappend items($from,$pnode,children) $jid
+ }
+ if {[info exists attr(node)]} {
+
+ # Not two nodes of a jid may be identical. Beware for infinite loops!
+ # We only do some rudimentary check.
+ set node $attr(node)
+ if {[string equal $pnode $node]} {
+ continue
+ }
+ lappend items($from,$pnode,nodes) $node
+ }
+ lappend items($from,$pnode,childs) [list $jid $node]
+
+ # Parents--->
+
+ # Keep list of parents since not unique.
+ lappend items($jid,$node,paL) $pitem
+
+ # Cache the optional attributes.
+ # Any {jid node} must have identical attributes and childrens.
+ foreach key {name action} {
+ if {[info exists attr($key)]} {
+ set items($jid,$node,$key) $attr($key)
+ }
+ }
+ if {$isrooms} {
+ set rooms($jid,$node) 1
+ }
+ }
+}
+
+# jlib::disco::parse_get_info --
+#
+# Fills the internal records with this disco info query result.
+
+proc jlib::disco::parse_get_info {jlibname from queryE} {
+ variable xmlns
+
+ upvar ${jlibname}::disco::items items
+ upvar ${jlibname}::disco::info info
+ upvar ${jlibname}::disco::rooms rooms
+
+ set node [wrapper::getattribute $queryE "node"]
+
+ array unset info [jlib::ESC $from],[jlib::ESC $node],*
+ set info($from,$node,xml) [getfulliq result $queryE -from $from]
+ set isconference 0
+
+ foreach c [wrapper::getchildren $queryE] {
+ unset -nocomplain attr
+ array set attr [wrapper::getattrlist $c]
+
+ # There can be one or many of each 'identity' and 'feature'.
+ switch -- [wrapper::gettag $c] {
+ identity {
+
+ # Each <identity/> element MUST possess 'category' and
+ # 'type' attributes. (category/type)
+ # Each identity element SHOULD have the same name value.
+ #
+ # XEP 0030:
+ # If the hierarchy category is used, every node in the
+ # hierarchy MUST be identified as either a branch or a leaf;
+ # however, since a node MAY have multiple identities, any given
+ # node MAY also possess an identity other than
+ # "hierarchy/branch" or "hierarchy/leaf".
+
+ # Protect for entities which don't follow the rules.
+ if {![info exists attr(category)] || ![info exists attr(type)]} {
+ continue
+ }
+ set category [string tolower $attr(category)]
+ set ctype [string tolower $attr(type)]
+ set name ""
+ if {[info exists attr(name)]} {
+ set name $attr(name)
+ }
+ set info($from,$node,name) $name
+ set cattype $category/$ctype
+ lappend info($from,$node,cattypes) $cattype
+ lappend info($cattype,typelist) $from
+ set info($cattype,typelist) \
+ [lsort -unique $info($cattype,typelist)]
+
+ if {![string match *@* $from]} {
+
+ switch -- $category {
+ conference {
+ lappend info(conferences) $from
+ set isconference 1
+ }
+ }
+ }
+ }
+ feature {
+ set feature $attr(var)
+ lappend info($from,$node,features) $feature
+ lappend info($feature,featurelist) $from
+
+ # Register any groupchat protocol with jlib.
+ # Note that each room also returns gc features; skip!
+ if {![string match *@* $from]} {
+
+ switch -- $feature {
+ "http://jabber.org/protocol/muc" {
+ $jlibname service registergcprotocol $from "muc"
+ }
+ "gc-1.0" {
+ $jlibname service registergcprotocol $from "gc-1.0"
+ }
+ }
+ }
+ }
+ }
+ }
+
+ # If this is a conference be sure to cache any children as rooms.
+ if {$isconference && [info exists items($from,,children)]} {
+ foreach c $items($from,,children) {
+ set rooms($c,) 1
+ }
+ }
+}
+
+proc jlib::disco::isdiscoed {jlibname discotype jid {node ""}} {
+
+ upvar ${jlibname}::disco::items items
+ upvar ${jlibname}::disco::info info
+
+ set jid [jlib::jidmap $jid]
+
+ switch -- $discotype {
+ items {
+ return [info exists items($jid,$node,xml)]
+ }
+ info {
+ return [info exists info($jid,$node,xml)]
+ }
+ }
+}
+
+proc jlib::disco::getxml {jlibname discotype jid {node ""}} {
+ return [get $jlibname $discotype xml $jid $node]
+}
+
+proc jlib::disco::get {jlibname discotype key jid {node ""}} {
+
+ upvar ${jlibname}::disco::items items
+ upvar ${jlibname}::disco::info info
+
+ set jid [jlib::jidmap $jid]
+
+ switch -- $discotype {
+ items {
+ if {[info exists items($jid,$node,$key)]} {
+ return $items($jid,$node,$key)
+ }
+ }
+ info {
+ if {[info exists info($jid,$node,$key)]} {
+ return $info($jid,$node,$key)
+ }
+ }
+ }
+ return
+}
+
+# Both the items and the info elements may have name attributes! Related???
+
+# The login servers jid name attribute is not returned via any items
+# element; only via info/identity element.
+#
+
+proc jlib::disco::name {jlibname jid {node ""}} {
+
+ upvar ${jlibname}::disco::items items
+ upvar ${jlibname}::disco::info info
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists items($jid,$node,name)]} {
+ return $items($jid,$node,name)
+ } elseif {[info exists info($jid,$node,name)]} {
+ return $info($jid,$node,name)
+ } else {
+ return
+ }
+}
+
+# jlib::disco::features --
+#
+# Returns the var attributes of all feature elements for this jid/node.
+
+proc jlib::disco::features {jlibname jid {node ""}} {
+
+ upvar ${jlibname}::disco::info info
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists info($jid,$node,features)]} {
+ return $info($jid,$node,features)
+ } else {
+ return
+ }
+}
+
+# jlib::disco::hasfeature --
+#
+# Returns 1 if the jid/node has the specified feature var.
+
+proc jlib::disco::hasfeature {jlibname feature jid {node ""}} {
+
+ upvar ${jlibname}::disco::info info
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists info($jid,$node,features)]} {
+ set features $info($jid,$node,features)
+ return [expr [lsearch -exact $features $feature] < 0 ? 0 : 1]
+ } else {
+ return 0
+ }
+}
+
+# jlib::disco::types --
+#
+# Returns a list of all category/types of this jid/node.
+
+proc jlib::disco::types {jlibname jid {node ""}} {
+
+ upvar ${jlibname}::disco::info info
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists info($jid,$node,cattypes)]} {
+ return $info($jid,$node,cattypes)
+ } else {
+ return
+ }
+}
+
+# jlib::disco::iscategorytype --
+#
+# Search for any matching feature var glob pattern.
+
+proc jlib::disco::iscategorytype {jlibname cattype jid {node ""}} {
+
+ upvar ${jlibname}::disco::info info
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists info($jid,$node,cattypes)]} {
+ set types $info($jid,$node,cattypes)
+ return [expr [lsearch -glob $types $cattype] < 0 ? 0 : 1]
+ } else {
+ return 0
+ }
+}
+
+# jlib::disco::getjidsforfeature --
+#
+# Returns a list of all jids that support the specified feature.
+
+proc jlib::disco::getjidsforfeature {jlibname feature} {
+
+ upvar ${jlibname}::disco::info info
+
+ if {[info exists info($feature,featurelist)]} {
+ set info($feature,featurelist) [lsort -unique $info($feature,featurelist)]
+ return $info($feature,featurelist)
+ } else {
+ return
+ }
+}
+
+# jlib::disco::getjidsforcategory --
+#
+# Returns all jids that match the glob pattern category/type.
+#
+# Arguments:
+# jlibname: name of existing jabberlib instance
+# pattern: a global pattern of jid type/subtype (gateway/*).
+#
+# Results:
+# List of jid's matching the type pattern. nodes???
+
+proc jlib::disco::getjidsforcategory {jlibname pattern} {
+
+ upvar ${jlibname}::disco::info info
+
+ set jidL [list]
+ foreach {key jids} [array get info "$pattern,typelist"] {
+ set jidL [concat $jidL $jids]
+ }
+ return $jidL
+}
+
+# jlib::disco::getallcategories --
+#
+# Returns all categories that match the glob pattern catpattern.
+#
+# Arguments:
+# jlibname: name of existing jabberlib instance
+# pattern: a global pattern of jid type/subtype (gateway/*).
+#
+# Results:
+# List of types matching the category/type pattern.
+
+proc jlib::disco::getallcategories {jlibname pattern} {
+
+ upvar ${jlibname}::disco::info info
+
+ set cattypes [list]
+ foreach {key jids} [array get info "$pattern,typelist"] {
+ lappend cattypes [string map {,typelist ""} $key]
+ }
+ return [lsort -unique $cattypes]
+}
+
+proc jlib::disco::getconferences {jlibname} {
+
+ upvar ${jlibname}::disco::info info
+
+ return [lsort -unique $info(conferences)]
+}
+
+# jlib::disco::isroom --
+#
+# Room or not? The problem is that some components, notably some
+# msn gateways, have multiple categories, gateway and conference. BAD!
+# We therefore use a specific 'rooms' array.
+
+proc jlib::disco::isroom {jlibname jid} {
+
+ upvar ${jlibname}::disco::rooms rooms
+
+ if {[info exists rooms($jid,)]} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# jlib::disco::children --
+#
+# Returns a list of all child jids of this jid.
+
+proc jlib::disco::children {jlibname jid} {
+
+ upvar ${jlibname}::disco::items items
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists items($jid,,children)]} {
+ return $items($jid,,children)
+ } else {
+ return
+ }
+}
+
+proc jlib::disco::childs {jlibname jid {node ""}} {
+
+ upvar ${jlibname}::disco::items items
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists items($jid,$node,childs)]} {
+ return $items($jid,$node,childs)
+ } else {
+ return
+ }
+}
+
+# jlib::disco::nodes --
+#
+# Returns a list of child nodes of this jid|node.
+
+proc jlib::disco::nodes {jlibname jid {node ""}} {
+
+ upvar ${jlibname}::disco::items items
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists items($jid,$node,nodes)]} {
+ return $items($jid,$node,nodes)
+ } else {
+ return
+ }
+}
+
+proc jlib::disco::handle_get {discotype jlibname from queryE args} {
+
+ upvar ${jlibname}::disco::handler handler
+
+ set ishandled 0
+ if {[info exists handler]} {
+ set ishandled [uplevel #0 $handler \
+ [list $jlibname $discotype $from $queryE] $args]
+ }
+ return $ishandled
+}
+
+# jlib::disco::unavail_cb --
+#
+# Registered unavailable presence callback.
+# Frees internal cache related to this jid.
+
+proc jlib::disco::unavail_cb {jlibname xmldata} {
+
+ # This screws up gateway handling completely since a gateway is still
+ # a gateway even if unavailable!
+ # @@@ Perhaps we shall make a distinction here between ordinary users
+ # and services?
+ #set jid [wrapper::getattribute $xmldata from]
+ #reset $jlibname $jid
+}
+
+# jlib::disco::reset --
+#
+# Clear this particular jid and all its children.
+
+proc jlib::disco::reset {jlibname {jid ""} {node ""}} {
+
+ upvar ${jlibname}::disco::items items
+ upvar ${jlibname}::disco::info info
+ upvar ${jlibname}::disco::rooms rooms
+
+ if {($jid eq "") && ($node eq "")} {
+ array unset items
+ array unset info
+ array unset rooms
+
+ set info(conferences) [list]
+ } else {
+ set jid [jlib::jidmap $jid]
+
+ # Can be problems with this (ICQ) ???
+ if {[info exists items($jid,,children)]} {
+ foreach child $items($jid,,children) {
+ ResetJid $jlibname $child
+ }
+ }
+ ResetJid $jlibname $jid
+ }
+}
+
+# jlib::disco::ResetJid --
+#
+# Clear only this particular jid.
+
+proc jlib::disco::ResetJid {jlibname jid} {
+
+ upvar ${jlibname}::disco::items items
+ upvar ${jlibname}::disco::info info
+ upvar ${jlibname}::disco::rooms rooms
+
+ if {$jid eq ""} {
+ unset -nocomplain items info rooms
+ set info(conferences) [list]
+ } else {
+
+ if {0} {
+
+ # Keep parents!
+
+ if {[info exists items($jid,parent)]} {
+ set parent $items($jid,parent)
+ }
+ if {[info exists items($jid,parents)]} {
+ set parents $items($jid,parents)
+ }
+
+ if {[info exists items($jid,,parent2)]} {
+ set parent2 $items($jid,,parent2)
+ }
+ if {[info exists items($jid,,parents2)]} {
+ set parents2 $items($jid,,parents2)
+ }
+
+ }
+
+ array unset items [jlib::ESC $jid],*
+ array unset info [jlib::ESC $jid],*
+ array unset rooms [jlib::ESC $jid],*
+
+ if {0} {
+
+ # Add back parent(s).
+ if {[info exists parent]} {
+ set items($jid,parent) $parent
+ }
+ if {[info exists parents]} {
+ set items($jid,parents) $parents
+ }
+
+ if {[info exists parent2]} {
+ set items($jid,,parent2) $parent2
+ }
+ if {[info exists parents2]} {
+ set items($jid,,parents2) $parents2
+ }
+
+ }
+
+ # Rest.
+ foreach {key value} [array get info "*,typelist"] {
+ set info($key) [lsearch -all -not -inline -exact $value $jid]
+ }
+ foreach {key value} [array get info "*,featurelist"] {
+ set info($key) [lsearch -all -not -inline -exact $value $jid]
+ }
+ }
+}
+
+proc jlib::disco::Debug {num str} {
+ variable debug
+ if {$num <= $debug} {
+ puts $str
+ }
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::disco {
+
+ jlib::ensamble_register disco \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# ftrans.tcl --
+#
+# This file is part of the jabberlib.
+# It provides support for the file-transfer profile (XEP-0096).
+#
+# Copyright (c) 2005-2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: ftrans.tcl,v 1.31 2008/02/10 09:43:22 matben Exp $
+#
+############################# USAGE ############################################
+#
+# NAME
+# filetransfer - convenience library for the file-transfer profile of si.
+#
+# SYNOPSIS
+#
+#
+# OPTIONS
+#
+#
+# INSTANCE COMMANDS
+# jlibName filetransfer send jid tclProc \
+# -progress, -description, -date, -hash, -block-size, -mime
+# jlibName filetransfer reset sid
+# jlibName filetransfer ifree sid
+#
+############################# CHANGES ##########################################
+
+package require jlib
+package require jlib::si
+package require jlib::disco
+
+package provide jlib::ftrans 0.1
+
+namespace eval jlib::ftrans {
+
+ variable xmlns
+ set xmlns(ftrans) "http://jabber.org/protocol/si/profile/file-transfer"
+
+ # Our target handlers.
+ jlib::si::registerprofile $xmlns(ftrans) \
+ [namespace current]::open_handler \
+ [namespace current]::recv \
+ [namespace current]::close_handler
+
+ # This is our reader commands when the transport sends off data
+ # on the network.
+ jlib::si::registerreader $xmlns(ftrans) \
+ [namespace current]::open_data \
+ [namespace current]::read_data \
+ [namespace current]::close_data
+
+ jlib::disco::registerfeature $xmlns(ftrans)
+
+ # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::ftrans::registerhandler --
+#
+# An application using file-transfer must register here to get a call
+# when we receive a file-transfer query.
+
+proc jlib::ftrans::registerhandler {clientProc} {
+ variable handler
+ set handler $clientProc
+}
+
+proc jlib::ftrans::init {jlibname args} {
+
+ # Keep different state arrays for initiator (i) and receiver (r).
+ namespace eval ${jlibname}::ftrans {
+ variable istate
+ variable tstate
+ }
+
+ # Register this feature with disco.
+}
+
+# jlib::ftrans::cmdproc --
+#
+# Just dispatches the command to the right procedure.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# cmd:
+# args: all args to the cmd procedure.
+#
+# Results:
+# none.
+
+proc jlib::ftrans::cmdproc {jlibname cmd args} {
+ return [eval {$cmd $jlibname} $args]
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions used by the initiator (sender).
+
+# jlib::ftrans::send --
+#
+# High level interface to the file-transfer profile for si.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid:
+# args:
+#
+# Results:
+# sid to identify this transaction.
+
+proc jlib::ftrans::send {jlibname jid cmd args} {
+ variable xmlns
+ upvar ${jlibname}::ftrans::istate istate
+ #puts "jlib::ftrans::send $args"
+
+ set sid [jlib::util::from args -sid [jlib::generateuuid]]
+ set fileE [eval {i_constructor $jlibname $sid $jid $cmd} $args]
+
+ # The 'block-size' is crucial here; must tell the stream in question.
+ set cmd [namespace current]::open_cb
+ jlib::si::send_set $jlibname $jid $sid $istate($sid,-mime) $xmlns(ftrans) \
+ $fileE $cmd -block-size $istate($sid,-block-size)
+
+ return $sid
+}
+
+# jlib::ftrans::i_constructor --
+#
+# This is the initiator constructor of a file transfer object.
+# Makes a new ftrans instance but doesn't do any networking.
+#
+# Results:
+# The file element.
+
+proc jlib::ftrans::i_constructor {jlibname sid jid cmd args} {
+ variable xmlns
+ upvar ${jlibname}::ftrans::istate istate
+
+ # 4096 is the recommended block-size
+ array set opts {
+ -progress ""
+ -block-size 4096
+ -mime application/octet-stream
+ }
+ array set opts $args
+ if {![info exists opts(-data)] \
+ && ![info exists opts(-file)] \
+ && ![info exists opts(-base64)]} {
+ return -code error "must have any of -data, -file, or -base64"
+ }
+ #puts "jlib::ftrans::i_constructor (i) $args"
+
+ # @@@ TODO
+ if {![info exists opts(-file)]} {return -code error "todo"}
+
+ switch -- [info exists opts(-base64)],[info exists opts(-data)],[info exists opts(-file)] {
+ 1,0,0 {
+ set dtype base64
+ set size [string length $opts(-base64)]
+ }
+ 0,1,0 {
+ set dtype data
+ set size [string length $opts(-data)]
+ }
+ 0,0,1 {
+ set dtype file
+ set fileName $opts(-file)
+ if {![file readable $fileName]} {
+ return -code error "file \"$fileName\" is not readable"
+ }
+
+ # File open is not done until we get the 'open_cb'.
+ set size [file size $fileName]
+ set name [file tail $fileName]
+ }
+ default {
+ return -code error "must have exactly one of -data, -file, or -base64"
+ }
+ }
+ set istate($sid,sid) $sid
+ set istate($sid,jid) $jid
+ set istate($sid,cmd) $cmd
+ set istate($sid,dtype) $dtype
+ set istate($sid,size) $size
+ set istate($sid,status) ""
+ set istate($sid,bytes) 0
+ foreach {key value} [array get opts] {
+ set istate($sid,$key) $value
+ }
+ switch -- $dtype {
+ file {
+ set istate($sid,name) $name
+ set istate($sid,fileName) $fileName
+ }
+ }
+
+ return [eval {element $name $size} $args]
+}
+
+# jlib::ftrans::uri --
+#
+# Create a sipub uri that references a local file.
+# XEP-0096 File Transfer, sect. 6.2.2 recvfile:
+# xmpp:romeo@montague.net/orchard?recvfile;sid=pub234;mime-type=text%2Fplain&name=reply.txt&size=2048
+
+proc jlib::ftrans::uri {jid fileName mime} {
+
+ # NB: The JID must be uri encoded as a path to preserver the "/"
+ # while the query part must be encoded as is.
+ set spid [jlib::sipub::newcache $fileName $mime]
+ set tail [file tail $fileName]
+ set size [file size $fileName]
+ set jid [uriencode::quotepath $jid]
+ set uri "xmpp:$jid?recvfile"
+ set uri2 ""
+ append uri2 ";" "sid=$spid"
+ append uri2 ";" "mime-type=$mime"
+ append uri2 ";" "name=$tail"
+ append uri2 ";" "size=$size"
+ set uri2 [::uri::urn::quote $uri2]
+
+ return $uri$uri2
+}
+
+# jlib::ftrans::element --
+#
+# Just create the file element. Nothing cached. Stateless.
+#
+# <file xmlns='http://jabber.org/protocol/si/profile/file-transfer'
+# name='NDA.pdf'
+# size='138819'
+# date='2004-01-28T10:07Z'>
+# <desc>All Shakespearean characters must sign and return this NDA ASAP</desc>
+# </file>
+#
+# Arguments:
+# name
+# size
+# args: -description -date -hash
+#
+# Result:
+# The file element.
+
+proc jlib::ftrans::element {name size args} {
+ variable xmlns
+
+ array set argsA $args
+
+ set subEL [list]
+ if {[info exists argsA(-description)]} {
+ set descE [wrapper::createtag "desc" -chdata $argsA(-description)]
+ set subEL [list $descE]
+ }
+ set attrs [list xmlns $xmlns(ftrans) name $name size $size]
+ if {[info exists argsA(-date)]} {
+ lappend attrs date $argsA(-date)
+ }
+ if {[info exists argsA(-hash)]} {
+ lappend attrs hash $argsA(-hash)
+ }
+ set fileE [wrapper::createtag "file" -attrlist $attrs -subtags $subEL]
+
+ return $fileE
+}
+
+# jlib::ftrans::sipub_element --
+#
+# This creates a new sipub instance. Typically only used for normal
+# messages. For groupchats, pubsub etc. you must not use this one.
+
+proc jlib::ftrans::sipub_element {jlibname name size fileName mime args} {
+ variable xmlns
+
+ set fileE [element $name $size]
+ set sipubE [jlib::sipub::element [$jlibname myjid] $xmlns(ftrans) \
+ $fileE $fileName $mime]
+
+ return $sipubE
+}
+
+# jlib::ftrans::open_cb --
+#
+# This is a transports way of reporting result from it's 'open' method.
+
+proc jlib::ftrans::open_cb {jlibname type sid subiq} {
+ variable xmlns
+ upvar ${jlibname}::ftrans::istate istate
+
+ #puts "jlib::ftrans::open_cb (i)"
+
+ if {[string equal $type "error"]} {
+ set istate($sid,status) "error"
+ uplevel #0 $istate($sid,cmd) [list $jlibname error $sid $subiq]
+ ifree $jlibname $sid
+ }
+}
+
+# jlib::ftrans::open_data, read_data, close_data --
+#
+# These are all used by the streams (transports) to handle the data
+# stream it needs when transmitting.
+
+proc jlib::ftrans::open_data {jlibname sid} {
+ upvar ${jlibname}::ftrans::istate istate
+ #puts "jlib::ftrans::open_data (i) sid=$sid"
+
+ # @@@ assuming -file type
+ # This must never fail since tested if 'readable' before.
+ set fd [open $istate($sid,fileName) r]
+ fconfigure $fd -translation binary
+ set istate($sid,fd) $fd
+ return
+}
+
+proc jlib::ftrans::read_data {jlibname sid} {
+ upvar ${jlibname}::ftrans::istate istate
+ #puts "jlib::ftrans::read_data (i) sid=$sid"
+
+ # If we have reached eof we receive empty.
+ set data [read $istate($sid,fd) $istate($sid,-block-size)]
+ set len [string length $data]
+ #puts "\t len=$len"
+ incr istate($sid,bytes) $len
+
+ if {[string length $istate($sid,-progress)]} {
+ uplevel #0 $istate($sid,-progress) \
+ [list $jlibname $sid $istate($sid,size) $istate($sid,bytes)]
+ }
+ return $data
+}
+
+# This is called by the stream when either all data have been sent or if
+# there is any network error.
+
+proc jlib::ftrans::close_data {jlibname sid {err ""}} {
+ upvar ${jlibname}::ftrans::istate istate
+ #puts "jlib::ftrans::close_data (i) sid=$sid, err=$err"
+
+ # Empty -> eof.
+ catch {close $istate($sid,fd)}
+
+ if {$err eq ""} {
+ set istate($sid,status) "ok"
+ } else {
+ set istate($sid,status) "error"
+ set istate($sid,error) "networkerror"
+ }
+
+ # Close stream.
+ # Shall we wait for a result from this query before reporting?
+ set cmd [namespace current]::close_cb
+ jlib::si::send_close $jlibname $sid $cmd
+}
+
+# jlib::ftrans::close_cb --
+#
+# This is the callback to 'jlib::si::send_close'.
+# It is our destructor.
+
+proc jlib::ftrans::close_cb {jlibname type sid subiq} {
+ upvar ${jlibname}::ftrans::istate istate
+ #puts "jlib::ftrans::close_cb (i)"
+
+ # We may have an error status.
+ set status $istate($sid,status)
+ if {$status eq "error"} {
+ set err $istate($sid,error)
+ uplevel #0 $istate($sid,cmd) [list $jlibname error $sid [list $err ""]]
+ } elseif {$status eq "reset"} {
+ uplevel #0 $istate($sid,cmd) [list $jlibname reset $sid {}]
+ } else {
+ uplevel #0 $istate($sid,cmd) [list $jlibname $type $sid $subiq]
+ }
+
+ # There could be situations, a transfer manager, where we want to keep
+ # this information.
+ ifree $jlibname $sid
+}
+
+# jlib::ftrans::ireset --
+#
+# Reset an initiated transaction.
+
+proc jlib::ftrans::ireset {jlibname sid} {
+ upvar ${jlibname}::ftrans::istate istate
+
+ if {[info exists istate($sid,aid)]} {
+ after cancel $istate($sid,aid)
+ }
+ set istate($sid,status) "reset"
+ set cmd [namespace current]::close_cb
+ jlib::si::send_close $jlibname $sid $cmd
+}
+
+proc jlib::ftrans::iresetall {jlibname} {
+
+ foreach spec [initiatorinfo $jlibname] {
+ set sid [lindex $spec 0]
+ ireset $jlibname $sid
+ }
+}
+
+# jlib::ftrans::initiatorinfo --
+#
+# Returns current open transfers we have initiated.
+
+proc jlib::ftrans::initiatorinfo {jlibname} {
+ upvar ${jlibname}::ftrans::istate istate
+
+ set iList [list]
+ foreach skey [array names istate *,sid] {
+ set sid $istate($skey)
+ set opts $sid
+ foreach {key value} [array get istate $sid,*] {
+ set name [string map [list $sid, ""] $key]
+ lappend opts $name $value
+ }
+ lappend iList $opts
+ }
+ return $iList
+}
+
+proc jlib::ftrans::getinitiatorstate {jlibname sid} {
+ upvar ${jlibname}::ftrans::istate istate
+
+ set opts [list]
+ foreach {key value} [array get istate $sid,*] {
+ set name [string map [list $sid, ""] $key]
+ lappend opts $name $value
+ }
+ return $opts
+}
+
+proc jlib::ftrans::ifree {jlibname sid} {
+ upvar ${jlibname}::ftrans::istate istate
+ #puts "jlib::ftrans::ifree (i) sid=$sid"
+
+ array unset istate $sid,*
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a target (receiver) of a stream.
+
+# jlib::ftrans::open_handler --
+#
+# Callback when si receives this specific profile (file-transfer).
+# It is called as an iq-set/si handler.
+#
+# There are two ways this can work:
+# 1) Using the global handler registered by 'registerhandler'
+# 2) Or the for a specific sid, 'register_sid_handler', which is typically
+# used for sipub.
+
+proc jlib::ftrans::open_handler {jlibname sid jid siE respCmd args} {
+ variable handler
+ variable xmlns
+ upvar ${jlibname}::ftrans::tstate tstate
+ upvar ${jlibname}::ftrans::sid_handler sid_handler
+ #puts "jlib::ftrans::open_handler (t)"
+
+ if {![info exists handler]} {
+ return -code break
+ }
+ eval {t_constructor $jlibname $sid $jid $siE} $args
+
+ set tstate($sid,cmd) $respCmd
+
+ set opts [list]
+ foreach key {mime desc hash date} {
+ if {[string length $tstate($sid,$key)]} {
+ lappend opts -$key $tstate($sid,$key)
+ }
+ }
+ lappend opts -queryE $siE
+
+ # Make a call up to application level to pick destination file.
+ # This is an idle call in order not to block.
+ set cb [list [namespace current]::accept $jlibname $sid]
+
+ # For sipub we have a registered handler for this sid.
+ if {[info exists sid_handler($sid)]} {
+ set cmd $sid_handler($sid)
+ unset sid_handler($sid)
+ } else {
+ set cmd $handler
+ }
+ after idle [list eval $cmd \
+ [list $jlibname $jid $tstate($sid,name) $tstate($sid,size) $cb] $opts]
+
+ return
+}
+
+proc jlib::ftrans::t_constructor {jlibname sid jid siE args} {
+ variable handler
+ variable xmlns
+ upvar ${jlibname}::ftrans::tstate tstate
+ #puts "jlib::ftrans::t_constructor (t)"
+
+ array set opts {
+ -channel ""
+ -command ""
+ -progress ""
+ }
+ array set opts $args
+ set fileE [wrapper::getfirstchild $siE "file" $xmlns(ftrans)]
+ if {![llength $fileE]} {
+ # Exception
+ return
+ }
+ set tstate($sid,sid) $sid
+ set tstate($sid,jid) $jid
+ set tstate($sid,mime) [wrapper::getattribute $siE "mime-type"]
+ foreach {key value} [array get opts] {
+ set tstate($sid,$key) $value
+ }
+ if {[string length $opts(-channel)]} {
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ # File element attributes 'name' and 'size' are required!
+ array set attr {
+ name ""
+ size 0
+ date ""
+ hash ""
+ }
+ array set attr [wrapper::getattrlist $fileE]
+ foreach {name value} [array get attr] {
+ set tstate($sid,$name) $value
+ }
+ set tstate($sid,desc) ""
+ set descE [wrapper::getfirstchildwithtag $fileE "desc"]
+ if {[llength $descE]} {
+ set tstate($sid,desc) [wrapper::getcdata $descE]
+ }
+ set tstate($sid,bytes) 0
+ set tstate($sid,data) ""
+
+ return
+}
+
+# jlib::ftrans::register_sid_handler --
+#
+# Used by sipub to take over from the client handler for this sid.
+
+proc jlib::ftrans::register_sid_handler {jlibname sid cmd} {
+ upvar ${jlibname}::ftrans::sid_handler sid_handler
+ #puts "jlib::ftrans::register_sid_handler (t)"
+ set sid_handler($sid) $cmd
+}
+
+# jlib::ftrans::accept --
+#
+# Used by profile handler to accept/reject file transfer.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# args: -channel
+# -command
+# -progress
+
+proc jlib::ftrans::accept {jlibname sid accepted args} {
+ upvar ${jlibname}::ftrans::tstate tstate
+
+ array set opts {
+ -channel ""
+ -command ""
+ -progress ""
+ }
+ array set opts $args
+ foreach {key value} [array get opts] {
+ set tstate($sid,$key) $value
+ }
+ if {$accepted} {
+ set type ok
+ if {[string length $opts(-channel)]} {
+ fconfigure $opts(-channel) -translation binary
+ # -buffersize 4096
+ }
+ } else {
+ set type error
+ }
+ set respCmd $tstate($sid,cmd)
+ eval $respCmd [list $type {}]
+ if {!$accepted} {
+ tfree $jlibname $sid
+ }
+}
+
+# jlib::ftrans::recv --
+#
+# Registered handler when receiving data. Called indirectly from stream.
+
+proc jlib::ftrans::recv {jlibname sid data} {
+ upvar ${jlibname}::ftrans::tstate tstate
+ #puts "jlib::ftrans::recv (t)"
+
+ set len [string length $data]
+ #puts "\t len=$len"
+ incr tstate($sid,bytes) $len
+ if {[string length $tstate($sid,-channel)]} {
+ if {[catch {puts -nonewline $tstate($sid,-channel) $data} err]} {
+ terror $jlibname $sid $err
+ return
+ }
+ } else {
+ #puts "\t append"
+ append tstate($sid,data) $data
+ }
+ if {$len && [string length $tstate($sid,-progress)]} {
+ uplevel #0 $tstate($sid,-progress) [list $jlibname $sid \
+ $tstate($sid,size) $tstate($sid,bytes)]
+ }
+}
+
+# jlib::ftrans::close_handler --
+#
+# Registered handler when closing the stream.
+# This is called both for normal close and when an error occured
+# in the stream to close prematurely.
+
+proc jlib::ftrans::close_handler {jlibname sid {errmsg ""}} {
+ upvar ${jlibname}::ftrans::tstate tstate
+ #puts "jlib::ftrans::close_handler (t)"
+
+ # Be sure to close the file before doing the callback, else md5 bail out!
+ if {[string length $tstate($sid,-channel)]} {
+ close $tstate($sid,-channel)
+ }
+ if {[string length $tstate($sid,-command)]} {
+ if {[string length $errmsg]} {
+ uplevel #0 $tstate($sid,-command) [list $jlibname $sid error $errmsg]
+ } else {
+ uplevel #0 $tstate($sid,-command) [list $jlibname $sid ok]
+ }
+ }
+ tfree $jlibname $sid
+}
+
+proc jlib::ftrans::data {jlibname sid} {
+ return $tstate($sid,data)
+}
+
+# jlib::ftrans::treset --
+#
+# Resets are closes down target side file-transfer during transport.
+
+proc jlib::ftrans::treset {jlibname sid} {
+ upvar ${jlibname}::ftrans::tstate tstate
+ #puts "jlib::ftrans::treset (t)"
+
+ # Tell transport we are resetting.
+ jlib::si::reset $jlibname $sid
+
+ set tstate($sid,status) "reset"
+ if {[string length $tstate($sid,-channel)]} {
+ close $tstate($sid,-channel)
+ }
+ if {[string length $tstate($sid,-command)]} {
+ uplevel #0 $tstate($sid,-command) [list $jlibname $sid reset]
+ }
+ tfree $jlibname $sid
+}
+
+# jlib::ftrans::targetinfo --
+#
+# Returns current target transfers.
+
+proc jlib::ftrans::targetinfo {jlibname} {
+ upvar ${jlibname}::ftrans::tstate tstate
+
+ set tList [list]
+ foreach skey [array names tstate *,sid] {
+ set sid $tstate($skey)
+ set opts [list]
+ foreach {key value} [array get tstate $sid,*] {
+ set name [string map [list $sid, ""] $key]
+ lappend opts $name $value
+ }
+ lappend tList $opts
+ }
+ return $tList
+}
+
+proc jlib::ftrans::gettargetstate {jlibname sid} {
+ upvar ${jlibname}::ftrans::tstate tstate
+
+ set opts [list]
+ foreach {key value} [array get tstate $sid,*] {
+ set name [string map [list $sid, ""] $key]
+ lappend opts $name $value
+ }
+ return $opts
+}
+
+proc jlib::ftrans::terror {jlibname sid {errormsg ""}} {
+ upvar ${jlibname}::ftrans::tstate tstate
+ #puts "jlib::ftrans::terror (t) errormsg=$errormsg"
+
+ if {[string length $tstate($sid,-channel)]} {
+ close $tstate($sid,-channel)
+ }
+ if {[string length $tstate($sid,-command)]} {
+ uplevel #0 $tstate($sid,-command) [list $jlibname $sid error $errormsg]
+ }
+ tfree $jlibname $sid
+}
+
+proc jlib::ftrans::tfree {jlibname sid} {
+ upvar ${jlibname}::ftrans::tstate tstate
+ #puts "jlib::ftrans::tfree (t) sid=$sid"
+
+ array unset tstate $sid,*
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::ftrans {
+
+ jlib::ensamble_register filetransfer \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# groupchat.tcl--
+#
+# Support for the old gc-1.0 groupchat protocol.
+#
+# Copyright (c) 2002-2005 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: groupchat.tcl,v 1.10 2008/02/06 13:57:25 matben Exp $
+#
+############################# USAGE ############################################
+#
+# INSTANCE COMMANDS
+# jlibName groupchat enter room nick
+# jlibName groupchat exit room
+# jlibName groupchat mynick room
+# jlibName groupchat setnick room nick ?-command tclProc?
+# jlibName groupchat status room
+# jlibName groupchat participants room
+# jlibName groupchat allroomsin
+#
+################################################################################
+
+package provide groupchat 1.0
+package provide jlib::groupchat 1.0
+
+namespace eval jlib {}
+
+namespace eval jlib::groupchat {}
+
+# jlib::groupchat --
+#
+# Provides API's for the old-style groupchat protocol, 'groupchat 1.0'.
+
+proc jlib::groupchat {jlibname cmd args} {
+ return [eval {[namespace current]::groupchat::${cmd} $jlibname} $args]
+}
+
+proc jlib::groupchat::init {jlibname} {
+ upvar ${jlibname}::gchat gchat
+
+ namespace eval ${jlibname}::groupchat {
+ variable rooms
+ }
+ set gchat(allroomsin) [list]
+}
+
+# jlib::groupchat::enter --
+#
+# Enter room using the 'gc-1.0' protocol by sending <presence>.
+#
+# args: -command callback
+
+proc jlib::groupchat::enter {jlibname room nick args} {
+ upvar ${jlibname}::gchat gchat
+ upvar ${jlibname}::groupchat::rooms rooms
+
+ set room [jlib::jidmap $room]
+ set jid $room/$nick
+ eval {$jlibname send_presence -to $jid} $args
+ set gchat($room,mynick) $nick
+
+ # This is not foolproof since it may not always success.
+ lappend gchat(allroomsin) $room
+ set rooms($room) 1
+ $jlibname service setroomprotocol $room "gc-1.0"
+ set gchat(allroomsin) [lsort -unique $gchat(allroomsin)]
+ return
+}
+
+proc jlib::groupchat::exit {jlibname room} {
+ upvar ${jlibname}::gchat gchat
+
+ set room [jlib::jidmap $room]
+ if {[info exists gchat($room,mynick)]} {
+ set nick $gchat($room,mynick)
+ set jid $room/$nick
+ $jlibname send_presence -to $jid -type "unavailable"
+ unset -nocomplain gchat($room,mynick)
+ }
+ set ind [lsearch -exact $gchat(allroomsin) $room]
+ if {$ind >= 0} {
+ set gchat(allroomsin) [lreplace $gchat(allroomsin) $ind $ind]
+ }
+ $jlibname roster clearpresence "${room}*"
+ return
+}
+
+proc jlib::groupchat::mynick {jlibname room} {
+ upvar ${jlibname}::gchat gchat
+
+ set room [jlib::jidmap $room]
+ return $gchat($room,mynick)
+}
+
+proc jlib::groupchat::setnick {jlibname room nick args} {
+ upvar ${jlibname}::gchat gchat
+
+ set room [jlib::jidmap $room]
+ set jid $room/$nick
+ eval {$jlibname send_presence -to $jid} $args
+ set gchat($room,mynick) $nick
+}
+
+proc jlib::groupchat::status {jlibname room args} {
+ upvar ${jlibname}::gchat gchat
+
+ set room [jlib::jidmap $room]
+ if {[info exists gchat($room,mynick)]} {
+ set nick $gchat($room,mynick)
+ } else {
+ return -code error "Unknown nick name for room \"$room\""
+ }
+ set jid ${room}/${nick}
+ eval {$jlibname send_presence -to $jid} $args
+}
+
+proc jlib::groupchat::participants {jlibname room} {
+
+ upvar ${jlibname}::agent agent
+ upvar ${jlibname}::gchat gchat
+
+ set room [jlib::jidmap $room]
+ set isroom 0
+ if {[regexp {^[^@]+@([^@ ]+)$} $room match domain]} {
+ if {[info exists agent($domain,groupchat)]} {
+ set isroom 1
+ }
+ }
+ if {!$isroom} {
+ return -code error "Not recognized \"$room\" as a groupchat room"
+ }
+
+ # The rosters presence elements should give us all info we need.
+ set everyone {}
+ foreach userAttr [$jlibname roster getpresence $room -type available] {
+ unset -nocomplain attrArr
+ array set attrArr $userAttr
+ lappend everyone ${room}/$attrArr(-resource)
+ }
+ return $everyone
+}
+
+proc jlib::groupchat::isroom {jlibname jid} {
+ upvar ${jlibname}::groupchat::rooms rooms
+
+ if {[info exists rooms($jid)]} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+proc jlib::groupchat::allroomsin {jlibname} {
+ upvar ${jlibname}::gchat gchat
+
+ set gchat(allroomsin) [lsort -unique $gchat(allroomsin)]
+ return $gchat(allroomsin)
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# ibb.tcl --
+#
+# This file is part of the jabberlib.
+# It provides support for the ibb stuff (In Band Bytestreams).
+#
+# Copyright (c) 2005 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: ibb.tcl,v 1.22 2007/11/30 14:38:34 matben Exp $
+#
+############################# USAGE ############################################
+#
+# NAME
+# ibb - convenience command library for the ibb part of XMPP.
+#
+# SYNOPSIS
+# jlib::ibb::init jlibname
+#
+# OPTIONS
+#
+#
+# INSTANCE COMMANDS
+# jlibName ib send_set jid command ?-key value?
+#
+############################# CHANGES ##########################################
+#
+# 0.1 first version
+
+package require jlib
+package require base64 ; # tcllib
+package require jlib::disco
+package require jlib::si
+
+package provide jlib::ibb 0.1
+
+namespace eval jlib::ibb {
+
+ variable inited 0
+ variable xmlns
+ set xmlns(ibb) "http://jabber.org/protocol/ibb"
+ set xmlns(amp) "http://jabber.org/protocol/amp"
+
+ jlib::si::registertransport $xmlns(ibb) $xmlns(ibb) 80 \
+ [namespace current]::si_open \
+ [namespace current]::si_close
+
+ jlib::disco::registerfeature $xmlns(ibb)
+
+ # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::ibb::init --
+#
+# Sets up jabberlib handlers and makes a new instance if an ibb object.
+
+proc jlib::ibb::init {jlibname args} {
+
+ #puts "jlib::ibb::init"
+
+ variable inited
+ variable xmlns
+
+ if {!$inited} {
+ InitOnce
+ }
+
+ # Keep different state arrays for initiator (i) and target (t).
+ namespace eval ${jlibname}::ibb {
+ variable priv
+ variable opts
+ variable istate
+ variable tstate
+ }
+ upvar ${jlibname}::ibb::priv priv
+ upvar ${jlibname}::ibb::opts opts
+
+ array set opts {
+ -block-size 4096
+ }
+ array set opts $args
+
+ # Each base64 byte takes 6 bits; need to translate to binary bytes.
+ set binblock [expr {(6 * $opts(-block-size))/8}]
+ set priv(binblock) [expr {6 * ($binblock/6)}]
+
+ # Register some standard iq handlers that is handled internally.
+ $jlibname iq_register set $xmlns(ibb) [namespace current]::handle_set
+ $jlibname message_register * $xmlns(ibb) [namespace current]::message_handler
+
+ return
+}
+
+proc jlib::ibb::InitOnce { } {
+
+ variable ampElem
+ variable inited
+ variable xmlns
+
+ set rule1 [wrapper::createtag "rule" \
+ -attrlist {condition deliver-at value stored action error}]
+ set rule2 [wrapper::createtag "rule" \
+ -attrlist {condition match-resource value exact action error}]
+ set ampElem [wrapper::createtag "amp" \
+ -attrlist [list xmlns $xmlns(amp)] \
+ -subtags [list $rule1 $rule2]]
+
+ set inited 1
+}
+
+# jlib::ibb::cmdproc --
+#
+# Just dispatches the command to the right procedure.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# cmd:
+# args: all args to the cmd procedure.
+#
+# Results:
+# none.
+
+proc jlib::ibb::cmdproc {jlibname cmd args} {
+
+ # Which command? Just dispatch the command to the right procedure.
+ return [eval {$cmd $jlibname} $args]
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a initiator (sender).
+
+# jlib::ibb::si_open, si_close --
+#
+# Bindings for si.
+
+proc jlib::ibb::si_open {jlibname jid sid args} {
+
+ upvar ${jlibname}::ibb::istate istate
+ #puts "jlib::ibb::si_open (i)"
+
+ set istate($sid,sid) $sid
+ set istate($sid,jid) $jid
+ set istate($sid,seq) 0
+ set istate($sid,status) ""
+ set si_open_cb [namespace current]::si_open_cb
+ eval {send_open $jlibname $jid $sid $si_open_cb} $args
+ return
+}
+
+proc jlib::ibb::si_open_cb {jlibname sid type subiq args} {
+
+ upvar ${jlibname}::ibb::istate istate
+ #puts "jlib::ibb::si_open_cb (i)"
+
+ # Since this is an async call we may have been reset.
+ if {![info exists istate($sid,sid)]} {
+ return
+ }
+ jlib::si::transport_open_cb $jlibname $sid $type $subiq
+
+ # If all went well this far we initiate the read/write data process.
+ if {$type eq "result"} {
+
+ # Tell the profile to prepare to read data (open file).
+ jlib::si::open_data $jlibname $sid
+ si_read $jlibname $sid
+ }
+}
+
+proc jlib::ibb::si_read {jlibname sid} {
+
+ upvar ${jlibname}::ibb::istate istate
+ #puts "jlib::ibb::si_read (i)"
+
+ # Since this is an async call we may have been reset.
+ if {![info exists istate($sid,sid)]} {
+ return
+ }
+
+ # We have been reset or something.
+ if {$istate($sid,status) eq "close"} {
+ return
+ }
+ set data [jlib::si::read_data $jlibname $sid]
+ set len [string length $data]
+
+ if {$len > 0} {
+ si_send $jlibname $sid $data
+ } else {
+
+ # Empty data from the reader means that we are done.
+ jlib::si::close_data $jlibname $sid
+ }
+}
+
+proc jlib::ibb::si_send {jlibname sid data} {
+
+ upvar ${jlibname}::ibb::istate istate
+ #puts "jlib::ibb::si_send (i)"
+
+ set jid $istate($sid,jid)
+ send_data $jlibname $jid $sid $data [namespace current]::si_send_cb
+
+ # Trick to avoid UI blocking.
+ # @@@ We should have a method to detect if xmpp socket writable.
+ after idle [list after 0 [list \
+ [namespace current]::si_read $jlibname $sid]]
+}
+
+# jlib::ibb::si_send_cb --
+#
+# XEP says that we SHOULD track each mesage, in case of error.
+
+proc jlib::ibb::si_send_cb {jlibname sid type subiq args} {
+
+ upvar ${jlibname}::ibb::istate istate
+ #puts "jlib::ibb::si_send_cb (i)"
+
+ # We get this async so we may have been reset or something.
+ if {![info exists istate($sid,sid)]} {
+ return
+ }
+ if {[string equal $type "error"]} {
+ jlib::si::close_data $jlibname $sid error
+ ifree $jlibname $sid
+ }
+}
+
+# jlib::ibb::si_close --
+#
+# The profile closes us down. It could be a reset.
+
+proc jlib::ibb::si_close {jlibname sid} {
+
+ upvar ${jlibname}::ibb::istate istate
+ #puts "jlib::ibb::si_close (i)"
+
+ # Keep a status so we can stop sending messages right away.
+ set istate($sid,status) "close"
+ set jid $istate($sid,jid)
+ set cmd [namespace current]::si_close_cb
+
+ send_close $jlibname $jid $sid $cmd
+}
+
+# jlib::ibb::si_close_cb --
+#
+# This is our destructor that ends it all.
+
+proc jlib::ibb::si_close_cb {jlibname sid type subiq args} {
+
+ upvar ${jlibname}::ibb::istate istate
+ #puts "jlib::ibb::si_close_cb (i)"
+
+ set jid $istate($sid,jid)
+
+ jlib::si::transport_close_cb $jlibname $sid $type $subiq
+ ifree $jlibname $sid
+}
+
+proc jlib::ibb::ifree {jlibname sid} {
+
+ upvar ${jlibname}::ibb::istate istate
+ #puts "jlib::ibb::ifree (i)"
+
+ array unset istate $sid,*
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+proc jlib::ibb::configure {jlibname args} {
+
+ upvar ${jlibname}::ibb::opts opts
+
+ # @@@ TODO
+
+}
+
+# jlib::ibb::send_open --
+#
+# Initiates a file transport. We must be able to configure 'block-size'
+# from the file-transfer profile.
+#
+# Arguments:
+#
+
+proc jlib::ibb::send_open {jlibname jid sid cmd args} {
+ variable xmlns
+ upvar ${jlibname}::ibb::opts opts
+
+ #puts "jlib::ibb::send_open (i)"
+
+ array set arr [list -block-size $opts(-block-size)]
+ array set arr $args
+
+ set openElem [wrapper::createtag "open" \
+ -attrlist [list sid $sid block-size $arr(-block-size) xmlns $xmlns(ibb)]]
+ jlib::send_iq $jlibname set [list $openElem] -to $jid \
+ -command [concat $cmd [list $jlibname $sid]]
+ return
+}
+
+# jlib::ibb::send_data --
+#
+#
+
+proc jlib::ibb::send_data {jlibname jid sid data cmd} {
+ variable xmlns
+ variable ampElem
+ upvar ${jlibname}::ibb::istate istate
+ #puts "jlib::ibb::send_data (i) sid=$sid, cmd=$cmd"
+
+ set jid $istate($sid,jid)
+ set seq $istate($sid,seq)
+ set edata [base64::encode $data]
+ set dataElem [wrapper::createtag "data" \
+ -attrlist [list xmlns $xmlns(ibb) sid $sid seq $seq] \
+ -chdata $edata]
+ set istate($sid,seq) [expr {($seq + 1) % 65536}]
+
+ jlib::send_message $jlibname $jid -xlist [list $dataElem $ampElem] \
+ -command [concat $cmd [list $jlibname $sid]]
+}
+
+# jlib::ibb::send_close --
+#
+# Sends the close tag.
+#
+# Arguments:
+#
+
+proc jlib::ibb::send_close {jlibname jid sid cmd} {
+ variable xmlns
+ #puts "jlib::ibb::send_close (i)"
+
+ set closeElem [wrapper::createtag "close" \
+ -attrlist [list sid $sid xmlns $xmlns(ibb)]]
+ jlib::send_iq $jlibname set [list $closeElem] -to $jid \
+ -command [concat $cmd [list $jlibname $sid]]
+ return
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a target (receiver) of a stream.
+
+# jlib::ibb::handle_set --
+#
+# Parse incoming ibb iq-set open/close element.
+# It is being assumed that we already have accepted a stream initiation.
+
+proc jlib::ibb::handle_set {jlibname from subiq args} {
+
+ variable xmlns
+ upvar ${jlibname}::ibb::tstate tstate
+
+ #puts "jlib::ibb::handle_set (t)"
+
+ set tag [wrapper::gettag $subiq]
+ array set attr [wrapper::getattrlist $subiq]
+ array set argsArr $args
+ if {![info exists argsArr(-id)] || ![info exists attr(sid)]} {
+ # We can't do more here.
+ return 0
+ }
+ set sid $attr(sid)
+
+ # We make sure that we have already got a si with this sid.
+ if {![jlib::si::havesi $jlibname $sid]} {
+ send_error $jlibname $from $argsArr(-id) $sid 404 cancel item-not-found
+ return 1
+ }
+
+ switch -- $tag {
+ open {
+ if {![info exists attr(block-size)]} {
+ # @@@ better stanza!
+ send_error $jlibname $from $argsArr(-id) $sid 501 cancel \
+ feature_not_implemented
+ return
+ }
+ set tstate($sid,sid) $sid
+ set tstate($sid,jid) $from
+ set tstate($sid,block-size) $attr(block-size)
+ set tstate($sid,seq) 0
+
+ # Make a success response on open.
+ jlib::send_iq $jlibname "result" {} -to $from -id $argsArr(-id)
+ }
+ close {
+
+ # Make a success response on close.
+ jlib::send_iq $jlibname "result" {} -to $from -id $argsArr(-id)
+ jlib::si::stream_closed $jlibname $sid
+ tfree $jlibname $sid
+ }
+ default {
+ return 0
+ }
+ }
+ return 1
+}
+
+# jlib::ibb::message_handler --
+#
+# Message handler for incoming http://jabber.org/protocol/ibb elements.
+
+proc jlib::ibb::message_handler {jlibname ns msgElem args} {
+
+ variable xmlns
+ upvar ${jlibname}::ibb::tstate tstate
+
+ array set argsArr $args
+ #puts "jlib::ibb::message_handler (t) ns=$ns"
+
+ set jid [wrapper::getattribute $msgElem "from"]
+
+ # Pack up the data and deliver to si.
+ set dataElems [wrapper::getchildswithtagandxmlns $msgElem data $xmlns(ibb)]
+ foreach dataElem $dataElems {
+ array set attr [wrapper::getattrlist $dataElem]
+ set sid $attr(sid)
+ set seq $attr(seq)
+
+ # We make sure that we have already got a si with this sid.
+ # Since there can be many of these, reply with error only to first.
+ if {![jlib::si::havesi $jlibname $sid] \
+ || ![info exists tstate($sid,sid)]} {
+ if {[info exists argsArr(-id)]} {
+ set id $argsArr(-id)
+ jlib::send_message_error $jlibname $jid $id 404 cancel \
+ item-not-found
+ }
+ return 1
+ }
+
+ # Check that no packets have been lost.
+ if {$seq != $tstate($sid,seq)} {
+ if {[info exists argsArr(-id)]} {
+ #puts "\t seq=$seq, expectseq=$expectseq"
+ set id $argsArr(-id)
+ jlib::send_message_error $jlibname $jid $id 400 cancel \
+ bad-request
+ }
+ return 1
+ }
+
+ set encdata [wrapper::getcdata $dataElem]
+ if {[catch {
+ set data [base64::decode $encdata]
+ }]} {
+ if {[info exists argsArr(-id)]} {
+ jlib::send_message_error $jlibname $jid $id 400 cancel bad-request
+ }
+ return 1
+ }
+
+ # Next expected 'seq'.
+ set tstate($sid,seq) [expr {($seq + 1) % 65536}]
+
+ # Deliver to si for further processing.
+ jlib::si::stream_recv $jlibname $sid $data
+ }
+ return 1
+}
+
+proc jlib::ibb::send_error {jlibname jid id sid errcode errtype stanza} {
+
+ jlib::send_iq_error $jlibname $jid $id $errcode $errtype $stanza
+ tfree $jlibname $sid
+}
+
+proc jlib::ibb::tfree {jlibname sid} {
+
+ upvar ${jlibname}::ibb::tstate tstate
+ #puts "jlib::ibb::tfree (t)"
+
+ array unset tstate $sid,*
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::ibb {
+
+ jlib::ensamble_register ibb \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# jabberlib.tcl --
+#
+# This is the main part of the jabber lib, a Tcl library for interacting
+# with jabber servers. The core parts are known under the name XMPP.
+#
+# Copyright (c) 2001-2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: jabberlib.tcl,v 1.199 2008/06/09 14:24:46 matben Exp $
+#
+# Error checking is minimal, and we assume that all clients are to be trusted.
+#
+# News: the transport mechanism shall be completely configurable, but where
+# the standard mechanism (put directly to socket) is included here.
+#
+# Variables used in JabberLib:
+#
+# lib:
+# lib(wrap) : Wrap ID
+# lib(clientcmd) : Callback proc up to the client
+# lib(sock) : socket name
+# lib(streamcmd) : Callback command to run when the <stream>
+# tag is received from the server.
+#
+# iqcmd:
+# iqcmd(uid) : Next iq id-number. Sent in
+# "id" attributes of <iq> packets.
+# iqcmd($id) : Callback command to run when iq result
+# packet of $id is received.
+#
+# locals:
+# locals(server) : The servers logical name (streams 'from')
+# locals(username)
+# locals(myjid)
+# locals(myjid2)
+#
+############################# SCHEMA ###########################################
+#
+# TclXML <---> wrapper <---> jabberlib <---> client
+# |
+# jlib::roster
+# jlib::disco
+# jlib::muc
+# ...
+#
+# Most jlib-packages are self-registered and are invoked using ensamble (sub)
+# commands.
+#
+############################# USAGE ############################################
+#
+# NAME
+# jabberlib - an interface between Jabber clients and the wrapper
+#
+# SYNOPSIS
+# jlib::new clientCmd ?-opt value ...?
+# jlib::havesasl
+# jlib::havetls
+#
+# OPTIONS
+# -iqcommand callback for <iq> elements not handled explicitly
+# -messagecommand callback for <message> elements
+# -presencecommand callback for <presence> elements
+# -streamnamespace initialization namespace (D = "jabber:client")
+# -keepalivesecs send a newline character with this interval
+# -autoawaymins if > 0 send away message after this many minutes
+# -xautoawaymins if > 0 send xaway message after this many minutes
+# -awaymsg the away message
+# -xawaymsg the xaway message
+# -autodiscocaps 0|1 should presence caps elements be auto discoed
+#
+# INSTANCE COMMANDS
+# jlibName config ?args?
+# jlibName openstream server ?args?
+# jlibName closestream
+# jlibName element_deregister xmlns func
+# jlibName element_register xmlns func ?seq?
+# jlibName getstreamattr name
+# jlibName get_feature name
+# jlibName get_last to cmd
+# jlibName get_time to cmd
+# jlibName getserver
+# jlibName get_version to cmd
+# jlibName getrecipientjid jid
+# jlibName get_registered_presence_stanzas ?tag? ?xmlns?
+# jlibName iq_get xmlns ?-to, -command, -sublists?
+# jlibName iq_set xmlns ?-to, -command, -sublists?
+# jlibName iq_register type xmlns cmd
+# jlibName message_register xmlns cmd
+# jlibName myjid
+# jlibName myjid2
+# jlibName myjidmap
+# jlibName myjid2map
+# jlibName mypresence
+# jlibName oob_set to cmd url ?args?
+# jlibName presence_register type cmd
+# jlibName registertransport name initProc sendProc resetProc ipProc
+# jlibName register_set username password cmd ?args?
+# jlibName register_get cmd ?args?
+# jlibName register_presence_stanza elem
+# jlibName register_remove to cmd ?args?
+# jlibName resetstream
+# jlibName schedule_auto_away
+# jlibName search_get to cmd
+# jlibName search_set to cmd ?args?
+# jlibName send_iq type xmldata ?args?
+# jlibName send_message to ?args?
+# jlibName send_presence ?args?
+# jlibName send_auth username resource ?args?
+# jlibName send xmllist
+# jlibName setsockettransport socket
+# jlibName state
+# jlibName transport
+# jlibName deregister_presence_stanza tag xmlns
+#
+#
+# The callbacks given for any of the '-iqcommand', '-messagecommand',
+# or '-presencecommand' must have the following form:
+#
+# tclProc {jlibname xmldata}
+#
+# where 'type' is the type attribute valid for each specific element, and
+# 'args' is a list of '-key value' pairs. The '-iqcommand' returns a boolean
+# telling if any 'get' is handled or not. If not, then a "Not Implemented" is
+# returned automatically.
+#
+# The clientCmd procedure must have the following form:
+#
+# clientCmd {jlibName what args}
+#
+# where 'what' can be any of: connect, disconnect, xmlerror,
+# version, networkerror, ....
+# 'args' is a list of '-key value' pairs.
+#
+# @@@ TODO:
+#
+# 1) Rewrite from scratch and deliver complete iq, message, and presence
+# elements to callbacks. Callbacks then get attributes like 'from' etc
+# using accessor functions.
+#
+# 2) Cleanup all the presence code.
+#
+#-------------------------------------------------------------------------------
+
+# @@@ TODO: change package names to jlib::*
+
+package require wrapper
+package require service
+package require stanzaerror
+package require streamerror
+package require groupchat
+package require jlib::util
+
+package provide jlib 2.0
+
+
+namespace eval jlib {
+
+ # Globals same for all instances of this jlib.
+ # > 1 prints raw xml I/O
+ # > 2 prints a lot more
+ variable debug 0
+ if {[info exists ::debugLevel] && ($::debugLevel > 1) && ($debug == 0)} {
+ set debug 2
+ }
+
+ variable statics
+ set statics(inited) 0
+ set statics(presenceTypeExp) \
+ {(available|unavailable|subscribe|unsubscribe|subscribed|unsubscribed|invisible|probe)}
+ set statics(instanceCmds) [list]
+
+ variable version 1.0
+
+ # Running number.
+ variable uid 0
+
+ # Let jlib components register themselves for subcommands, ensamble,
+ # so that they can be invoked by: jlibname subcommand ...
+ variable ensamble
+
+ # Some common xmpp xml namespaces.
+ variable xmppxmlns
+ array set xmppxmlns {
+ stream "http://etherx.jabber.org/streams"
+ streams "urn:ietf:params:xml:ns:xmpp-streams"
+ tls "urn:ietf:params:xml:ns:xmpp-tls"
+ sasl "urn:ietf:params:xml:ns:xmpp-sasl"
+ bind "urn:ietf:params:xml:ns:xmpp-bind"
+ stanzas "urn:ietf:params:xml:ns:xmpp-stanzas"
+ session "urn:ietf:params:xml:ns:xmpp-session"
+ }
+
+ variable jxmlns
+ array set jxmlns {
+ amp "http://jabber.org/protocol/amp"
+ caps "http://jabber.org/protocol/caps"
+ compress "http://jabber.org/features/compress"
+ disco "http://jabber.org/protocol/disco"
+ disco,items "http://jabber.org/protocol/disco#items"
+ disco,info "http://jabber.org/protocol/disco#info"
+ ibb "http://jabber.org/protocol/ibb"
+ muc "http://jabber.org/protocol/muc"
+ muc,user "http://jabber.org/protocol/muc#user"
+ muc,admin "http://jabber.org/protocol/muc#admin"
+ muc,owner "http://jabber.org/protocol/muc#owner"
+ pubsub "http://jabber.org/protocol/pubsub"
+ }
+
+ # This is likely to change when XEP accepted.
+ set jxmlns(entitytime) "http://www.xmpp.org/extensions/xep-0202.html#ns"
+
+ # Auto away and extended away are only set when the
+ # current status has a lower priority than away or xa respectively.
+ # After an idea by Zbigniew Baniewski.
+ variable statusPriority
+ array set statusPriority {
+ chat 1
+ available 2
+ away 3
+ xa 4
+ dnd 5
+ invisible 6
+ unavailable 7
+ }
+}
+
+proc jlib::getxmlns {name} {
+ variable xmppxmlns
+ variable jxmlns
+
+ if {[info exists xmppxmlns($name)]} {
+ return $xmppxmlns($name)
+ } elseif {[info exists xmppxmlns($name)]} {
+ return $jxmlns($name)
+ } else {
+ return -code error "unknown xmlns for $name"
+ }
+}
+
+# jlib::register_instance --
+#
+# Packages can register here to get notified when a new jlib instance is
+# created.
+
+proc jlib::register_instance {cmd} {
+ variable statics
+
+ lappend statics(instanceCmds) $cmd
+}
+
+# jlib::new --
+#
+# This creates a new instance jlib interpreter.
+#
+# Arguments:
+# clientcmd: callback procedure for the client
+# args:
+# -iqcommand
+# -messagecommand
+# -presencecommand
+# -streamnamespace
+# -keepalivesecs
+# -autoawaymins
+# -xautoawaymins
+# -awaymsg
+# -xawaymsg
+# -autodiscocaps
+#
+# Results:
+# jlibname which is the namespaced instance command
+
+proc jlib::new {clientcmd args} {
+
+ variable jxmlns
+ variable statics
+ variable objectmap
+ variable uid
+ variable ensamble
+
+ # Generate unique command token for this jlib instance.
+ # Fully qualified!
+ set jlibname [namespace current]::jlib[incr uid]
+
+ # Instance specific namespace.
+ namespace eval $jlibname {
+ variable lib
+ variable locals
+ variable iqcmd
+ variable iqhook
+ variable msghook
+ variable preshook
+ variable genhook
+ variable opts
+ variable pres
+ variable features
+ }
+
+ # Set simpler variable names.
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::iqcmd iqcmd
+ upvar ${jlibname}::prescmd prescmd
+ upvar ${jlibname}::msgcmd msgcmd
+ upvar ${jlibname}::opts opts
+ upvar ${jlibname}::locals locals
+ upvar ${jlibname}::features features
+
+ array set opts {
+ -iqcommand ""
+ -messagecommand ""
+ -presencecommand ""
+ -streamnamespace "jabber:client"
+ -keepalivesecs 60
+ -autoawaymins 0
+ -xautoawaymins 0
+ -awaymsg ""
+ -xawaymsg ""
+ -autodiscocaps 0
+ }
+
+ # Verify options.
+ eval verify_options $jlibname $args
+
+ if {!$statics(inited)} {
+ init
+ }
+
+ set wrapper [wrapper::new [list [namespace current]::got_stream $jlibname] \
+ [list [namespace current]::end_of_parse $jlibname] \
+ [list [namespace current]::dispatcher $jlibname] \
+ [list [namespace current]::xmlerror $jlibname]]
+
+ set iqcmd(uid) 1001
+ set prescmd(uid) 1001
+ set msgcmd(uid) 1001
+ set lib(clientcmd) $clientcmd
+ set lib(async_handler) ""
+ set lib(wrap) $wrapper
+ set lib(resetCmds) [list]
+
+ set lib(isinstream) 0
+ set lib(state) ""
+ set lib(transport,name) ""
+
+ set lib(socketfilter,out) [list]
+ set lib(socketfilter,in) [list]
+
+ set lib(tee,send) [list]
+ set lib(tee,recv) [list]
+
+ init_inst $jlibname
+
+ # Init groupchat state.
+ groupchat::init $jlibname
+
+ # Register some standard iq handlers that are handled internally.
+ iq_register $jlibname get jabber:iq:last \
+ [namespace current]::handle_get_last
+ iq_register $jlibname get jabber:iq:time \
+ [namespace current]::handle_get_time
+ # This overrides any client handler which is bad.
+ #iq_register $jlibname get jabber:iq:version \
+ # [namespace current]::handle_get_version
+
+ iq_register $jlibname get $jxmlns(entitytime) \
+ [namespace current]::handle_entity_time
+
+ # Create the actual jlib instance procedure.
+ proc $jlibname {cmd args} \
+ "eval jlib::cmdproc {$jlibname} \$cmd \$args"
+
+ # Init the service layer for this jlib instance.
+ service::init $jlibname
+
+ # Init ensamble commands.
+ foreach {- name} [array get ensamble *,name] {
+ uplevel #0 $ensamble($name,init) $jlibname
+ }
+
+ return $jlibname
+}
+
+# jlib::init --
+#
+# Static initializations.
+
+proc jlib::init {} {
+ variable statics
+
+ if {[catch {package require jlibsasl}]} {
+ set statics(sasl) 0
+ } else {
+ set statics(sasl) 1
+ sasl_init
+ }
+ if {[catch {package require jlibtls}]} {
+ set statics(tls) 0
+ } else {
+ set statics(tls) 1
+ }
+
+ set statics(inited) 1
+}
+
+# jlib::init_inst --
+#
+# Instance specific initializations.
+
+proc jlib::init_inst {jlibname} {
+
+ upvar ${jlibname}::locals locals
+ upvar ${jlibname}::features features
+
+ # Any of {available chat away xa dnd invisible unavailable}
+ set locals(status) "unavailable"
+ set locals(pres,type) "unavailable"
+ set locals(myjid) ""
+ set locals(myjid2) ""
+ set locals(myjidmap) ""
+ set locals(myjid2map) ""
+ set locals(trigAutoAway) 1
+ set locals(server) ""
+ set locals(servermap) ""
+
+ set features(trace) [list]
+}
+
+# jlib::havesasl --
+#
+# Cache this info for effectiveness. It is needed at application level.
+
+proc jlib::havesasl {} {
+ variable statics
+
+ if {![info exists statics(sasl)]} {
+ if {[catch {package require jlibsasl}]} {
+ set statics(sasl) 0
+ } else {
+ set statics(sasl) 1
+ }
+ }
+ return $statics(sasl)
+}
+
+# jlib::havetls --
+#
+# Cache this info for effectiveness. It is needed at application level.
+
+proc jlib::havetls {} {
+ variable statics
+
+ if {![info exists statics(tls)]} {
+ if {[catch {package require jlibtls}]} {
+ set statics(tls) 0
+ } else {
+ set statics(tls) 1
+ }
+ }
+ return $statics(tls)
+}
+
+proc jlib::havecompress {} {
+ variable statics
+
+ if {![info exists statics(compress)]} {
+ if {[catch {package require jlib::compress}]} {
+ set statics(compress) 0
+ } else {
+ set statics(compress) 1
+ }
+ }
+ return $statics(compress)
+}
+
+# jlib::register_package --
+#
+# This is supposed to be a method for jlib::* packages to register
+# themself just so we know they are there. So far only for the 'roster'.
+
+proc jlib::register_package {name} {
+ variable statics
+
+ set statics($name) 1
+}
+
+# jlib::ensamble_register --
+#
+# Register a sub command.
+# This is then used as: 'jlibName subCmd ...'
+
+proc jlib::ensamble_register {name initProc cmdProc} {
+ variable statics
+ variable ensamble
+
+ set ensamble($name,name) $name
+ set ensamble($name,init) $initProc
+ set ensamble($name,cmd) $cmdProc
+
+ # Must call the initProc for already existing jlib instances.
+ if {$statics(inited)} {
+ foreach jlibname [namespace children ::jlib jlib*] {
+ uplevel #0 $initProc $jlibname
+ }
+ }
+}
+
+proc jlib::ensamble_deregister {name} {
+ variable ensamble
+
+ array unset ensamble ${name},*
+}
+
+# jlib::cmdproc --
+#
+# Just dispatches the command to the right procedure.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# cmd: openstream - closestream - send_iq - send_message ... etc.
+# args: all args to the cmd procedure.
+#
+# Results:
+# none.
+
+proc jlib::cmdproc {jlibname cmd args} {
+ variable ensamble
+
+ # Which command? Just dispatch the command to the right procedure.
+ if {[info exists ensamble($cmd,cmd)]} {
+ return [uplevel #0 $ensamble($cmd,cmd) $jlibname $args]
+ } else {
+ return [eval {$cmd $jlibname} $args]
+ }
+}
+
+# jlib::config --
+#
+# See documentaion for details.
+#
+# Arguments:
+# args Options parsed by the procedure.
+#
+# Results:
+# depending on args.
+
+proc jlib::config {jlibname args} {
+ variable ensamble
+ upvar ${jlibname}::opts opts
+
+ set options [lsort [array names opts -*]]
+ set usage [join $options ", "]
+ if {[llength $args] == 0} {
+ set result [list]
+ foreach name $options {
+ lappend result $name $opts($name)
+ }
+ return $result
+ }
+ regsub -all -- - $options {} options
+ set pat ^-([join $options |])$
+ if {[llength $args] == 1} {
+ set flag [lindex $args 0]
+ if {[regexp -- $pat $flag]} {
+ return $opts($flag)
+ } else {
+ return -code error "Unknown option $flag, must be: $usage"
+ }
+ } else {
+ array set argsA $args
+
+ # Reschedule auto away only if changed. Before setting new opts!
+ # Better to use 'tk inactive' or 'tkinactive' and handle this on
+ # application level.
+ if {[info exists argsA(-autoawaymins)] && \
+ ($argsA(-autoawaymins) != $opts(-autoawaymins))} {
+ schedule_auto_away $jlibname
+ }
+ if {[info exists argsA(-xautoawaymins)] && \
+ ($argsA(-xautoawaymins) != $opts(-xautoawaymins))} {
+ schedule_auto_away $jlibname
+ }
+ foreach {flag value} $args {
+ if {[regexp -- $pat $flag]} {
+ set opts($flag) $value
+ } else {
+ return -code error "Unknown option $flag, must be: $usage"
+ }
+ }
+ }
+
+ # Let components configure themselves.
+ # @@@ It is better to let components handle this???
+ foreach ename [array names ensamble] {
+ set ecmd ${ename}::configure
+ if {[llength [info commands $ecmd]]} {
+ #uplevel #0 $ecmd $jlibname $args
+ }
+ }
+
+ return
+}
+
+# jlib::verify_options
+#
+# Check if valid options and set them.
+#
+# Arguments
+#
+# args The argument list given on the call.
+#
+# Side Effects
+# Sets error
+
+proc jlib::verify_options {jlibname args} {
+
+ upvar ${jlibname}::opts opts
+
+ set validopts [array names opts]
+ set usage [join $validopts ", "]
+ regsub -all -- - $validopts {} theopts
+ set pat ^-([join $theopts |])$
+ foreach {flag value} $args {
+ if {[regexp $pat $flag]} {
+
+ # Validate numbers
+ if {[info exists opts($flag)] && \
+ [string is integer -strict $opts($flag)] && \
+ ![string is integer -strict $value]} {
+ return -code error "Bad value for $flag ($value), must be integer"
+ }
+ set opts($flag) $value
+ } else {
+ return -code error "Unknown option $flag, can be: $usage"
+ }
+ }
+}
+
+# jlib::state --
+#
+# Accesor for the internal 'state'.
+
+proc jlib::state {jlibname} {
+
+ upvar ${jlibname}::lib lib
+
+ return $lib(state)
+}
+
+# jlib::register_reset --
+#
+# Packages can register here to get notified when the jlib stream is reset.
+
+proc jlib::register_reset {jlibname cmd} {
+
+ upvar ${jlibname}::lib lib
+
+ lappend lib(resetCmds) $cmd
+}
+
+# jlib::registertransport --
+#
+# We must have a transport mechanism for our xml. Socket is standard but
+# http is also possible.
+
+proc jlib::registertransport {jlibname name initProc sendProc resetProc ipProc} {
+
+ upvar ${jlibname}::lib lib
+
+ set lib(transport,name) $name
+ set lib(transport,init) $initProc
+ set lib(transport,send) $sendProc
+ set lib(transport,reset) $resetProc
+ set lib(transport,ip) $ipProc
+}
+
+proc jlib::transport {jlibname} {
+
+ upvar ${jlibname}::lib lib
+
+ return $lib(transport,name)
+}
+
+# jlib::setsockettransport --
+#
+# Sets the standard socket transport and the actual socket to use.
+
+proc jlib::setsockettransport {jlibname sock} {
+
+ upvar ${jlibname}::lib lib
+
+ # Settings for the raw socket transport layer.
+ set lib(sock) $sock
+ set lib(transport,name) "socket"
+ set lib(transport,init) [namespace current]::initsocket
+ set lib(transport,send) [namespace current]::putssocket
+ set lib(transport,reset) [namespace current]::resetsocket
+ set lib(transport,ip) [namespace current]::ipsocket
+}
+
+# The procedures for the standard socket transport layer -----------------------
+
+# jlib::initsocket
+#
+# Default transport mechanism; init already opened socket.
+#
+# Arguments:
+#
+# Side Effects:
+# none
+
+proc jlib::initsocket {jlibname} {
+
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::opts opts
+
+ set sock $lib(sock)
+ if {[catch {
+ fconfigure $sock -blocking 0 -buffering none -encoding utf-8
+ } err]} {
+ return -code error "The connection failed or dropped later"
+ }
+
+ # Set up callback on incoming socket.
+ fileevent $sock readable [list [namespace current]::recvsocket $jlibname]
+
+ # Schedule keep-alives to keep socket open in case anyone want's to close it.
+ # Be sure to not send any keep-alives before the stream is inited.
+ if {$opts(-keepalivesecs)} {
+ after [expr 1000 * $opts(-keepalivesecs)] \
+ [list [namespace current]::schedule_keepalive $jlibname]
+ }
+}
+
+# jlib::putssocket
+#
+# Default transport mechanism; put directly to socket.
+#
+# Arguments:
+#
+# xml The xml that is to be written.
+#
+# Side Effects:
+# none
+
+proc jlib::putssocket {jlibname xml} {
+
+ upvar ${jlibname}::lib lib
+
+ Debug 2 "SEND: $xml"
+
+ if {$lib(socketfilter,out) ne {}} {
+ set xml [$lib(socketfilter,out) $jlibname $xml]
+ }
+ if {[catch {puts -nonewline $lib(sock) $xml} err]} {
+ # Error propagated to the caller that calls clientcmd.
+ return -code error $err
+ }
+}
+
+# jlib::resetsocket
+#
+# Default transport mechanism; reset socket.
+#
+# Arguments:
+#
+# Side Effects:
+# none
+
+proc jlib::resetsocket {jlibname} {
+
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::locals locals
+
+ catch {close $lib(sock)}
+ catch {after cancel $locals(aliveid)}
+
+ set lib(socketfilter,out) [list]
+ set lib(socketfilter,in) [list]
+}
+
+# jlib::recvsocket --
+#
+# Default transport mechanism; fileevent on socket socket.
+# Callback on incoming socket xml data. Feeds our wrapper and XML parser.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+#
+# Results:
+# none.
+
+proc jlib::recvsocket {jlibname} {
+
+ upvar ${jlibname}::lib lib
+
+ if {[catch {eof $lib(sock)} iseof] || $iseof} {
+ kill $jlibname
+ invoke_async_error $jlibname networkerror
+ return
+ }
+
+ # Read what we've got.
+ if {[catch {read $lib(sock)} data]} {
+ kill $jlibname
+ invoke_async_error $jlibname networkerror
+ return
+ }
+ if {$lib(socketfilter,in) ne {}} {
+ set data [$lib(socketfilter,in) $jlibname $data]
+ }
+ Debug 2 "RECV: $data"
+
+ # Feed the XML parser. When the end of a command element tag is reached,
+ # we get a callback to 'jlib::dispatcher'.
+ wrapper::parse $lib(wrap) $data
+}
+
+proc jlib::set_socket_filter {jlibname outcmd incmd} {
+
+ upvar ${jlibname}::lib lib
+
+ set lib(socketfilter,out) $outcmd
+ set lib(socketfilter,in) $incmd
+
+ fconfigure $lib(sock) -translation binary
+}
+
+# jlib::ipsocket --
+#
+# Get our own ip address.
+
+proc jlib::ipsocket {jlibname} {
+
+ upvar ${jlibname}::lib lib
+
+ if {[string length $lib(sock)]} {
+ return [lindex [fconfigure $lib(sock) -sockname] 0]
+ } else {
+ return ""
+ }
+}
+
+# standard socket transport layer end ------------------------------------------
+
+proc jlib::tee_recv {jlibname cmd procName} {
+
+ upvar ${jlibname}::lib lib
+
+ if {$cmd eq "add"} {
+ lappend lib(tee,recv) $procName
+ } elseif {$cmd eq "remove"} {
+ set lib(tee,recv) [lsearch -all -inline -not $lib(tee,recv) $procName]
+ } else {
+ return -code error "unknown sub command \"$cmd\""
+ }
+}
+
+proc jlib::tee_send {jlibname cmd procName} {
+
+ upvar ${jlibname}::lib lib
+
+ if {$cmd eq "add"} {
+ lappend lib(tee,send) $procName
+ } elseif {$cmd eq "remove"} {
+ set lib(tee,send) [lsearch -all -inline -not $lib(tee,send) $procName]
+ } else {
+ return -code error "unknown sub command \"$cmd\""
+ }
+}
+
+# jlib::recv --
+#
+# Feed the XML parser. When the end of a command element tag is reached,
+# we get a callback to 'jlib::dispatcher'.
+
+proc jlib::recv {jlibname xml} {
+
+ upvar ${jlibname}::lib lib
+
+ wrapper::parse $lib(wrap) $xml
+}
+
+# jlib::openstream --
+#
+# Initializes a stream to a jabber server. The socket must already
+# be opened. Sets up fileevent on incoming xml stream.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# server: the domain name or ip number of the server.
+# args:
+# -cmd callback when we receive the <stream> tag from the server.
+# -to the receipients jabber id.
+# -id
+# -version
+#
+# Results:
+# none.
+
+proc jlib::openstream {jlibname server args} {
+
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::locals locals
+ upvar ${jlibname}::opts opts
+ variable xmppxmlns
+
+ array set argsA $args
+
+ # The server 'to' attribute is only temporary until we have either a
+ # confirmation or a redirection (alias) in received streams 'from' attribute.
+ set locals(server) $server
+ set locals(servermap) [jidmap $server]
+ set locals(last) [clock seconds]
+
+ # Make sure we start with a clean state.
+ wrapper::reset $lib(wrap)
+
+ set optattr ""
+ foreach {key value} $args {
+
+ switch -- $key {
+ -cmd {
+ if {$value ne ""} {
+ # Register a <stream> callback proc.
+ set lib(streamcmd) $value
+ }
+ }
+ -socket {
+ # empty
+ }
+ default {
+ set attr [string trimleft $key "-"]
+ append optattr " $attr='$value'"
+ }
+ }
+ }
+ set lib(isinstream) 1
+ set lib(state) "instream"
+
+ if {[catch {
+
+ # This call to the transport layer shall set up fileevent callbacks etc.
+ # to handle all incoming xml.
+ uplevel #0 $lib(transport,init) $jlibname
+
+ # Network errors if failed to open connection properly are likely to show here.
+ set xml "<?xml version='1.0' encoding='UTF-8'?><stream:stream\
+ xmlns='$opts(-streamnamespace)' xmlns:stream='$xmppxmlns(stream)'\
+ xml:lang='[getlang]' to='$server'$optattr>"
+
+ sendraw $jlibname $xml
+ } err]} {
+
+ # The socket probably was never connected,
+ # or the connection dropped later.
+ #closestream $jlibname
+ kill $jlibname
+ return -code error "The connection failed or dropped later: $err"
+ }
+ return
+}
+
+# jlib::sendstream --
+#
+# Utility for SASL, TLS etc. Sends only the actual stream:stream tag.
+# May throw error!
+
+proc jlib::sendstream {jlibname args} {
+
+ upvar ${jlibname}::locals locals
+ upvar ${jlibname}::opts opts
+ variable xmppxmlns
+
+ set attr ""
+ foreach {key value} $args {
+ set name [string trimleft $key "-"]
+ append attr " $name='$value'"
+ }
+ set xml "<stream:stream\
+ xmlns='$opts(-streamnamespace)' xmlns:stream='$xmppxmlns(stream)'\
+ to='$locals(server)' xml:lang='[getlang]' $attr>"
+
+ sendraw $jlibname $xml
+}
+
+# jlib::closestream --
+#
+# Closes the stream down, closes socket, and resets internal variables.
+# It should handle the complete shutdown of our connection and state.
+#
+# There is a potential problem if called from within a xml parser
+# callback which makes the subsequent parsing to fail. (after idle?)
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+#
+# Results:
+# none.
+
+proc jlib::closestream {jlibname} {
+
+ upvar ${jlibname}::lib lib
+
+ Debug 4 "jlib::closestream"
+
+ if {$lib(isinstream)} {
+ set xml "</stream:stream>"
+ catch {sendraw $jlibname $xml}
+ set lib(isinstream) 0
+ }
+ kill $jlibname
+}
+
+# jlib::invoke_async_error --
+#
+# Used for reporting async errors, typically network errors.
+
+proc jlib::invoke_async_error {jlibname err {msg ""}} {
+
+ upvar ${jlibname}::lib lib
+ Debug 4 "jlib::invoke_async_error err=$err, msg=$msg"
+
+ if {$lib(async_handler) eq ""} {
+ uplevel #0 $lib(clientcmd) [list $jlibname $err -errormsg $msg]
+ } else {
+ uplevel #0 $lib(async_handler) [list $jlibname $err $msg]
+ }
+}
+
+# jlib::set_async_error_handler --
+#
+# This is a way to get all async events directly to a registered handler
+# without delivering them to clientcmd. Used in jlib::connect.
+proc jlib::set_async_error_handler {jlibname {cmd ""}} {
+
+ upvar ${jlibname}::lib lib
+
+ set lib(async_handler) $cmd
+}
+
+# jlib::reporterror --
+#
+# Used for transports to report async, fatal and nonrecoverable errors.
+
+proc jlib::reporterror {jlibname err {msg ""}} {
+
+ Debug 4 "jlib::reporterror"
+
+ kill $jlibname
+ invoke_async_error $jlibname $err $msg
+}
+
+# jlib::kill --
+#
+# Like closestream but without any network transactions.
+
+proc jlib::kill {jlibname} {
+
+ upvar ${jlibname}::lib lib
+
+ Debug 4 "jlib::kill"
+
+ # Close socket typically.
+ catch {uplevel #0 $lib(transport,reset) $jlibname}
+ reset $jlibname
+
+ # Be sure to reset the wrapper, which implicitly resets the XML parser.
+ wrapper::reset $lib(wrap)
+ return
+}
+
+proc jlib::wrapper_reset {jlibname} {
+ upvar ${jlibname}::lib lib
+ wrapper::reset $lib(wrap)
+}
+
+# jlib::getip --
+#
+# Transport independent way of getting own ip address.
+
+proc jlib::getip {jlibname} {
+ upvar ${jlibname}::lib lib
+ return [$lib(transport,ip) $jlibname]
+}
+
+# jlib::getserver --
+#
+# Is the received streams 'from' attribute which is the logical host.
+# This is normally identical to the 'to' attribute but not always.
+
+proc jlib::getserver {jlibname} {
+ upvar ${jlibname}::locals locals
+ return $locals(server)
+}
+
+proc jlib::getservermap {jlibname} {
+ upvar ${jlibname}::locals locals
+ return $locals(servermap)
+}
+
+# jlib::isinstream --
+#
+# Utility to help us closing down a stream.
+
+proc jlib::isinstream {jlibname} {
+ upvar ${jlibname}::lib lib
+ return $lib(isinstream)
+}
+
+# jlib::dispatcher --
+#
+# Just dispatches the xml to any of the iq, message, or presence handlers,
+# which in turn dispatches further and/or handles internally.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# xmldata: the complete xml as a hierarchical list.
+#
+# Results:
+# none.
+
+proc jlib::dispatcher {jlibname xmldata} {
+ upvar ${jlibname}::lib lib
+
+ # Which method?
+ set tag [wrapper::gettag $xmldata]
+
+ switch -- $tag {
+ iq {
+ iq_handler $jlibname $xmldata
+ }
+ message {
+ message_handler $jlibname $xmldata
+ }
+ presence {
+ presence_handler $jlibname $xmldata
+ }
+ features {
+ features_handler $jlibname $xmldata
+ }
+ error {
+ error_handler $jlibname $xmldata
+ }
+ default {
+ element_run_hook $jlibname $xmldata
+ }
+ }
+
+ foreach cmd $lib(tee,recv) {
+ uplevel #0 $cmd [list $jlibname $xmldata]
+ }
+
+ # Will have to wait...
+ #general_run_hook $jlibname $xmldata
+}
+
+# jlib::iq_handler --
+#
+# Callback for incoming <iq> elements.
+# The handling sequence is the following:
+# 1) handle all preregistered callbacks via id attributes
+# 2) handle callbacks specific for 'type' and 'xmlns' that have been
+# registered with 'iq_register'
+# 3) if unhandled by 2, use any -iqcommand callback
+# 4) if type='get' and still unhandled, return an error element
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# xmldata the xml element as a list structure.
+#
+# Results:
+# roster object set, callbacks invoked.
+
+proc jlib::iq_handler {jlibname xmldata} {
+
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::iqcmd iqcmd
+ upvar ${jlibname}::opts opts
+ upvar ${jlibname}::locals locals
+ variable xmppxmlns
+
+ Debug 4 "jlib::iq_handler: ------------"
+
+ # Extract the command level XML data items.
+ set tag [wrapper::gettag $xmldata]
+ array set attrArr [wrapper::getattrlist $xmldata]
+
+ # Make an argument list ('-key value' pairs) suitable for callbacks.
+ # Make variables of the attributes.
+ set arglist [list]
+ foreach {key value} [array get attrArr] {
+ set $key $value
+ lappend arglist -$key $value
+ }
+
+ # This helps callbacks to adapt to using full element as argument.
+ lappend arglist -xmldata $xmldata
+
+ # The 'type' attribute must exist! Else we return silently.
+ if {![info exists type]} {
+ return
+ }
+ if {[info exists from]} {
+ set afrom $from
+ } else {
+ set afrom $locals(servermap)
+ }
+
+ # @@@ Section 9.2.3 of RFC 3920 states in part:
+ # 6. An IQ stanza of type "result" MUST include zero or one child elements.
+ # 7. An IQ stanza of type "error" SHOULD include the child element
+ # contained in the associated "get" or "set" and MUST include an <error/>
+ # child....
+
+ set childlist [wrapper::getchildren $xmldata]
+ set subiq [lindex $childlist 0]
+ set xmlns [wrapper::getattribute $subiq xmlns]
+
+ set ishandled 0
+
+ # (1) Handle all preregistered callbacks via id attributes.
+ # Must be type 'result' or 'error'.
+ # Some components use type='set' instead of 'result'.
+ # BUT this creates logical errors since we may also receive iq with
+ # identical id!
+
+ # @@@ It would be better NOT to have separate calls for errors.
+
+ switch -- $type {
+ result {
+
+ # Protect us from our own 'set' calls when we are awaiting
+ # 'result' or 'error'.
+ set setus 0
+ if {($type eq "set") && ($afrom eq $locals(myjidmap))} {
+ set setus 1
+ }
+
+ if {!$setus && [info exists id] && [info exists iqcmd($id)]} {
+ uplevel #0 $iqcmd($id) [list result $subiq]
+
+ # @@@ TODO:
+ #uplevel #0 $iqcmd($id) [list $jlibname xmldata]
+
+ # The callback my in turn call 'closestream' which unsets
+ # all iq before returning.
+ unset -nocomplain iqcmd($id)
+ set ishandled 1
+ }
+ }
+ error {
+ set errspec [getstanzaerrorspec $xmldata]
+ if {[info exists id] && [info exists iqcmd($id)]} {
+
+ # @@@ Having a separate form of error callbacks is really BAD!!!
+ uplevel #0 $iqcmd($id) [list error $errspec]
+
+ #uplevel #0 $iqcmd($id) [list $jlibname $xmldata]
+
+ unset -nocomplain iqcmd($id)
+ set ishandled 1
+ }
+ }
+ }
+
+ # (2) Handle callbacks specific for 'type' and 'xmlns' that have been
+ # registered with 'iq_register'
+
+ if {[string equal $ishandled "0"]} {
+ set ishandled [eval {
+ iq_run_hook $jlibname $type $xmlns $afrom $subiq} $arglist]
+ }
+
+ # (3) If unhandled by 2, use any -iqcommand callback.
+
+ if {[string equal $ishandled "0"]} {
+ if {[string length $opts(-iqcommand)]} {
+ set ishandled [uplevel #0 $opts(-iqcommand) [list $jlibname $xmldata]]
+ }
+
+ # (4) If type='get' or 'set', and still unhandled, return an error element.
+
+ if {[string equal $ishandled "0"] && \
+ ([string equal $type "get"] || [string equal $type "set"])} {
+
+ # Return a "Not Implemented" to the sender. Just switch to/from,
+ # type='result', and add an <error> element.
+ if {[info exists attrArr(from)]} {
+ return_error $jlibname $xmldata 501 cancel "feature-not-implemented"
+ }
+ }
+ }
+}
+
+# jlib::return_error --
+#
+# Returns an iq-error response using complete iq-element.
+
+proc jlib::return_error {jlibname iqElem errcode errtype errtag} {
+ variable xmppxmlns
+
+ array set attr [wrapper::getattrlist $iqElem]
+ set childlist [wrapper::getchildren $iqElem]
+
+ # Switch from -> to, type='error', retain any id.
+ set attr(to) $attr(from)
+ set attr(type) "error"
+ unset attr(from)
+
+ set iqElem [wrapper::setattrlist $iqElem [array get attr]]
+ set stanzaElem [wrapper::createtag $errtag \
+ -attrlist [list xmlns $xmppxmlns(stanzas)]]
+ set errElem [wrapper::createtag "error" -subtags [list $stanzaElem] \
+ -attrlist [list code $errcode type $errtype]]
+
+ lappend childlist $errElem
+ set iqElem [wrapper::setchildlist $iqElem $childlist]
+
+ send $jlibname $iqElem
+}
+
+# jlib::send_iq_error --
+#
+# Sends an iq error element as a response to a iq element.
+
+proc jlib::send_iq_error {jlibname jid id errcode errtype stanza {extraElem {}}} {
+ variable xmppxmlns
+
+ set stanzaElem [wrapper::createtag $stanza \
+ -attrlist [list xmlns $xmppxmlns(stanzas)]]
+ set errChilds [list $stanzaElem]
+ if {[llength $extraElem]} {
+ lappend errChilds $extraElem
+ }
+ set errElem [wrapper::createtag "error" \
+ -attrlist [list code $errcode type $errtype] \
+ -subtags $errChilds]
+ set iqElem [wrapper::createtag "iq" \
+ -attrlist [list type error to $jid id $id] -subtags [list $errElem]]
+
+ send $jlibname $iqElem
+}
+
+# jlib::message_handler --
+#
+# Callback for incoming <message> elements. See 'jlib::dispatcher'.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# xmldata the xml element as a list structure.
+#
+# Results:
+# callbacks invoked.
+
+proc jlib::message_handler {jlibname xmldata} {
+
+ upvar ${jlibname}::opts opts
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::msgcmd msgcmd
+
+ # Extract the command level XML data items.
+ set attrlist [wrapper::getattrlist $xmldata]
+ set childlist [wrapper::getchildren $xmldata]
+ set attrArr(type) "normal"
+ array set attrArr $attrlist
+ set type $attrArr(type)
+
+ # Make an argument list ('-key value' pairs) suitable for callbacks.
+ # Make variables of the attributes.
+ foreach {key value} [array get attrArr] {
+ set vopts(-$key) $value
+ }
+
+ # This helps callbacks to adapt to using full element as argument.
+ set vopts(-xmldata) $xmldata
+ set ishandled 0
+
+ switch -- $type {
+ error {
+ set errspec [getstanzaerrorspec $xmldata]
+ set vopts(-error) $errspec
+ }
+ }
+
+ # Extract the message sub-elements.
+ # @@@ really bad solution... Deliver full element instead
+ set xmlnsList [list]
+ foreach child $childlist {
+
+ # Extract the message sub-elements XML data items.
+ set ctag [wrapper::gettag $child]
+ set cchdata [wrapper::getcdata $child]
+
+ switch -- $ctag {
+ body - subject - thread {
+ set vopts(-$ctag) $cchdata
+ }
+ error {
+ # handled above
+ }
+ default {
+ lappend elem(-$ctag) $child
+ lappend xmlnsList [wrapper::getattribute $child xmlns]
+ }
+ }
+ }
+ set xmlnsList [lsort -unique $xmlnsList]
+ set arglist [array get vopts]
+
+ # Invoke any registered handler for this particular message.
+ set iscallback 0
+ if {[info exists attrArr(id)]} {
+ set id $attrArr(id)
+
+ # Avoid the weird situation when we send to ourself.
+ if {[info exists msgcmd($id)] && ![info exists msgcmd($id,self)]} {
+ uplevel #0 $msgcmd($id) [list $jlibname $type] $arglist
+ unset -nocomplain msgcmd($id)
+ set iscallback 1
+ }
+ unset -nocomplain msgcmd($id,self)
+ }
+
+ # Invoke any registered message handlers for this type and xmlns.
+ if {[array exists elem]} {
+ set arglist [concat [array get vopts] [array get elem]]
+ foreach xmlns $xmlnsList {
+ set ishandled [eval {
+ message_run_hook $jlibname $type $xmlns $xmldata} $arglist]
+ if {$ishandled} {
+ break
+ }
+ }
+ }
+ if {!$iscallback && [string equal $ishandled "0"]} {
+
+ # Invoke callback to client.
+ if {[string length $opts(-messagecommand)]} {
+ uplevel #0 $opts(-messagecommand) [list $jlibname $xmldata]
+ }
+ }
+}
+
+# jlib::send_message_error --
+#
+# Sends a message error element as a response to another message.
+
+proc jlib::send_message_error {jlibname jid id errcode errtype stanza {extraElem {}}} {
+ variable xmppxmlns
+
+ set stanzaElem [wrapper::createtag $stanza \
+ -attrlist [list xmlns $xmppxmlns(stanzas)]]
+ set errChilds [list $stanzaElem]
+ if {[llength $extraElem]} {
+ lappend errChilds $extraElem
+ }
+ set errElem [wrapper::createtag "error" \
+ -attrlist [list code $errcode type $errtype] \
+ -subtags $errChilds]
+ set msgElem [wrapper::createtag "iq" \
+ -attrlist [list type error to $jid id $id] \
+ -subtags [list $errElem]]
+
+ send $jlibname $msgElem
+}
+
+# jlib::presence_handler --
+#
+# Callback for incoming <presence> elements. See 'jlib::dispatcher'.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# xmldata the xml element as a list structure.
+#
+# Results:
+# roster object set, callbacks invoked.
+
+proc jlib::presence_handler {jlibname xmldata} {
+ variable statics
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::prescmd prescmd
+ upvar ${jlibname}::opts opts
+ upvar ${jlibname}::locals locals
+
+ set id [wrapper::getattribute $xmldata id]
+
+ # Handle callbacks specific for 'type' that have been registered with
+ # 'presence_register(_ex)'.
+
+ # We keep two sets of registered handlers, jlib internal which are
+ # called first, and then externals which are used by the client.
+
+ # Internals:
+ presence_run_hook $jlibname 1 $xmldata
+ presence_ex_run_hook $jlibname 1 $xmldata
+
+ # Externals:
+ presence_run_hook $jlibname 0 $xmldata
+ presence_ex_run_hook $jlibname 0 $xmldata
+
+ # Invoke any callback before the rosters callback.
+ # @@@ Right place ???
+ if {[info exists prescmd($id)]} {
+ uplevel #0 $prescmd($id) [list $jlibname $xmldata]
+ unset -nocomplain prescmd($id)
+ }
+
+ # This is the last station.
+ if {[string length $opts(-presencecommand)]} {
+ uplevel #0 $opts(-presencecommand) [list $jlibname $xmldata]
+ }
+}
+
+# jlib::features_handler --
+#
+# Callback for the <stream:features> element.
+
+proc jlib::features_handler {jlibname xmllist} {
+
+ upvar ${jlibname}::features features
+ variable xmppxmlns
+ variable jxmlns
+
+ Debug 4 "jlib::features_handler"
+
+ set features(xmllist) $xmllist
+
+ foreach child [wrapper::getchildren $xmllist] {
+ wrapper::splitxml $child tag attr chdata children
+ set xmlns [wrapper::getattribute $child xmlns]
+
+ # All feature elements must be namespaced.
+ if {$xmlns eq ""} {
+ continue
+ }
+ set features(elem,$xmlns) $child
+
+ switch -- $tag {
+ starttls {
+
+ # TLS
+ if {$xmlns eq $xmppxmlns(tls)} {
+ set features(starttls) 1
+ set childs [wrapper::getchildswithtag $child required]
+ if {$childs ne ""} {
+ set features(starttls,required) 1
+ }
+ }
+ }
+ compression {
+
+ # Compress
+ if {$xmlns eq $jxmlns(compress)} {
+ set features(compression) 1
+ foreach c [wrapper::getchildswithtag $child method] {
+ set method [wrapper::getcdata $c]
+ set features(compression,$method) 1
+ }
+ }
+ }
+ mechanisms {
+
+ # SASL
+ set mechanisms [list]
+ if {$xmlns eq $xmppxmlns(sasl)} {
+ set features(sasl) 1
+ foreach mechelem $children {
+ wrapper::splitxml $mechelem mtag mattr mchdata mchild
+ if {$mtag eq "mechanism"} {
+ lappend mechanisms $mchdata
+ }
+ set features(mechanism,$mchdata) 1
+ }
+ }
+
+ # Variable that may trigger a trace event.
+ set features(mechanisms) $mechanisms
+ }
+ bind {
+ if {$xmlns eq $xmppxmlns(bind)} {
+ set features(bind) 1
+ }
+ }
+ session {
+ if {$xmlns eq $xmppxmlns(session)} {
+ set features(session) 1
+ }
+ }
+ default {
+
+ # Have no idea of what this could be.
+ set features($xmlns) 1
+ }
+ }
+ }
+
+ if {$features(trace) ne {}} {
+ uplevel #0 $features(trace) [list $jlibname]
+ }
+}
+
+# jlib::trace_stream_features --
+#
+# Register a callback when getting stream features.
+# Only one component at a time.
+#
+# args: tclProc set callback
+# {} unset callback
+# empty return callback
+
+proc jlib::trace_stream_features {jlibname args} {
+
+ upvar ${jlibname}::features features
+
+ switch -- [llength $args] {
+ 0 {
+ return $features(trace)
+ }
+ 1 {
+ set features(trace) [lindex $args 0]
+ }
+ default {
+ return -code error "Usage: trace_stream_features ?tclProc?"
+ }
+ }
+}
+
+# jlib::get_feature, have_feature --
+#
+# Just to get access of the stream features.
+
+proc jlib::get_feature {jlibname name {name2 ""}} {
+
+ upvar ${jlibname}::features features
+
+ set ans ""
+ if {$name2 ne ""} {
+ if {[info exists features($name,$name2)]} {
+ set ans $features($name,$name2)
+ }
+ } else {
+ if {[info exists features($name)]} {
+ set ans $features($name)
+ }
+ }
+ return $ans
+}
+
+proc jlib::have_feature {jlibname {name ""} {name2 ""}} {
+
+ upvar ${jlibname}::features features
+
+ set ans 0
+ if {$name2 ne ""} {
+ if {[info exists features($name,$name2)]} {
+ set ans 1
+ }
+ } elseif {$name ne ""} {
+ if {[info exists features($name)]} {
+ set ans 1
+ }
+ } else {
+ if {[info exists features(xmllist)]} {
+ set ans 1
+ }
+ }
+ return $ans
+}
+
+# jlib::got_stream --
+#
+# Callback when we have parsed the initial root element.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# args: attributes
+#
+# Results:
+# none.
+
+proc jlib::got_stream {jlibname args} {
+
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::locals locals
+
+ Debug 4 "jlib::got_stream jlibname=$jlibname, args='$args'"
+
+ # Cache stream attributes.
+ foreach {name value} $args {
+ set locals(streamattr,$name) $value
+ }
+
+ # The streams 'from' attribute has the "last word" on the servers name.
+ if {[info exists locals(streamattr,from)]} {
+ set locals(server) $locals(streamattr,from)
+ set locals(servermap) [jidmap $locals(server)]
+ }
+ schedule_auto_away $jlibname
+
+ # If we use we should have a callback command here.
+ if {[info exists lib(streamcmd)] && [llength $lib(streamcmd)]} {
+ uplevel #0 $lib(streamcmd) $jlibname $args
+ unset lib(streamcmd)
+ }
+}
+
+# jlib::getthis --
+#
+# Access function for: server, username, myjid, myjid2...
+
+proc jlib::getthis {jlibname name} {
+
+ upvar ${jlibname}::locals locals
+
+ if {[info exists locals($name)]} {
+ return $locals($name)
+ } else {
+ return
+ }
+}
+
+# jlib::getstreamattr --
+#
+# Returns the value of any stream attribute, typically 'id'.
+
+proc jlib::getstreamattr {jlibname name} {
+
+ upvar ${jlibname}::locals locals
+
+ if {[info exists locals(streamattr,$name)]} {
+ return $locals(streamattr,$name)
+ } else {
+ return
+ }
+}
+
+# jlib::end_of_parse --
+#
+# Callback when the ending root element is parsed.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+#
+# Results:
+# none.
+
+proc jlib::end_of_parse {jlibname} {
+
+ upvar ${jlibname}::lib lib
+
+ Debug 4 "jlib::end_of_parse jlibname=$jlibname"
+
+ catch {eval $lib(transport,reset) $jlibname}
+ invoke_async_error $jlibname disconnect
+ reset $jlibname
+}
+
+# jlib::error_handler --
+#
+# Callback when receiving an stream:error element. According to xmpp-core
+# this is an unrecoverable error (4.7.1) and the stream MUST be closed
+# and the TCP connection also be closed.
+#
+# jabberd 1.4.3: <stream:error>Disconnected</stream:error>
+# jabberd 1.4.4:
+# <stream:error>
+# <xml-not-well-formed xmlns='urn:ietf:params:xml:ns:xmpp-streams'/>
+# </stream:error>
+# </stream:stream>
+
+proc jlib::error_handler {jlibname xmllist} {
+
+ variable xmppxmlns
+
+ Debug 4 "jlib::error_handler"
+
+ # This should handle all internal stuff.
+ closestream $jlibname
+
+ if {[llength [wrapper::getchildren $xmllist]]} {
+ set errspec [getstreamerrorspec $xmllist]
+ set errcode "xmpp-streams-error-[lindex $errspec 0]"
+ set errmsg [lindex $errspec 1]
+ } else {
+ set errcode xmpp-streams-error
+ set errmsg [wrapper::getcdata $xmllist]
+ }
+ invoke_async_error $jlibname $errcode $errmsg
+}
+
+# jlib::xmlerror --
+#
+# Callback when we receive an XML error from the wrapper (parser).
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+#
+# Results:
+# none.
+
+proc jlib::xmlerror {jlibname args} {
+
+ Debug 4 "jlib::xmlerror jlibname=$jlibname, args='$args'"
+
+ # This should handle all internal stuff.
+ closestream $jlibname
+ invoke_async_error $jlibname xmlerror $args
+}
+
+# jlib::reset --
+#
+# Unsets all iqcmd($id) callback procedures.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+#
+# Results:
+# none.
+
+proc jlib::reset {jlibname} {
+
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::iqcmd iqcmd
+ upvar ${jlibname}::prescmd prescmd
+ upvar ${jlibname}::locals locals
+ upvar ${jlibname}::features features
+
+ Debug 4 "jlib::reset"
+
+ cancel_auto_away $jlibname
+
+ set num $iqcmd(uid)
+ unset -nocomplain iqcmd
+ set iqcmd(uid) $num
+
+ set num $prescmd(uid)
+ unset -nocomplain prescmd
+ set prescmd(uid) $num
+
+ unset -nocomplain locals
+ unset -nocomplain features
+
+ init_inst $jlibname
+
+ set lib(isinstream) 0
+ set lib(state) "reset"
+
+ stream_reset $jlibname
+ if {[havesasl]} {
+ sasl_reset $jlibname
+ }
+ if {[havetls]} {
+ tls_reset $jlibname
+ }
+
+ # Execute any register reset commands.
+ foreach cmd $lib(resetCmds) {
+ uplevel #0 $cmd $jlibname
+ }
+}
+
+# jlib::stream_reset --
+#
+# Clears out all variables that are cached for this stream.
+# The xmpp specifies that any information obtained during tls,sasl
+# must be discarded before opening a new stream.
+# Call this before opening a new stream
+
+proc jlib::stream_reset {jlibname} {
+
+ upvar ${jlibname}::locals locals
+ upvar ${jlibname}::features features
+
+ array unset locals streamattr,*
+
+ set cmd $features(trace)
+ unset -nocomplain features
+ set features(trace) $cmd
+}
+
+# jlib::getstanzaerrorspec --
+#
+# Extracts the error code and an error message from an type='error'
+# element. We must handle both the original Jabber protocol and the
+# XMPP protocol:
+#
+# The syntax for stanza-related errors is as follows (XMPP):
+#
+# <stanza-kind to='sender' type='error'>
+# [RECOMMENDED to include sender XML here]
+# <error type='error-type'>
+# <defined-condition xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
+# <text xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'>
+# OPTIONAL descriptive text
+# </text>
+# [OPTIONAL application-specific condition element]
+# </error>
+# </stanza-kind>
+#
+# Jabber:
+#
+# <iq type='error'>
+# <query ...>
+# <error code='..'> ... </error>
+# </query>
+# </iq>
+#
+# or:
+# <iq type='error'>
+# <error code='401'/>
+# <query ...>...</query>
+# </iq>
+#
+# or:
+# <message type='error' ...>
+# ...
+# <error code='403'>Forbidden</error>
+# </message>
+
+proc jlib::getstanzaerrorspec {stanza} {
+
+ variable xmppxmlns
+
+ set errcode ""
+ set errmsg ""
+
+ # First search children of stanza (<iq> element) for error element.
+ foreach child [wrapper::getchildren $stanza] {
+ set tag [wrapper::gettag $child]
+ if {[string equal $tag "error"]} {
+ set errelem $child
+ }
+ if {[string equal $tag "query"]} {
+ set queryelem $child
+ }
+ }
+ if {![info exists errelem] && [info exists queryelem]} {
+
+ # Search children if <query> element (Jabber).
+ set errlist [wrapper::getchildswithtag $queryelem "error"]
+ if {[llength $errlist]} {
+ set errelem [lindex $errlist 0]
+ }
+ }
+
+ # Found it! XMPP contains an error stanza and not pure text.
+ if {[info exists errelem]} {
+ foreach {errcode errmsg} [geterrspecfromerror $errelem stanzas] {break}
+ }
+ return [list $errcode $errmsg]
+}
+
+# jlib::getstreamerrorspec --
+#
+# Extracts the error code and an error message from a stream:error
+# element. We must handle both the original Jabber protocol and the
+# XMPP protocol:
+#
+# The syntax for stream errors is as follows:
+#
+# <stream:error>
+# <defined-condition xmlns='urn:ietf:params:xml:ns:xmpp-streams'/>
+# <text xmlns='urn:ietf:params:xml:ns:xmpp-streams'>
+# OPTIONAL descriptive text
+# </text>
+# [OPTIONAL application-specific condition element]
+# </stream:error>
+#
+# Jabber:
+#
+
+proc jlib::getstreamerrorspec {errelem} {
+
+ return [geterrspecfromerror $errelem streams]
+}
+
+# jlib::geterrspecfromerror --
+#
+# Get an error specification from an stanza error element.
+#
+# Arguments:
+# errelem: the <error/> element
+# kind. 'stanzas' or 'streams'
+#
+# Results:
+# {errcode errmsg}
+
+proc jlib::geterrspecfromerror {errelem kind} {
+
+ variable xmppxmlns
+ variable errCodeToText
+
+ array set msgproc {
+ stanzas stanzaerror::getmsg
+ streams streamerror::getmsg
+ }
+ set cchdata [wrapper::getcdata $errelem]
+ set errcode [wrapper::getattribute $errelem code]
+ set errmsg "Unknown"
+
+ if {[string is integer -strict $errcode]} {
+ if {$cchdata ne ""} {
+ set errmsg $cchdata
+ } elseif {[info exists errCodeToText($errcode)]} {
+ set errmsg $errCodeToText($errcode)
+ }
+ } elseif {$cchdata ne ""} {
+
+ # Old jabber way.
+ set errmsg $cchdata
+ }
+
+ # xmpp way.
+ foreach c [wrapper::getchildren $errelem] {
+ set tag [wrapper::gettag $c]
+
+ switch -- $tag {
+ text {
+ # Use only as a complement iff our language. ???
+ set xmlns [wrapper::getattribute $c xmlns]
+ set lang [wrapper::getattribute $c xml:lang]
+ # [string equal $lang [getlang]]
+ if {[string equal $xmlns $xmppxmlns($kind)]} {
+ set errstr [wrapper::getcdata $c]
+ }
+ }
+ default {
+ set xmlns [wrapper::getattribute $c xmlns]
+ if {[string equal $xmlns $xmppxmlns($kind)]} {
+ set errcode $tag
+ set errstr [$msgproc($kind) $tag]
+ }
+ }
+ }
+ }
+ if {[info exists errstr]} {
+ set errmsg $errstr
+ }
+ if {$errmsg eq ""} {
+ set errmsg "Unknown"
+ }
+ return [list $errcode $errmsg]
+}
+
+# jlib::bind_resource --
+#
+# xmpp requires us to bind a resource to the stream.
+
+proc jlib::bind_resource {jlibname resource cmd} {
+
+ variable xmppxmlns
+
+ # If resource is an empty string request the server to create it.
+ set subtags [list]
+ if {$resource ne ""} {
+ set subtags [list [wrapper::createtag resource -chdata $resource]]
+ }
+ set xmllist [wrapper::createtag bind \
+ -attrlist [list xmlns $xmppxmlns(bind)] -subtags $subtags]
+ send_iq $jlibname set [list $xmllist] \
+ -command [list [namespace current]::parse_bind_resource $jlibname $cmd]
+}
+
+proc jlib::parse_bind_resource {jlibname cmd type subiq args} {
+
+ upvar ${jlibname}::locals locals
+ variable xmppxmlns
+
+ # The server MAY change the 'resource' why we need to check this here.
+ if {[string equal [wrapper::gettag $subiq] bind] && \
+ [string equal [wrapper::getattribute $subiq xmlns] $xmppxmlns(bind)]} {
+ set jidElem [wrapper::getfirstchildwithtag $subiq jid]
+ if {[llength $jidElem]} {
+
+ # Server replies with full JID.
+ set sjid [wrapper::getcdata $jidElem]
+ splitjid $sjid sjid2 sresource
+ if {![string equal [resourcemap $locals(resource)] $sresource]} {
+ set locals(myjid) $sjid
+ set locals(myjid2) $sjid2
+ set locals(resource) $sresource
+ set locals(myjidmap) [jidmap $sjid]
+ set locals(myjid2map) [jidmap $sjid2]
+ }
+ }
+ }
+ uplevel #0 $cmd [list $jlibname $type $subiq]
+}
+
+# jlib::invoke_iq_callback --
+#
+# Callback when we get server response on iq set/get.
+# This is a generic callback procedure.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# cmd: the 'cmd' argument in the calling procedure.
+# type: "error" or "ok".
+# subiq: if type="error", this is a list {errcode errmsg},
+# else it is the query element as a xml list structure.
+#
+# Results:
+# none.
+
+proc jlib::invoke_iq_callback {jlibname cmd type subiq} {
+
+ Debug 3 "jlib::invoke_iq_callback cmd=$cmd, type=$type, subiq=$subiq"
+
+ uplevel #0 $cmd [list $jlibname $type $subiq]
+}
+
+# jlib::parse_search_set --
+#
+# Callback for 'jabber:iq:search' 'result' and 'set' elements.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# cmd: the callback to notify.
+# type: "ok", "error", or "set"
+# subiq:
+
+proc jlib::parse_search_set {jlibname cmd type subiq} {
+
+ upvar ${jlibname}::lib lib
+
+ uplevel #0 $cmd [list $type $subiq]
+}
+
+# jlib::iq_register --
+#
+# Handler for registered iq callbacks.
+#
+# @@@ We could think of a more general mechanism here!!!!
+# 1) Using -type, -xmlns, -from etc.
+
+proc jlib::iq_register {jlibname type xmlns func {seq 50}} {
+
+ upvar ${jlibname}::iqhook iqhook
+
+ lappend iqhook($type,$xmlns) [list $func $seq]
+ set iqhook($type,$xmlns) \
+ [lsort -integer -index 1 [lsort -unique $iqhook($type,$xmlns)]]
+}
+
+proc jlib::iq_run_hook {jlibname type xmlns from subiq args} {
+
+ upvar ${jlibname}::iqhook iqhook
+
+ set ishandled 0
+
+ foreach key [list $type,$xmlns *,$xmlns $type,*] {
+ if {[info exists iqhook($key)]} {
+ foreach spec $iqhook($key) {
+ set func [lindex $spec 0]
+ set code [catch {
+ uplevel #0 $func [list $jlibname $from $subiq] $args
+ } ans]
+ if {$code} {
+ bgerror "iqhook $func failed: $code\n$::errorInfo"
+ }
+ if {[string equal $ans "1"]} {
+ set ishandled 1
+ break
+ }
+ }
+ }
+ if {$ishandled} {
+ break
+ }
+ }
+ return $ishandled
+}
+
+# jlib::message_register --
+#
+# Handler for registered message callbacks.
+#
+# We could think of a more general mechanism here!!!!
+
+proc jlib::message_register {jlibname type xmlns func {seq 50}} {
+
+ upvar ${jlibname}::msghook msghook
+
+ lappend msghook($type,$xmlns) [list $func $seq]
+ set msghook($type,$xmlns) \
+ [lsort -integer -index 1 [lsort -unique $msghook($type,$xmlns)]]
+}
+
+proc jlib::message_run_hook {jlibname type xmlns xmldata args} {
+
+ upvar ${jlibname}::msghook msghook
+
+ set ishandled 0
+
+ foreach key [list $type,$xmlns *,$xmlns $type,*] {
+ if {[info exists msghook($key)]} {
+ foreach spec $msghook($key) {
+ set func [lindex $spec 0]
+ set code [catch {
+ uplevel #0 $func [list $jlibname $xmlns $xmldata] $args
+ } ans]
+ if {$code} {
+ bgerror "msghook $func failed: $code\n$::errorInfo"
+ }
+ if {[string equal $ans "1"]} {
+ set ishandled 1
+ break
+ }
+ }
+ }
+ if {$ishandled} {
+ break
+ }
+ }
+ return $ishandled
+}
+
+# @@@ We keep two versions, internal for jlib usage and external for apps.
+# Do this for all registered callbacks!
+
+# jlib::presence_register --
+#
+# Handler for registered presence callbacks. Simple version.
+
+proc jlib::presence_register_int {jlibname type func {seq 50}} {
+ pres_reg $jlibname 1 $type $func $seq
+}
+
+proc jlib::presence_register {jlibname type func {seq 50}} {
+ pres_reg $jlibname 0 $type $func $seq
+}
+
+proc jlib::pres_reg {jlibname int type func {seq 50}} {
+
+ upvar ${jlibname}::preshook preshook
+
+ lappend preshook($int,$type) [list $func $seq]
+ set preshook($int,$type) \
+ [lsort -integer -index 1 [lsort -unique $preshook($int,$type)]]
+}
+
+proc jlib::presence_run_hook {jlibname int xmldata} {
+
+ upvar ${jlibname}::preshook preshook
+ upvar ${jlibname}::locals locals
+
+ set type [wrapper::getattribute $xmldata type]
+ set from [wrapper::getattribute $xmldata from]
+ if {$type eq ""} {
+ set type "available"
+ }
+ if {$from eq ""} {
+ set from $locals(server)
+ }
+ set ishandled 0
+
+ if {[info exists preshook($int,$type)]} {
+ foreach spec $preshook($int,$type) {
+ set func [lindex $spec 0]
+ set code [catch {
+ uplevel #0 $func [list $jlibname $xmldata]
+ } ans]
+ if {$code} {
+ bgerror "preshook $func failed: $code\n$::errorInfo"
+ }
+ if {[string equal $ans "1"]} {
+ set ishandled 1
+ break
+ }
+ }
+ }
+ return $ishandled
+}
+
+proc jlib::presence_deregister_int {jlibname type func} {
+ pres_dereg $jlibname 1 $type $func
+}
+
+proc jlib::presence_deregister {jlibname type func} {
+ pres_dereg $jlibname 0 $type $func
+}
+
+proc jlib::pres_dereg {jlibname int type func} {
+
+ upvar ${jlibname}::preshook preshook
+
+ if {[info exists preshook($int,$type)]} {
+ set idx [lsearch -glob $preshook($int,$type) "$func *"]
+ if {$idx >= 0} {
+ set preshook($int,$type) [lreplace $preshook($int,$type) $idx $idx]
+ }
+ }
+}
+
+# jlib::presence_register_ex --
+#
+# Set extended presence callbacks which can be triggered for
+# various attributes and elements.
+#
+# The internal storage consists of two parts:
+# 1) attributes; stored as array keys using wildcards (*)
+# 2) elements : stored as a -tag .. -xmlns .. list
+#
+# expreshook($type,$from,$from2) {{{-key value ...} tclProc seq} {...} ...}
+#
+# These are matched separately but not independently.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# func: tclProc
+# args: -type type and from must match the presence element
+# -from attributes
+# -from2 match the bare from jid
+# -tag tag and xmlns must coexist in the same element
+# -xmlns for a valid match
+# -seq priority 0-100 (D=50)
+#
+# Results:
+# none.
+
+proc jlib::presence_register_ex_int {jlibname func args} {
+ eval {pres_reg_ex $jlibname 1 $func} $args
+}
+
+proc jlib::presence_register_ex {jlibname func args} {
+ eval {pres_reg_ex $jlibname 0 $func} $args
+}
+
+proc jlib::pres_reg_ex {jlibname int func args} {
+
+ upvar ${jlibname}::expreshook expreshook
+
+ set type "*"
+ set from "*"
+ set from2 "*"
+ set seq 50
+
+ foreach {key value} $args {
+ switch -- $key {
+ -from - -from2 {
+ set name [string trimleft $key "-"]
+ set $name [ESC $value]
+ }
+ -type {
+ set type $value
+ }
+ -tag - -xmlns {
+ set aopts($key) $value
+ }
+ -seq {
+ set seq $value
+ }
+ }
+ }
+ set pat "$type,$from,$from2"
+
+ # The 'opts' must be ordered.
+ set opts [list]
+ foreach key [array names aopts] {
+ lappend opts $key $aopts($key)
+ }
+ lappend expreshook($int,$pat) [list $opts $func $seq]
+ set expreshook($int,$pat) \
+ [lsort -integer -index 2 [lsort -unique $expreshook($int,$pat)]]
+}
+
+proc jlib::presence_ex_run_hook {jlibname int xmldata} {
+
+ upvar ${jlibname}::expreshook expreshook
+ upvar ${jlibname}::locals locals
+
+ set type [wrapper::getattribute $xmldata type]
+ set from [wrapper::getattribute $xmldata from]
+ if {$type eq ""} {
+ set type "available"
+ }
+ if {$from eq ""} {
+ set from $locals(server)
+ }
+ set from2 [barejid $from]
+ set pkey "$int,$type,$from,$from2"
+
+ # Make matching in two steps, attributes and elements.
+ # First the attributes.
+ set matched [list]
+ foreach {pat value} [array get expreshook $int,*] {
+
+ if {[string match $pat $pkey]} {
+
+ foreach spec $value {
+
+ # Match attributes only if opts empty.
+ if {[lindex $spec 0] eq {}} {
+ set func [lindex $spec 1]
+ set code [catch {
+ uplevel #0 $func [list $jlibname $xmldata]
+ } ans]
+ if {$code} {
+ bgerror "preshook $func failed: $code\n$::errorInfo"
+ }
+ } else {
+
+ # Collect all callbacks that match the attributes and have
+ # a nonempty element spec.
+ lappend matched $spec
+ }
+ }
+ }
+ }
+
+ # Now try match the elements with the ones that matched the attributes.
+ if {[llength $matched]} {
+
+ # Start by collecting all tags and xmlns we have in 'xmldata'.
+ set tagxmlns [list]
+ foreach c [wrapper::getchildren $xmldata] {
+ set xmlns [wrapper::getattribute $c xmlns]
+ lappend tagxmlns [list [wrapper::gettag $c] $xmlns]
+ }
+
+ foreach spec $matched {
+ array set opts {-tag * -xmlns *}
+ array set opts [lindex $spec 0]
+
+ # The 'olist' must be ordered.
+ set olist [list $opts(-tag) $opts(-xmlns)]
+ set idx [lsearch -glob $tagxmlns $olist]
+ if {$idx >= 0} {
+ set func [lindex $spec 1]
+ set code [catch {
+ uplevel #0 $func [list $jlibname $xmldata]
+ } ans]
+ if {$code} {
+ bgerror "preshook $func failed: $code\n$::errorInfo"
+ }
+ }
+ }
+ }
+}
+
+proc jlib::presence_deregister_ex_int {jlibname func args} {
+ eval {pres_dereg_ex $jlibname 1 $func} $args
+}
+
+proc jlib::presence_deregister_ex {jlibname func args} {
+ eval {pres_dereg_ex $jlibname 0 $func} $args
+}
+
+proc jlib::pres_dereg_ex {jlibname int func args} {
+
+ upvar ${jlibname}::expreshook expreshook
+
+ set type "*"
+ set from "*"
+ set from2 "*"
+ set seq "*"
+
+ foreach {key value} $args {
+ switch -- $key {
+ -from - -from2 {
+ set name [string trimleft $key "-"]
+ set $name [jlib::ESC $value]
+ }
+ -type {
+ set type $value
+ }
+ -tag - -xmlns {
+ set aopts($key) $value
+ }
+ -seq {
+ set seq $value
+ }
+ }
+ }
+ set pat "$type,$from,$from2"
+ if {[info exists expreshook($int,$pat)]} {
+
+ # The 'opts' must be ordered.
+ set opts [list]
+ foreach key [array names aopts] {
+ lappend opts $key $aopts($key)
+ }
+ set idx [lsearch -glob $expreshook($int,$pat) [list $opts $func $seq]]
+ if {$idx >= 0} {
+ set expreshook($int,$pat) [lreplace $expreshook($int,$pat) $idx $idx]
+ if {$expreshook($int,$pat) eq {}} {
+ unset expreshook($int,$pat)
+ }
+ }
+ }
+}
+
+# jlib::element_register --
+#
+# Used to get callbacks from non stanza elements, like sasl etc.
+
+proc jlib::element_register {jlibname xmlns func {seq 50}} {
+
+ upvar ${jlibname}::elementhook elementhook
+
+ lappend elementhook($xmlns) [list $func $seq]
+ set elementhook($xmlns) \
+ [lsort -integer -index 1 [lsort -unique $elementhook($xmlns)]]
+}
+
+proc jlib::element_deregister {jlibname xmlns func} {
+
+ upvar ${jlibname}::elementhook elementhook
+
+ if {![info exists elementhook($xmlns)]} {
+ return
+ }
+ set ind -1
+ set found 0
+ foreach spec $elementhook($xmlns) {
+ incr ind
+ if {[string equal $func [lindex $spec 0]]} {
+ set found 1
+ break
+ }
+ }
+ if {$found} {
+ set elementhook($xmlns) [lreplace $elementhook($xmlns) $ind $ind]
+ }
+}
+
+proc jlib::element_run_hook {jlibname xmldata} {
+
+ upvar ${jlibname}::elementhook elementhook
+
+ set ishandled 0
+ set xmlns [wrapper::getattribute $xmldata xmlns]
+
+ if {[info exists elementhook($xmlns)]} {
+ foreach spec $elementhook($xmlns) {
+ set func [lindex $spec 0]
+ set code [catch {
+ uplevel #0 $func [list $jlibname $xmldata]
+ } ans]
+ if {$code} {
+ bgerror "preshook $func failed: $code\n$::errorInfo"
+ }
+ if {[string equal $ans "1"]} {
+ set ishandled 1
+ break
+ }
+ }
+ }
+ return $ishandled
+}
+
+# This part is supposed to be a maximal flexible event register mechanism.
+#
+# Bind: stanza (presence, iq, message,...)
+# its attributes (optional)
+# any child tag name (optional)
+# its attributes (optional)
+#
+# genhook(stanza) = {{attrspec childspec func seq} ...}
+#
+# with: attrspec = {name1 value1 name2 value2 ...}
+# childspec = {tag attrspec}
+
+# jlib::general_register --
+#
+# A mechanism to register for almost any kind of elements.
+
+proc jlib::general_register {jlibname tag attrspec childspec func {seq 50}} {
+
+ upvar ${jlibname}::genhook genhook
+
+ lappend genhook($tag) [list $attrspec $childspec $func $seq]
+ set genhook($tag) \
+ [lsort -integer -index 3 [lsort -unique $genhook($tag)]]
+}
+
+proc jlib::general_run_hook {jlibname xmldata} {
+
+ upvar ${jlibname}::genhook genhook
+
+ set ishandled 0
+ set tag [wrapper::gettag $xmldata]
+ if {[info exists genhook($tag)]} {
+ foreach spec $genhook($tag) {
+ lassign $spec attrspec childspec func seq
+ lassign $childspec ctag cattrspec
+ if {![match_attr $attrspec [wrapper::getattrlist $xmldata]]} {
+ continue
+ }
+
+ # Search child elements for matches.
+ set match 0
+ foreach c [wrapper::getchildren $xmldata] {
+ if {$ctag ne "" && $ctag ne [wrapper::gettag $c]} {
+ continue
+ }
+ if {![match_attr $cattrspec [wrapper::getattrlist $c]]} {
+ continue
+ }
+ set match 1
+ break
+ }
+ if {!$match} {
+ continue
+ }
+
+ # If the spec survived here it matched.
+ set code [catch {
+ uplevel #0 $func [list $jlibname $xmldata]
+ } ans]
+ if {$code} {
+ bgerror "genhook $func failed: $code\n$::errorInfo"
+ }
+ if {[string equal $ans "1"]} {
+ set ishandled 1
+ break
+ }
+ }
+ }
+ return $ishandled
+}
+
+proc jlib::match_attr {attrspec attr} {
+
+ array set attrA $attr
+ foreach {name value} $attrspec {
+ if {![info exists attrA($name)]} {
+ return 0
+ } elseif {$value ne $attrA($name)} {
+ return 0
+ }
+ }
+ return 1
+}
+
+proc jlib::general_deregister {jlibname tag attrspec childspec func} {
+
+ upvar ${jlibname}::genhook genhook
+
+ if {[info exists genhook($tag)]} {
+ set idx [lsearch -glob $genhook($tag) [list $attrspec $childspec $func *]]
+ if {$idx >= 0} {
+ set genhook($tag) [lreplace $genhook($tag) $idx $idx]
+
+ }
+ }
+}
+
+# Test code...
+if {0} {
+ proc cb {args} {puts "************** $args"}
+ set childspec [list query [list xmlns "http://jabber.org/protocol/disco#items"]]
+ ::jlib::jlib1 general_register iq {} $childspec cb
+ ::jlib::jlib1 general_deregister iq {} $childspec cb
+
+
+}
+
+# jlib::send_iq --
+#
+# To send an iq (info/query) packet.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# type: can be "get", "set", "result", or "error".
+# "result" and "error" are used when replying an incoming iq.
+# xmldata: list of elements as xmllists
+# args:
+# -to $to : Specify jid to send this packet to. If it
+# isn't specified, this part is set to sender's user-id by
+# the server.
+#
+# -id $id : Specify an id to send with the <iq>.
+# If $type is "get", or "set", then the id will be generated
+# by jlib internally, and this switch will not work.
+# If $type is "result" or "error", then you may use this
+# switch.
+#
+# -command $cmd : Specify a callback to call when the
+# reply-packet is got. This switch will not work if $type
+# is "result" or "error".
+#
+# Results:
+# none.
+
+proc jlib::send_iq {jlibname type xmldata args} {
+
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::iqcmd iqcmd
+
+ Debug 3 "jlib::send_iq type='$type', xmldata='$xmldata', args='$args'"
+
+ array set argsA $args
+ set attrlist [list "type" $type]
+
+ # Need to generate a unique identifier (id) for this packet.
+ if {[string equal $type "get"] || [string equal $type "set"]} {
+ lappend attrlist "id" $iqcmd(uid)
+
+ # Record any callback procedure.
+ if {[info exists argsA(-command)] && ($argsA(-command) ne "")} {
+ set iqcmd($iqcmd(uid)) $argsA(-command)
+ }
+ incr iqcmd(uid)
+ } elseif {[info exists argsA(-id)]} {
+ lappend attrlist "id" $argsA(-id)
+ }
+ unset -nocomplain argsA(-id) argsA(-command)
+ foreach {key value} [array get argsA] {
+ set name [string trimleft $key -]
+ lappend attrlist $name $value
+ }
+ set xmllist [wrapper::createtag "iq" -attrlist $attrlist -subtags $xmldata]
+
+ send $jlibname $xmllist
+ return
+}
+
+# jlib::iq_get, iq_set --
+#
+# Wrapper for 'send_iq' for set/getting namespaced elements.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# xmlns:
+# args: -to recepient jid
+# -command procName
+# -sublists
+# else as attributes
+#
+# Results:
+# none.
+
+proc jlib::iq_get {jlibname xmlns args} {
+
+ set opts [list]
+ set sublists [list]
+ set attrlist [list xmlns $xmlns]
+ foreach {key value} $args {
+
+ switch -- $key {
+ -command {
+ lappend opts -command \
+ [list [namespace current]::invoke_iq_callback $jlibname $value]
+ }
+ -to {
+ lappend opts -to $value
+ }
+ -sublists {
+ set sublists $value
+ }
+ default {
+ lappend attrlist [string trimleft $key "-"] $value
+ }
+ }
+ }
+ set xmllist [wrapper::createtag "query" -attrlist $attrlist \
+ -subtags $sublists]
+ eval {send_iq $jlibname "get" [list $xmllist]} $opts
+ return
+}
+
+proc jlib::iq_set {jlibname xmlns args} {
+
+ set opts [list]
+ set sublists [list]
+ foreach {key value} $args {
+
+ switch -- $key {
+ -command {
+ lappend opts -command \
+ [list [namespace current]::invoke_iq_callback $jlibname $value]
+ }
+ -to {
+ lappend opts -to $value
+ }
+ -sublists {
+ set sublists $value
+ }
+ default {
+ #lappend subelements [wrapper::createtag \
+ # [string trimleft $key -] -chdata $value]
+ }
+ }
+ }
+ set xmllist [wrapper::createtag "query" -attrlist [list xmlns $xmlns] \
+ -subtags $sublists]
+ eval {send_iq $jlibname "set" [list $xmllist]} $opts
+ return
+}
+
+# jlib::send_auth --
+#
+# Send simple client authentication.
+# It implements the 'jabber:iq:auth' set method.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# username:
+# resource:
+# cmd: client command to be executed at the iq "result" element.
+# args: Any of "-password" or "-digest" must be given.
+# -password
+# -digest
+# -to
+#
+# Results:
+# none.
+
+proc jlib::send_auth {jlibname username resource cmd args} {
+
+ upvar ${jlibname}::locals locals
+
+ set subelements [list \
+ [wrapper::createtag "username" -chdata $username] \
+ [wrapper::createtag "resource" -chdata $resource]]
+ set toopt [list]
+
+ foreach {key value} $args {
+ switch -- $key {
+ -password - -digest {
+ lappend subelements [wrapper::createtag \
+ [string trimleft $key -] -chdata $value]
+ }
+ -to {
+ set toopt [list -to $value]
+ }
+ }
+ }
+
+ # Cache our login jid.
+ set myjid ${username}@$locals(server)/${resource}
+ set myjid2 ${username}@$locals(server)
+
+ set locals(username) $username
+ set locals(resource) $resource
+ set locals(myjid) $myjid
+ set locals(myjid2) $myjid2
+ set locals(myjidmap) [jidmap $myjid]
+ set locals(myjid2map) [jidmap $myjid2]
+
+ set xmllist [wrapper::createtag "query" -attrlist {xmlns jabber:iq:auth} \
+ -subtags $subelements]
+ eval {send_iq $jlibname "set" [list $xmllist] -command \
+ [list [namespace current]::invoke_iq_callback $jlibname $cmd]} $toopt
+
+ return
+}
+
+# jlib::register_get --
+#
+# Sent with a blank query to retrieve registration information.
+# Retrieves a key for use on future registration pushes.
+# It implements the 'jabber:iq:register' get method.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# cmd: client command to be executed at the iq "result" element.
+# args: -to : the jid for the service
+#
+# Results:
+# none.
+
+proc jlib::register_get {jlibname cmd args} {
+
+ array set argsA $args
+ set xmllist [wrapper::createtag "query" -attrlist {xmlns jabber:iq:register}]
+ if {[info exists argsA(-to)]} {
+ set toopt [list -to $argsA(-to)]
+ } else {
+ set toopt ""
+ }
+ eval {send_iq $jlibname "get" [list $xmllist] -command \
+ [list [namespace current]::invoke_iq_callback $jlibname $cmd]} $toopt
+ return
+}
+
+# jlib::register_set --
+#
+# Create a new account with the server, or to update user information.
+# It implements the 'jabber:iq:register' set method.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# username:
+# password:
+# cmd: client command to be executed at the iq "result" element.
+# args: -to : the jid for the service
+# -nick :
+# -name :
+# -first :
+# -last :
+# -email :
+# -address :
+# -city :
+# -state :
+# -zip :
+# -phone :
+# -url :
+# -date :
+# -misc :
+# -text :
+# -key :
+#
+# Results:
+# none.
+
+proc jlib::register_set {jlibname username password cmd args} {
+
+ set subelements [list \
+ [wrapper::createtag "username" -chdata $username] \
+ [wrapper::createtag "password" -chdata $password]]
+ array set argsA $args
+ foreach argsswitch [array names argsA] {
+ if {[string equal $argsswitch "-to"]} {
+ continue
+ }
+ set par [string trimleft $argsswitch {-}]
+ lappend subelements [wrapper::createtag $par \
+ -chdata $argsA($argsswitch)]
+ }
+ set xmllist [wrapper::createtag "query" \
+ -attrlist {xmlns jabber:iq:register} \
+ -subtags $subelements]
+
+ if {[info exists argsA(-to)]} {
+ set toopt [list -to $argsA(-to)]
+ } else {
+ set toopt ""
+ }
+ eval {send_iq $jlibname "set" [list $xmllist] -command \
+ [list [namespace current]::invoke_iq_callback $jlibname $cmd]} $toopt
+ return
+}
+
+# jlib::register_remove --
+#
+# It implements the 'jabber:iq:register' set method with a <remove/> tag.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# to:
+# cmd: client command to be executed at the iq "result" element.
+# args -key
+#
+# Results:
+# none.
+
+proc jlib::register_remove {jlibname to cmd args} {
+
+ set subelements [list [wrapper::createtag "remove"]]
+ array set argsA $args
+ if {[info exists argsA(-key)]} {
+ lappend subelements [wrapper::createtag "key" -chdata $argsA(-key)]
+ }
+ set xmllist [wrapper::createtag "query" \
+ -attrlist {xmlns jabber:iq:register} -subtags $subelements]
+
+ eval {send_iq $jlibname "set" [list $xmllist] -command \
+ [list [namespace current]::invoke_iq_callback $jlibname $cmd]} -to $to
+ return
+}
+
+# jlib::search_get --
+#
+# Sent with a blank query to retrieve search information.
+# Retrieves a key for use on future search pushes.
+# It implements the 'jabber:iq:search' get method.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# to: this must be a searchable jud service, typically
+# 'jud.jabber.org'.
+# cmd: client command to be executed at the iq "result" element.
+#
+# Results:
+# none.
+
+proc jlib::search_get {jlibname to cmd} {
+
+ set xmllist [wrapper::createtag "query" -attrlist {xmlns jabber:iq:search}]
+ send_iq $jlibname "get" [list $xmllist] -to $to -command \
+ [list [namespace current]::invoke_iq_callback $jlibname $cmd]
+ return
+}
+
+# jlib::search_set --
+#
+# Makes an actual search in our roster at the server.
+# It implements the 'jabber:iq:search' set method.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# cmd: client command to be executed at the iq "result" element.
+# to: this must be a searchable jud service, typically
+# 'jud.jabber.org'.
+# args: -subtags list
+#
+# Results:
+# none.
+
+proc jlib::search_set {jlibname to cmd args} {
+
+ set argsA(-subtags) [list]
+ array set argsA $args
+
+ set xmllist [wrapper::createtag "query" \
+ -attrlist {xmlns jabber:iq:search} \
+ -subtags $argsA(-subtags)]
+ send_iq $jlibname "set" [list $xmllist] -to $to -command \
+ [list [namespace current]::parse_search_set $jlibname $cmd]
+
+ return
+}
+
+# jlib::send_message --
+#
+# Sends a message element.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# to: the jabber id of the receiver.
+# args:
+# -subject $subject : Set subject of the message to
+# $subject.
+#
+# -thread $thread : Set thread of the message to
+# $thread.
+#
+# -priority $priority : Set priority of the message to
+# $priority.
+#
+# -body text :
+#
+# -type $type : normal, chat or groupchat
+#
+# -id token
+#
+# -from : only for internal use, never send
+#
+# -xlist $xlist : A list containing *X* xml_data.
+# Anything can be put inside an *X*. Please make sure you
+# created it with "wrapper::createtag" procedure,
+# and also, it has a "xmlns" attribute in its root tag.
+#
+# -command
+#
+# Results:
+# none.
+
+proc jlib::send_message {jlibname to args} {
+
+ upvar ${jlibname}::msgcmd msgcmd
+ upvar ${jlibname}::locals locals
+
+ Debug 3 "jlib::send_message to=$to, args=$args"
+
+ array set argsA $args
+ if {[info exists argsA(-command)]} {
+ set uid $msgcmd(uid)
+ set msgcmd($uid) $argsA(-command)
+ incr msgcmd(uid)
+ lappend args -id $uid
+ unset argsA(-command)
+
+ # There exist a weird situation if we send to ourself.
+ # Skip this registered command the 1st time we get this,
+ # and let any handlers take over. Trigger this 2nd time.
+ if {[string equal $to $locals(myjidmap)]} {
+ set msgcmd($uid,self) 1
+ }
+
+ }
+ set xmllist [eval {send_message_xmllist $to} [array get argsA]]
+ send $jlibname $xmllist
+ return
+}
+
+# jlib::send_message_xmllist --
+#
+# Create the xml list for send_message.
+
+proc jlib::send_message_xmllist {to args} {
+
+ array set argsA $args
+ set attr [list to $to]
+ set children [list]
+
+ foreach {name value} $args {
+ set par [string trimleft $name "-"]
+
+ switch -- $name {
+ -xlist {
+ foreach xchild $value {
+ lappend children $xchild
+ }
+ }
+ -type {
+ if {![string equal $value "normal"]} {
+ lappend attr "type" $value
+ }
+ }
+ -id - -from {
+ lappend attr $par $value
+ }
+ default {
+ lappend children [wrapper::createtag $par -chdata $value]
+ }
+ }
+ }
+ return [wrapper::createtag "message" -attrlist $attr -subtags $children]
+}
+
+# jlib::send_presence --
+#
+# To send your presence.
+#
+# Arguments:
+#
+# jlibname: the instance of this jlib.
+# args:
+# -keep 0|1 (D=0) we may keep the present 'status' and 'show'
+# elements for undirected presence
+# -to the JID of the recepient.
+# -from should never be set by client!
+# -type one of 'available', 'unavailable', 'subscribe',
+# 'unsubscribe', 'subscribed', 'unsubscribed', 'invisible'.
+# -status
+# -priority persistant option if undirected presence
+# -show
+# -xlist
+# -extras
+# -command Specify a callback to call if we may expect any reply
+# package, as entering a room with 'gc-1.0'.
+#
+# Results:
+# none.
+
+proc jlib::send_presence {jlibname args} {
+
+ variable statics
+ upvar ${jlibname}::locals locals
+ upvar ${jlibname}::opts opts
+ upvar ${jlibname}::prescmd prescmd
+ upvar ${jlibname}::pres pres
+
+ Debug 3 "jlib::send_presence args='$args'"
+
+ set attrlist [list]
+ set children [list]
+ set directed 0
+ set keep 0
+ set type "available"
+ array set argsA $args
+
+ foreach {key value} $args {
+ set par [string trimleft $key -]
+
+ switch -- $key {
+ -command {
+ lappend attrlist "id" $prescmd(uid)
+ set prescmd($prescmd(uid)) $value
+ incr prescmd(uid)
+ }
+ -extras - -xlist {
+ foreach xchild $value {
+ lappend children $xchild
+ }
+ }
+ -from {
+ # Should never happen!
+ lappend attrlist $par $value
+ }
+ -keep {
+ set keep $value
+ }
+ -priority - -show {
+ lappend children [wrapper::createtag $par -chdata $value]
+ }
+ -status {
+ if {$value ne ""} {
+ lappend children [wrapper::createtag $par -chdata $value]
+ }
+ }
+ -to {
+ # Presence to server (undirected) shall not contain a to.
+ if {$value ne $locals(servermap)} {
+ lappend attrlist $par $value
+ set directed 1
+ }
+ }
+ -type {
+ set type $value
+ if {[regexp $statics(presenceTypeExp) $type]} {
+ lappend attrlist $par $type
+ } else {
+ return -code error "Is not valid presence type: \"$type\""
+ }
+ }
+ default {
+ return -code error "unrecognized option \"$value\""
+ }
+ }
+ }
+
+ # Must be destined to login server (by default).
+ if {!$directed} {
+
+ # Each and every presence stanza MUST contain the complete presence
+ # state of the client. As a convinience we cache previous states and
+ # may use them if not set explicitly:
+ # 1. <show/>
+ # 2. <status/>
+ # 3. <priority/> Always reused if cached
+
+ foreach name {show status} {
+ if {[info exists argsA(-$name)]} {
+ set locals(pres,$name) $argsA(-$name)
+ } elseif {[info exists locals(pres,$name)]} {
+ if {$keep} {
+ lappend children [wrapper::createtag $name \
+ -chdata $locals(pres,$name)]
+ } else {
+ unset -nocomplain locals(pres,$name)
+ }
+ }
+ }
+ if {[info exists argsA(-priority)]} {
+ set locals(pres,priority) $argsA(-priority)
+ } elseif {[info exists locals(pres,priority)]} {
+ lappend children [wrapper::createtag "priority" \
+ -chdata $locals(pres,priority)]
+ }
+
+ set locals(pres,type) $type
+
+ set locals(status) $type
+ if {[info exists argsA(-show)]} {
+ set locals(status) $argsA(-show)
+ set locals(pres,show) $argsA(-show)
+ }
+ }
+
+ # Assemble our registered presence stanzas. Only for undirected?
+ foreach {key elem} [array get pres "stanza,*,"] {
+ lappend children $elem
+ }
+ foreach {key elem} [array get pres "stanza,*,$type"] {
+ lappend children $elem
+ }
+
+ set xmllist [wrapper::createtag "presence" -attrlist $attrlist \
+ -subtags $children]
+ send $jlibname $xmllist
+
+ return
+}
+
+# jlib::register_presence_stanza, ... --
+#
+# Each presence element we send to the server (undirected) must contain
+# the complete state. This is a way to add custom presence stanzas
+# to our internal presence state to send each time we set our presence
+# with the server (undirected presence).
+# They are stored by tag, xmlns, and an optional type attribute.
+# Any existing presence stanza with identical tag/xmlns/type will
+# be replaced.
+#
+# Arguments:
+# jlibname: the instance of this jlib
+# elem: xml element
+# args -type available | unavailable | ...
+
+proc jlib::register_presence_stanza {jlibname elem args} {
+
+ upvar ${jlibname}::pres pres
+
+ set argsA(-type) ""
+ array set argsA $args
+ set type $argsA(-type)
+
+ set tag [wrapper::gettag $elem]
+ set xmlns [wrapper::getattribute $elem xmlns]
+ set pres(stanza,$tag,$xmlns,$type) $elem
+}
+
+proc jlib::deregister_presence_stanza {jlibname tag xmlns} {
+
+ upvar ${jlibname}::pres pres
+
+ array unset pres "stanza,$tag,$xmlns,*"
+}
+
+proc jlib::get_registered_presence_stanzas {jlibname {tag *} {xmlns *}} {
+
+ upvar ${jlibname}::pres pres
+
+ set stanzas [list]
+ foreach key [array names pres -glob stanza,$tag,$xmlns,*] {
+ lassign [split $key ,] - t x type
+ set spec [list $t $x $pres($key)]
+ if {$type ne ""} {
+ lappend spec -type $type
+ }
+ lappend stanzas $spec
+ }
+ return $stanzas
+}
+
+# jlib::send --
+#
+# Sends general xml using a xmllist.
+# Never throws error. Network errors reported via callback.
+
+proc jlib::send {jlibname xmllist} {
+
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::locals locals
+
+ # For the auto away function.
+ if {$locals(trigAutoAway)} {
+ schedule_auto_away $jlibname
+ }
+ set locals(last) [clock seconds]
+ set xml [wrapper::createxml $xmllist]
+ foreach cmd $lib(tee,send) {
+ uplevel #0 $cmd [list $jlibname $xmllist]
+ }
+
+ # We fail only if already in stream.
+ # The first failure reports the network error, closes the stream,
+ # which stops multiple errors to be reported to the client.
+ if {$lib(isinstream)} {
+ if {[catch {
+ uplevel #0 $lib(transport,send) [list $jlibname $xml]
+ } err]} {
+ kill $jlibname
+ invoke_async_error $jlibname networkerror
+ }
+ }
+ return
+}
+
+# jlib::sendraw --
+#
+# Send raw xml. The caller is responsible for catching errors.
+
+proc jlib::sendraw {jlibname xml} {
+
+ upvar ${jlibname}::lib lib
+
+ uplevel #0 $lib(transport,send) [list $jlibname $xml]
+}
+
+# jlib::mypresence --
+#
+# Returns any of {available away xa chat dnd invisible unavailable}
+# for our status with the login server.
+
+proc jlib::mypresence {jlibname} {
+
+ upvar ${jlibname}::locals locals
+
+ if {[info exists locals(pres,show)]} {
+ return $locals(pres,show)
+ } else {
+ return $locals(pres,type)
+ }
+}
+
+proc jlib::mypresencestatus {jlibname} {
+
+ upvar ${jlibname}::locals locals
+
+ if {[info exists locals(pres,status)]} {
+ return $locals(pres,status)
+ } else {
+ return ""
+ }
+}
+
+# jlib::myjid --
+#
+# Returns our 3-tier jid as authorized with the login server.
+
+proc jlib::myjid {jlibname} {
+ upvar ${jlibname}::locals locals
+ return $locals(myjid)
+}
+
+proc jlib::myjid2 {jlibname} {
+ upvar ${jlibname}::locals locals
+ return $locals(myjid2)
+}
+
+proc jlib::myjidmap {jlibname} {
+ upvar ${jlibname}::locals locals
+ return $locals(myjidmap)
+}
+
+proc jlib::myjid2map {jlibname} {
+ upvar ${jlibname}::locals locals
+ return $locals(myjid2map)
+}
+
+# jlib::oob_set --
+#
+# It implements the 'jabber:iq:oob' set method.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# to:
+# cmd: client command to be executed at the iq "result" element.
+# url:
+# args:
+# -desc
+#
+# Results:
+# none.
+
+proc jlib::oob_set {jlibname to cmd url args} {
+
+ set attrlist {xmlns jabber:iq:oob}
+ set children [list [wrapper::createtag "url" -chdata $url]]
+ array set argsA $args
+ if {[info exists argsA(-desc)] && [string length $argsA(-desc)]} {
+ lappend children [wrapper::createtag "desc" -chdata $argsA(-desc)]
+ }
+ set xmllist [wrapper::createtag query -attrlist $attrlist \
+ -subtags $children]
+ send_iq $jlibname set [list $xmllist] -to $to -command \
+ [list [namespace current]::invoke_iq_callback $jlibname $cmd]
+ return
+}
+
+# jlib::get_last --
+#
+# Query the 'last' of 'to' using 'jabber:iq:last' get.
+
+proc jlib::get_last {jlibname to cmd} {
+
+ set xmllist [wrapper::createtag "query" \
+ -attrlist {xmlns jabber:iq:last}]
+ send_iq $jlibname "get" [list $xmllist] -to $to -command \
+ [list [namespace current]::invoke_iq_callback $jlibname $cmd]
+ return
+}
+
+# jlib::handle_get_last --
+#
+# Seconds since last activity. Response to 'jabber:iq:last' get.
+
+proc jlib::handle_get_last {jlibname from subiq args} {
+
+ upvar ${jlibname}::locals locals
+
+ array set argsA $args
+
+ set secs [expr [clock seconds] - $locals(last)]
+ set xmllist [wrapper::createtag "query" \
+ -attrlist [list xmlns jabber:iq:last seconds $secs]]
+
+ set opts [list]
+ if {[info exists argsA(-from)]} {
+ lappend opts -to $argsA(-from)
+ }
+ if {[info exists argsA(-id)]} {
+ lappend opts -id $argsA(-id)
+ }
+ eval {send_iq $jlibname "result" [list $xmllist]} $opts
+
+ # Tell jlib's iq-handler that we handled the event.
+ return 1
+}
+
+# jlib::get_time --
+#
+# Query the 'time' of 'to' using 'jabber:iq:time' get.
+
+proc jlib::get_time {jlibname to cmd} {
+
+ set xmllist [wrapper::createtag "query" \
+ -attrlist {xmlns jabber:iq:time}]
+ send_iq $jlibname "get" [list $xmllist] -to $to -command \
+ [list [namespace current]::invoke_iq_callback $jlibname $cmd]
+ return
+}
+
+# jlib::handle_get_time --
+#
+# Send our time. Response to 'jabber:iq:time' get.
+
+proc jlib::handle_get_time {jlibname from subiq args} {
+
+ array set argsA $args
+
+ # Applications using 'jabber:iq:time' SHOULD use the old format,
+ # not the format defined in XEP-0082.
+ set secs [clock seconds]
+ set utc [clock format $secs -format "%Y%m%dT%H:%M:%S" -gmt 1]
+ set tz "GMT"
+ set display [clock format $secs]
+ set subtags [list \
+ [wrapper::createtag "utc" -chdata $utc] \
+ [wrapper::createtag "tz" -chdata $tz] \
+ [wrapper::createtag "display" -chdata $display] ]
+ set xmllist [wrapper::createtag "query" -subtags $subtags \
+ -attrlist {xmlns jabber:iq:time}]
+
+ set opts [list]
+ if {[info exists argsA(-from)]} {
+ lappend opts -to $argsA(-from)
+ }
+ if {[info exists argsA(-id)]} {
+ lappend opts -id $argsA(-id)
+ }
+ eval {send_iq $jlibname "result" [list $xmllist]} $opts
+
+ # Tell jlib's iq-handler that we handled the event.
+ return 1
+}
+
+# Support for XEP-0202 Entity Time.
+
+proc jlib::get_entity_time {jlibname to cmd} {
+ variable jxmlns
+
+ set xmllist [wrapper::createtag "time" \
+ -attrlist [list xmlns $jxmlns(entitytime)]]
+ send_iq $jlibname "get" [list $xmllist] -to $to -command \
+ [list [namespace current]::invoke_iq_callback $jlibname $cmd]
+ return
+}
+
+proc jlib::handle_entity_time {jlibname from subiq args} {
+ variable jxmlns
+
+ array set argsA $args
+
+ # Figure out our time zone in terms of HH:MM.
+ # Compare with the GMT time and take the diff. Avoid year wrap around.
+ set secs [clock seconds]
+ set day [clock format $secs -format "%j"]
+ if {$day eq "001"} {
+ incr secs [expr {24*60*60}]
+ } elseif {($day eq "365") || ($day eq "366")} {
+ incr secs [expr {-2*24*60*60}]
+ }
+ set format "%S + 60*(%M + 60*(%H + 24*%j))"
+ set local [clock format $secs -format $format]
+ set gmt [clock format $secs -format $format -gmt 1]
+
+ # Remove leading zeros since they will be interpreted as octals.
+ regsub -all {0+([1-9]+)} $local {\1} local
+ regsub -all {0+([1-9]+)} $gmt {\1} gmt
+ set local [expr $local]
+ set gmt [expr $gmt]
+ set mindiff [expr {($local - $gmt)/60}]
+ set sign [expr {$mindiff >= 0 ? "" : "-"}]
+ set zhour [expr {abs($mindiff)/60}]
+ set zmin [expr {$mindiff % 60}]
+ set tzo [format "$sign%.2d:%.2d" $zhour $zmin]
+
+ # Time format according to XEP-0082 (XMPP Date and Time Profiles).
+ # <utc>2006-12-19T17:58:35Z</utc>
+ set utc [clock format $secs -format "%Y-%m-%dT%H:%M:%SZ" -gmt 1]
+
+ set subtags [list \
+ [wrapper::createtag "tzo" -chdata $tzo] \
+ [wrapper::createtag "utc" -chdata $utc] ]
+ set xmllist [wrapper::createtag "time" -subtags $subtags \
+ -attrlist [list xmlns $jxmlns(entitytime)]]
+
+ set opts [list]
+ if {[info exists argsA(-from)]} {
+ lappend opts -to $argsA(-from)
+ }
+ if {[info exists argsA(-id)]} {
+ lappend opts -id $argsA(-id)
+ }
+ eval {send_iq $jlibname "result" [list $xmllist]} $opts
+ return 1
+}
+
+# jlib::get_version --
+#
+# Query the 'version' of 'to' using 'jabber:iq:version' get.
+
+proc jlib::get_version {jlibname to cmd} {
+
+ set xmllist [wrapper::createtag "query" \
+ -attrlist {xmlns jabber:iq:version}]
+ send_iq $jlibname "get" [list $xmllist] -to $to -command \
+ [list [namespace current]::invoke_iq_callback $jlibname $cmd]
+ return
+}
+
+# jlib::handle_get_version --
+#
+# Send our version. Response to 'jabber:iq:version' get.
+
+proc jlib::handle_get_version {jlibname from subiq args} {
+ global prefs tcl_platform
+ variable version
+
+ array set argsA $args
+
+ # Return any id!
+ set opts [list]
+ if {[info exists argsA(-id)]} {
+ set opts [list -id $argsA(-id)]
+ }
+ set os $tcl_platform(os)
+ if {[info exists tcl_platform(osVersion)]} {
+ append os " " $tcl_platform(osVersion)
+ }
+ lappend opts -to $from
+ set subtags [list \
+ [wrapper::createtag name -chdata "JabberLib"] \
+ [wrapper::createtag version -chdata $version] \
+ [wrapper::createtag os -chdata $os] ]
+ set xmllist [wrapper::createtag query -subtags $subtags \
+ -attrlist {xmlns jabber:iq:version}]
+ eval {send_iq $jlibname "result" [list $xmllist]} $opts
+
+ # Tell jlib's iq-handler that we handled the event.
+ return 1
+}
+
+# jlib::schedule_keepalive --
+#
+# Supposed to detect network failures but seems not to work like that.
+
+proc jlib::schedule_keepalive {jlibname} {
+
+ upvar ${jlibname}::locals locals
+ upvar ${jlibname}::opts opts
+ upvar ${jlibname}::lib lib
+
+ if {$opts(-keepalivesecs) && $lib(isinstream)} {
+ if {[catch {
+ uplevel #0 $lib(transport,send) [list $jlibname "\n"]
+ flush $lib(sock)
+ } err]} {
+ kill $jlibname
+ invoke_async_error $jlibname networkerror
+ } else {
+ set locals(aliveid) [after [expr 1000 * $opts(-keepalivesecs)] \
+ [list [namespace current]::schedule_keepalive $jlibname]]
+ }
+ }
+}
+
+# OUTDATED !!!!!!!!!!!!!!!!!!!!
+
+# jlib::schedule_auto_away, cancel_auto_away, auto_away_cmd
+#
+# Procedures for auto away things.
+# Better to use 'tk inactive' or 'tkinactive' and handle this on
+# application level.
+
+proc jlib::schedule_auto_away {jlibname} {
+
+ upvar ${jlibname}::locals locals
+ upvar ${jlibname}::opts opts
+
+ cancel_auto_away $jlibname
+ if {$opts(-autoawaymins) > 0} {
+ set locals(afterawayid) [after [expr 60000 * $opts(-autoawaymins)] \
+ [list [namespace current]::auto_away_cmd $jlibname away]]
+ }
+ if {$opts(-xautoawaymins) > 0} {
+ set locals(afterxawayid) [after [expr 60000 * $opts(-xautoawaymins)] \
+ [list [namespace current]::auto_away_cmd $jlibname xaway]]
+ }
+}
+
+proc jlib::cancel_auto_away {jlibname} {
+
+ upvar ${jlibname}::locals locals
+
+ if {[info exists locals(afterawayid)]} {
+ after cancel $locals(afterawayid)
+ unset locals(afterawayid)
+ }
+ if {[info exists locals(afterxawayid)]} {
+ after cancel $locals(afterxawayid)
+ unset locals(afterxawayid)
+ }
+}
+
+# jlib::auto_away_cmd --
+#
+# what: "away", or "xaway"
+#
+# @@@ Replaced by idletime and AutoAway
+
+proc jlib::auto_away_cmd {jlibname what} {
+
+ variable statusPriority
+ upvar ${jlibname}::locals locals
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::opts opts
+
+ Debug 3 "jlib::auto_away_cmd what=$what"
+
+ if {$what eq "xaway"} {
+ set status xa
+ } else {
+ set status $what
+ }
+
+ # Auto away and extended away are only set when the
+ # current status has a lower priority than away or xa respectively.
+ if {$statusPriority($locals(status)) >= $statusPriority($status)} {
+ return
+ }
+
+ # Be sure not to trig ourselves.
+ set locals(trigAutoAway) 0
+
+ switch -- $what {
+ away {
+ send_presence $jlibname -show "away" -status $opts(-awaymsg)
+ }
+ xaway {
+ send_presence $jlibname -show "xa" -status $opts(-xawaymsg)
+ }
+ }
+ set locals(trigAutoAway) 1
+ uplevel #0 $lib(clientcmd) [list $jlibname $status]
+}
+
+# jlib::getrecipientjid --
+#
+# Tries to obtain the correct form of jid to send message to.
+# Follows the XMPP spec, section 4.1.
+#
+# @@@ Perhaps this should go in app code?
+
+proc jlib::getrecipientjid {jlibname jid} {
+ variable statics
+
+ set jid2 [barejid $jid]
+ set isroom [[namespace current]::service::isroom $jlibname $jid2]
+ if {$isroom} {
+ return $jid
+ } elseif {[info exists statics(roster)] && \
+ [$jlibname roster isavailable $jid]} {
+ return $jid
+ } else {
+ return $jid2
+ }
+}
+
+proc jlib::getlang {} {
+
+ if {[catch {package require msgcat}]} {
+ return en
+ } else {
+ set lang [lindex [::msgcat::mcpreferences] end]
+
+ switch -- $lang {
+ "" - c - posix {
+ return en
+ }
+ default {
+ return $lang
+ }
+ }
+ }
+}
+
+namespace eval jlib {
+
+ # We just the http error codes here since may be useful if we only
+ # get the 'code' attribute in an error element.
+ # @@@ Add to message catalogs.
+ variable errCodeToText
+ array set errCodeToText {
+ 100 "Continue"
+ 101 "Switching Protocols"
+ 200 "OK"
+ 201 "Created"
+ 202 "Accepted"
+ 203 "Non-Authoritative Information"
+ 204 "No Content"
+ 205 "Reset Content"
+ 206 "Partial Content"
+ 300 "Multiple Choices"
+ 301 "Moved Permanently"
+ 302 "Found"
+ 303 "See Other"
+ 304 "Not Modified"
+ 305 "Use Proxy"
+ 307 "Temporary Redirect"
+ 400 "Bad Request"
+ 401 "Unauthorized"
+ 402 "Payment Required"
+ 403 "Forbidden"
+ 404 "Not Found"
+ 405 "Method Not Allowed"
+ 406 "Not Acceptable"
+ 407 "Proxy Authentication Required"
+ 408 "Request Time-out"
+ 409 "Conflict"
+ 410 "Gone"
+ 411 "Length Required"
+ 412 "Precondition Failed"
+ 413 "Request Entity Too Large"
+ 414 "Request-URI Too Large"
+ 415 "Unsupported Media Type"
+ 416 "Requested Range Not Satisfiable"
+ 417 "Expectation Failed"
+ 500 "Internal Server Error"
+ 501 "Not Implemented"
+ 502 "Bad Gateway"
+ 503 "Service Unavailable"
+ 504 "Gateway Time-out"
+ 505 "HTTP Version not supported"
+ }
+}
+
+# Various utility procedures to handle jid's....................................
+
+# jlib::ESC --
+#
+# array get and array unset accepts glob characters. These need to be
+# escaped if they occur as part of a JID.
+# NB1: 'string match pattern str' MUST have pattern escaped!
+# NB2: This also applies to 'lsearch'!
+
+proc jlib::ESC {s} {
+ return [string map {* \\* ? \\? [ \\[ ] \\] \\ \\\\} $s]
+}
+
+# STRINGPREPs for the differnt parts of jids.
+
+proc jlib::UnicodeListToRE {ulist} {
+
+ set str [string map {- -\\u} $ulist]
+ set str "\\u[join $str \\u]"
+ return [subst $str]
+}
+
+# jlib::MakeHexHexEscList --
+#
+# Takes a list of characters and transforms them to their hexhex form.
+# Used by: XEP-0106: JID Escaping
+
+proc jlib::MakeHexHexEscList {clist} {
+
+ set hexlist [list]
+ foreach c $clist {
+ scan $c %c n
+ lappend hexlist [format %x $n]
+ }
+ return $hexlist
+}
+
+proc jlib::MakeHexHexCharMap {clist} {
+
+ set map [list]
+ foreach c $clist h [MakeHexHexEscList $clist] {
+ lappend map $c \\$h
+ }
+ return $map
+}
+
+proc jlib::MakeHexHexInvCharMap {clist} {
+
+ set map [list]
+ foreach c $clist h [MakeHexHexEscList $clist] {
+ lappend map \\$h $c
+ }
+ return $map
+}
+
+namespace eval jlib {
+
+ # Characters that need to be escaped since non valid.
+ # XEP-0106: JID Escaping
+ variable jidEsc { "\&'/:<>@\\}
+ variable jidEscMap [MakeHexHexCharMap [split $jidEsc ""]]
+ variable jidEscInvMap [MakeHexHexInvCharMap [split $jidEsc ""]]
+
+ # Prohibited ASCII characters.
+ set asciiC12C22 {\x00-\x1f\x80-\x9f\x7f\xa0}
+ set asciiC11 {\x20}
+
+ # C.1.1 is actually allowed (RFC3491), weird!
+ set asciiProhibit(domain) $asciiC11
+ append asciiProhibit(domain) $asciiC12C22
+ append asciiProhibit(domain) /@
+
+ # The nodeprep prohibits these characters in addition:
+ # All whitespace characters (which reduce to U+0020, also called SP)
+ # U+0022 (")
+ # U+0026 (&)
+ # U+0027 (')
+ # U+002F (/)
+ # U+003A (:)
+ # U+003C (<)
+ # U+003E (>)
+ # U+0040 (@)
+ set asciiProhibit(node) {"&'/:<>@}
+ append asciiProhibit(node) $asciiC11
+ append asciiProhibit(node) $asciiC12C22
+
+ set asciiProhibit(resource) $asciiC12C22
+
+ # RFC 3454 (STRINGPREP); all unicode characters:
+ #
+ # Maps to nothing (empty).
+ set mapB1 {
+ 00ad 034f 1806 180b 180c 180d 200b 200c
+ 200d 2060 fe00 fe01 fe02 fe03 fe04 fe05
+ fe06 fe07 fe08 fe09 fe0a fe0b fe0c fe0d
+ fe0e fe0f feff
+ }
+
+ # ASCII space characters. Just a space.
+ set prohibitC11 {0020}
+
+ # Non-ASCII space characters
+ set prohibitC12 {
+ 00a0 1680 2000 2001 2002 2003 2004 2005
+ 2006 2007 2008 2009 200a 200b 202f 205f
+ 3000
+ }
+
+ # C.2.1 ASCII control characters
+ set prohibitC21 {
+ 0000-001F 007F
+ }
+
+ # C.2.2 Non-ASCII control characters
+ set prohibitC22 {
+ 0080-009f 06dd 070f 180e 200c 200d 2028
+ 2029 2060 2061 2062 2063 206a-206f feff
+ fff9-fffc 1d173-1d17a
+ }
+
+ # C.3 Private use
+ set prohibitC3 {
+ e000-f8ff f0000-ffffd 100000-10fffd
+ }
+
+ # C.4 Non-character code points
+ set prohibitC4 {
+ fdd0-fdef fffe-ffff 1fffe-1ffff 2fffe-2ffff
+ 3fffe-3ffff 4fffe-4ffff 5fffe-5ffff 6fffe-6ffff
+ 7fffe-7ffff 8fffe-8ffff 9fffe-9ffff afffe-affff
+ bfffe-bffff cfffe-cffff dfffe-dffff efffe-effff
+ ffffe-fffff 10fffe-10ffff
+ }
+
+ # C.5 Surrogate codes
+ set prohibitC5 {d800-dfff}
+
+ # C.6 Inappropriate for plain text
+ set prohibitC6 {
+ fff9 fffa fffb fffc fffd
+ }
+
+ # C.7 Inappropriate for canonical representation
+ set prohibitC7 {2ff0-2ffb}
+
+ # C.8 Change display properties or are deprecated
+ set prohibitC8 {
+ 0340 0341 200e 200f 202a 202b 202c 202d
+ 202e 206a 206b 206c 206d 206e 206f
+ }
+
+ # Test: 0, 1, 2, A-Z
+ set test {
+ 0030 0031 0032 0041-005a
+ }
+
+ # And many more...
+
+ variable mapB1RE [UnicodeListToRE $mapB1]
+ variable prohibitC11RE [UnicodeListToRE $prohibitC11]
+ variable prohibitC12RE [UnicodeListToRE $prohibitC12]
+
+}
+
+# jlib::splitjid --
+#
+# Splits a general jid into a jid-2-tier and resource
+
+proc jlib::splitjid {jid jid2Var resourceVar} {
+
+ set idx [string first / $jid]
+ if {$idx == -1} {
+ uplevel 1 [list set $jid2Var $jid]
+ uplevel 1 [list set $resourceVar {}]
+ } else {
+ set jid2 [string range $jid 0 [expr {$idx - 1}]]
+ set res [string range $jid [expr {$idx + 1}] end]
+ uplevel 1 [list set $jid2Var $jid2]
+ uplevel 1 [list set $resourceVar $res]
+ }
+}
+
+# jlib::splitjidex --
+#
+# Split a jid into the parts: jid = [ node "@" ] domain [ "/" resource ]
+# Possibly empty. Doesn't check for valid content, only the form.
+#
+# RFC3920 3.1:
+# jid = [ node "@" ] domain [ "/" resource ]
+
+proc jlib::splitjidex {jid nodeVar domainVar resourceVar} {
+
+ set node ""
+ set domain ""
+ set res ""
+
+ # Node part:
+ set idx [string first @ $jid]
+ if {$idx > 0} {
+ set node [string range $jid 0 [expr {$idx-1}]]
+ set jid [string range $jid [expr {$idx+1}] end]
+ }
+
+ # Resource part:
+ set idx [string first / $jid]
+ if {$idx > 0} {
+ set res [string range $jid [expr {$idx+1}] end]
+ set jid [string range $jid 0 [expr {$idx-1}]]
+ }
+
+ # Domain part is what remains:
+ set domain $jid
+
+ uplevel 1 [list set $nodeVar $node]
+ uplevel 1 [list set $domainVar $domain]
+ uplevel 1 [list set $resourceVar $res]
+}
+
+proc jlib::barejid {jid} {
+
+ set idx [string first / $jid]
+ if {$idx == -1} {
+ return $jid
+ } else {
+ return [string range $jid 0 [expr {$idx-1}]]
+ }
+}
+
+proc jlib::resourcejid {jid} {
+ set idx [string first / $jid]
+ if {$idx > 0} {
+ return [string range $jid [expr {$idx+1}] end]
+ } else {
+ return ""
+ }
+}
+
+proc jlib::isbarejid {jid} {
+ return [expr {([string first / $jid] == -1) ? 1 : 0}]
+}
+
+proc jlib::isfulljid {jid} {
+ return [expr {([string first / $jid] == -1) ? 0 : 1}]
+}
+
+# jlib::joinjid --
+#
+# Joins the, optionally empty, parts into a jid.
+# domain must be nonempty though.
+
+proc jlib::joinjid {node domain resource} {
+
+ set jid $domain
+ if {$node ne ""} {
+ set jid ${node}@${jid}
+ }
+ if {$resource ne ""} {
+ append jid "/$resource"
+ }
+ return $jid
+}
+
+# jlib::jidequal --
+#
+# Checks if two jids are actually equal after mapped. Does not check
+# for prohibited characters.
+
+proc jlib::jidequal {jid1 jid2} {
+ return [string equal [jidmap $jid1] [jidmap $jid2]]
+}
+
+# jlib::jidvalidate --
+#
+# Checks if this is a valid jid interms of form and characters.
+
+proc jlib::jidvalidate {jid} {
+
+ if {$jid eq ""} {
+ return 0
+ } elseif {[catch {splitjidex $jid node name resource} ans]} {
+ return 0
+ }
+ foreach what {node name resource} {
+ if {$what ne ""} {
+ if {[catch {${what}prep [set $what]} ans]} {
+ return 0
+ }
+ }
+ }
+ return 1
+}
+
+# String preparation (STRINGPREP) RFC3454:
+#
+# The steps for preparing strings are:
+#
+# 1) Map -- For each character in the input, check if it has a mapping
+# and, if so, replace it with its mapping. This is described in
+# section 3.
+#
+# 2) Normalize -- Possibly normalize the result of step 1 using Unicode
+# normalization. This is described in section 4.
+#
+# 3) Prohibit -- Check for any characters that are not allowed in the
+# output. If any are found, return an error. This is described in
+# section 5.
+#
+# 4) Check bidi -- Possibly check for right-to-left characters, and if
+# any are found, make sure that the whole string satisfies the
+# requirements for bidirectional strings. If the string does not
+# satisfy the requirements for bidirectional strings, return an
+# error. This is described in section 6.
+
+# jlib::*map --
+#
+# Does the mapping part.
+
+proc jlib::nodemap {node} {
+
+ return [string tolower $node]
+}
+
+proc jlib::namemap {domain} {
+
+ return [string tolower $domain]
+}
+
+proc jlib::resourcemap {resource} {
+
+ # Note that resources are case sensitive!
+ return $resource
+}
+
+# jlib::*prep --
+#
+# Does the complete stringprep.
+
+proc jlib::nodeprep {node} {
+ variable asciiProhibit
+
+ set node [nodemap $node]
+ if {[regexp ".*\[${asciiProhibit(node)}\].*" $node]} {
+ return -code error "node part contains illegal character(s)"
+ }
+ return $node
+}
+
+proc jlib::nameprep {domain} {
+ variable asciiProhibit
+
+ set domain [namemap $domain]
+ if {[regexp ".*\[${asciiProhibit(domain)}\].*" $domain]} {
+ return -code error "domain contains illegal character(s)"
+ }
+ return $domain
+}
+
+proc jlib::resourceprep {resource} {
+ variable asciiProhibit
+
+ set resource [resourcemap $resource]
+
+ # Orinary spaces are allowed!
+ if {[regexp ".*\[${asciiProhibit(resource)}\].*" $resource]} {
+ return -code error "resource contains illegal character(s)"
+ }
+ return $resource
+}
+
+# jlib::jidmap --
+#
+# Does the mapping part of STRINGPREP. Does not check for prohibited
+# characters.
+#
+# Results:
+# throws an error if form unrecognized, else the mapped jid.
+
+proc jlib::jidmap {jid} {
+
+ if {$jid eq ""} {
+ return
+ }
+ # Guard against spurious spaces.
+ set jid [string trim $jid]
+ splitjidex $jid node domain resource
+ return [joinjid [nodemap $node] [namemap $domain] [resourcemap $resource]]
+}
+
+# jlib::jidprep --
+#
+# Applies STRINGPREP to the individiual and specific parts of the jid.
+#
+# Results:
+# throws an error if prohibited, else the prepared jid.
+
+proc jlib::jidprep {jid} {
+
+ if {$jid eq ""} {
+ return
+ }
+ splitjidex $jid node domain resource
+ set node [nodeprep $node]
+ set domain [nameprep $domain]
+ set resource [resourceprep $resource]
+ return [joinjid $node $domain $resource]
+}
+
+proc jlib::MapStr {str } {
+
+ # TODO
+}
+
+# jlib::escapestr, unescapestr, escapejid, unescapejid --
+#
+# XEP-0106: JID Escaping
+# NB1: 'escapstr' and 'unescapstr' must only be applied to the node
+# part of a JID.
+# NB2: 'escapstr' must never be applied twice!
+# NB3: it is currently unclear if escaping should be allowed on "ordinary"
+# user JIDs
+
+proc jlib::escapestr {str} {
+ variable jidEscMap
+ return [string map $jidEscMap $str]
+}
+
+proc jlib::unescapestr {str} {
+ variable jidEscInvMap
+ return [string map $jidEscInvMap $str]
+}
+
+proc jlib::escapejid {jid} {
+
+ # Node part:
+ # @@@ I think there is a protocol flaw here!!!
+ set idx [string first @ $jid]
+ if {$idx > 0} {
+ set node [string range $jid 0 [expr {$idx-1}]]
+ set rest [string range $jid [expr {$idx+1}] end]
+ return [escapestr $node]@$rest
+ } else {
+ return $jid
+ }
+}
+
+proc jlib::unescapejid {jid} {
+
+ # Node part:
+ # @@@ I think there is a protocol flaw here!!!
+ set idx [string first @ $jid]
+ if {$idx > 0} {
+ set node [string range $jid 0 [expr {$idx-1}]]
+ set rest [string range $jid [expr {$idx+1}] end]
+ return [unescapestr $node]@$rest
+ } else {
+ return $jid
+ }
+}
+
+proc jlib::setdebug {args} {
+ variable debug
+
+ if {[llength $args] == 0} {
+ return $debug
+ } elseif {[llength $args] == 1} {
+ set debug $args
+ } else {
+ return -code error "Usage: jlib::setdebug ?integer?"
+ }
+}
+
+# jlib::generateuuid --
+#
+# Simplified uuid generator. See the uuid package for a better one.
+
+proc jlib::generateuuid {} {
+ set MAX_INT 0x7FFFFFFF
+ # Bugfix Eric Hassold from Evolane
+ set hex1 [format {%x} [expr {[clock clicks] & $MAX_INT}]]
+ set hex2 [format {%x} [expr {int($MAX_INT*rand())}]]
+ return $hex1-$hex2
+}
+
+proc jlib::Debug {num str} {
+ global fdDebug
+ variable debug
+ if {$num <= $debug} {
+ if {[info exists fdDebug]} {
+ puts $fdDebug $str
+ flush $fdDebug
+ }
+ puts $str
+ }
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# jingle.tcl --
+#
+# This file is part of the jabberlib.
+# It provides support for the jingle stuff XEP-0166,
+# and provides pluggable "slots" for media description formats and
+# transport methods, which are implemented separately.
+#
+# Copyright (c) 2006 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: jingle.tcl,v 1.10 2007/07/19 06:28:17 matben Exp $
+#
+############################# USAGE ############################################
+#
+# NAME
+# jingle - library for Jingle
+#
+# SYNOPSIS
+# jlib::jingle::init jlibname
+# jlib::jingle::register name priority mediaElems transportElems tclProc
+#
+# The 'tclProc' is invoked for all jingle 'set' we get as:
+#
+# tclProc {jlibname jingleElem args}
+#
+# where the args are as usual the iq attributes, and the jingleElem is
+# guranteed to be a valid jingle element with the required attributes.
+#
+# OPTIONS
+#
+#
+# INSTANCE COMMANDS
+# jlibName jingle initiate name jid mediaElems trptElems cmd
+# jlibName jingle getstate session|media|transport sid
+# jlibName jingle getvalue session|media|transport sid key
+# jlibName jingle send_set sid action cmd ?elems?
+# jlibName jingle free sid
+#
+# The 'cmd' here are invoked just as ordinary send_iq callbacks:
+#
+# cmd {type subiq args}
+#
+# o You MUST use either 'initiate' or 'send_set' for anything not a *-info
+# call in order to keep the internal state machines inn sync.
+#
+# o In your registered tclProc you must handle all calls and start by
+# acknowledging the receipt by sending a result for session-* actions (?).
+#
+# o When a session is ended you are required to 'free' it yourself.
+#
+# o While debugging you may switch off 'verifyState' below.
+#
+# Each component registers a callback proc which gets called when there is
+# a 'set' (async) call aimed for it.
+#
+# jlib::jingle
+# ------------
+# / | | \
+# / | | \
+# / | | \
+# / | | \
+# iax libjingle sip file-transfer
+#
+# TODO
+# Use responder attribute
+#
+# UNCLEAR
+# o When are the state changed, after sending an action or when the response
+# is received?
+# o Does the media and transport require a result set for every state change?
+#
+################################################################################
+
+package require jlib
+package require jlib::disco
+
+package provide jlib::jingle 0.1
+
+namespace eval jlib::jingle {
+
+ variable inited 0
+ variable inited_reg 0
+ variable jxmlns
+ set jxmlns(jingle) "http://jabber.org/protocol/jingle"
+ set jxmlns(media) "http://jabber.org/protocol/jingle/media"
+ set jxmlns(transport) "http://jabber.org/protocol/jingle/transport"
+ set jxmlns(errors) "http://jabber.org/protocol/jingle#errors"
+
+ # Storage for registered media and transport.
+ variable jingle
+
+ # Cache some of our capabilities.
+ variable have
+ set have(jingle) 0
+
+ # By default we verify all state changes.
+ variable verifyState 1
+
+ # For each session/media/transport state, make a map of allowed
+ # state changes: state + action -> new state
+ # State changes not listed here are not allowed.
+ # @@@ It is presently unclear if these are independent.
+ # At least session-initiate and session-terminate control
+ # the media and transport states.
+
+ # Session state maps:
+ variable sessionMap
+ array set sessionMap {
+ pending,session-accept active
+ pending,session-redirect ended
+ pending,session-info pending
+ pending,session-terminate ended
+ active,session-redirect ended
+ active,session-info active
+ active,session-terminate ended
+ }
+
+ # Media state maps:
+ variable mediaMap
+ array set mediaMap {
+ pending,media-info pending
+ pending,media-accept active
+ active,media-info active
+ active,media-modify modifying
+ modifying,media-info modifying
+ modifying,media-accept active
+ modifying,media-decline active
+ }
+
+ # Transport state maps:
+ variable transportMap
+ array set transportMap {
+ pending,transport-info pending
+ pending,transport-accept active
+ active,transport-info active
+ active,transport-modify modifying
+ modifying,transport-info modifying
+ modifying,transport-accept active
+ modifying,transport-decline active
+ }
+
+ # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::jingle::first_register --
+#
+# This is called for the first component that registers.
+
+proc jlib::jingle::first_register {} {
+ variable jxmlns
+ variable inited_reg
+ variable have
+
+ # Now we know we have at least one component supporting this.
+ jlib::disco::registerfeature $jxmlns(jingle)
+ set have(jingle) 1
+ set inited_reg 1
+}
+
+# jlib::jingle::register --
+#
+# A jingle component registers for a number of media and transport
+# elements. These are used together with its registered command to
+# dispatch incoming requests.
+# The 'name' is for internal use only and is not related to the
+# Jabber Registrar.
+# Disco features are automatically registered but caps are not.
+#
+# NB: Currently this must be called before any jlib instance created,
+# that is, before jlib::jingle::init!
+#
+# Arguments:
+# name: unique name
+# priority: number between 0-100
+# mediaElems: list of the media elements. Only the xmlns is necessary.
+# The complete elements is supplied when doing an initiate.
+# transportElems: same for transport
+# cmd: tclProc for callbacks
+#
+# Result:
+# name
+
+proc jlib::jingle::register {name priority mediaElems transportElems cmd} {
+ variable jingle
+ variable inited_reg
+
+ set jingle($name,name) $name
+ set jingle($name,prio) $priority
+ set jingle($name,cmd) $cmd
+ set jingle($name,lmedia) $mediaElems
+ set jingle($name,ltransport) $transportElems
+
+ # Extract the xmlns for media and transport.
+ set jingle($name,media,lxmlns) {}
+ foreach elem $mediaElems {
+ set xmlns [wrapper::getattribute $elem xmlns]
+ lappend jingle($name,media,lxmlns) $xmlns
+ }
+ set jingle($name,transport,lxmlns) {}
+ foreach elem $transportElems {
+ set xmlns [wrapper::getattribute $elem xmlns]
+ lappend jingle($name,transport,lxmlns) $xmlns
+ }
+
+ # Register disco xmlns.
+ if {!$inited_reg} {
+ first_register
+ }
+ foreach xmlns $jingle($name,media,lxmlns) {
+ jlib::disco::registerfeature $xmlns
+ }
+ foreach xmlns $jingle($name,transport,lxmlns) {
+ jlib::disco::registerfeature $xmlns
+ }
+ return $name
+}
+
+# jlib::jingle::init --
+#
+# Sets up jabberlib handlers and makes a new instance if a jingle object.
+
+proc jlib::jingle::init {jlibname args} {
+ variable inited
+ variable jxmlns
+
+ if {!$inited} {
+ InitOnce
+ }
+
+ # Keep state array for each session as session(sid,...).
+ namespace eval ${jlibname}::jingle {
+ variable session
+ }
+ upvar ${jlibname}::jingle::session session
+
+ # Register some standard iq handlers that is handled internally.
+ $jlibname iq_register set $jxmlns(jingle) [namespace current]::set_handler
+ $jlibname register_reset [namespace current]::reset
+
+ return
+}
+
+proc jlib::jingle::InitOnce { } {
+
+ variable inited
+
+
+ set inited 1
+}
+
+proc jlib::jingle::have {what} {
+ variable have
+
+ # ???
+}
+
+# jlib::jingle::cmdproc --
+#
+# Just dispatches the command to the right procedure.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# cmd:
+# args: all args to the cmd procedure.
+#
+# Results:
+# none.
+
+proc jlib::jingle::cmdproc {jlibname cmd args} {
+
+ # Which command? Just dispatch the command to the right procedure.
+ return [eval {$cmd $jlibname} $args]
+}
+
+# jlib::jingle::send_set --
+#
+# Utility function for sending jingle set stanzas.
+# This MUST be used instead of send_iq since the internal state
+# machines must be updated as well. The exception is *-info actions
+# which don't affect the state.
+#
+# Arguments:
+#
+# Results:
+# None.
+
+proc jlib::jingle::send_set {jlibname sid action cmd {elems {}}} {
+ variable verifyState
+
+ # Be sure to set the internal state as well.
+ set state [set_state $jlibname $sid $action]
+ if {$verifyState && $state eq ""} {
+ return -code error "the proposed action $action is not allowed"
+ }
+ do_send_set $jlibname $sid $action $cmd $elems
+ return
+}
+
+# jlib::jingle::do_send_set --
+#
+# Makes the actual sending. State must be fixed prior to call.
+# Internal use only.
+
+proc jlib::jingle::do_send_set {jlibname sid action cmd {elems {}}} {
+ variable jxmlns
+ upvar ${jlibname}::jingle::session session
+
+ set jid $session($sid,jid)
+ set initiator $session($sid,initiator)
+ set attr [list xmlns $jxmlns(jingle) action $action \
+ initiator $initiator sid $sid]
+ set jelem [wrapper::createtag jingle -attrlist $attr -subtags $elems]
+
+ jlib::send_iq $jlibname set [list $jelem] -to $jid -command $cmd
+}
+
+# @@@ If the state changes shall only take place *after* received a response,
+# we need to intersect all calls here.
+proc jlib::jingle::send_set_cb {} {
+
+}
+
+# @@@ Same thing here!
+proc jlib::jingle::send_result {} {
+
+}
+
+# jlib::jingle::set_state --
+#
+# Checks to see if the requested action is a valid one.
+# Sets the new state if ok.
+#
+# Arguments:
+#
+# Results:
+# empty if inconsistent, else the new state.
+
+proc jlib::jingle::set_state {jlibname sid action} {
+ variable sessionMap
+ variable mediaMap
+ variable transportMap
+ upvar ${jlibname}::jingle::session session
+
+ #puts "jlib::jingle::set_state"
+
+ # Since we are a state machine we must check that the requested state
+ # change is consistent.
+ if {$action eq "session-initiate"} {
+
+ # No error checking here!
+ set session($sid,state,session) "pending"
+ set session($sid,state,media) "pending"
+ set session($sid,state,transport) "pending"
+ #puts "\t action=$action, state=pending"
+ return "pending"
+ } elseif {$action eq "session-terminate"} {
+
+ # No error checking here!
+ set session($sid,state,session) "ended"
+ set session($sid,state,media) "ended"
+ set session($sid,state,transport) "ended"
+ #puts "\t action=$action, state=ended"
+ return "ended"
+
+ } else {
+ set actionType [lindex [split $action -] 0]
+ set state $session($sid,state,$actionType)
+
+ #puts "\t action=$action, state=$state, actionType=$actionType"
+ if {[info exists ${actionType}Map\($state,$action)]} {
+ set state [set ${actionType}Map\($state,$action)]
+ #puts "\t new state=$state"
+ set session($sid,state,$actionType) $state
+ return $state
+ } else {
+ #puts "\t out-of-sync"
+ return ""
+ }
+ }
+}
+
+# jlib::jingle::initiate --
+#
+# A jingle component makes a session-initiate request.
+# This must be used instead of send_set for the initiate call.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# name:
+# jid:
+# mediaElems:
+# trptElems:
+# cmd:
+#
+# Results:
+# sid.
+
+proc jlib::jingle::initiate {jlibname name jid mediaElems trptElems cmd args} {
+ variable jingle
+ upvar ${jlibname}::jingle::session session
+
+ #puts "jlib::jingle::initiate"
+
+ # SIP may want to generate its own sid.
+ set opts(-sid) [jlib::generateuuid]
+ set opts(-initiator) [jlib::myjid $jlibname]
+ array set opts $args
+ set sid $opts(-sid)
+
+ # We keep the internal jingle states for this sid.
+ set session($sid,sid) $sid
+ set session($sid,jid) $jid
+ set session($sid,name) $name
+ set session($sid,initiator) $opts(-initiator)
+ set session($sid,cmd) $jingle($name,cmd)
+
+ set subElems [concat $mediaElems $trptElems]
+ set_state $jlibname $sid "session-initiate"
+
+ do_send_set $jlibname $sid "session-initiate" $cmd $subElems
+
+ return $sid
+}
+
+# jlib::jingle::set_handler --
+#
+# Parse incoming jingle set element.
+
+proc jlib::jingle::set_handler {jlibname from subiq args} {
+ variable have
+ variable verifyState
+ upvar ${jlibname}::jingle::session session
+
+ #puts "jlib::jingle::set_handler"
+
+ array set argsArr $args
+ if {![info exists argsArr(-id)]} {
+ return
+ }
+ set id $argsArr(-id)
+
+ # There are several reasons why the target entity might return an error
+ # instead of acknowledging receipt of the initiation request:
+ # o The initiating entity is unknown to the target entity (e.g., via
+ # presence subscription).
+ # o The target entity does not support Jingle.
+ # o The target entity does not support any of the specified media
+ # description formats.
+ # o The target entity does not support any of the specified transport
+ # methods.
+ # o The initiation request was malformed.
+
+ set jelem [wrapper::getfirstchildwithtag $argsArr(-xmldata) "jingle"]
+ if {$jelem eq {}} {
+ jlib::send_iq_error $jlibname $from $id 404 cancel service-unavailable
+ return 1
+ }
+ if {!$have(jingle)} {
+ jlib::send_iq_error $jlibname $from $id 404 cancel service-unavailable
+ return 1
+ }
+
+ # Check required attributes: sid, action, initiator.
+ foreach aname {sid action initiator} {
+ set $aname [wrapper::getattribute $jelem $aname]
+ if {$aname eq ""} {
+ #puts "\t missing $aname"
+ jlib::send_iq_error $jlibname $from $id 404 cancel bad-request
+ return 1
+ }
+ }
+ #puts "\t $sid $action $initiator"
+
+ # We already have a session for this sid.
+ if {[info exists session($sid,sid)]} {
+ if {$verifyState && $session($sid,state,session) eq "ended"} {
+ send_error $jlibname $from $id unknown-session
+ return 1
+ }
+
+ # The action must not be an initiate.
+ if {$verifyState && $action eq "session-initiate"} {
+ send_error $jlibname $from $id out-of-order
+ return 1
+ }
+
+ # Since we are a state machine we must check that the requested state
+ # change is consistent.
+ set state [set_state $jlibname $sid $action]
+ if {$verifyState && $state eq ""} {
+ #puts "\t $action out-of-order"
+ send_error $jlibname $from $id out-of-order
+ return 1
+ }
+ } else {
+
+ # The first action must be an initiate.
+ if {$verifyState && $action ne "session-initiate"} {
+ send_error $jlibname $from $id out-of-order
+ return 1
+ }
+ }
+
+ switch -- $action {
+ "session-initiate" {
+ set session($sid,sid) $sid
+ set session($sid,jid) $from
+ set session($sid,initiator) $initiator
+ set session($sid,jelem) $jelem
+ eval {initiate_handler $jlibname $sid $id $jelem} $args
+ }
+ default {
+ uplevel #0 $session($sid,cmd) $jlibname [list $jelem] $args
+ }
+ }
+
+ # Is handled here.
+ return 1
+}
+
+# jlib::jingle::initiate_handler --
+#
+# We must find the jingle component that matches this initiate.
+
+proc jlib::jingle::initiate_handler {jlibname sid id jelem args} {
+ variable jingle
+ upvar ${jlibname}::jingle::session session
+
+ #puts "jlib::jingle::initiate_handler"
+
+ # Use the 'sid' as the identifier for the state array.
+ set session($sid,state,session) "pending"
+ set session($sid,state,media) "pending"
+ set session($sid,state,transport) "pending"
+
+ set jid $session($sid,jid)
+
+ # Match the media and transport with the ones we have registered,
+ # and use the best matched registered component.
+ set nsmedia {}
+ foreach elem [wrapper::getchildswithtag $jelem "description"] {
+ lappend nsmedia [wrapper::getattribute $elem xmlns]
+ }
+ set nstrpt {}
+ foreach elem [wrapper::getchildswithtag $jelem "transport"] {
+ lappend nstrpt [wrapper::getattribute $elem xmlns]
+ }
+
+ # @@@ This matches only the xmlns which is not enough.
+ # The details is up to each component to negotiate?
+ #
+ # Make a list of candidates that support both media and transport xmlns:
+ # {{name prio} ...} and order them in decreasing priorities.
+ set lbest {}
+ set anymedia 0
+ set anytransport 0
+ foreach {- name} [array get jingle *,name] {
+ set mns [jlib::util::lintersect $jingle($name,media,lxmlns) $nsmedia]
+ set tns [jlib::util::lintersect $jingle($name,transport,lxmlns) $nstrpt]
+
+ # A component must support both media and transport.
+ if {[llength $mns] && [llength $tns]} {
+ lappend lbest [list $name $jingle($name,prio)]
+ }
+ if {[llength $mns]} {
+ set anymedia 1
+ }
+ if {[llength $tns]} {
+ set anytransport 1
+ }
+ }
+ if {$lbest eq {}} {
+ if {!$anymedia} {
+ send_error $jlibname $jid $id unsupported-media
+ } elseif {!$anytransport} {
+ send_error $jlibname $jid $id unsupported-transports
+ } else {
+ # It is the actual combination media/transport that is unsupported.
+ send_error $jlibname $jid $id unsupported-media
+ }
+ } else {
+ set lbest [lsort -integer -index 1 -decreasing $lbest]
+ #puts "\t lbest=$lbest"
+
+ # Delegate to the component.
+ # It is then up to the component to take the initiatives:
+ # transport-accept etc.
+ # @@@ We make a crude shortcut here and pick only the best.
+ set name [lindex $lbest 0 0]
+ set cmd $jingle($name,cmd)
+ set session($sid,name) $name
+ set session($sid,cmd) $cmd
+ uplevel #0 $cmd $jlibname [list $jelem] $args
+ }
+}
+
+proc jlib::jingle::send_error {jlibname jid id stanza} {
+ variable jxmlns
+
+ #puts "jlib::jingle::send_error"
+ # @@@ Not sure about the details here.
+ # We must add an extra error element:
+ # <unsupported-transports
+ # xmlns='http://jabber.org/protocol/jingle#errors'/>
+ set elem [wrapper::createtag $stanza \
+ -attrlist [list xmlns $jxmlns(errors)]]
+ jlib::send_iq_error $jlibname $jid $id 404 cancel bad-request $elem
+}
+
+# A few accessor functions.
+
+# jlib::jingle::getstate --
+#
+# Return the current state for session, media, or transport.
+
+proc jlib::jingle::getstate {jlibname type sid} {
+ upvar ${jlibname}::jingle::session session
+
+ return $session($sid,state,$type)
+}
+
+proc jlib::jingle::getvalue {jlibname sid key} {
+ upvar ${jlibname}::jingle::session session
+
+ return $session($sid,$key)
+}
+
+proc jlib::jingle::havesession {jlibname sid} {
+ upvar ${jlibname}::jingle::session session
+
+ return [info exists session($sid,sid)]
+}
+
+proc jlib::jingle::reset {jlibname} {
+
+ # Shall we clear out all sessions here?
+}
+
+proc jlib::jingle::free {jlibname sid} {
+ upvar ${jlibname}::jingle::session session
+
+ array unset session $sid,*
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::jingle {
+
+ jlib::ensamble_register jingle \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+# Primitive test code.
+if {0} {
+ package require jlib::jingle
+
+ set jlibname jlib::jlib1
+ set myjid [jlib::myjid $jlibname]
+ set jid $myjid
+ set xmlnsTransportIAX "http://jabber.org/protocol/jingle/transport/iax"
+ set xmlnsMediaAudio "http://jabber.org/protocol/jingle/media/audio"
+
+ # Register:
+ set transportElem [wrapper::createtag "transport" \
+ -attrlist [list xmlns $xmlnsTransportIAX version 2] ]
+ set mediaElemAudio [wrapper::createtag "description" \
+ -attrlist [list xmlns $xmlnsMediaAudio] ]
+
+ proc cmdIAX {jlibname _jelem args} {
+ #puts "IAX: $args"
+ array set argsArr $args
+ set sid [wrapper::getattribute $_jelem sid]
+ set action [wrapper::getattribute $_jelem action]
+ #puts "\t action=$action, sid=$sid"
+
+ # Only session actions are acknowledged?
+ if {[string match "session-*" $action]} {
+ $jlibname send_iq result {} -to $argsArr(-from) -id $argsArr(-id)
+ }
+
+ switch -- $action {
+ "session-initiate" {
+ set ::jelem $_jelem
+
+
+ }
+ }
+ }
+ jlib::jingle::register iax 50 \
+ [list $mediaElemAudio] [list $transportElem] cmdIAX
+
+ # Disco:
+ proc cb {args} {puts "cb: $args"}
+ $jlibname disco send_get info $jid cb
+
+ # Initiate:
+ set sid [$jlibname jingle initiate iax $jid \
+ [list $mediaElemAudio] [list $transportElem] cb]
+
+ # IAX callbacks:
+ set media [wrapper::getfirstchildwithtag $jelem "description"]
+ $jlibname jingle send_set $sid "media-accept" cb [list $media]
+
+ set trpt [wrapper::getfirstchildwithtag $jelem "transport"]
+ $jlibname jingle send_set $sid "transport-accept" cb [list $trpt]
+
+ $jlibname jingle send_set $sid "session-accept" cb
+
+ # Talk here!
+
+ parray ${jlibname}::jingle::session
+
+ # Shut up!
+ $jlibname jingle send_set $sid "session-terminate" cb
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# jlibdns.tcl --
+#
+# This file is part of the jabberlib.
+# It provides support for XEP-0156:
+# A DNS TXT Resource Record Format for XMPP Connection Methods
+# and client DNS SRV records (XMPP Core sect. 14.3)
+#
+# Copyright (c) 2006-2008 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: jlibdns.tcl,v 1.9 2008/03/27 15:15:26 matben Exp $
+#
+############################# USAGE ############################################
+#
+# NAME
+# jlib::dns - library for DNS lookups
+#
+# SYNOPSIS
+# jlib::dns::get_addr_port domain cmd
+# jlib::dns::get_http_bind_url domain cmd OUTDATED
+# jlib::dns::get_http_poll_url domain cmd
+# jlib::dns::get_http_bosh_url domain cmd
+#
+############################# 7.1.2 Initial Registration #######################
+#
+# <method>
+# <name>_xmpp-client-httppoll</name>
+# <desc>HTTP Polling connection method</desc>
+# <syntax>
+# The http: or https: URL at which to contact the HTTP Polling connection manager or proxy
+# </syntax>
+# <doc>XEP-0025</doc>
+# </method>
+#
+# <method>
+# <name>_xmpp-client-xbosh</name>
+# <desc>XMPP Over Bosh connection method</desc>
+# <syntax>
+# The http: or https: URL at which to contact the HTTP Binding connection manager or proxy
+# </syntax>
+# <doc>XEP-0206</doc>
+# </method>
+
+package require dns 9.9 ;# Fake version to avoid loding buggy version.
+package require jlib
+
+package provide jlib::dns 0.1
+
+namespace eval jlib::dns {
+
+ variable owner
+ array set owner {
+ client _xmpp-client._tcp
+ poll _xmppconnect
+ }
+
+ variable nameA
+ array set nameA {
+ bind _xmpp-client-httpbind
+ bosh _xmpp-client-xbosh
+ poll _xmpp-client-httppoll
+ }
+}
+
+proc jlib::dns::get_addr_port {domain cmd args} {
+
+ # dns::resolve may throw error!
+ set name _xmpp-client._tcp.$domain
+ return [eval {dns::resolve $name -type SRV \
+ -command [list [namespace current]::addr_cb $cmd]} $args]
+}
+
+proc jlib::dns::addr_cb {cmd token} {
+
+ set addrList {}
+ if {[dns::status $token] eq "ok"} {
+ set result [dns::result $token]
+ foreach reply $result {
+ array unset rr
+ array set rr $reply
+ if {[info exists rr(rdata)]} {
+ array unset rd
+ array set rd $rr(rdata)
+ if {[info exists rd(priority)] && \
+ [info exists rd(weight)] && \
+ [info exists rd(port)] && \
+ [info exists rd(target)] && \
+ [isUInt16 $rd(priority)] && \
+ [isUInt16 $rd(weight)] && \
+ [isUInt16 $rd(port)] && \
+ ($rd(target) ne ".")} {
+ if {$rd(weight) == 0} {
+ set n 0
+ } else {
+ set n [expr {($rd(weight)+1)*rand()}]
+ }
+ set priority [expr {$rd(priority)*65536 - $n}]
+ lappend addrList [list $priority $rd(target) $rd(port)]
+ }
+ }
+ }
+ if {[llength $addrList]} {
+ set addrPort {}
+ foreach p [lsort -real -index 0 $addrList] {
+ lappend addrPort [lrange $p 1 2]
+ }
+ uplevel #0 $cmd [list $addrPort]
+ } else {
+ uplevel #0 $cmd [list {} dns-empty]
+ }
+ } else {
+ uplevel #0 $cmd [list {} [dns::error $token]]
+ }
+
+ # Weird bug!
+ #after 2000 [list dns::cleanup $token]
+}
+
+proc jlib::dns::isUInt16 {n} {
+ return [expr {[string is integer -strict $n] && $n >= 0 && $n < 65536} \
+ ? 1 : 0]
+}
+
+proc jlib::dns::get_http_bind_url {domain cmd args} {
+ set name _xmppconnect.$domain
+ return [eval {dns::resolve $name -type TXT \
+ -command [list [namespace current]::http_cb bind $cmd]} $args]
+}
+
+proc jlib::dns::get_http_bosh_url {domain cmd args} {
+ set name _xmppconnect.$domain
+ return [eval {dns::resolve $name -type TXT \
+ -command [list [namespace current]::http_cb bosh $cmd]} $args]
+}
+
+proc jlib::dns::get_http_poll_url {domain cmd args} {
+ set name _xmppconnect.$domain
+ return [eval {dns::resolve $name -type TXT \
+ -command [list [namespace current]::http_cb poll $cmd]} $args]
+}
+
+proc jlib::dns::http_cb {attr cmd token} {
+ variable nameA
+
+ set found 0
+ if {[dns::status $token] eq "ok"} {
+ set result [dns::result $token]
+ foreach reply $result {
+ array unset rr
+ array set rr $reply
+ if {[info exists rr(rdata)]} {
+ if {[regexp "$nameA($attr)=(.*)" $rr(rdata) - url]} {
+ set found 1
+ uplevel #0 $cmd [list $url]
+ }
+ }
+ }
+ if {!$found} {
+ uplevel #0 $cmd [list {} dns-no-resource-record]
+ }
+ } else {
+ uplevel #0 $cmd [list {} [dns::error $token]]
+ }
+
+ # Weird bug!
+ #after 2000 [list dns::cleanup $token]
+}
+
+proc jlib::dns::reset {token} {
+ ::dns::reset $token
+ ::dns::cleanup $token
+}
+
+# Test
+if {0} {
+ proc cb {args} {puts "---> $args"}
+ jlib::dns::get_addr_port gmail.com cb
+ jlib::dns::get_addr_port jabber.ru cb
+ jlib::dns::get_addr_port jabber.com cb
+ jlib::dns::get_addr_port jabber.cz cb
+ jlib::dns::get_addr_port tigase.org cb
+ # Missing
+ jlib::dns::get_http_poll_url gmail.com cb
+ jlib::dns::get_http_poll_url jabber.ru cb
+ jlib::dns::get_http_poll_url ham9.net cb
+}
--- /dev/null
+# jlibhttp.tcl ---
+#
+# Provides a http transport mechanism for jabberlib.
+# Implements the deprecated XEP-0025: Jabber HTTP Polling protocol.
+#
+# Copyright (c) 2002-2008 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: jlibhttp.tcl,v 1.21 2008/02/29 12:55:36 matben Exp $
+#
+# USAGE ########################################################################
+#
+# jlib::http::new jlibname url ?-key value ...?
+# url A valid url for the POST method of HTTP.
+#
+# -keylength sets the length of the key sequence
+# -maxpollms ms max interval in ms for post requests
+# -minpollms ms min interval in ms for post requests
+# -proxyhost domain name of proxu host if any
+# -proxyport integer and its port number
+# -proxyusername name your username for the proxy
+# -proxypasswd secret and your password
+# (-resendinterval ms if sending fails, try again after this interval)
+# -timeout ms timeout for connecting the server
+# -usekeys 0|1 if keys should be used
+#
+# Although you can use the -proxy* switches here, it is much simpler to let
+# the autoproxy package configure them.
+#
+# Callbacks for the JabberLib:
+# jlib::http::transportinit, jlib::http::transportreset,
+# jlib::http::send, jlib::http::transportip
+#
+# STATES #######################################################################
+#
+# priv(state): "" inactive and not reset
+# "instream" active connection
+# "reset" reset by callback
+#
+# priv(status): "" inactive
+# "scheduled" http post is scheduled as timer event
+# "pending" http post made, waiting for response
+# "error" error status
+
+package require jlib
+package require http 2.4
+package require base64
+package require sha1
+
+package provide jlib::http 0.1
+
+namespace eval jlib::http {
+
+ # Check for the TLS package so we can use https.
+ if {![catch {package require tls}]} {
+ http::register https 443 ::tls::socket
+ }
+
+ # Inherit jlib's debug level.
+ variable debug 0
+ if {!$debug} {
+ set debug [namespace parent]::debug
+ }
+ variable errcode
+ array set errcode {
+ 0 "unknown error"
+ -1 "server error"
+ -2 "bad request"
+ -3 "key sequence error"
+ }
+}
+
+# jlib::http::new --
+#
+# Configures the state of this thing.
+
+proc jlib::http::new {jlibname url args} {
+
+ namespace eval ${jlibname}::http {
+ variable priv
+ variable opts
+ }
+ upvar ${jlibname}::http::priv priv
+ upvar ${jlibname}::http::opts opts
+
+ Debug 2 "jlib::http::new url=$url, args=$args"
+
+ array set opts {
+ -keylength 64
+ -maxpollms 16000
+ -minpollms 4000
+ -proxyhost ""
+ -proxyport 80
+ -proxyusername ""
+ -proxypasswd ""
+ -resendinterval 20000
+ -timeout 30000
+ -usekeys 1
+ header ""
+ port 80
+ proxyheader ""
+ url ""
+ pollupfactor 0.8
+ polldownfactor 1.2
+ }
+ set RE {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$}
+ if {![regexp -nocase $RE $url - prefix proto host - port filepath]} {
+ return -code error "the url \"$url\" is not valid"
+ }
+ set opts(url) $url
+ set opts(host) $host
+ if {$port ne ""} {
+ set opts(port) $port
+ }
+ array set opts $args
+
+ set priv(id) 0
+ set priv(afterid) ""
+
+ # Perhaps the autoproxy package can be used here?
+ if {[string length $opts(-proxyhost)] && [string length $opts(-proxyport)]} {
+ ::http::config -proxyhost $opts(-proxyhost) -proxyport $opts(-proxyport)
+ }
+ if {[string length $opts(-proxyusername)] || \
+ [string length $opts(-proxypasswd)]} {
+ set opts(proxyheader) [BuildProxyHeader \
+ $opts(-proxyusername) $opts(-proxypasswd)]
+ }
+ set opts(header) $opts(proxyheader)
+
+ # Initialize.
+ InitState $jlibname
+
+ $jlibname registertransport "http" \
+ [namespace current]::transportinit \
+ [namespace current]::send \
+ [namespace current]::transportreset \
+ [namespace current]::transportip
+
+ return
+}
+
+# jlib::http::InitState --
+#
+# Sets initial state of 'priv' array.
+
+proc jlib::http::InitState {jlibname} {
+
+ upvar ${jlibname}::http::priv priv
+ upvar ${jlibname}::http::opts opts
+
+ set ms [clock clicks -milliseconds]
+
+ set priv(state) ""
+ set priv(status) ""
+
+ set priv(afterid) ""
+ set priv(xml) ""
+ set priv(lastxml) "" ; # Last posted xml.
+ set priv(id) 0
+ set priv(first) 1
+ set priv(first) 0
+ set priv(postms) -1
+ set priv(ip) ""
+ set priv(lastpostms) $ms
+ set priv(2lastpostms) $ms
+ set priv(keys) {}
+ if {$opts(-usekeys)} {
+ set priv(keys) [NewKeySequence [NewSeed] $opts(-keylength)]
+ }
+}
+
+# jlib::http::BuildProxyHeader --
+#
+# Builds list for the "Proxy-Authorization" header line.
+
+proc jlib::http::BuildProxyHeader {proxyusername proxypasswd} {
+
+ set str $proxyusername:$proxypasswd
+ set auth [list "Proxy-Authorization" "Basic [base64::encode $str]"]
+ return $auth
+}
+
+proc jlib::http::NewSeed { } {
+ set MAX_INT 0x7FFFFFFF
+ set num [expr {int($MAX_INT*rand())}]
+ return [format %0x $num]
+}
+
+proc jlib::http::NewKeySequence {seed len} {
+
+ set keys $seed
+ set prevkey $seed
+
+ for {set i 1} {$i < $len} {incr i} {
+
+ # It seems that it is expected to have sha1 in binary format;
+ # get from hex
+ set hex [::sha1::sha1 $prevkey]
+ set key [::base64::encode [binary format H* $hex]]
+ lappend keys $key
+ set prevkey $key
+ }
+ return $keys
+}
+
+# jlib::http::transportinit --
+#
+# For the -transportinit command.
+
+proc jlib::http::transportinit {jlibname} {
+
+ upvar ${jlibname}::http::priv priv
+ upvar ${jlibname}::http::opts opts
+
+ InitState $jlibname
+}
+
+# jlib::http::transportreset --
+#
+# For the -transportreset command.
+
+proc jlib::http::transportreset {jlibname} {
+
+ upvar ${jlibname}::http::priv priv
+
+ Debug 2 "jlib::http::transportreset"
+
+ # Stop polling and resends.
+ if {$priv(afterid) ne ""} {
+ catch {after cancel $priv(afterid)}
+ }
+ set priv(afterid) ""
+ set priv(state) "reset"
+ set priv(ip) ""
+
+ # If we have got cached xml to send must post it now and ignore response.
+ if {[string length $priv(xml)] > 2} {
+ Post $jlibname
+ }
+ if {[info exists priv(token)]} {
+ ::http::reset $priv(token)
+ ::http::cleanup $priv(token)
+ unset priv(token)
+ }
+}
+
+# jlib::http::transportip --
+#
+# Get our own ip address.
+# @@@ If proxy we have the usual firewall problem!
+
+proc jlib::http::transportip {jlibname} {
+
+ upvar ${jlibname}::http::priv priv
+
+ return $priv(ip)
+}
+
+# jlib::http::send --
+#
+# For the -transportsend command.
+
+proc jlib::http::send {jlibname xml} {
+
+ upvar ${jlibname}::http::priv priv
+ upvar ${jlibname}::http::opts opts
+
+ Debug 2 "jlib::http::send state='$priv(state)' $xml"
+
+ # Cancel if already 'reset'.
+ if {[string equal $priv(state) "reset"]} {
+ return
+ }
+ set priv(state) "instream"
+
+ append priv(xml) $xml
+
+ # If this is our first post we shall post right away.
+ if {$priv(status) eq ""} {
+ Post $jlibname
+
+ # Unless we already have a pending event, post as soon as possible.
+ } elseif {$priv(status) ne "pending"} {
+ PostASAP $jlibname
+ }
+}
+
+# jlib::http::PostASAP --
+#
+# Make a post as soon as possible without taking 'minpollms' as the
+# constraint. If we have waited longer than 'minpollms' post right away,
+# else reschedule if necessary to post at 'minpollms'.
+
+proc jlib::http::PostASAP {jlibname} {
+
+ upvar ${jlibname}::http::priv priv
+ upvar ${jlibname}::http::opts opts
+
+ Debug 2 "jlib::http::PostASAP"
+
+ if {$priv(afterid) eq ""} {
+ SchedulePost $jlibname minpollms
+ } else {
+
+ # now (case A) now (case B)
+ # | |
+ # ---------------------------------------------------> time
+ # | ->| ->|
+ # last post min max
+
+ # We shall always use '-minpollms' when there is something to send.
+ set nowms [clock clicks -milliseconds]
+ set minms [expr {$priv(lastpostms) + $opts(-minpollms)}]
+ if {$nowms < $minms} {
+
+ # Case A:
+ # If next post is scheduled after min, then repost at min instead.
+ if {$priv(nextpostms) > $minms} {
+ SchedulePost $jlibname minpollms
+ }
+ } else {
+
+ # Case B:
+ # We have already waited longer than '-minpollms'.
+ after cancel $priv(afterid)
+ set priv(afterid) ""
+ Post $jlibname
+ }
+ }
+}
+
+# jlib::http::Schedule --
+#
+# Computes the time for the next post and calls SchedulePost.
+
+proc jlib::http::Schedule {jlibname} {
+
+ upvar ${jlibname}::http::priv priv
+ upvar ${jlibname}::http::opts opts
+
+ Debug 2 "jlib::http::Schedule len priv(lastxml)=[string length $priv(lastxml)]"
+
+ # Compute time for next post.
+ set ms [clock clicks -milliseconds]
+ if {$priv(lastxml) eq ""} {
+ set when [expr {$opts(polldownfactor) * ($ms - $priv(2lastpostms))}]
+ set when [Min $when $opts(-maxpollms)]
+ set when [Max $when $opts(-minpollms)]
+ } else {
+ set when minpollms
+ }
+
+ # Reschedule next post unless 'reset'.
+ # Always keep a scheduled post at 'maxpollms' (or something else),
+ # and let any subsequent events reschedule if at an earlier time.
+ if {[string equal $priv(state) "instream"]} {
+ SchedulePost $jlibname $when
+ }
+}
+
+# jlib::http::SchedulePost --
+#
+# Schedule a post as a timer event.
+
+proc jlib::http::SchedulePost {jlibname when} {
+
+ upvar ${jlibname}::http::priv priv
+ upvar ${jlibname}::http::opts opts
+
+ Debug 2 "jlib::http::SchedulePost when=$when"
+
+ set nowms [clock clicks -milliseconds]
+
+ switch -- $when {
+ minpollms {
+ set minms [expr {$priv(lastpostms) + $opts(-minpollms)}]
+ set afterms [expr {$minms - $nowms}]
+ }
+ maxpollms {
+ set maxms [expr {$priv(lastpostms) + $opts(-maxpollms)}]
+ set afterms [expr {$maxms - $nowms}]
+ }
+ default {
+ set afterms $when
+ }
+ }
+ if {$afterms < 0} {
+ set afterms 0
+ }
+ set priv(afterms) [expr int($afterms)]
+ set priv(nextpostms) [expr {$nowms + $afterms}]
+ set priv(postms) [expr {$priv(nextpostms) - $priv(lastpostms)}]
+
+ if {$priv(afterid) ne ""} {
+ after cancel $priv(afterid)
+ }
+ set priv(status) "scheduled"
+ set priv(afterid) [after $priv(afterms) \
+ [list [namespace current]::Post $jlibname]]
+}
+
+# jlib::http::Post --
+#
+# Just a wrapper for PostXML when sending xml.
+
+proc jlib::http::Post {jlibname} {
+
+ upvar ${jlibname}::http::priv priv
+
+ Debug 2 "jlib::http::Post"
+
+ # If called directly any timers must have been cancelled before this.
+ set priv(afterid) ""
+ set xml $priv(xml)
+ set priv(xml) ""
+ PostXML $jlibname $xml
+}
+
+# jlib::http::PostXML --
+#
+# Do actual posting with (any) xml to send.
+# Always called from 'Post'.
+
+proc jlib::http::PostXML {jlibname xml} {
+
+ upvar ${jlibname}::http::priv priv
+ upvar ${jlibname}::http::opts opts
+
+ Debug 2 "jlib::http::PostXML"
+
+ set xml [encoding convertto utf-8 $xml]
+
+ if {$opts(-usekeys)} {
+
+ # Administrate the keys. Pick from end until no left.
+ set key [lindex $priv(keys) end]
+ set priv(keys) [lrange $priv(keys) 0 end-1]
+
+ # Need new key sequence?
+ if {[llength $priv(keys)] == 0} {
+ set priv(keys) [NewKeySequence [NewSeed] $opts(-keylength)]
+ set newkey [lindex $priv(keys) end]
+ set priv(keys) [lrange $priv(keys) 0 end-1]
+ set query "$priv(id);$key;$newkey,$xml"
+ Debug 4 "\t key change"
+ } else {
+ set query "$priv(id);$key,$xml"
+ }
+ } else {
+ set query "$priv(id),$xml"
+ }
+ set priv(status) "pending"
+ if {[string equal $priv(state) "reset"]} {
+ set cmdProc [namespace current]::NoopResponse
+ } else {
+ set cmdProc [list [namespace current]::Response $jlibname]
+ }
+ set progProc [list [namespace current]::Progress $jlibname]
+
+ Debug 2 "POST: $query"
+
+ # -query forces a POST request.
+ # Make sure we send it as text dispite the application/* type.???
+ if {[catch {
+ set token [::http::geturl $opts(url) \
+ -timeout $opts(-timeout) \
+ -headers $opts(header) \
+ -query $query \
+ -queryprogress $progProc \
+ -command $cmdProc]
+ } msg]} {
+ # @@@ We could have a method here to retry a number of times before
+ # giving up.
+ Debug 2 "\t post failed: $msg"
+ Error $jlibname networkerror $msg
+ } else {
+ set priv(token) $token
+ set priv(lastxml) $xml
+ set priv(2lastpostms) $priv(lastpostms)
+ set priv(lastpostms) [clock clicks -milliseconds]
+ }
+}
+
+# jlib::http::Progress --
+#
+# Only useful the first post to get socket and our own IP.
+
+proc jlib::http::Progress {jlibname token args} {
+
+ upvar ${jlibname}::http::priv priv
+
+ if {$priv(ip) eq ""} {
+ # @@@ When we switch to httpex we will add a method for this.
+ set s [set $token\(sock)]
+ set priv(ip) [lindex [fconfigure $s -sockname] 0]
+ }
+}
+
+# jlib::http::Response --
+#
+# The response to our POST request. Parse any indata that should
+# be of mime type text/xml
+
+proc jlib::http::Response {jlibname token} {
+
+ upvar #0 $token state
+ upvar ${jlibname}::http::priv priv
+ upvar ${jlibname}::http::opts opts
+ variable errcode
+
+ Debug 2 "jlib::http::Response priv(state)=$priv(state)"
+
+ # We may have been 'reset' after this post was sent!
+ if {[string equal $priv(state) "reset"]} {
+ return
+ }
+ set status [::http::status $token]
+
+ Debug 2 "\t status=$status, ::http::ncode=[::http::ncode $token]"
+
+ if {$status eq "ok"} {
+ if {[::http::ncode $token] != 200} {
+ Error $jlibname error [::http::ncode $token]
+ return
+ }
+ set haveCookie 0
+ set haveContentType 0
+
+ foreach {key value} $state(meta) {
+
+ if {[string equal -nocase $key "set-cookie"]} {
+
+ # Extract the 'ID' from the Set-Cookie key.
+ foreach pair [split $value ";"] {
+ set pair [string trim $pair]
+ if {[string equal -nocase -length 3 "ID=" $pair]} {
+ set id [string range $pair 3 end]
+ break
+ }
+ }
+
+ if {![info exists id]} {
+ Error $jlibname error \
+ "Set-Cookie in HTTP header \"$value\" invalid"
+ return
+ }
+
+ # Invesitigate the ID:
+ set ids [split $id :]
+ if {[llength $ids] == 2} {
+
+ # Any identifier that ends in ':0' indicates an error.
+ if {[string equal [lindex $ids 1] "0"]} {
+
+ # ID=0:0 Unknown Error. The response body can
+ # contain a textual error message.
+ # ID=-1:0 Server Error.
+ # ID=-2:0 Bad Request.
+ # ID=-3:0 Key Sequence Error .
+ set code [lindex $ids 0]
+ if {[info exists errcode($code)]} {
+ set errmsg $errcode($code)
+ } else {
+ set errmsg "Server error $id"
+ }
+ Error $jlibname error $errmsg
+ return
+ }
+ }
+ set haveCookie 1
+ } elseif {[string equal -nocase $key "content-type"]} {
+
+ # Responses from the server have Content-Type: text/xml.
+ # Both the request and response bodies are UTF-8
+ # encoded text, even if an HTTP header to the contrary
+ # exists.
+ # ejabberd: Content-Type {text/plain; charset=utf-8}
+
+ set typeOK 0
+ if {[string match -nocase "*text/xml*" $value]} {
+ set typeOK 1
+ } elseif {[regexp -nocase { *text/plain; *charset=utf-8} $value]} {
+ set typeOK 1
+ }
+
+ if {!$typeOK} {
+ # This is an invalid response.
+ set errmsg "Content-Type in HTTP header is "
+ append errmsg $value
+ append errmsg " expected \"text/xml\" or \"text/plain\""
+ Error $jlibname error $errmsg
+ return
+ }
+ set haveContentType 1
+ }
+ }
+ if {!$haveCookie} {
+ Error $jlibname error "missing Set-Cookie in HTTP header"
+ return
+ }
+ if {!$haveContentType} {
+ Error $jlibname error "missing Content-Type in HTTP header"
+ return
+ }
+ set priv(id) $id
+ set priv(lastxml) ""
+ set body [::http::data $token]
+ Debug 2 "POLL: $body"
+
+ # Send away to jabberlib for parsing and processing.
+ if {[string length $body] > 2} {
+ [namespace parent]::recv $jlibname $body
+ }
+
+ # Reschedule new POST.
+ # NB: We always rescedule from the POST callback to avoid queuing
+ # up requests which can distort the order and make a
+ # 'key sequence error'
+ if {[string length $body] > 2} {
+ SchedulePost $jlibname minpollms
+ } else {
+ Schedule $jlibname
+ }
+ } else {
+
+ # @@@ We could have a method here to retry a number of times before
+ # giving up.
+ Error $jlibname $status [::http::error $token]
+ return
+ }
+
+ # And cleanup after each post.
+ ::http::cleanup $token
+ unset priv(token)
+}
+
+# jlib::http::NoopResponse --
+#
+# This shall be used when we flush out any xml after a 'reset' and
+# don't expect any further actions to be taken.
+
+proc jlib::http::NoopResponse {token} {
+
+ Debug 2 "jlib::http::NoopResponse"
+
+ # Only thing we shall do here.
+ ::http::cleanup $token
+}
+
+# jlib::http::Error --
+#
+# Only network errors and server errors are reported here.
+
+proc jlib::http::Error {jlibname status {errmsg ""}} {
+
+ upvar ${jlibname}::http::priv priv
+
+ Debug 2 "jlib::http::Error status=$status, errmsg=$errmsg"
+
+ set priv(status) "error"
+ if {[info exists priv(token)]} {
+ ::http::cleanup $priv(token)
+ unset priv(token)
+ }
+
+ # @@@ We should perhaps be more specific here.
+ jlib::reporterror $jlibname networkerror $errmsg
+}
+
+proc jlib::http::Min {x y} {
+ return [expr {$x <= $y ? $x : $y}]
+}
+
+proc jlib::http::Max {x y} {
+ return [expr {$x >= $y ? $x : $y}]
+}
+
+proc jlib::http::Debug {num str} {
+ variable debug
+ if {$num <= $debug} {
+ puts $str
+ }
+}
+
+#-------------------------------------------------------------------------------
+
--- /dev/null
+# jlibsasl.tcl --
+#
+# This file is part of the jabberlib. It provides support for the
+# sasl authentication layer via the tclsasl package or the saslmd5
+# pure tcl package.
+# It also makes the resource binding and session initiation.
+#
+# o sasl authentication
+# skipped:
+# X bind resource
+# X establish session
+#
+# Copyright (c) 2004-2006 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: jlibsasl.tcl,v 1.29 2007/09/12 07:20:46 matben Exp $
+
+package require jlib
+package require saslmd5
+set ::_saslpack saslmd5
+
+package provide jlibsasl 1.0
+
+
+namespace eval jlib {
+ variable cyrussasl
+
+ if {$::_saslpack eq "cyrussasl"} {
+ set cyrussasl 1
+ } else {
+ set cyrussasl 0
+ }
+ unset ::_saslpack
+}
+
+proc jlib::sasl_init {} {
+ variable cyrussasl
+
+ if {$cyrussasl} {
+ sasl::client_init -callbacks \
+ [list [list log [namespace current]::sasl_log]]
+ } else {
+ # empty
+ }
+}
+
+proc jlib::decode64 {str} {
+ variable cyrussasl
+
+ if {$cyrussasl} {
+ return [sasl::decode64 $str]
+ } else {
+ return [saslmd5::decode64 $str]
+ }
+}
+
+proc jlib::encode64 {str} {
+ variable cyrussasl
+
+ if {$cyrussasl} {
+ return [sasl::encode64 $str]
+ } else {
+ return [saslmd5::encode64 $str]
+ }
+}
+
+# jlib::auth_sasl --
+#
+# Create a new SASL object.
+
+proc jlib::auth_sasl {jlibname username resource password cmd} {
+
+ upvar ${jlibname}::locals locals
+ variable xmppxmlns
+
+ Debug 4 "jlib::auth_sasl"
+
+ # Cache our login jid.
+ set locals(username) $username
+ set locals(resource) $resource
+ set locals(password) $password
+ set locals(myjid2) ${username}@$locals(server)
+ set locals(myjid) ${username}@$locals(server)/${resource}
+ set locals(sasl,cmd) $cmd
+
+ # Set up callbacks for elements that are of interest to us.
+ element_register $jlibname $xmppxmlns(sasl) [namespace current]::sasl_parse
+
+ if {[have_feature $jlibname mechanisms]} {
+ auth_sasl_continue $jlibname
+ } else {
+ trace_stream_features $jlibname [namespace current]::sasl_features
+ }
+}
+
+proc jlib::sasl_features {jlibname} {
+
+ upvar ${jlibname}::locals locals
+
+ Debug 4 "jlib::sasl_features"
+
+ # Verify that sasl is supported before going on.
+ set features [get_feature $jlibname "mechanisms"]
+ if {$features eq ""} {
+ set msg "no sasl mechanisms announced by the server"
+ sasl_final $jlibname error [list sasl-no-mechanisms $msg]
+ } else {
+ auth_sasl_continue $jlibname
+ }
+}
+
+proc jlib::sasl_parse {jlibname xmldata} {
+
+ set tag [wrapper::gettag $xmldata]
+
+ switch -- $tag {
+ challenge {
+ sasl_challenge $jlibname $tag $xmldata
+ }
+ failure {
+ sasl_failure $jlibname $tag $xmldata
+ }
+ success {
+ sasl_success $jlibname $tag $xmldata
+ }
+ default {
+ sasl_final $jlibname error [list sasl-protocol-error {}]
+ }
+ }
+ return
+}
+
+# jlib::auth_sasl_continue --
+#
+# We respond to the
+# <stream:features>
+# <mechanisms ...>
+# <mechanism>DIGEST-MD5</mechanism>
+# <mechanism>PLAIN</mechanism>
+# ...
+
+proc jlib::auth_sasl_continue {jlibname} {
+
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::locals locals
+ variable xmppxmlns
+ variable cyrussasl
+
+ Debug 4 "jlib::auth_sasl_continue"
+
+ if {$cyrussasl} {
+
+ # TclSASL's callback id's seem to be a bit mixed up.
+ foreach id {authname user pass getrealm} {
+ lappend callbacks [list $id [list [namespace current]::sasl_callback \
+ $jlibname]]
+ }
+ set sasltoken [sasl::client_new \
+ -service xmpp -serverFQDN $locals(server) -callbacks $callbacks \
+ -flags success_data]
+ } else {
+
+ # The saslmd5 package follow the naming convention in RFC 2831
+ foreach id {username authzid pass realm} {
+ lappend callbacks [list $id [list [namespace current]::saslmd5_callback \
+ $jlibname]]
+ }
+ set sasltoken [saslmd5::client_new \
+ -service xmpp -serverFQDN $locals(server) -callbacks $callbacks \
+ -flags success_data]
+ }
+ set lib(sasl,token) $sasltoken
+
+ if {$cyrussasl} {
+ $sasltoken -operation setprop -property sec_props \
+ -value {min_ssf 0 max_ssf 0 flags {noplaintext}}
+ } else {
+ $sasltoken setprop sec_props {min_ssf 0 max_ssf 0 flags {noplaintext}}
+ }
+
+ # Returns a serialized array if succesful.
+ set mechanisms [get_feature $jlibname mechanisms]
+ if {$cyrussasl} {
+ set code [catch {
+ $sasltoken -operation start -mechanisms $mechanisms \
+ -interact [list [namespace current]::sasl_interact $jlibname]
+ } out]
+ } else {
+ set ans [$sasltoken start -mechanisms $mechanisms]
+ set code [lindex $ans 0]
+ set out [lindex $ans 1]
+ }
+ Debug 4 "\t -operation start: code=$code, out=$out"
+
+ switch -- $code {
+ 0 {
+ # ok
+ array set outArr $out
+ set xmllist [wrapper::createtag auth \
+ -attrlist [list xmlns $xmppxmlns(sasl) mechanism $outArr(mechanism)] \
+ -chdata [encode64 $outArr(output)]]
+ send $jlibname $xmllist
+ }
+ 4 {
+ # continue
+ array set outArr $out
+ set xmllist [wrapper::createtag auth \
+ -attrlist [list xmlns $xmppxmlns(sasl) mechanism $outArr(mechanism)] \
+ -chdata [encode64 $outArr(output)]]
+ send $jlibname $xmllist
+ }
+ default {
+ # This is an error
+ # We should perhaps send an abort element here.
+ sasl_final $jlibname error [list sasl-protocol-error $out]
+ }
+ }
+}
+
+proc jlib::sasl_interact {jlibname data} {
+
+ # empty
+}
+
+# jlib::sasl_callback --
+#
+# TclSASL's callback id's seem to be a bit mixed up.
+
+proc jlib::sasl_callback {jlibname data} {
+
+ upvar ${jlibname}::locals locals
+
+ array set arr $data
+
+ # @@@ Is 'convertto utf-8' really necessary?
+
+ switch -- $arr(id) {
+ authname {
+ # username
+ set value [encoding convertto utf-8 $locals(username)]
+ }
+ user {
+ # authzid
+ set value [encoding convertto utf-8 $locals(myjid2)]
+ }
+ pass {
+ set value [encoding convertto utf-8 $locals(password)]
+ }
+ getrealm {
+ set value [encoding convertto utf-8 $locals(server)]
+ }
+ default {
+ set value ""
+ }
+ }
+ return $value
+}
+
+# jlib::saslmd5_callback --
+#
+# The saslmd5 package follow the naming convention in RFC 2831.
+
+proc jlib::saslmd5_callback {jlibname data} {
+
+ upvar ${jlibname}::locals locals
+
+ array set arr $data
+
+ switch -- $arr(id) {
+ username {
+ set value [encoding convertto utf-8 $locals(username)]
+ }
+ pass {
+ set value [encoding convertto utf-8 $locals(password)]
+ }
+ authzid {
+
+ # xmpp-core sect. 6.1:
+ # As specified in [SASL], the initiating entity MUST NOT provide an
+ # authorization identity unless the authorization identity is
+ # different from the default authorization identity derived from
+ # the authentication identity as described in [SASL].
+
+ #set value [encoding convertto utf-8 $locals(myjid2)]
+ set value ""
+ }
+ realm {
+ set value [encoding convertto utf-8 $locals(server)]
+ }
+ default {
+ set value ""
+ }
+ }
+ Debug 4 "jlib::saslmd5_callback id=$arr(id), value=$value"
+
+ return $value
+}
+
+proc jlib::sasl_challenge {jlibname tag xmllist} {
+
+ Debug 4 "jlib::sasl_challenge"
+
+ sasl_step $jlibname [wrapper::getcdata $xmllist]
+ return
+}
+
+proc jlib::sasl_step {jlibname serverin64} {
+
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::locals locals
+ variable xmppxmlns
+ variable cyrussasl
+
+ set serverin [decode64 $serverin64]
+ Debug 4 "jlib::sasl_step, serverin=$serverin"
+
+ # Note that 'step' returns the output if succesful, not a serialized array!
+ if {$cyrussasl} {
+ set code [catch {
+ $lib(sasl,token) -operation step -input $serverin \
+ -interact [list [namespace current]::sasl_interact $jlibname]
+ } output]
+ } else {
+ foreach {code output} [$lib(sasl,token) step -input $serverin] {break}
+ }
+ Debug 4 "\t code=$code \n\t output=$output"
+
+ switch -- $code {
+ 0 {
+ # ok
+ set xmllist [wrapper::createtag response \
+ -attrlist [list xmlns $xmppxmlns(sasl)] \
+ -chdata [encode64 $output]]
+ send $jlibname $xmllist
+ }
+ 4 {
+ # continue
+ set xmllist [wrapper::createtag response \
+ -attrlist [list xmlns $xmppxmlns(sasl)] \
+ -chdata [encode64 $output]]
+ send $jlibname $xmllist
+ }
+ default {
+ #puts "\t errdetail: [$lib(sasl,token) -operation errdetail]"
+ sasl_final $jlibname error [list sasl-protocol-error $output]
+ }
+ }
+}
+
+proc jlib::sasl_failure {jlibname tag xmllist} {
+
+ upvar ${jlibname}::locals locals
+ variable xmppxmlns
+
+ Debug 4 "jlib::sasl_failure"
+
+ if {[wrapper::getattribute $xmllist xmlns] eq $xmppxmlns(sasl)} {
+ set errE [lindex [wrapper::getchildren $xmllist] 0]
+ if {[llength $errE]} {
+ set errtag [wrapper::gettag $errE]
+ set errmsg [sasl_getmsg $errtag]
+ } else {
+ set errmsg "not-authorized"
+ }
+ sasl_final $jlibname error [list $errtag $errmsg]
+ }
+ return
+}
+
+proc jlib::sasl_success {jlibname tag xmllist} {
+
+ upvar ${jlibname}::lib lib
+
+ Debug 4 "jlib::sasl_success"
+
+ # Upon receiving a success indication within the SASL negotiation, the
+ # client MUST send a new stream header to the server, to which the
+ # server MUST respond with a stream header as well as a list of
+ # available stream features. Specifically, if the server requires the
+ # client to bind a resource to the stream after successful SASL
+ # negotiation, it MUST include an empty <bind/> element qualified by
+ # the 'urn:ietf:params:xml:ns:xmpp-bind' namespace in the stream
+ # features list it presents to the client upon sending the header for
+ # the response stream sent after successful SASL negotiation (but not
+ # before):
+
+ wrapper::reset $lib(wrap)
+
+ # We must clear out any server info we've received so far.
+ stream_reset $jlibname
+
+ if {[catch {
+ sendstream $jlibname -version 1.0
+ } err]} {
+ sasl_final $jlibname error [list network-failure $err]
+ return
+ }
+ sasl_final $jlibname result $xmllist
+
+ return
+
+ # Wait for the resource binding feature (optional) or session (mandantory):
+ trace_stream_features $jlibname \
+ [namespace current]::auth_sasl_features_write
+ return
+}
+
+proc jlib::auth_sasl_features_write {jlibname} {
+
+ upvar ${jlibname}::locals locals
+
+ if {[have_feature $jlibname bind]} {
+ bind_resource $jlibname $locals(resource) \
+ [namespace current]::resource_bind_cb
+ } else {
+ establish_session $jlibname
+ }
+}
+
+proc jlib::resource_bind_cb {jlibname type subiq} {
+
+ if {$type eq "error"} {
+ sasl_final $jlibname error $subiq
+ } else {
+ establish_session $jlibname
+ }
+}
+
+proc jlib::establish_session {jlibname} {
+
+ variable xmppxmlns
+
+ # Establish the session.
+ set xmllist [wrapper::createtag session \
+ -attrlist [list xmlns $xmppxmlns(session)]]
+ send_iq $jlibname set [list $xmllist] -command \
+ [list [namespace current]::send_session_cb $jlibname]
+}
+
+proc jlib::send_session_cb {jlibname type subiq args} {
+
+ upvar ${jlibname}::locals locals
+
+ sasl_final $jlibname $type $subiq
+}
+
+proc jlib::sasl_final {jlibname type subiq} {
+
+ upvar ${jlibname}::locals locals
+ variable xmppxmlns
+
+ Debug 4 "jlib::sasl_final"
+
+ # We are no longer interested in these.
+ element_deregister $jlibname $xmppxmlns(sasl) [namespace current]::sasl_parse
+
+ uplevel #0 $locals(sasl,cmd) [list $jlibname $type $subiq]
+}
+
+proc jlib::sasl_log {args} {
+
+ Debug 2 "SASL: $args"
+}
+
+proc jlib::sasl_reset {jlibname} {
+
+ variable xmppxmlns
+
+ set cmd [trace_stream_features $jlibname]
+ if {$cmd eq "[namespace current]::sasl_features"} {
+ trace_stream_features $jlibname {}
+ }
+ element_deregister $jlibname $xmppxmlns(sasl) [namespace current]::sasl_parse
+}
+
+namespace eval jlib {
+
+ # This maps Defined Conditions to clear text messages.
+ # RFC 3920 (XMPP core); 6.4 Defined Conditions
+ # Added 'bad-auth' which seems to be a ejabberd anachronism.
+
+ variable saslmsg
+ array set saslmsg {
+ aborted {The receiving entity acknowledges an abort element sent by the initiating entity.}
+ incorrect-encoding {The data provided by the initiating entity could not be processed because the [BASE64] encoding is incorrect.}
+ invalid-authzid {The authzid provided by the initiating entity is invalid, either because it is incorrectly formatted or because the initiating entity does not have permissions to authorize that ID.}
+ invalid-mechanism {The initiating entity did not provide a mechanism or requested a mechanism that is not supported by the receiving entity.}
+ mechanism-too-weak {The mechanism requested by the initiating entity is weaker than server policy permits for that initiating entity.}
+ not-authorized {The authentication failed because the initiating entity did not provide valid credentials (this includes but is not limited to the case of an unknown username).}
+ temporary-auth-failure {The authentication failed because of a temporary error condition within the receiving entity.}
+ bad-auth {The authentication failed because the initiating entity did not provide valid credentials (this includes but is not limited to the case of an unknown username).}
+ }
+}
+
+proc jlib::sasl_getmsg {condition} {
+ variable saslmsg
+
+ if {[info exists saslmsg($condition)]} {
+ return $saslmsg($condition)
+ } else {
+ return $condition
+ }
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# jlibtls.tcl --
+#
+# This file is part of the jabberlib. It provides support for the
+# tls network socket security layer.
+#
+# Copyright (c) 2004 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: jlibtls.tcl,v 1.19 2007/07/23 15:11:43 matben Exp $
+
+package require tls
+package require jlib
+
+package provide jlibtls 1.0
+
+
+proc jlib::starttls {jlibname cmd args} {
+
+ upvar ${jlibname}::locals locals
+ variable xmppxmlns
+
+ Debug 2 "jlib::starttls"
+
+ set locals(tls,cmd) $cmd
+
+ # Set up callbacks for the xmlns that is of interest to us.
+ element_register $jlibname $xmppxmlns(tls) [namespace current]::tls_parse
+
+ if {[have_feature $jlibname]} {
+ tls_continue $jlibname
+ } else {
+ trace_stream_features $jlibname [namespace current]::tls_features_write
+ }
+}
+
+proc jlib::tls_features_write {jlibname} {
+
+ Debug 2 "jlib::tls_features_write"
+
+ trace_stream_features $jlibname {}
+ tls_continue $jlibname
+}
+
+proc jlib::tls_continue {jlibname} {
+
+ variable xmppxmlns
+
+ Debug 2 "jlib::tls_continue"
+
+ # Must verify that the server provides a 'starttls' feature.
+ if {![have_feature $jlibname starttls]} {
+ tls_finish $jlibname starttls-nofeature
+ }
+ set xmllist [wrapper::createtag starttls -attrlist [list xmlns $xmppxmlns(tls)]]
+ send $jlibname $xmllist
+
+ # Wait for 'failure' or 'proceed' element.
+}
+
+proc jlib::tls_parse {jlibname xmldata} {
+
+ set tag [wrapper::gettag $xmldata]
+
+ switch -- $tag {
+ proceed {
+ tls_proceed $jlibname $tag $xmldata
+ }
+ failure {
+ tls_failure $jlibname $tag $xmldata
+ }
+ default {
+ tls_finish $jlibname starttls-protocol-error "unrecognized element"
+ }
+ }
+ return
+}
+
+proc jlib::tls_proceed {jlibname tag xmllist} {
+
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::locals locals
+
+ Debug 2 "jlib::tls_proceed"
+
+ set sock $lib(sock)
+
+ # Make it a SSL connection.
+ if {[catch {
+ tls::import $sock -cafile "" -certfile "" -keyfile "" \
+ -request 1 -server 0 -require 0 -ssl2 no -ssl3 yes -tls1 yes
+ } err]} {
+ close $sock
+ tls_finish $jlibname starttls-failure $err
+ }
+
+ # We must initiate the handshake before getting any answers.
+ set locals(tls,retry) 0
+ set locals(tls,fevent) [fileevent $sock readable]
+ tls_handshake $jlibname
+}
+
+# jlib::tls_handshake --
+#
+# Performs the TLS handshake using filevent readable until completed
+# or a nonrecoverable error.
+# This method of using fileevent readable seems independent of
+# speed of network connection (dialup/broadband) which a fixed
+# loop with 50ms delay isn't!
+
+proc jlib::tls_handshake {jlibname} {
+ global errorCode
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::locals locals
+
+ set sock $lib(sock)
+
+ # Do SSL handshake.
+ if {$locals(tls,retry) > 100} {
+ close $sock
+ set err "too long retry to setup SSL connection"
+ tls_finish $jlibname starttls-failure $err
+ } elseif {[catch {tls::handshake $sock} complete]} {
+ if {[lindex $errorCode 1] eq "EAGAIN"} {
+ incr locals(tls,retry)
+
+ # Temporarily hijack these events.
+ fileevent $sock readable \
+ [namespace code [list tls_handshake $jlibname]]
+ } else {
+ close $sock
+ tls_finish $jlibname starttls-failure $err
+ }
+ } elseif {$complete} {
+ Debug 2 "\t number of TLS handshakes=$locals(tls,retry)"
+
+ # Reset the event handler to what it was.
+ fileevent $sock readable $locals(tls,fevent)
+ tls_handshake_fin $jlibname
+ }
+}
+
+proc jlib::tls_handshake_fin {jlibname} {
+
+ upvar ${jlibname}::lib lib
+
+ wrapper::reset $lib(wrap)
+
+ # We must clear out any server info we've received so far.
+ stream_reset $jlibname
+ set sock $lib(sock)
+
+ # The tls package resets the encoding to: -encoding binary
+ if {[catch {
+ fconfigure $sock -encoding utf-8
+ sendstream $jlibname -version 1.0
+ } err]} {
+ tls_finish $jlibname network-failure $err
+ return
+ }
+
+ # Wait for the SASL features. Seems to be the only way to detect success.
+ trace_stream_features $jlibname [namespace current]::tls_features_write_2nd
+ return
+}
+
+proc jlib::tls_features_write_2nd {jlibname} {
+
+ Debug 2 "jlib::tls_features_write_2nd"
+
+ tls_finish $jlibname
+}
+
+proc jlib::tls_failure {jlibname tag xmllist} {
+
+ Debug 2 "jlib::tls_failure"
+
+ # Seems we don't get any additional error info here.
+ tls_finish $jlibname starttls-failure "tls failed"
+}
+
+proc jlib::tls_finish {jlibname {errcode ""} {msg ""}} {
+
+ upvar ${jlibname}::locals locals
+ variable xmppxmlns
+
+ Debug 2 "jlib::tls_finish errcode=$errcode, msg=$msg"
+
+ trace_stream_features $jlibname {}
+ element_deregister $jlibname $xmppxmlns(tls) [namespace current]::tls_parse
+
+ if {$errcode ne ""} {
+ uplevel #0 $locals(tls,cmd) $jlibname [list error [list $errcode $msg]]
+ } else {
+ uplevel #0 $locals(tls,cmd) $jlibname [list result {}]
+ }
+}
+
+# jlib::tls_reset --
+#
+#
+
+proc jlib::tls_reset {jlibname} {
+
+ variable xmppxmlns
+
+ element_deregister $jlibname $xmppxmlns(tls) [namespace current]::tls_parse
+
+ set cmd [trace_stream_features $jlibname]
+ if {$cmd eq "[namespace current]::tls_features_write"} {
+ trace_stream_features $jlibname {}
+ } elseif {$cmd eq "[namespace current]::tls_features_write_2nd"} {
+ trace_stream_features $jlibname {}
+ }
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# muc.tcl --
+#
+# This file is part of jabberlib.
+# It implements the Multi User Chat (MUC) protocol part of the XMPP
+# protocol as defined by the 'http://jabber.org/protocol/muc*'
+# namespace.
+#
+# Copyright (c) 2003-2005 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: muc.tcl,v 1.40 2007/10/22 11:51:33 matben Exp $
+#
+############################# USAGE ############################################
+#
+# NAME
+# muc - convenience command library for MUC
+#
+# OPTIONS
+# see below for instance command options
+#
+# INSTANCE COMMANDS
+# jlibname muc allroomsin
+# jlibname muc create roomjid nick callback ?-extras?
+# jlibname muc destroy roomjid ?-command, -reason, alternativejid?
+# jlibname muc enter roomjid nick ?-command, -extras, -password?
+# jlibname muc exit roomjid
+# jlibname muc getaffiliation roomjid affiliation callback
+# jlibname muc getrole roomjid role callback
+# jlibname muc getroom roomjid callback
+# jlibname muc invite roomjid jid ?-reason?
+# jlibname muc isroom jid
+# jlibname muc mynick roomjid
+# jlibname muc participants roomjid
+# jlibname muc setaffiliation roomjid nick affiliation ?-command, -reason?
+# jlibname muc setnick roomjid nick ?-command?
+# jlibname muc setrole roomjid nick role ?-command, -reason?
+# jlibname muc setroom roomjid type ?-command, -form?
+#
+############################# CHANGES ##########################################
+#
+# 0.1 first version
+# 0.2 rewritten as a standalone component
+# 0.3 ensamble command
+#
+# 050913 INCOMPATIBLE CHANGE! complete reorganization using ensamble command.
+
+package require jlib
+package require jlib::disco
+package require jlib::roster
+
+package provide jlib::muc 0.3
+
+namespace eval jlib::muc {
+
+ # Globals same for all instances of this jlib.
+ variable debug 0
+
+ variable xmlns
+ array set xmlns {
+ "muc" "http://jabber.org/protocol/muc"
+ "admin" "http://jabber.org/protocol/muc#admin"
+ "owner" "http://jabber.org/protocol/muc#owner"
+ "user" "http://jabber.org/protocol/muc#user"
+ }
+
+ variable muc
+ set muc(affiliationExp) {(owner|admin|member|outcast|none)}
+ set muc(roleExp) {(moderator|participant|visitor|none)}
+
+ jlib::disco::registerfeature $xmlns(muc)
+
+ # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::muc::init --
+#
+# Creates a new instance of a muc object.
+#
+# Arguments:
+# jlibname: name of existing jabberlib instance; fully qualified!
+# args:
+#
+# Results:
+# namespaced instance command
+
+proc jlib::muc::init {jlibname args} {
+
+ Debug 2 "jlib::muc::init jlibname=$jlibname"
+
+ # Instance specific namespace.
+ namespace eval ${jlibname}::muc {
+ variable cache
+ variable rooms
+ }
+ upvar ${jlibname}::muc::cache cache
+ upvar ${jlibname}::muc::rooms rooms
+
+ # Register service.
+ $jlibname service register muc muc
+
+ $jlibname register_reset [namespace current]::reset
+
+ return
+}
+
+# jlib::muc::cmdproc --
+#
+# Just dispatches the command to the right procedure.
+#
+# Arguments:
+# jlibname name of jabberlib instance.
+# cmd the method.
+# args all args to the cmd method.
+#
+# Results:
+# from the individual command if any.
+
+proc jlib::muc::cmdproc {jlibname cmd args} {
+ return [eval {$cmd $jlibname} $args]
+}
+
+# jlib::muc::invoke_callback -- ?????????????
+#
+#
+
+proc jlib::muc::invoke_callback {mucname cmd type subiq} {
+ uplevel #0 $cmd [list $mucname $type $subiq]
+}
+
+# jlib::muc::enter --
+#
+# Enter room.
+#
+# Arguments:
+# jlibname name of jabberlib instance.
+# roomjiid
+# nick nick name
+# args ?-command callbackProc?
+# ?-extras list of xmllist?
+# ?-password str?
+#
+# Results:
+# none.
+
+proc jlib::muc::enter {jlibname roomjid nick args} {
+ variable xmlns
+ upvar ${jlibname}::muc::cache cache
+ upvar ${jlibname}::muc::rooms rooms
+
+ set xsub [list]
+ set extras [list]
+ set cmd ""
+ foreach {name value} $args {
+
+ switch -- $name {
+ -command {
+ set cmd $value
+ }
+ -extras {
+ set extras $value
+ }
+ -password {
+ set xsub [list [wrapper::createtag "password" \
+ -chdata $value]]
+ }
+ default {
+ return -code error "Unrecognized option \"$name\""
+ }
+ }
+ }
+ set jid $roomjid/$nick
+ set xelem [wrapper::createtag "x" -subtags $xsub \
+ -attrlist [list xmlns $xmlns(muc)]]
+ $jlibname send_presence -to $jid -xlist [list $xelem] -extras $extras \
+ -command [list [namespace current]::parse_enter $cmd]
+ set cache($roomjid,mynick) $nick
+ set rooms($roomjid) 1
+ $jlibname service setroomprotocol $roomjid "muc"
+}
+
+# jlib::muc::parse_enter --
+#
+# Callback when entering room to make sure there are no error.
+
+proc jlib::muc::parse_enter {cmd jlibname xmldata} {
+ upvar ${jlibname}::muc::cache cache
+
+ set from [wrapper::getattribute $xmldata from]
+ set type [wrapper::getattribute $xmldata type]
+ if {$type eq ""} {
+ set type "available"
+ }
+ set roomjid [jlib::jidmap [jlib::barejid $from]]
+ if {[string equal $type "error"]} {
+ unset -nocomplain cache($roomjid,mynick)
+ } else {
+ set cache($roomjid,inside) 1
+ }
+ if {$cmd ne ""} {
+ uplevel #0 $cmd [list $jlibname $xmldata]
+ }
+}
+
+# jlib::muc::exit --
+#
+# Exit room.
+
+proc jlib::muc::exit {jlibname roomjid} {
+ upvar ${jlibname}::muc::cache cache
+
+ if {[info exists cache($roomjid,mynick)]} {
+ set jid $roomjid/$cache($roomjid,mynick)
+ $jlibname send_presence -to $jid -type "unavailable"
+ unset -nocomplain cache($roomjid,mynick)
+ }
+ unset -nocomplain cache($roomjid,inside)
+ $jlibname roster clearpresence "${roomjid}*"
+}
+
+# jlib::muc::setnick --
+#
+# Set new nick name for room.
+
+proc jlib::muc::setnick {jlibname roomjid nick args} {
+ upvar ${jlibname}::muc::cache cache
+
+ set opts [list]
+ foreach {name value} $args {
+ switch -- $name {
+ -command {
+ lappend opts $name $value
+ }
+ default {
+ return -code error "Unrecognized option \"$name\""
+ }
+ }
+ }
+ set jid $roomjid/$nick
+ eval {$jlibname send_presence -to $jid} $opts
+ set cache($roomjid,mynick) $nick
+}
+
+# jlib::muc::invite --
+#
+#
+
+proc jlib::muc::invite {jlibname roomjid jid args} {
+ variable xmlns
+
+ set opts [list]
+ set children [list]
+ foreach {name value} $args {
+ switch -- $name {
+ -command {
+ lappend opts $name $value
+ }
+ -reason {
+ lappend children [wrapper::createtag \
+ [string trimleft $name "-"] -chdata $value]
+ }
+ -continue {
+ lappend children [wrapper::createtag "continue"]
+ }
+ default {
+ return -code error "Unrecognized option \"$name\""
+ }
+ }
+ }
+ set invite [list [wrapper::createtag "invite" \
+ -attrlist [list to $jid] -subtags $children]]
+
+ set xelem [wrapper::createtag "x" \
+ -attrlist [list xmlns $xmlns(user)] \
+ -subtags $invite]
+ eval {$jlibname send_message $roomjid -xlist [list $xelem]} $opts
+}
+
+# jlib::muc::setrole --
+#
+#
+
+proc jlib::muc::setrole {jlibname roomjid nick role args} {
+ variable muc
+ variable xmlns
+
+ if {![regexp $muc(roleExp) $role]} {
+ return -code error "Unrecognized role \"$role\""
+ }
+ set opts [list]
+ set subitem [list]
+ foreach {name value} $args {
+ switch -- $name {
+ -command {
+ lappend opts -command [concat $value $jlibname]
+ }
+ -reason {
+ set subitem [list [wrapper::createtag "reason" -chdata $value]]
+ }
+ default {
+ return -code error "Unrecognized option \"$name\""
+ }
+ }
+ }
+
+ set subelements [list [wrapper::createtag "item" \
+ -attrlist [list nick $nick role $role] \
+ -subtags $subitem]]
+
+ set xmllist [wrapper::createtag "query" \
+ -attrlist [list xmlns $xmlns(admin)] \
+ -subtags $subelements]
+ eval {$jlibname send_iq "set" [list $xmllist] -to $roomjid} $opts
+}
+
+# jlib::muc::setaffiliation --
+#
+#
+
+proc jlib::muc::setaffiliation {jlibname roomjid nick affiliation args} {
+ variable muc
+ variable xmlns
+
+ if {![regexp $muc(affiliationExp) $affiliation]} {
+ return -code error "Unrecognized affiliation \"$affiliation\""
+ }
+ set opts [list]
+ set subitem [list]
+ foreach {name value} $args {
+ switch -- $name {
+ -command {
+ lappend opts -command [concat $value $jlibname]
+ }
+ -reason {
+ set subitem [list [wrapper::createtag "reason" -chdata $value]]
+ }
+ default {
+ return -code error "Unrecognized option \"$name\""
+ }
+ }
+ }
+
+ switch -- $affiliation {
+ owner {
+ set ns $xmlns(owner)
+ }
+ default {
+ set ns $xmlns(admin)
+ }
+ }
+
+ set subelements [list [wrapper::createtag "item" \
+ -attrlist [list nick $nick affiliation $affiliation] \
+ -subtags $subitem]]
+
+ set xmllist [wrapper::createtag "query" \
+ -attrlist [list xmlns $ns] -subtags $subelements]
+ eval {$jlibname send_iq "set" [list $xmllist] -to $roomjid} $opts
+}
+
+# jlib::muc::getrole --
+#
+#
+
+proc jlib::muc::getrole {jlibname roomjid role callback} {
+ variable muc
+ variable xmlns
+
+ if {![regexp $muc(roleExp) $role]} {
+ return -code error "Unrecognized role \"$role\""
+ }
+ set subelements [list [wrapper::createtag "item" \
+ -attrlist [list role $role]]]
+
+ set xmllist [wrapper::createtag "query" \
+ -attrlist [list xmlns $xmlns(admin)] \
+ -subtags $subelements]
+ $jlibname send_iq "get" [list $xmllist] -to $roomjid \
+ -command [concat $callback $jlibname]
+}
+
+# jlib::muc::getaffiliation --
+#
+#
+
+proc jlib::muc::getaffiliation {jlibname roomjid affiliation callback} {
+ variable muc
+ variable xmlns
+
+ if {![regexp $muc(affiliationExp) $affiliation]} {
+ return -code error "Unrecognized role \"$affiliation\""
+ }
+ set subelements [list [wrapper::createtag "item" \
+ -attrlist [list affiliation $affiliation]]]
+
+ switch -- $affiliation {
+ owner - admin {
+ set ns $xmlns(owner)
+ }
+ default {
+ set ns $xmlns(admin)
+ }
+ }
+
+ set xmllist [wrapper::createtag "query" \
+ -attrlist [list xmlns $ns] -subtags $subelements]
+ $jlibname send_iq "get" [list $xmllist] -to $roomjid \
+ -command [concat $callback $jlibname]
+}
+
+# jlib::muc::create --
+#
+# The first thing to do when creating a room.
+#
+# Arguments:
+# jlibname name of jabberlib instance.
+# roomjiid
+# nick nick name
+# command callbackProc
+# args ?-extras list of xmllist?
+#
+# Results:
+# none.
+
+proc jlib::muc::create {jlibname roomjid nick command args} {
+ variable xmlns
+ upvar ${jlibname}::muc::cache cache
+ upvar ${jlibname}::muc::rooms rooms
+
+ set extras [list]
+ foreach {name value} $args {
+
+ switch -- $name {
+ -extras {
+ set extras $value
+ }
+ default {
+ return -code error "Unrecognized option \"$name\""
+ }
+ }
+ }
+ set jid $roomjid/$nick
+ set xelem [wrapper::createtag "x" -attrlist [list xmlns $xmlns(muc)]]
+ $jlibname send_presence \
+ -to $jid -xlist [list $xelem] -extras $extras \
+ -command [list [namespace current]::parse_create $command]
+ set cache($roomjid,mynick) $nick
+ set rooms($roomjid) 1
+ $jlibname service setroomprotocol $roomjid "muc"
+}
+
+proc jlib::muc::parse_create {cmd jlibname xmldata} {
+ upvar ${jlibname}::muc::cache cache
+
+ set from [wrapper::getattribute $xmldata from]
+ set type [wrapper::getattribute $xmldata type]
+ if {$type eq ""} {
+ set type "available"
+ }
+ set roomjid [jlib::jidmap [jlib::barejid $from]]
+ if {[string equal $type "error"]} {
+ unset -nocomplain cache($roomjid,mynick)
+ } else {
+ set cache($roomjid,inside) 1
+ }
+ if {$cmd ne ""} {
+ uplevel #0 $cmd [list $jlibname $xmldata]
+ }
+}
+
+# jlib::muc::setroom --
+#
+# Sends an iq set element to room. If -form the 'type' argument is
+# omitted.
+#
+# Arguments:
+# jlibname name of muc instance.
+# roomjid the rooms jid.
+# type typically 'submit' or 'cancel'.
+# args:
+# -command
+# -form xmllist starting with the x-element
+#
+# Results:
+# None.
+
+proc jlib::muc::setroom {jlibname roomjid type args} {
+ variable xmlns
+
+ set opts [list]
+ set subelements [list]
+ foreach {name value} $args {
+ switch -- $name {
+ -command {
+ lappend opts -command [concat $value $jlibname]
+ }
+ -form {
+ set xelem $value
+ }
+ default {
+ return -code error "Unrecognized option \"$name\""
+ }
+ }
+ }
+ if {[info exists xelem]} {
+ if {[llength $xelem] == 0} {
+ set xelem [list [wrapper::createtag "x" \
+ -attrlist [list xmlns "jabber:x:data" type $type]]]
+ }
+ set xmllist [wrapper::createtag "query" -subtags $xelem \
+ -attrlist [list xmlns $xmlns(owner)]]
+ eval {$jlibname send_iq "set" [list $xmllist] -to $roomjid} $opts
+ }
+}
+
+# jlib::muc::destroy --
+#
+#
+# Arguments:
+# jlibname name of muc instance.
+# roomjid the rooms jid.
+# args -command, -reason, alternativejid.
+#
+# Results:
+# None.
+
+proc jlib::muc::destroy {jlibname roomjid args} {
+ variable xmlns
+
+ set opts [list]
+ set subelements [list]
+ foreach {name value} $args {
+
+ switch -- $name {
+ -command {
+ lappend opts -command [concat $value $jlibname]
+ }
+ -reason {
+ lappend subelements [wrapper::createtag "reason" \
+ -chdata $value]
+ }
+ -alternativejid {
+ lappend subelements [wrapper::createtag "alt" \
+ -attrlist [list jid $value]]
+ }
+ default {
+ return -code error "Unrecognized option \"$name\""
+ }
+ }
+ }
+
+ set destroyelem [wrapper::createtag "destroy" -subtags $subelements \
+ -attrlist [list jid $roomjid]]
+
+ set xmllist [wrapper::createtag "query" -subtags [list $destroyelem] \
+ -attrlist [list xmlns $xmlns(owner)]]
+ eval {$jlibname send_iq "set" [list $xmllist] -to $roomjid} $opts
+}
+
+# jlib::muc::getroom --
+#
+#
+
+proc jlib::muc::getroom {jlibname roomjid callback} {
+ variable xmlns
+
+ set xmllist [wrapper::createtag "query" \
+ -attrlist [list xmlns $xmlns(owner)]]
+ $jlibname send_iq "get" [list $xmllist] -to $roomjid \
+ -command [concat $callback $jlibname]
+}
+
+# jlib::muc::mynick --
+#
+# Returns own nick name for room, or empty if not there.
+
+proc jlib::muc::mynick {jlibname roomjid} {
+ upvar ${jlibname}::muc::cache cache
+
+ if {[info exists cache($roomjid,mynick)]} {
+ return $cache($roomjid,mynick)
+ } else {
+ return ""
+ }
+}
+
+# jlib::muc::allroomsin --
+#
+# Returns a list of all room jid's we are inside.
+
+proc jlib::muc::allroomsin {jlibname} {
+ upvar ${jlibname}::muc::cache cache
+
+ set roomList [list]
+ foreach key [array names cache "*,inside"] {
+ regexp {(.+),inside} $key match room
+ lappend roomList $room
+ }
+ return $roomList
+}
+
+proc jlib::muc::isroom {jlibname jid} {
+ upvar ${jlibname}::muc::rooms rooms
+
+ if {[info exists rooms($jid)]} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# jlib::muc::participants --
+#
+#
+
+proc jlib::muc::participants {jlibname roomjid} {
+ upvar ${jlibname}::muc::cache cache
+
+ set everyone [list]
+
+ # The rosters presence elements should give us all info we need.
+ foreach userAttr [$jlibname roster getpresence $roomjid -type available] {
+ unset -nocomplain attr
+ array set attr $userAttr
+ lappend everyone $roomjid/$attr(-resource)
+ }
+ return $everyone
+}
+
+proc jlib::muc::reset {jlibname} {
+ upvar ${jlibname}::muc::cache cache
+ upvar ${jlibname}::muc::rooms rooms
+
+ unset -nocomplain cache
+ unset -nocomplain rooms
+}
+
+proc jlib::muc::Debug {num str} {
+ variable debug
+ if {$num <= $debug} {
+ puts $str
+ }
+}
+
+# We have to do it here since need the initProc befor doing this.
+
+namespace eval jlib::muc {
+
+ jlib::ensamble_register muc \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+#-------------------------------------------------------------------------------
+
--- /dev/null
+# pep.tcl --
+#
+# This file is part of the jabberlib. It contains support code
+# for the Personal Eventing PubSub
+# (xmlns='http://jabber.org/protocol/pubsub') XEP-0163.
+#
+# Copyright (c) 2007 Mats Bengtsson
+# Copyright (c) 2006 Antonio Cano Damas
+#
+# This file is distributed under BSD style license.
+#
+# $Id: pep.tcl,v 1.10 2007/09/06 13:20:47 matben Exp $
+#
+############################# USAGE ############################################
+#
+# INSTANCE COMMANDS
+# jlibName pep create
+# jlibName pep have
+# jlibName pep publish
+# jlibName pep retract
+# jlibName pep subscribe
+#
+################################################################################
+#
+# With PEP version 1.0 and mutual presence subscriptions we only need:
+#
+# jlibName pep have
+# jlibName pep publish
+# jlibName pep retract ?-notify 0|1?
+#
+# Typical names and nodes:
+# activity 'http://jabber.org/protocol/activity'
+# geoloc 'http://jabber.org/protocol/geoloc'
+# mood 'http://jabber.org/protocol/mood'
+# tune 'http://jabber.org/protocol/tune'
+#
+# NB: It is currently unclear there should be an id attribute in the item
+# element since PEP doesn't use it but pubsub do, and the experimental
+# OpenFire PEP implementation.
+
+package require jlib::disco
+package require jlib::pubsub
+
+package provide jlib::pep 0.3
+
+namespace eval jlib::pep {
+
+ # Common xml namespaces.
+ variable xmlns
+ array set xmlns {
+ node_config "http://jabber.org/protocol/pubsub#node_config"
+ }
+
+ variable state
+}
+
+# jlib::pep::init --
+#
+# Creates a new instance of the pep object.
+
+proc jlib::pep::init {jlibname} {
+
+ # Instance specifics arrays.
+ namespace eval ${jlibname}::pep {
+ variable autosub
+ set autosub(presreg) 0
+ }
+}
+
+proc jlib::pep::cmdproc {jlibname cmd args} {
+ return [eval {$cmd $jlibname} $args]
+}
+
+# Setting own PEP --------------------------------------------------------------
+#
+# Disco server for PEP, disco own bare JID, create pubsub node.
+#
+# 1) Disco server for pubsub/pep support
+# 2) Create node if not there (optional)
+# 3) Publish item
+
+# jlib::pep::have --
+#
+# Simplified way to know if a JID supports PEP or not.
+# Typically only needed for the server JID.
+# The command just gets invoked with: jlibname boolean
+
+proc jlib::pep::have {jlibname jid cmd} {
+ $jlibname disco get_async info $jid [namespace code [list OnPepDisco $cmd]]
+}
+
+proc jlib::pep::OnPepDisco {cmd jlibname type from subiq args} {
+
+ set havepep 0
+ if {$type eq "result"} {
+ set node [wrapper::getattribute $subiq node]
+
+ # Check if disco returns <identity category='pubsub' type='pep'/>
+ if {[$jlibname disco iscategorytype pubsub/pep $from $node]} {
+ set havepep 1
+ }
+ }
+ uplevel #0 $cmd [list $jlibname $havepep]
+}
+
+# jlib::pep::create --
+#
+# Create a PEP node service.
+# This shall not be necessary if we want just the default configuration.
+#
+# Arguments:
+# node typically xmlns
+# args: -access_model "presence", "open", "roster", or "whitelist"
+# -fields additional list of field elements
+# -command tclProc
+#
+# Results:
+# none
+
+proc jlib::pep::create {jlibname node args} {
+ variable xmlns
+
+ array set argsA {
+ -access_model presence
+ -command {}
+ -fields {}
+ }
+ array set argsA $args
+
+ # Configure setup for PEP node
+ set valueFormE [wrapper::createtag value -chdata $xmlns(node_config)]
+ set fieldFormE [wrapper::createtag field \
+ -attrlist [list var "FORM_TYPE" type hidden] \
+ -subtags [list $valueFormE]]
+
+ # PEP Values for access_model: roster / presence / open or authorize / whitelist
+ set valueModelE [wrapper::createtag value -chdata $argsA(-access_model)]
+ set fieldModelE [wrapper::createtag field \
+ -attrlist [list var "pubsub#access_model"] \
+ -subtags [list $valueModelE]]
+
+ set xattr [list xmlns "jabber:x:data" type submit]
+ set xsubE [list $fieldFormE $fieldModelE]
+ set xsubE [concat $xsubE $argsA(-fields)]
+ set xE [wrapper::createtag x -attrlist $xattr -subtags $xsubE]
+
+ $jlibname pubsub create -node $node -configure $xE -command $argsA(-command)
+}
+
+# jlib::pep::publish --
+#
+# Publish a stanza into the PEP node (create an item to a node)
+# Typically:
+#
+# <publish node='http://jabber.org/protocol/mood'>
+# <item>
+# <mood xmlns='http://jabber.org/protocol/mood'>
+# <annoyed/>
+# <text>curse my nurse!</text>
+# </mood>
+# </item>
+# </publish>
+#
+# Arguments:
+# node typically xmlns
+# itemE XML stanza to publishing
+# args for the 'publish subscribe'
+#
+# Results:
+# none
+
+proc jlib::pep::publish {jlibname node itemE args} {
+ eval {$jlibname pubsub publish $node -items [list $itemE]} $args
+}
+
+# jlib::pep::retract --
+#
+# Retract a PEP item (Delete an item from a node)
+#
+# Arguments:
+# node typically xmlns
+#
+# Results:
+# none
+
+proc jlib::pep::retract {jlibname node args} {
+ #set itemE [wrapper::createtag item]
+ # Se comment above about this one.
+ set itemE [wrapper::createtag item -attrlist [list id current]]
+ eval {$jlibname pubsub retract $node [list $itemE]} $args
+}
+
+# Others PEP -------------------------------------------------------------------
+#
+# In normal circumstances with mutual presence subscriptions we don't
+# need to do pusub subscribe.
+#
+# 1) disco bare JID (not necessary for 1.0)
+# 2) subscribe to node (not necessary for 1.0)
+# 3) handle events (pubsub register_event tclProc -node)
+
+# jlib::pep::subscribe --
+#
+# Arguments:
+# jid JID which we want to subscribe to.
+# node typically xmlns
+# args: anything for the pubsub command, like -command.
+#
+# Results:
+# none
+
+proc jlib::pep::subscribe {jlibname jid node args} {
+
+ # If an entity is not subscribed to the account owner's presence,
+ # it MUST subscribe to a node using....
+ set myjid2 [$jlibname myjid2]
+ eval {$jlibname pubsub subscribe $jid $myjid2 -node $node} $args
+}
+
+# @@@ OUTDATED; BACKUP !!!!!!!!!!!!!!!
+
+# jlib::pep::set_auto_subscribe --
+#
+# Subscribe all available users automatically.
+
+proc jlib::pep::set_auto_subscribe {jlibname node args} {
+ upvar ${jlibname}::pep::autosub autosub
+
+ array set argsA {
+ -command {}
+ }
+ array set argsA $args
+ set autosub($node,node) $node
+ set autosub($node,-command) $argsA(-command)
+
+ # For those where we've already got presence.
+ set jidL [$jlibname roster getusers -type available]
+ foreach jid $jidL {
+
+ # We may not yet have disco info for this.
+ if {[$jlibname disco iscategorytype gateway/* $jid]} {
+ continue
+ }
+
+ # If Juliet's server supports PEP (thereby making juliet@capulet.com
+ # a virtual pubsub service), it MUST return an identity of "pubsub/pep"
+ $jlibname disco get_async items $jid \
+ [list [namespace current]::OnDiscoItems $node]
+ }
+
+ # And register an event handler for any presence.
+ if {!$autosub(presreg)} {
+ set autosub(presreg) 1
+ $jlibname presence_register_int available \
+ [namespace code [list PresenceEvent $node]]
+ }
+}
+
+proc jlib::pep::list_auto_subscribe {jlibname} {
+ upvar ${jlibname}::pep::autosub autosub
+
+ set nodes {}
+ foreach {key node} [array get autosub *,node] {
+ lappend nodes $node
+ }
+ return $nodes
+}
+
+proc jlib::pep::have_auto_subscribe {jlibname node} {
+ upvar ${jlibname}::pep::autosub autosub
+
+ return [info exists autosub($node,node)]
+}
+
+proc jlib::pep::unset_auto_subscribe {jlibname node} {
+ upvar ${jlibname}::pep::autosub autosub
+
+ array unset autosub $node,*
+ if {![llength [array names autosub *,node]]} {
+ set autosub(presreg) 0
+ $jlibname presence_deregister_int available \
+ [namespace code [list PresenceEvent $node]]
+ }
+}
+
+proc jlib::pep::PresenceEvent {jlibname xmldata node} {
+ upvar ${jlibname}::pep::autosub autosub
+ variable state
+
+ set type [wrapper::getattribute $xmldata type]
+ set from [wrapper::getattribute $xmldata from]
+ if {$type eq ""} {
+ set type "available"
+ }
+ set jid2 [jlib::barejid $from]
+ if {![$jlibname roster isitem $jid2]} {
+ return
+ }
+ if {[$jlibname disco iscategorytype gateway/* $from]} {
+ return
+ }
+
+ # We should be careful not to disco/publish for each presence change.
+ # @@@ There is a small glitch here if user changes presence before we
+ # received its disco result.
+ if {![$jlibname disco isdiscoed info $from]} {
+ foreach {key node} [array get autosub $node,*] {
+ $jlibname disco get_async items $jid2 \
+ [list [namespace current]::OnDiscoItems $node]
+ }
+ }
+}
+
+proc jlib::pep::OnDiscoItems {node jlibname type from subiq args} {
+
+ # Get contact PEP nodes.
+ if {$type eq "result"} {
+ set nodes [$jlibname disco nodes $from]
+ if {[lsearch -exact $nodes $node] >= 0} {
+
+ # NEW PEP:
+ # If an entity is not subscribed to the account owner's presence,
+ # it MUST subscribe to a node using....
+ set subscribe [$jlibname roster getsubscription $from]
+ set myjid2 [$jlibname myjid2]
+ $jlibname pubsub subscribe $from $myjid2 -node $node \
+ -command $autosub($node,-command)
+ }
+ }
+}
+
+# We have to do it here since need the initProc before doing this.
+namespace eval jlib::pep {
+
+ jlib::ensamble_register pep \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+# Test:
+if {0} {
+ package require jlib::pep
+ set jlibname ::jlib::jlib1
+ set moodNode "http://jabber.org/protocol/mood"
+ set mood "neutral"
+ proc cb {args} {puts "---> $args"}
+ set server [$jlibname getserver]
+ set myjid2 [$jlibname myjid2]
+ $jlibname pubsub register_event cb -node $moodNode
+ $jlibname disco send_get info $server cb
+
+ # List items
+ $jlibname disco send_get items $myjid2 cb
+ $jlibname pubsub items $myjid2 $moodNode
+
+ # Retract item from node
+ set pepE [wrapper::createtag mood -attrlist [list xmlns $moodNode]]
+ set itemE [wrapper::createtag item -subtags [list $pepE]]
+ $jlibname pubsub retract $moodNode [list $itemE]
+
+ # Delete node
+ $jlibname pubsub delete $myjid2 $moodNode
+
+ # Publish item to node
+ set moodChildEs [list [wrapper::createtag mood]]
+ set moodE [wrapper::createtag mood \
+ -attrlist [list xmlns $moodNode] -subtags $moodChildEs]
+ set itemE [wrapper::createtag item -subtags [list $moodE]]
+ $jlibname pubsub publish $moodNode -items [list $itemE] -command cb
+
+ # User
+ set jid matben2@stor.no-ip.org
+ $jlibname disco send_get info $jid cb
+ $jlibname disco send_get items $jid cb
+ $jlibname roster getsubscription $jid
+ $jlibname pubsub items $jid $moodNode
+
+ # PEP
+ # Owner
+ $jlibname pep have $server cb
+ $jlibname pep create $moodNode
+ $jlibname pep publish $moodNode $itemE
+
+ # User
+ $jlibname disco send_get items $jid cb
+ $jlibname pep subscribe $jid $moodNode
+
+}
+
--- /dev/null
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded groupchat 1.0 [list source [file join $dir groupchat.tcl]]
+package ifneeded jlib 2.0 [list source [file join $dir jabberlib.tcl]]
+package ifneeded jlib::http 0.1 [list source [file join $dir jlibhttp.tcl]]
+package ifneeded jlibsasl 1.0 [list source [file join $dir jlibsasl.tcl]]
+package ifneeded jlibtls 1.0 [list source [file join $dir jlibtls.tcl]]
+package ifneeded saslmd5 1.0 [list source [file join $dir saslmd5.tcl]]
+package ifneeded service 1.0 [list source [file join $dir service.tcl]]
+package ifneeded stanzaerror 1.0 [list source [file join $dir stanzaerror.tcl]]
+package ifneeded streamerror 1.0 [list source [file join $dir streamerror.tcl]]
+package ifneeded tinydom 0.2 [list source [file join $dir tinydom.tcl]]
+package ifneeded wrapper 1.2 [list source [file join $dir wrapper.tcl]]
+
+package ifneeded jlib::avatar 0.1 [list source [file join $dir avatar.tcl]]
+package ifneeded jlib::bind 0.1 [list source [file join $dir bind.tcl]]
+package ifneeded jlib::bytestreams 0.4 [list source [file join $dir bytestreams.tcl]]
+package ifneeded jlib::caps 0.3 [list source [file join $dir caps.tcl]]
+package ifneeded jlib::compress 0.1 [list source [file join $dir compress.tcl]]
+package ifneeded jlib::connect 0.1 [list source [file join $dir connect.tcl]]
+package ifneeded jlib::disco 0.1 [list source [file join $dir disco.tcl]]
+package ifneeded jlib::dns 0.1 [list source [file join $dir jlibdns.tcl]]
+package ifneeded jlib::ftrans 0.1 [list source [file join $dir ftrans.tcl]]
+package ifneeded jlib::ibb 0.1 [list source [file join $dir ibb.tcl]]
+package ifneeded jlib::jingle 0.1 [list source [file join $dir jingle.tcl]]
+package ifneeded jlib::muc 0.3 [list source [file join $dir muc.tcl]]
+package ifneeded jlib::pep 0.3 [list source [file join $dir pep.tcl]]
+package ifneeded jlib::pubsub 0.2 [list source [file join $dir pubsub.tcl]]
+package ifneeded jlib::roster 1.0 [list source [file join $dir roster.tcl]]
+package ifneeded jlib::si 0.1 [list source [file join $dir si.tcl]]
+package ifneeded jlib::sipub 0.2 [list source [file join $dir sipub.tcl]]
+package ifneeded jlib::util 0.1 [list source [file join $dir util.tcl]]
+package ifneeded jlib::vcard 0.1 [list source [file join $dir vcard.tcl]]
--- /dev/null
+# pubsub.tcl --
+#
+# This file is part of the jabberlib. It contains support code
+# for the pub-sub (xmlns='http://jabber.org/protocol/pubsub') XEP-0060.
+#
+# Copyright (c) 2005-2006 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: pubsub.tcl,v 1.21 2008/01/01 09:05:27 matben Exp $
+#
+############################# USAGE ############################################
+#
+# INSTANCE COMMANDS
+# jlibName pubsub affiliations
+# jlibName pubsub create
+# jlibName pubsub delete
+# jlibName pubsub deregister_event
+# jlibName pubsub items
+# jlibName pubsub options
+# jlibName pubsub publish
+# jlibName pubsub purge
+# jlibName pubsub register_event
+# jlibName pubsub retract
+# jlibName pubsub subscribe
+# jlibName pubsub unsubscribe
+#
+################################################################################
+#
+# BRIEF:
+#
+# pubsub-service
+# node
+# item
+# item
+# ...
+# node
+# item
+# ...
+# ...
+#
+# Owner use case:
+#
+# create node
+# delete node
+#
+# publish item to a node
+# retract (remove) item from a node
+#
+# User use case:
+#
+# register for events
+# subscribe to a node
+# unsubscribe from a node
+#
+################################################################################
+
+package provide jlib::pubsub 0.2
+
+namespace eval jlib::pubsub {
+
+ variable debug 0
+
+ # Common xml namespaces.
+ variable xmlns
+ array set xmlns {
+ pubsub "http://jabber.org/protocol/pubsub"
+ errors "http://jabber.org/protocol/pubsub#errors"
+ event "http://jabber.org/protocol/pubsub#event"
+ owner "http://jabber.org/protocol/pubsub#owner"
+ }
+}
+
+# jlib::pubsub::init --
+#
+# Creates a new instance of the pubsub object.
+#
+# Arguments:
+# jlibname: name of existing jabberlib instance
+#
+# Results:
+# namespaced instance command
+
+proc jlib::pubsub::init {jlibname} {
+
+ variable xmlns
+
+ # Instance specific arrays.
+ namespace eval ${jlibname}::pubsub {
+ variable items
+ variable events
+ }
+
+ # Register event notifier.
+ $jlibname message_register normal $xmlns(event) [namespace code event]
+}
+
+proc jlib::pubsub::cmdproc {jlibname cmd args} {
+
+ # Which command? Just dispatch the command to the right procedure.
+ return [eval {$cmd $jlibname} $args]
+}
+
+# jlib::pubsub::create --
+#
+# Create a new pubsub node.
+#
+# Arguments:
+# args:
+# -to (JID) if not indicated, we are using PEP recomendations
+# -command tclProc
+# -configure 0 no configure element
+# 1 new node with default configuration
+# xmldata jabber:x:data element
+# -node the nodeID (else we get an instant node)
+#
+# Results:
+# none
+
+proc jlib::pubsub::create {jlibname args} {
+
+ variable xmlns
+
+ set attr [list]
+ set opts [list]
+ set configure 0
+ foreach {key value} $args {
+ set name [string trimleft $key -]
+
+ switch -- $key {
+ -command {
+ lappend opts -command $value
+ }
+ -configure {
+ set configure $value
+ }
+ -node {
+ lappend attr $name $value
+ }
+ -to {
+ lappend opts -to $value
+ }
+ }
+ }
+ set subtags [list [wrapper::createtag create -attrlist $attr]]
+ if {$configure eq "1"} {
+ lappend subtags [wrapper::createtag configure]
+ } elseif {[wrapper::validxmllist $configure]} {
+ lappend subtags [wrapper::createtag configure -subtags [list $configure]]
+ }
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(pubsub)] -subtags $subtags]]
+ eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::configure --
+#
+# Get or set configuration options for a node.
+#
+# Arguments:
+# type: get|set
+# to: JID
+#
+# Results:
+# none
+
+proc jlib::pubsub::configure {jlibname type to node args} {
+
+ variable xmlns
+
+ set opts [list -to $to]
+ set xE [list]
+ foreach {key value} $args {
+ switch -- $key {
+ -command {
+ lappend opts -command $value
+ }
+ -x {
+ set xE $value
+ }
+ }
+ }
+ set subtags [list [wrapper::createtag configure \
+ -attrlist [list node $node] -subtags [list $xE]]]
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(owner)] -subtags $subtags]]
+ eval {jlib::send_iq $jlibname $type $xmllist} $opts
+}
+
+# jlib::pubsub::default --
+#
+# Request default configuration options for new nodes.
+
+proc jlib::pubsub::default {jlibname to args} {
+
+ variable xmlns
+
+ set opts [list -to $to]
+ foreach {key value} $args {
+ switch -- $key {
+ -command {
+ lappend opts -command $value
+ }
+ }
+ }
+ set subtags [list [wrapper::createtag default]]
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(owner)] -subtags $subtags]]
+ eval {jlib::send_iq $jlibname get $xmllist} $opts
+}
+
+# jlib::pubsub::delete --
+#
+# Delete a node.
+
+proc jlib::pubsub::delete {jlibname to node args} {
+
+ variable xmlns
+
+ set opts [list -to $to]
+ foreach {key value} $args {
+ switch -- $key {
+ -command {
+ lappend opts -command $value
+ }
+ }
+ }
+ set subtags [list [wrapper::createtag delete -attrlist [list node $node]]]
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(owner)] -subtags $subtags]]
+ eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::purge --
+#
+# Purge all node items. (Deletes all items of a node.)
+
+proc jlib::pubsub::purge {jlibname to node args} {
+
+ variable xmlns
+
+ set opts [list -to $to]
+ foreach {key value} $args {
+ switch -- $key {
+ -command {
+ lappend opts -command $value
+ }
+ }
+ }
+ set subtags [list [wrapper::createtag purge -attrlist [list node $node]]]
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(owner)] -subtags $subtags]]
+ eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::subscriptions --
+#
+# Gets or sets subscriptions.
+#
+# Arguments:
+# type: get|set
+# to: JID
+# node: pubsub nodeID
+# args:
+# -command tclProc
+# -subscriptions list of subscription elements
+# Results:
+# none
+
+proc jlib::pubsub::subscriptions {jlibname type to node args} {
+
+ variable xmlns
+
+ set opts [list -to $to]
+ set subsEs [list]
+ foreach {key value} $args {
+ switch -- $key {
+ -command {
+ lappend opts -command $value
+ }
+ -subscriptions {
+ set subsEs $value
+ }
+ }
+ }
+ set subtags [list [wrapper::createtag subscriptions \
+ -attrlist [list node $node] -subtags $subsEs]]
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(owner)] -subtags $subtags]]
+ eval {jlib::send_iq $jlibname $type $xmllist} $opts
+}
+
+# jlib::pubsub::affiliations --
+#
+# Gets or sets affiliations.
+#
+# Arguments:
+# type: get|set
+# to: JID
+# node: pubsub nodeID
+# args:
+# -command tclProc
+# -affiliations list of affiliation elements
+# Results:
+# none
+
+proc jlib::pubsub::affiliations {jlibname type to node args} {
+
+ variable xmlns
+
+ set opts [list -to $to]
+ set affEs [list]
+ foreach {key value} $args {
+ switch -- $key {
+ -command {
+ lappend opts -command $value
+ }
+ -affiliations {
+ set affEs $value
+ }
+ }
+ }
+ set subtags [list [wrapper::createtag affiliations] \
+ -attrlist [list node $node] -subtags $affEs]]
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(pubsub)] -subtags $subtags]]
+ eval {jlib::send_iq $jlibname $type $xmllist} $opts
+}
+
+# jlib::pubsub::items --
+#
+# Retrieve items from a node.
+
+proc jlib::pubsub::items {jlibname to node args} {
+
+ variable xmlns
+
+ set opts [list -to $to]
+ set attr [list node $node]
+ set itemids [list]
+ foreach {key value} $args {
+ set name [string trimleft $key -]
+
+ switch -- $key {
+ -command {
+ lappend opts -command $value
+ }
+ -itemids {
+ set itemids $value
+ }
+ -max_items - -subid {
+ lappend attr $name $value
+ }
+ }
+ }
+ set items [list]
+ foreach id $itemids {
+ lappend items [wrapper::createtag item -attrlist [list id $id]]
+ }
+ set subtags [list [wrapper::createtag items \
+ -attrlist $attr -subtags $items]]
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(pubsub)] -subtags $subtags]]
+ eval {jlib::send_iq $jlibname get $xmllist} $opts
+}
+
+# jlib::pubsub::options --
+#
+# Gets or sets options for a JID+node
+#
+# Arguments:
+# type: set or get
+# to: JID for pubsub service
+# jid: the subscribed JID
+# args:
+# -command tclProc
+# -subid subscription ID
+# -xdata
+#
+# Results:
+# none
+
+proc jlib::pubsub::options {jlibname type to jid node args} {
+
+ variable xmlns
+
+ set opts [list -to $to]
+ set attr [list node $node jid $jid]
+ set xdata [list]
+
+ foreach {key value} $args {
+ switch -- $key {
+ -command {
+ lappend opts -command $value
+ }
+ -subid {
+ lappend attr subid $value
+ }
+ -xdata {
+ set xdata $value
+ }
+ }
+ }
+ set optE [list [wrapper::createtag options \
+ -attrlist $attr -subtags [list $xdata]]]
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(pubsub)] -subtags $optE]]
+ eval {jlib::send_iq $jlibname $type $xmllist} $opts
+}
+
+# jlib::pubsub::publish --
+#
+# Publish an item to a node.
+#
+# Arguments:
+# args:
+# -to (JID) if not indicated, we are using PEP recomendations
+# -command tclProc
+# -configure 0 no configure element
+# 1 new node with default configuration
+# xmldata jabber:x:data element
+# -node the nodeID (else we get an instant node)
+# -items
+#
+# Results:
+# none
+
+proc jlib::pubsub::publish {jlibname node args} {
+
+ variable xmlns
+
+ set opts [list]
+ set itemEs [list]
+ foreach {key value} $args {
+ switch -- $key {
+ -command {
+ lappend opts -command $value
+ }
+ -items {
+ set itemEs $value
+ }
+ -to {
+ lappend opts -to $value
+ }
+ }
+ }
+ set subtags [list [wrapper::createtag publish \
+ -attrlist [list node $node] -subtags $itemEs]]
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(pubsub)] -subtags $subtags]]
+ eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::retract --
+#
+# Delete an item from a node.
+
+proc jlib::pubsub::retract {jlibname node items args} {
+
+ variable xmlns
+
+ set opts [list]
+ set attr [list node $node]
+
+ foreach {key value} $args {
+ switch -- $key {
+ -command {
+ lappend opts $name $value
+ }
+ -notify {
+ # Must be boolean.
+ lappend attr notify $value
+ }
+ -to {
+ lappend opts -to $value
+ }
+ }
+ }
+ set subtags [list [wrapper::createtag retract \
+ -attrlist $attr -subtags $items]]
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(pubsub)] -subtags $subtags]]
+ eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::subscribe --
+#
+# Subscribe to a JID+nodeID.
+#
+# Arguments:
+# to: JID for pubsub service
+# jid: the subscribed JID
+# args:
+# -command tclProc
+# -node pubsub nodeID; MUST be there except for root collection
+# node
+#
+# Results:
+#
+
+proc jlib::pubsub::subscribe {jlibname to jid args} {
+
+ variable xmlns
+
+ set opts [list -to $to]
+ set attr [list jid $jid]
+ foreach {key value} $args {
+ switch -- $key {
+ -command {
+ lappend opts -command $value
+ }
+ -node {
+ lappend attr node $value
+ }
+ }
+ }
+ set subEs [list [wrapper::createtag subscribe -attrlist $attr]]
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(pubsub)] -subtags $subEs]]
+ eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::unsubscribe --
+#
+# Unsubscribe to a JID+nodeID.
+
+proc jlib::pubsub::unsubscribe {jlibname to jid node args} {
+
+ variable xmlns
+
+ set opts [list -to $to]
+ set attr [list node $node jid $jid]
+ foreach {key value} $args {
+ switch -- $key {
+ -command {
+ lappend opts -command $value
+ }
+ -subid {
+ lappend attr subid $value
+ }
+ }
+ }
+ set unsubE [list [wrapper::createtag unsubscribe -attrlist $attr]]
+ set xmllist [list [wrapper::createtag pubsub \
+ -attrlist [list xmlns $xmlns(pubsub)] -subtags $unsubE]]
+ eval {jlib::send_iq $jlibname set $xmllist} $opts
+}
+
+# jlib::pubsub::register_event --
+#
+# Register for specific pubsub events.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# func: tclProc
+# args: -from
+# -node
+# -seq priority 0-100 (D=50)
+#
+# Results:
+# none.
+
+# @@@ TODO:
+# <event xmlns='http://jabber.org/protocol/pubsub#event'>
+# <collection>
+# <node id='new-node-id'>
+# </collection>
+# </event>
+
+proc jlib::pubsub::register_event {jlibname func args} {
+
+ upvar ${jlibname}::events events
+
+ # args: -from, -node
+ set from "*"
+ set node "*"
+ set seq 50
+
+ foreach {key value} $args {
+ switch -- $key {
+ -from {
+ set from [jlib::ESC $value]
+ }
+ -node {
+
+ # The pubsub service MUST ensure that the NodeID conforms to
+ # the Resourceprep profile of Stringprep as described in
+ # RFC 3920.
+ # @@@ ???
+ set node [jlib::resourceprep $value]
+ }
+ -seq {
+ set seq $value
+ }
+ }
+ }
+ set pattern "$from,$node"
+ lappend events($pattern) [list $func $seq]
+ set events($pattern) \
+ [lsort -integer -index 1 [lsort -unique $events($pattern)]]
+}
+
+proc jlib::pubsub::deregister_event {jlibname func args} {
+
+ upvar ${jlibname}::events events
+
+ set from "*"
+ set node "*"
+
+ foreach {key value} $args {
+ switch -- $key {
+ -from {
+ set from [jlib::ESC $value]
+ }
+ -node {
+ set node [jlib::resourceprep $value]
+ }
+ }
+ }
+ set pattern "$from,$node"
+ if {[info exists events($pattern)]} {
+ set idx [lsearch -glob $events($pattern) [list $func *]]
+ if {$idx >= 0} {
+ set events($pattern) [lreplace $events($pattern) $idx $idx]
+ }
+ }
+}
+
+# jlib::pubsub::event --
+#
+# The event notifier. Dispatches events to the relevant registered
+# event handlers.
+#
+# Normal events:
+# <event xmlns='http://jabber.org/protocol/pubsub#event'>
+# <items node='princely_musings'>
+# <item id='ae890ac52d0df67ed7cfdf51b644e901'>
+# ... ENTRY ...
+# </item>
+# </items>
+# </event>
+
+proc jlib::pubsub::event {jlibname ns msgE args} {
+
+ variable xmlns
+ upvar ${jlibname}::events events
+
+ array set aargs $args
+ set xmldata $aargs(-xmldata)
+
+ set from [wrapper::getattribute $xmldata from]
+ set nodes [list]
+
+ set eventEs [wrapper::getchildswithtagandxmlns $xmldata event $xmlns(event)]
+ foreach eventE $eventEs {
+ set itemsEs [wrapper::getchildswithtag $eventE items]
+ foreach itemsE $itemsEs {
+ lappend nodes [wrapper::getattribute $itemsE node]
+ }
+ }
+ foreach node $nodes {
+ set key "$from,$node"
+ foreach {pattern value} [array get events] {
+ if {[string match $pattern $key]} {
+ foreach spec $value {
+ set func [lindex $spec 0]
+ set code [catch {
+ uplevel #0 $func [list $jlibname $xmldata]
+ } ans]
+ if {$code} {
+ bgerror "jlib::pubsub::event $func failed: $code\n$::errorInfo"
+ }
+ }
+ }
+ }
+ }
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::pubsub {
+
+ jlib::ensamble_register pubsub \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+if {0} {
+ # Test code.
+ set jlib jlib::jlib1
+ set psjid pubsub.sgi.se
+ set psjid pubsub.devrieze.dyndns.org
+ set myjid [$jlib myjid2]
+ set server [$jlib getserver]
+ set itemE [wrapper::createtag item -attrlist [list id 123456789]]
+ proc cb {args} {puts "---> $args"}
+ set node mats
+ set node home/$server/matben/xyz
+
+ $jlib pubsub create -to $psjid -node $node -command cb
+ $jlib pubsub register_event cb -from $psjid -node $node
+ $jlib pubsub subscribe $psjid $myjid -node $node -command cb
+ $jlib pubsub subscriptions get $psjid $node -command cb
+ $jlib pubsub publish $node -to $psjid -items [list $itemE]
+
+}
+
+#-------------------------------------------------------------------------------
+
--- /dev/null
+
+All jabberlib sources are distributed under the BSD license.
+
+README
+
+ - Install TclXML as a proper package. Must be patched version!
+
+ - start wish
+
+ - TODO
+
+ - If you run tclsh instead of wish be sure to start the event loop.
--- /dev/null
+# roster.tcl --
+#
+# An object for storing the roster and presence information for a
+# jabber client. Is used together with jabberlib.
+#
+# Copyright (c) 2001-2006 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: roster.tcl,v 1.68 2008/03/29 11:55:06 matben Exp $
+#
+# Note that every jid in the rostA is usually (always) without any resource,
+# but the jid's in the presA are identical to the 'from' attribute, except
+# the presA($jid-2,res) which have any resource stripped off. The 'from'
+# attribute are (always) with /resource.
+#
+# All jid's in internal arrays are STRINGPREPed!
+#
+# Variables used in roster:
+#
+# rostA(groups) : List of all groups the exist in roster.
+#
+# rostA($jid,item) : $jid.
+#
+# rostA($jid,name) : Name of $jid.
+#
+# rostA($jid,groups) : Groups $jid is in. Note: PLURAL!
+#
+# rostA($jid,subscription) : Subscription of $jid (to|from|both|"")
+#
+# rostA($jid,ask) : "Ask" of $jid
+# (subscribe|unsubscribe|"")
+#
+# presA($jid-2,res) : List of resources for this $jid.
+#
+# presA($from,type) : One of 'available' or 'unavailable.
+#
+# presA($from,status) : The presence status element.
+#
+# presA($from,priority) : The presence priority element.
+#
+# presA($from,show) : The presence show element.
+#
+# presA($from,x,xmlns) : Storage for x elements.
+# xmlns is a namespace but where any
+# http://jabber.org/protocol/ stripped off
+#
+# oldpresA : As presA but any previous state.
+#
+# state($jid,*) : Keeps other info not directly related
+# to roster or presence elements.
+#
+############################# USAGE ############################################
+#
+# Changes to the state of this object should only be made from jabberlib,
+# and never directly by the client!
+#
+# NAME
+# roster - an object for roster and presence information.
+#
+# SYNOPSIS
+# jlibname roster cmd ??
+#
+# INSTANCE COMMANDS
+# jlibname roster availablesince jid
+# jlibname roster clearpresence ?jidpattern?
+# jlibname roster getgroups ?jid?
+# jlibname roster getask jid
+# jlibname roster getcapsattr jid name
+# jlibname roster getname jid
+# jlibname roster getpresence jid ?-resource, -type?
+# jlibname roster getresources jid
+# jlibname roster gethighestresource jid
+# jlibname roster getrosteritem jid
+# jlibname roster getstatus jid
+# jlibname roster getsubscription jid
+# jlibname roster getusers ?-type available|unavailable?
+# jlibname roster getx jid xmlns
+# jlibname roster getextras jid xmlns
+# jlibname roster isavailable jid
+# jlibname roster isitem jid
+# jlibname roster haveroster
+# jlibname roster reset
+# jlibname roster send_get ?-command tclProc?
+# jlibname roster send_remove ?-command tclProc?
+# jlibname roster send_set ?-command tclProc, -name, -groups?
+# jlibname roster wasavailable jid
+#
+# The 'clientCommand' procedure must have the following form:
+#
+# clientCommand {jlibname what {jid {}} args}
+#
+# where 'what' can be any of: enterroster, exitroster, presence, remove, set.
+# The args is a list of '-key value' pairs with the following keys for each
+# 'what':
+# enterroster: no keys
+# exitroster: no keys
+# presence: -resource (required)
+# -type (required)
+# -status (optional)
+# -priority (optional)
+# -show (optional)
+# -x (optional)
+# -extras (optional)
+# remove: no keys
+# set: -name (optional)
+# -subscription (optional)
+# -groups (optional)
+# -ask (optional)
+#
+################################################################################
+
+package require jlib
+
+package provide jlib::roster 1.0
+
+namespace eval jlib::roster {
+
+ variable rostGlobals
+
+ # Globals same for all instances of this roster.
+ set rostGlobals(debug) 0
+
+ # List of all rostA element sub entries. First the actual roster,
+ # with 'rostA($jid,...)'
+ set rostGlobals(tags) {name groups ask subscription}
+
+ # ...and the presence arrays: 'presA($jid/$resource,...)'
+ # The list of resources is treated separately (presA($jid,res))
+ set rostGlobals(presTags) {type status priority show x}
+
+ # Used for sorting resources.
+ variable statusPrio
+ array set statusPrio {
+ chat 1
+ available 2
+ away 3
+ xa 4
+ dnd 5
+ invisible 6
+ unavailable 7
+ }
+
+ # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::roster::roster --
+#
+# This creates a new instance of a roster.
+#
+# Arguments:
+# clientCmd: callback procedure when internals of roster or
+# presence changes.
+# args:
+#
+# Results:
+#
+
+proc jlib::roster::init {jlibname args} {
+
+ # Instance specific namespace.
+ namespace eval ${jlibname}::roster {
+ variable rostA
+ variable presA
+ variable options
+ variable priv
+
+ set priv(haveroster) 0
+ }
+
+ # Set simpler variable names.
+ upvar ${jlibname}::roster::rostA rostA
+ upvar ${jlibname}::roster::options options
+
+ # Register for roster pushes.
+ $jlibname iq_register set "jabber:iq:roster" [namespace code set_handler]
+
+ # Register for presence. Be sure they are first in order.
+ # @@@ We should have a separate internal register API to avoid any conflicts.
+ $jlibname presence_register_int available \
+ [namespace code presence_handler] 10
+ $jlibname presence_register_int unavailable \
+ [namespace code presence_handler] 10
+
+ set rostA(groups) [list]
+ set options(cmd) ""
+
+ jlib::register_package roster
+}
+
+# jlib::roster::cmdproc --
+#
+# Just dispatches the command to the right procedure.
+#
+# Arguments:
+# jlibname: name of existing jabberlib instance
+# cmd:
+# args: all args to the cmd procedure.
+#
+# Results:
+# none.
+
+proc jlib::roster::cmdproc {jlibname cmd args} {
+
+ # Which command? Just dispatch the command to the right procedure.
+ return [eval {$cmd $jlibname} $args]
+}
+
+# jlib::roster::register_cmd --
+#
+# This sets a client callback command.
+
+proc jlib::roster::register_cmd {jlibname cmd} {
+ upvar ${jlibname}::roster::options options
+
+ set options(cmd) $cmd
+}
+
+proc jlib::roster::haveroster {jlibname} {
+ upvar ${jlibname}::roster::priv priv
+
+ return $priv(haveroster)
+}
+
+# jlib::roster::send_get --
+#
+# Request our complete roster.
+#
+# Arguments:
+# jlibname: name of existing jabberlib instance
+# args: -command tclProc
+#
+# Results:
+# none.
+
+proc jlib::roster::send_get {jlibname args} {
+
+ array set argsA {-command {}}
+ array set argsA $args
+
+ set queryE [wrapper::createtag "query" \
+ -attrlist [list xmlns jabber:iq:roster]]
+ jlib::send_iq $jlibname "get" [list $queryE] \
+ -command [list [namespace current]::send_get_cb $jlibname $argsA(-command)]
+ return
+}
+
+proc jlib::roster::send_get_cb {jlibname cmd type queryE} {
+
+ if {![string equal $type "error"]} {
+ enterroster $jlibname
+ handle_roster $jlibname $queryE
+ exitroster $jlibname
+ }
+ if {$cmd ne {}} {
+ uplevel #0 $cmd [list $type $queryE]
+ }
+}
+
+# jlib::roster::set_handler --
+#
+# This gets called for roster pushes.
+
+proc jlib::roster::set_handler {jlibname from queryE args} {
+
+ handle_roster $jlibname $queryE
+
+ # RFC 3921, sect 8.1:
+ # The 'from' and 'to' addresses are OPTIONAL in roster pushes; ...
+ # A client MUST acknowledge each roster push with an IQ stanza of
+ # type "result"...
+ array set argsA $args
+ if {[info exists argsA(-id)]} {
+ $jlibname send_iq "result" {} -id $argsA(-id)
+ }
+ return 1
+}
+
+proc jlib::roster::handle_roster {jlibname queryE} {
+
+ upvar ${jlibname}::roster::itemA itemA
+
+ foreach itemE [wrapper::getchildren $queryE] {
+ if {[wrapper::gettag $itemE] ne "item"} {
+ continue
+ }
+ set subscription "none"
+ set opts [list]
+ set havejid 0
+ foreach {aname avalue} [wrapper::getattrlist $itemE] {
+ set $aname $avalue
+ if {$aname eq "jid"} {
+ set havejid 1
+ } else {
+ lappend opts -$aname $avalue
+ }
+ }
+
+ # This shall NEVER happen!
+ if {!$havejid} {
+ continue
+ }
+ set mjid [jlib::jidmap $jid]
+ if {$subscription eq "remove"} {
+ unset -nocomplain itemA($mjid)
+ removeitem $jlibname $jid
+ } else {
+ set itemA($mjid) $itemE
+ set groups [list]
+ foreach groupE [wrapper::getchildswithtag $itemE group] {
+ lappend groups [wrapper::getcdata $groupE]
+ }
+ if {[llength $groups]} {
+ lappend opts -groups $groups
+ }
+ eval {setitem $jlibname $jid} $opts
+ }
+ }
+}
+
+# jlib::roster::send_set --
+#
+# To set/add an jid in/to your roster.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: jabber user id to add/set.
+# args:
+# -command tclProc
+# -name $name: A name to show the user-id as on roster to the user.
+# -groups $group_list: Groups of user. If you omit this, then the user's
+# groups will be set according to the user's options
+# stored in the roster object. If user doesn't exist,
+# or you haven't got your roster, user's groups will be
+# set to "", which means no groups.
+#
+# Results:
+# none.
+
+proc jlib::roster::send_set {jlibname jid args} {
+
+ upvar ${jlibname}::roster::rostA rostA
+
+ array set argsA {-command {}}
+ array set argsA $args
+
+ set mjid [jlib::jidmap $jid]
+
+ # Find group(s).
+ if {[info exists argsA(-groups)]} {
+ set groups $argsA(-groups)
+ } elseif {[info exists rostA($mjid,groups)]} {
+ set groups $rostA($mjid,groups)
+ } else {
+ set groups [list]
+ }
+
+ set attr [list jid $jid]
+ set name ""
+ if {[info exists argsA(-name)] && [string length $argsA(-name)]} {
+ set name $argsA(-name)
+ lappend attr name $name
+ }
+ set groupEs [list]
+ foreach group $groups {
+ if {$group ne ""} {
+ lappend groupEs [wrapper::createtag "group" -chdata $group]
+ }
+ }
+
+ # Roster items get pushed to us. Only any errors need to be taken care of.
+ set itemE [wrapper::createtag "item" -attrlist $attr -subtags $groupEs]
+ set queryE [wrapper::createtag "query" \
+ -attrlist [list xmlns jabber:iq:roster] -subtags [list $itemE]]
+ jlib::send_iq $jlibname "set" [list $queryE] -command $argsA(-command)
+ return
+}
+
+proc jlib::roster::send_remove {jlibname jid args} {
+
+ array set argsA {-command {}}
+ array set argsA $args
+
+ # Roster items get pushed to us. Only any errors need to be taken care of.
+ set itemE [wrapper::createtag "item" \
+ -attrlist [list jid $jid subscription remove]]
+ set queryE [wrapper::createtag "query" \
+ -attrlist [list xmlns jabber:iq:roster] -subtags [list $itemE]]
+ jlib::send_iq $jlibname "set" [list $queryE] -command $argsA(-command)
+ return
+}
+
+# jlib::roster::setitem --
+#
+# Adds or modifies an existing roster item.
+# Features not set are left as they are; features not set will give
+# nonexisting array entries, just to differentiate between an empty
+# element and a nonexisting one.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: 2-tier jid, with no /resource, usually.
+# Some transports keep a resource part in jid.
+# args: a list of '-key value' pairs, where '-key' is any of:
+# -name value
+# -subscription value
+# -groups list Note: GROUPS in plural!
+# -ask value
+#
+# Results:
+# none.
+
+proc jlib::roster::setitem {jlibname jid args} {
+ variable rostGlobals
+ upvar ${jlibname}::roster::rostA rostA
+ upvar ${jlibname}::roster::options options
+
+ Debug 2 "roster::setitem jid='$jid', args='$args'"
+
+ set mjid [jlib::jidmap $jid]
+
+ # Clear out the old state since an 'ask' element may still be lurking.
+ foreach key $rostGlobals(tags) {
+ unset -nocomplain rostA($mjid,$key)
+ }
+
+ # This array is better than list to keep track of users.
+ set rostA($mjid,item) $mjid
+
+ # Old values will be overwritten, nonexisting options will result in
+ # nonexisting array entries.
+ foreach {name value} $args {
+ set par [string trimleft $name "-"]
+ set rostA($mjid,$par) $value
+ if {[string equal $par "groups"]} {
+ foreach gr $value {
+ if {[lsearch -exact $rostA(groups) $gr] < 0} {
+ lappend rostA(groups) $gr
+ }
+ }
+ }
+ }
+
+ # Be sure to evaluate the registered command procedure.
+ if {[string length $options(cmd)]} {
+ uplevel #0 $options(cmd) [list $jlibname set $jid] $args
+ }
+ return
+}
+
+# jlib::roster::removeitem --
+#
+# Removes an existing roster item and all its presence info.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: 2-tier jid with no /resource.
+#
+# Results:
+# none.
+
+proc jlib::roster::removeitem {jlibname jid} {
+ variable rostGlobals
+
+ upvar ${jlibname}::roster::rostA rostA
+ upvar ${jlibname}::roster::presA presA
+ upvar ${jlibname}::roster::oldpresA oldpresA
+ upvar ${jlibname}::roster::options options
+
+ Debug 2 "roster::removeitem jid='$jid'"
+
+ set mjid [jlib::jidmap $jid]
+
+ # Be sure to evaluate the registered command procedure.
+ # Do this BEFORE unsetting the internal state!
+ if {[string length $options(cmd)]} {
+ uplevel #0 $options(cmd) [list $jlibname remove $jid]
+ }
+
+ # First the roster, then presence...
+ foreach name $rostGlobals(tags) {
+ unset -nocomplain rostA($mjid,$name)
+ }
+ unset -nocomplain rostA($mjid,item)
+
+ # Be sure to unset all, also jid3 entries!
+ array unset presA [jlib::ESC $mjid]*
+ array unset oldpresA [jlib::ESC $mjid]*
+ return
+}
+
+# jlib::roster::ClearRoster --
+#
+# Removes all existing roster items but keeps all presence info.(?)
+# and list of resources.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+#
+# Results:
+# none. Callback evaluated.
+
+proc jlib::roster::ClearRoster {jlibname} {
+
+ variable rostGlobals
+ upvar ${jlibname}::roster::rostA rostA
+ upvar ${jlibname}::roster::itemA itemA
+ upvar ${jlibname}::roster::options options
+
+ Debug 2 "roster::ClearRoster"
+
+ # Remove the roster.
+ foreach {x mjid} [array get rostA *,item] {
+ foreach key $rostGlobals(tags) {
+ unset -nocomplain rostA($mjid,$key)
+ }
+ }
+ array unset rostA *,item
+ unset -nocomplain itemA
+
+ # Be sure to evaluate the registered command procedure.
+ if {[string length $options(cmd)]} {
+ uplevel #0 $options(cmd) [list $jlibname enterroster]
+ }
+ return
+}
+
+# jlib::roster::enterroster --
+#
+# Is called when new roster coming.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+#
+# Results:
+# none.
+
+proc jlib::roster::enterroster {jlibname} {
+
+ ClearRoster $jlibname
+}
+
+# jlib::roster::exitroster --
+#
+# Is called when finished receiving a roster get command.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+#
+# Results:
+# none. Callback evaluated.
+
+proc jlib::roster::exitroster {jlibname} {
+
+ upvar ${jlibname}::roster::options options
+ upvar ${jlibname}::roster::priv priv
+
+ set priv(haveroster) 1
+
+ # Be sure to evaluate the registered command procedure.
+ if {[string length $options(cmd)]} {
+ uplevel #0 $options(cmd) [list $jlibname exitroster]
+ }
+}
+
+# jlib::roster::reset --
+#
+# Removes everything stored in the roster object, including all roster
+# items and any presence information.
+
+proc jlib::roster::reset {jlibname} {
+
+ upvar ${jlibname}::roster::rostA rostA
+ upvar ${jlibname}::roster::presA presA
+ upvar ${jlibname}::roster::priv priv
+
+ unset -nocomplain rostA presA
+ set rostA(groups) {}
+ set priv(haveroster) 0
+}
+
+# jlib::roster::clearpresence --
+#
+# Removes all presence cached internally for jid glob pattern.
+# Helpful when exiting a room.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jidpattern: glob pattern for items to remove.
+#
+# Results:
+# none.
+
+proc jlib::roster::clearpresence {jlibname {jidpattern ""}} {
+
+ upvar ${jlibname}::roster::presA presA
+ upvar ${jlibname}::roster::oldpresA oldpresA
+
+ Debug 2 "roster::clearpresence '$jidpattern'"
+
+ if {$jidpattern eq ""} {
+ unset -nocomplain presA
+ } else {
+ array unset presA $jidpattern
+ array unset oldpresA $jidpattern
+ }
+}
+
+proc jlib::roster::presence_handler {jlibname xmldata} {
+ presence $jlibname $xmldata
+ return 0
+}
+
+# jlib::roster::presence --
+#
+# Registered internal presence handler for 'available' and 'unavailable'
+# that caches all presence info.
+
+proc jlib::roster::presence {jlibname xmldata} {
+
+ variable rostGlobals
+ upvar ${jlibname}::roster::rostA rostA
+ upvar ${jlibname}::roster::presA presA
+ upvar ${jlibname}::roster::oldpresA oldpresA
+ upvar ${jlibname}::roster::state state
+
+ Debug 2 "jlib::roster::presence"
+
+ set from [wrapper::getattribute $xmldata from]
+ set type [wrapper::getattribute $xmldata type]
+ if {$type eq ""} {
+ set type "available"
+ }
+
+ # We don't handle subscription types (remove?).
+ if {$type ne "available" && $type ne "unavailable"} {
+ return
+ }
+
+ set mjid [jlib::jidmap $from]
+ jlib::splitjid $mjid mjid2 res
+
+ # Set secs only if unavailable before.
+ if {![info exists presA($mjid,type)] \
+ || ($presA($mjid,type) eq "unavailable")} {
+ set state($mjid,secs) [clock seconds]
+ }
+
+ # Keep cache of any old state.
+ # Note special handling of * for array unset - prefix with \\ to quote.
+ array unset oldpresA [jlib::ESC $mjid],*
+ array set oldpresA [array get presA [jlib::ESC $mjid],*]
+
+ # Clear out the old presence state since elements may still be lurking.
+ array unset presA [jlib::ESC $mjid],*
+
+ # Add to list of resources.
+ set presA($mjid2,res) [lsort -unique [lappend presA($mjid2,res) $res]]
+
+ set presA($mjid,type) $type
+
+ foreach E [wrapper::getchildren $xmldata] {
+ set tag [wrapper::gettag $E]
+ set chdata [wrapper::getcdata $E]
+
+ switch -- $tag {
+ priority {
+ if {[string is integer -strict $chdata]} {
+ set presA($mjid,$tag) $chdata
+ }
+ }
+ status {
+ set presA($mjid,$tag) $chdata
+ }
+ show {
+ if {[regexp {^(away|chat|dnd|xa)$} $chdata]} {
+ set presA($mjid,$tag) $chdata
+ }
+ }
+ x {
+ set ns [wrapper::getattribute $E xmlns]
+ regexp {http://jabber.org/protocol/(.*)$} $ns - ns
+ set presA($mjid,x,$ns) $E
+ }
+ default {
+
+ # This can be anything properly namespaced.
+ set ns [wrapper::getattribute $E xmlns]
+ set presA($mjid,extras,$ns) $E
+ }
+ }
+ }
+}
+
+
+# Firts attempt to keep the jid's as they are reported, with no separate
+# resource part.
+
+proc jlib::roster::setpresence2 {jlibname xmldata} {
+
+
+}
+
+# jlib::roster::getrosteritem --
+#
+# Returns the state of an existing roster item.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: .
+#
+# Results:
+# a list of '-key value' pairs where key is any of:
+# name, groups, subscription, ask. Note GROUPS in plural!
+
+proc jlib::roster::getrosteritem {jlibname jid} {
+
+ variable rostGlobals
+ upvar ${jlibname}::roster::rostA rostA
+ upvar ${jlibname}::roster::options options
+
+ Debug 2 "roster::getrosteritem jid='$jid'"
+
+ set mjid [jlib::jidmap $jid]
+ if {![info exists rostA($mjid,item)]} {
+ return {}
+ }
+ set result [list]
+ foreach key $rostGlobals(tags) {
+ if {[info exists rostA($mjid,$key)]} {
+ lappend result -$key $rostA($mjid,$key)
+ }
+ }
+ return $result
+}
+
+proc jlib::roster::getitem {jlibname jid} {
+
+ upvar ${jlibname}::roster::itemA itemA
+
+ set mjid [jlib::jidmap $jid]
+ if {[info exists itemA($mjid)]} {
+ return $itemA($mjid)
+ } else {
+ return {}
+ }
+}
+
+# jlib::roster::isitem --
+#
+# Does the jid exist in the roster?
+
+proc jlib::roster::isitem {jlibname jid} {
+
+ upvar ${jlibname}::roster::rostA rostA
+
+ set mjid [jlib::jidmap $jid]
+ return [expr {[info exists rostA($mjid,item)] ? 1 : 0}]
+}
+
+# jlib::roster::getrosterjid --
+#
+# Returns the matching jid as reported by a roster item.
+# If given a full JID try match this, else bare JID.
+# If given a bare JID try match this, else find any matching full JID.
+# For ordinary users this is a jid2.
+#
+# @@@ NB: For the new xmpp lib we shall have a mapping from the roster JID
+# to a set of online JID's if any, which shall be completely indpendent
+# of bare vs. full JID forms!
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid:
+#
+# Results:
+# a jid or empty if no matching roster item.
+
+proc jlib::roster::getrosterjid {jlibname jid} {
+
+ upvar ${jlibname}::roster::rostA rostA
+
+ set mjid [jlib::jidmap $jid]
+ if {[info exists rostA($mjid,item)]} {
+ return $jid
+ } else {
+ set mjid2 [jlib::barejid $mjid]
+ if {[info exists rostA($mjid2,item)]} {
+ return [jlib::barejid $jid]
+ } else {
+ set name [array names rostA [jlib::ESC $mjid2]*,item]
+ if {[llength $name] == 1} {
+ # There should only be one.
+ return [string map {",item" ""} $name]
+ }
+ }
+ }
+ return
+}
+
+# jlib::roster::getusers --
+#
+# Returns a list of jid's of all existing roster items.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# args: -type available|unavailable
+#
+# Results:
+# list of all 2-tier jid's in roster
+
+proc jlib::roster::getusers {jlibname args} {
+
+ upvar ${jlibname}::roster::rostA rostA
+ upvar ${jlibname}::roster::presA presA
+
+ set all {}
+ foreach {x jid} [array get rostA *,item] {
+ lappend all $jid
+ }
+ array set argsA $args
+ set jidlist {}
+ if {$args == {}} {
+ set jidlist $all
+ } elseif {[info exists argsA(-type)]} {
+ set type $argsA(-type)
+ set jidlist {}
+ foreach jid2 $all {
+ set isavailable 0
+
+ # Be sure to handle empty resources as well: '1234@icq.host'
+ foreach key [array names presA "[jlib::ESC $jid2]*,type"] {
+ if {[string equal $presA($key) "available"]} {
+ set isavailable 1
+ break
+ }
+ }
+ if {$isavailable && [string equal $type "available"]} {
+ lappend jidlist $jid2
+ } elseif {!$isavailable && [string equal $type "unavailable"]} {
+ lappend jidlist $jid2
+ }
+ }
+ }
+ return $jidlist
+}
+
+# jlib::roster::getpresence --
+#
+# Returns the presence state of an existing roster item.
+# This is as reported in presence element.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: username@server, without /resource.
+# args ?-resource, -type?
+# -resource: return presence for this alone,
+# else a list for each resource.
+# Allow empty resources!!??
+# -type: return presence for (un)available only.
+#
+# Results:
+# a list of '-key value' pairs where key is any of:
+# resource, type, status, priority, show, x.
+# If the 'resource' in argument is not given,
+# the result contains a sublist for each resource. IMPORTANT! Bad?
+# BAD!!!!!!!!!!!!!!!!!!!!!!!!
+
+proc jlib::roster::getpresence {jlibname jid args} {
+
+ variable rostGlobals
+ upvar ${jlibname}::roster::rostA rostA
+ upvar ${jlibname}::roster::presA presA
+ upvar ${jlibname}::roster::options options
+
+ Debug 2 "roster::getpresence jid=$jid, args='$args'"
+
+ set jid [jlib::jidmap $jid]
+ array set argsA $args
+ set haveRes 0
+ if {[info exists argsA(-resource)]} {
+ set haveRes 1
+ set resource $argsA(-resource)
+ }
+
+ # It may happen that there is no roster item for this jid (groupchat).
+ if {![info exists presA($jid,res)] || ($presA($jid,res) eq "")} {
+ if {[info exists argsA(-type)] && \
+ [string equal $argsA(-type) "available"]} {
+ return
+ } else {
+ if {$haveRes} {
+ return [list -resource $resource -type unavailable]
+ } else {
+ return [list [list -resource "" -type unavailable]]
+ }
+ }
+ }
+
+ set result [list]
+ if {$haveRes} {
+
+ # Return presence only from the specified resource.
+ # Be sure to handle empty resources as well: '1234@icq.host'
+ if {[lsearch -exact $presA($jid,res) $resource] < 0} {
+ return [list -resource $resource -type unavailable]
+ }
+ set result [list -resource $resource]
+ if {$resource eq ""} {
+ set jid3 $jid
+ } else {
+ set jid3 $jid/$resource
+ }
+ if {[info exists argsA(-type)] && \
+ ![string equal $argsA(-type) $presA($jid3,type)]} {
+ return
+ }
+ foreach key $rostGlobals(presTags) {
+ if {[info exists presA($jid3,$key)]} {
+ lappend result -$key $presA($jid3,$key)
+ }
+ }
+ } else {
+
+ # Get presence for all resources.
+ # Be sure to handle empty resources as well: '1234@icq.host'
+ foreach res $presA($jid,res) {
+ set thisRes [list -resource $res]
+ if {$res eq ""} {
+ set jid3 $jid
+ } else {
+ set jid3 $jid/$res
+ }
+ if {[info exists argsA(-type)] && \
+ ![string equal $argsA(-type) $presA($jid3,type)]} {
+ # Empty.
+ } else {
+ foreach key $rostGlobals(presTags) {
+ if {[info exists presA($jid3,$key)]} {
+ lappend thisRes -$key $presA($jid3,$key)
+ }
+ }
+ lappend result $thisRes
+ }
+ }
+ }
+ return $result
+}
+
+# UNFINISHED!!!!!!!!!!
+# Return empty list or -type unavailable ???
+# '-key value' or 'key value' ???
+# Returns a list of flat arrays
+
+proc jlib::roster::getpresence2 {jlibname jid args} {
+
+ variable rostGlobals
+ upvar ${jlibname}::roster::rostA rostA
+ upvar ${jlibname}::roster::presA2 presA2
+ upvar ${jlibname}::roster::options options
+
+ Debug 2 "roster::getpresence2 jid=$jid, args='$args'"
+
+ array set argsA {
+ -type *
+ }
+ array set argsA $args
+
+ set mjid [jlib::jidmap $jid]
+ jlib::splitjid $mjid jid2 resource
+ set result {}
+
+ if {$resource eq ""} {
+
+ # 2-tier jid. Match any resource.
+ set arrlist [concat [array get presA2 [jlib::ESC $mjid],jid] \
+ [array get presA2 [jlib::ESC $mjid]/*,jid]]
+ foreach {key value} $arrlist {
+ set thejid $value
+ set jidresult {}
+ foreach {akey avalue} [array get presA2 [jlib::ESC $thejid],*] {
+ set thekey [string map [list $thejid, ""] $akey]
+ lappend jidresult -$thekey $avalue
+ }
+ if {[llength $jidresult]} {
+ lappend result $jidresult
+ }
+ }
+ } else {
+
+ # 3-tier jid. Only exact match.
+ if {[info exists presA2($mjid,type)]} {
+ if {[string match $argsA(-type) $presA2($mjid,type)]} {
+ set result [list [list -jid $jid -type $presA2($mjid,type)]]
+ }
+ } else {
+ set result [list [list -jid $jid -type unavailable]]
+ }
+ }
+ return $result
+}
+
+# jlib::roster::getoldpresence --
+#
+# This makes a simplified assumption and uses the full JID.
+
+proc jlib::roster::getoldpresence {jlibname jid} {
+
+ variable rostGlobals
+ upvar ${jlibname}::roster::rostA rostA
+ upvar ${jlibname}::roster::oldpresA oldpresA
+
+ set jid [jlib::jidmap $jid]
+
+ if {[info exists oldpresA($jid,type)]} {
+ set result [list]
+ foreach key $rostGlobals(presTags) {
+ if {[info exists oldpresA($jid,$key)]} {
+ lappend result -$key $oldpresA($jid,$key)
+ }
+ }
+ } else {
+ set result [list -type unavailable]
+ }
+ return $result
+}
+
+# jlib::roster::getgroups --
+#
+# Returns the list of groups for this jid, or an empty list if not
+# exists. If no jid, return a list of all groups existing in this roster.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: (optional).
+#
+# Results:
+# a list of groups or empty.
+
+proc jlib::roster::getgroups {jlibname {jid {}}} {
+
+ upvar ${jlibname}::roster::rostA rostA
+
+ Debug 2 "roster::getgroups jid='$jid'"
+
+ set jid [jlib::jidmap $jid]
+ if {[string length $jid]} {
+ if {[info exists rostA($jid,groups)]} {
+ return $rostA($jid,groups)
+ } else {
+ return
+ }
+ } else {
+ set rostA(groups) [lsort -unique $rostA(groups)]
+ return $rostA(groups)
+ }
+}
+
+# jlib::roster::getname --
+#
+# Returns the roster name of this jid.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid:
+#
+# Results:
+# the roster name or empty.
+
+proc jlib::roster::getname {jlibname jid} {
+
+ upvar ${jlibname}::roster::rostA rostA
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists rostA($jid,name)]} {
+ return $rostA($jid,name)
+ } else {
+ return ""
+ }
+}
+
+# jlib::roster::getsubscription --
+#
+# Returns the 'subscription' state of this jid.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid:
+#
+# Results:
+# the 'subscription' state or "none" if no 'subscription' state.
+
+proc jlib::roster::getsubscription {jlibname jid} {
+
+ upvar ${jlibname}::roster::rostA rostA
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists rostA($jid,subscription)]} {
+ return $rostA($jid,subscription)
+ } else {
+ return none
+ }
+}
+
+# jlib::roster::getask --
+#
+# Returns the 'ask' state of this jid.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid:
+#
+# Results:
+# the 'ask' state or empty if no 'ask' state.
+
+proc jlib::roster::getask {jlibname jid} {
+
+ upvar ${jlibname}::roster::rostA rostA
+
+ Debug 2 "roster::getask jid='$jid'"
+
+ if {[info exists rostA($jid,ask)]} {
+ return $rostA($jid,ask)
+ } else {
+ return ""
+ }
+}
+
+# jlib::roster::getresources --
+#
+# Returns a list of all resources for this JID or empty.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: a JID without any resource (jid2) typically.
+# it must be the JID which is reported by roster.
+# args ?-type?
+# -type: return presence for (un)available only.
+#
+# Results:
+# a list of all resources for this jid or empty.
+
+proc jlib::roster::getresources {jlibname jid args} {
+
+ upvar ${jlibname}::roster::presA presA
+
+ Debug 2 "roster::getresources jid='$jid'"
+ array set argsA $args
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists presA($jid,res)]} {
+ if {[info exists argsA(-type)]} {
+
+ # Need to loop through all resources for this jid.
+ set resL [list]
+ set type $argsA(-type)
+ foreach res $presA($jid,res) {
+
+ # Be sure to handle empty resources as well: '1234@icq.host'
+ if {$res eq ""} {
+ set jid3 $jid
+ } else {
+ set jid3 $jid/$res
+ }
+ if {[string equal $argsA(-type) $presA($jid3,type)]} {
+ lappend resL $res
+ }
+ }
+ return $resL
+ } else {
+ return $presA($jid,res)
+ }
+ } else {
+
+ # If the roster JID is something like: icq.home.se/registered
+ set jid2 [jlib::barejid $jid]
+ if {[info exists presA($jid2,res)]} {
+ if {[info exists argsA(-type)]} {
+
+ # Need to loop through all resources for this jid.
+ set resL [list]
+ set type $argsA(-type)
+ foreach res $presA($jid2,res) {
+
+ # Be sure to handle empty resources as well: '1234@icq.host'
+ if {$res eq ""} {
+ set jid3 $jid2
+ } else {
+ set jid3 $jid2/$res
+ }
+ if {[string equal $argsA(-type) $presA($jid3,type)]} {
+ lappend resL $res
+ }
+ }
+ return $resL
+ } else {
+ return $presA($jid2,res)
+ }
+ } else {
+ return
+ }
+ }
+}
+
+proc jlib::roster::getmatchingjids2 {jlibname jid args} {
+
+ upvar ${jlibname}::roster::presA2 presA2
+
+ set jidlist {}
+ set arrlist [concat [array get presA2 [jlib::ESC $mjid],jid] \
+ [array get presA2 [jlib::ESC $mjid]/*,jid]]
+ foreach {key value} $arrlist {
+ lappend jidlist $value
+ }
+ return $jidlist
+}
+
+# jlib::roster::gethighestresource --
+#
+# Returns the resource with highest priority for this jid or empty.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: a jid without any resource (jid2).
+#
+# Results:
+# a resource for this jid or empty if unavailable.
+
+proc jlib::roster::gethighestresource {jlibname jid} {
+
+ upvar ${jlibname}::roster::presA presA
+ variable statusPrio
+
+ Debug 2 "roster::gethighestresource jid='$jid'"
+
+ set jid [jlib::jidmap $jid]
+ set maxResL [list]
+
+ # @@@ Perhaps this sorting shall be made when receiving presence instead?
+
+ if {[info exists presA($jid,res)]} {
+
+ # Find the resource corresponding to the highest priority (D=0).
+ set maxPrio -128
+
+ foreach res $presA($jid,res) {
+
+ # Be sure to handle empty resources as well: '1234@icq.host'
+ if {$res eq ""} {
+ set jid3 $jid
+ } else {
+ set jid3 $jid/$res
+ }
+ if {[info exists presA($jid3,type)]} {
+ if {$presA($jid3,type) eq "available"} {
+ set prio 0
+ if {[info exists presA($jid3,priority)]} {
+ set prio $presA($jid3,priority)
+ }
+ if {$prio > $maxPrio} {
+ set maxPrio $prio
+ set maxResL [list $res]
+ } elseif {$prio == $maxPrio} {
+ lappend maxResL $res
+ }
+ }
+ }
+ }
+ }
+ if {[llength $maxResL] == 1} {
+ set maxRes [lindex $maxResL 0]
+ } elseif {[llength $maxResL] > 1} {
+
+ # Sort according to show attributes.
+ set resIndL [list]
+ foreach res $maxResL {
+ if {$res eq ""} {
+ set jid3 $jid
+ } else {
+ set jid3 $jid/$res
+ }
+ set show "available"
+ if {[info exists presA($jid3,show)]} {
+ set show $presA($jid3,show)
+ }
+ lappend resIndL [list $res $statusPrio($show)]
+ }
+ set resIndL [lsort -integer -index 1 $resIndL]
+ set maxRes [lindex $resIndL 0 0]
+ } else {
+ set maxRes ""
+ }
+ return $maxRes
+}
+
+proc jlib::roster::getmaxpriorityjid2 {jlibname jid} {
+
+ upvar ${jlibname}::roster::presA2 presA2
+
+ Debug 2 "roster::getmaxpriorityjid2 jid='$jid'"
+
+ # Find the resource corresponding to the highest priority (D=0).
+ set maxjid ""
+ set maxpri 0
+ foreach jid3 [getmatchingjids2 $jlibname $jid] {
+ if {[info exists presA2($jid3,priority)]} {
+ if {$presA2($jid3,priority) > $maxpri} {
+ set maxjid $jid3
+ set maxpri $presA2($jid3,priority)
+ }
+ }
+ }
+ return $jid3
+}
+
+# jlib::roster::isavailable --
+#
+# Returns boolean 0/1. Returns 1 only if presence is equal to available.
+# If 'jid' without resource, return 1 if any is available.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: either 'username$hostname', or 'username$hostname/resource'.
+#
+# Results:
+# 0/1.
+
+proc jlib::roster::isavailable {jlibname jid} {
+
+ upvar ${jlibname}::roster::presA presA
+
+ Debug 2 "roster::isavailable jid='$jid'"
+
+ set jid [jlib::jidmap $jid]
+
+ # If any resource in jid, we get it here.
+ jlib::splitjid $jid jid2 resource
+
+ if {[string length $resource] > 0} {
+ if {[info exists presA($jid2/$resource,type)]} {
+ if {[string equal $presA($jid2/$resource,type) "available"]} {
+ return 1
+ } else {
+ return 0
+ }
+ } else {
+ return 0
+ }
+ } else {
+
+ # Be sure to allow for 'user@domain' with empty resource.
+ foreach key [array names presA "[jlib::ESC $jid2]*,type"] {
+ if {[string equal $presA($key) "available"]} {
+ return 1
+ }
+ }
+ return 0
+ }
+}
+
+proc jlib::roster::isavailable2 {jlibname jid} {
+
+ upvar ${jlibname}::roster::presA2 presA2
+
+ Debug 2 "roster::isavailable jid='$jid'"
+
+ set jid [jlib::jidmap $jid]
+
+ # If any resource in jid, we get it here.
+ jlib::splitjid $jid jid2 resource
+
+ if {[string length $resource] > 0} {
+ if {[info exists presA($jid2/$resource,type)]} {
+ if {[string equal $presA($jid2/$resource,type) "available"]} {
+ return 1
+ } else {
+ return 0
+ }
+ } else {
+ return 0
+ }
+ } else {
+
+ # Be sure to allow for 'user@domain' with empty resource.
+ foreach key [array names presA "[jlib::ESC $jid2]*,type"] {
+ if {[string equal $presA($key) "available"]} {
+ return 1
+ }
+ }
+ return 0
+ }
+}
+
+# jlib::roster::wasavailable --
+#
+# As 'isavailable' but for any "old" former presence state.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: either 'username$hostname', or 'username$hostname/resource'.
+#
+# Results:
+# 0/1.
+
+proc jlib::roster::wasavailable {jlibname jid} {
+
+ upvar ${jlibname}::roster::oldpresA oldpresA
+
+ Debug 2 "roster::wasavailable jid='$jid'"
+
+ set jid [jlib::jidmap $jid]
+
+ # If any resource in jid, we get it here.
+ jlib::splitjid $jid jid2 resource
+
+ if {[string length $resource] > 0} {
+ if {[info exists oldpresA($jid2/$resource,type)]} {
+ if {[string equal $oldpresA($jid2/$resource,type) "available"]} {
+ return 1
+ } else {
+ return 0
+ }
+ } else {
+ return 0
+ }
+ } else {
+
+ # Be sure to allow for 'user@domain' with empty resource.
+ foreach key [array names oldpresA "[jlib::ESC $jid2]*,type"] {
+ if {[string equal $oldpresA($key) "available"]} {
+ return 1
+ }
+ }
+ return 0
+ }
+}
+
+# jlib::roster::anychange --
+#
+# Returns boolean telling us if any presence attributes as listed
+# in 'nameList' has changed.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: the JID as reported in presence
+# nameList: type | status | priority | show, D=type
+#
+# Results:
+# 0/1.
+
+proc jlib::roster::anychange {jlibname jid {nameList type}} {
+
+ upvar ${jlibname}::roster::presA presA
+ upvar ${jlibname}::roster::oldpresA oldpresA
+
+ set jid [jlib::jidmap $jid]
+
+ foreach name $nameList {
+ set have1 [info exists presA($jid,$name)]
+ set have2 [info exists oldpresA($jid,$name)]
+ if {$have1 && $have2} {
+ if {$presA($jid,$name) ne $oldpresA($jid,$name)} {
+ return 1
+ }
+ } elseif {($have1 && !$have2) || (!$have1 && $have2)} {
+ return 1
+ }
+ }
+ return 0
+}
+
+# jlib::roster::gettype --
+#
+# Returns "available" or "unavailable".
+
+proc jlib::roster::gettype {jlibname jid} {
+
+ upvar ${jlibname}::roster::presA presA
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists presA($jid,type)]} {
+ return $presA($jid,type)
+ } else {
+ return "unavailable"
+ }
+}
+
+proc jlib::roster::getshow {jlibname jid} {
+
+ upvar ${jlibname}::roster::presA presA
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists presA($jid,show)]} {
+ return $presA($jid,show)
+ } else {
+ return ""
+ }
+}
+proc jlib::roster::getstatus {jlibname jid} {
+
+ upvar ${jlibname}::roster::presA presA
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists presA($jid,status)]} {
+ return $presA($jid,status)
+ } else {
+ return ""
+ }
+}
+
+# jlib::roster::getx --
+#
+# Returns the xml list for this jid's x element with given xml namespace.
+# Returns empty if no matching info.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: any jid
+# xmlns: the (mandatory) xmlns specifier. Any prefix
+# http://jabber.org/protocol/ must be stripped off.
+# @@@ BAD!!!!
+#
+# Results:
+# xml list or empty.
+
+proc jlib::roster::getx {jlibname jid xmlns} {
+
+ upvar ${jlibname}::roster::presA presA
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists presA($jid,x,$xmlns)]} {
+ return $presA($jid,x,$xmlns)
+ } else {
+ return
+ }
+}
+
+# jlib::roster::getextras --
+#
+# Returns the xml list for this jid's extras element with given xml namespace.
+# Returns empty if no matching info.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: any jid
+# xmlns: the (mandatory) full xmlns specifier.
+#
+# Results:
+# xml list or empty.
+
+proc jlib::roster::getextras {jlibname jid xmlns} {
+
+ upvar ${jlibname}::roster::presA presA
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists presA($jid,extras,$xmlns)]} {
+ return $presA($jid,extras,$xmlns)
+ } else {
+ return
+ }
+}
+
+# jlib::roster::getcapsattr --
+#
+# Access function for the <c/> caps elements attributes:
+#
+# <presence>
+# <c
+# xmlns='http://jabber.org/protocol/caps'
+# node='http://coccinella.sourceforge.net/protocol/caps'
+# ver='0.95.2'
+# ext='ftrans voip_h323 voip_sip'/>
+# </presence>
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: any jid
+# attrname:
+#
+# Results:
+# the value of the attribute or empty
+
+proc jlib::roster::getcapsattr {jlibname jid attrname} {
+
+ upvar jlib::jxmlns jxmlns
+ upvar ${jlibname}::roster::presA presA
+
+ set attr ""
+ set jid [jlib::jidmap $jid]
+ set xmlnscaps $jxmlns(caps)
+ if {[info exists presA($jid,extras,$xmlnscaps)]} {
+ set cElem $presA($jid,extras,$xmlnscaps)
+ set attr [wrapper::getattribute $cElem $attrname]
+ }
+ return $attr
+}
+
+proc jlib::roster::havecaps {jlibname jid} {
+
+ upvar jlib::jxmlns jxmlns
+ upvar ${jlibname}::roster::presA presA
+
+ set xmlnscaps $jxmlns(caps)
+ return [info exists presA($jid,extras,$xmlnscaps)]
+}
+
+# jlib::roster::availablesince --
+#
+# Not sure exactly how delay elements are updated when new status set.
+
+proc jlib::roster::availablesince {jlibname jid} {
+
+ upvar ${jlibname}::roster::presA presA
+ upvar ${jlibname}::roster::state state
+
+ set jid [jlib::jidmap $jid]
+ set xmlns "jabber:x:delay"
+ if {[info exists presA($jid,x,$xmlns)]} {
+
+ # An ISO 8601 point-in-time specification. clock works!
+ set stamp [wrapper::getattribute $presA($jid,x,$xmlns) stamp]
+ set time [clock scan $stamp -gmt 1]
+ } elseif {[info exists state($jid,secs)]} {
+ set time $state($jid,secs)
+ } else {
+ set time ""
+ }
+ return $time
+}
+
+proc jlib::roster::getpresencesecs {jlibname jid} {
+
+ upvar ${jlibname}::roster::state state
+
+ set jid [jlib::jidmap $jid]
+ if {[info exists state($jid,secs)]} {
+ return $state($jid,secs)
+ } else {
+ return ""
+ }
+}
+
+proc jlib::roster::Debug {num str} {
+ variable rostGlobals
+ if {$num <= $rostGlobals(debug)} {
+ puts "===========$str"
+ }
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::roster {
+
+ jlib::ensamble_register roster \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# saslmd5.tcl --
+#
+# This package provides a rudimentary implementation of the client side
+# SASL authentication method using the DIGEST-MD5 mechanism.
+# SASL [RFC 2222]
+# DIGEST-MD5 [RFC 2831]
+# ANONYMOUS []
+#
+# It also includes the PLAIN mechanism, so saslmd5 is a misnomer.
+#
+# Copyright (c) 2004 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: saslmd5.tcl,v 1.13 2008/02/19 07:30:38 matben Exp $
+
+package require base64
+package require md5 2.0
+
+package provide saslmd5 1.0
+
+
+namespace eval saslmd5 {
+
+ # These are in order of preference.
+ variable mechanisms [list "DIGEST-MD5" "PLAIN"]
+ # @@@ Enable this when testing. Not production code!
+ #variable mechanisms [list "DIGEST-MD5" "PLAIN" "ANONYMOUS"]
+ variable needed {username authzid pass realm}
+ variable uid 0
+
+}
+
+# "static" methods.
+
+proc saslmd5::mechanisms {} {
+ variable mechanisms
+ return $mechanisms
+}
+
+proc saslmd5::info {args} {
+
+ # empty
+ return {}
+}
+
+proc saslmd5::client_init {args} {
+
+ # empty
+}
+
+proc saslmd5::decode64 {str} {
+ return [::base64::decode $str]
+}
+
+proc saslmd5::encode64 {str} {
+
+ # important! no whitespace allowed in response!
+ return [string map [list "\n" ""] [::base64::encode $str]]
+}
+
+# saslmd5::client_new --
+#
+# Create a new instance for a session.
+#
+# Arguments:
+# args -callbacks {{id proc} ...} with id any of
+# {username authzid pass realm}
+# note that everyone must be utf-8 encoded!
+# -service name of service (xmpp)
+# -serverFQDN servers fully qualified domain name
+# -flags not used
+#
+# Results:
+# token.
+
+proc saslmd5::client_new {args} {
+ variable uid
+
+ #puts "saslmd5::client_new"
+ set token [namespace current]::[incr uid]
+ variable $token
+ upvar 0 $token state
+
+ set state(step) 0
+ set state(service) ""
+ set state(serverFQDN) ""
+ set state(flags) {}
+
+ foreach {key value} $args {
+ switch -- $key {
+ -callbacks {
+ set_callbacks $token $value
+ }
+ -service - -serverFQDN - -flags {
+ set state([string trimleft $key -]) $value
+ }
+ default {
+ return -code error "unrocognized option \"$key\""
+ }
+ }
+ }
+
+ proc $token {cmd args} \
+ "eval [namespace current]::cmdproc {$token} \$cmd \$args"
+
+ return $token
+}
+
+proc saslmd5::cmdproc {token cmd args} {
+
+ # Which command? Just dispatch the command to the right procedure.
+ return [eval {method_$cmd $token} $args]
+}
+
+# class methods.
+
+# saslmd5::method_start --
+#
+# Starts negotiating.
+#
+# Arguments:
+# token
+# args -mechanisms {list of mechanisms}
+#
+# Results:
+# {returnCode list-or-error}.
+
+proc saslmd5::method_start {token args} {
+ variable $token
+ upvar 0 $token state
+ variable mechanisms
+
+ #puts "saslmd5::method_start $args"
+ set state(step) 0
+
+ foreach {key value} $args {
+ switch -- $key {
+ -mechanisms {
+ set state(inmechanisms) $value
+ }
+ default {
+ # empty
+ }
+ }
+ }
+ if {![::info exists state(inmechanisms)]} {
+ return [list 1 "missing a \"-mechanisms\" option"]
+ }
+
+ # we must have at least on of the servers announced mechanisms
+ set match 0
+ foreach m $mechanisms {
+ if {[set idx [lsearch -exact $state(inmechanisms) $m]] >= 0} {
+ set match 1
+ set mechanism [lindex $state(inmechanisms) $idx]
+ break
+ }
+ }
+ if {!$match} {
+ return [list 1 "the servers mechanisms \"$state(inmechanisms)\"\
+ do not match any of the supported mechanisms \"$mechanisms\""]
+ }
+ set state(step) 1
+
+ switch -- $mechanism {
+ PLAIN {
+ set output [get_plain_output $token]
+ }
+ DIGEST-MD5 {
+ set output ""
+ }
+ ANONYMOUS {
+ set output [get_anonymous_output $token]
+ }
+ }
+
+ # continue
+ return [list 4 [list mechanism $mechanism output $output]]
+}
+
+proc saslmd5::get_plain_output {token} {
+ variable $token
+ upvar 0 $token state
+
+ # SENT: <auth
+ # xmlns="urn:ietf:params:xml:ns:xmpp-sasl"
+ # mechanism="PLAIN">
+ # somelongstring
+ # </auth>
+ # where somelongstring is (from Pandion's .js src):
+ # /* Plaintext algorithm:
+ # * Base64( UTF8( Addr ) + 0x00 + UTF8( User ) + 0x00 + UTF8( Pass ) )
+ # */
+ # User is the username, Addr is the full JID, and Pass is the password.
+
+ request_userpars $token
+
+ set username $state(upar,username)
+ set pass $state(upar,pass)
+ set realm $state(upar,realm)
+
+ set user_lat1 [encoding convertto iso8859-1 $username]
+ set pass_lat1 [encoding convertto iso8859-1 $pass]
+ set realm_lat1 [encoding convertto iso8859-1 $realm]
+
+ set jid [jlib::joinjid $user_lat1 $realm_lat1 ""]
+ return [binary format a*xa*xa* $jid $user_lat1 $pass_lat1]
+}
+
+proc saslmd5::get_anonymous_output {token} {
+
+ # @@@ Is this correct???
+ return [jlib::generateuuid]
+}
+
+# saslmd5::method_step --
+#
+# Takes one step when negotiating.
+#
+# Arguments:
+# token
+# args -input challenge
+#
+# Results:
+# {returnCode list-or-error}.
+
+proc saslmd5::method_step {token args} {
+ variable $token
+ upvar 0 $token state
+
+ #puts "saslmd5::method_step $token, $args"
+ foreach {key value} $args {
+ switch -- $key {
+ -input {
+ set challenge $value
+ }
+ }
+ }
+ if {![::info exists challenge]} {
+ return [list 1 "must have -input challenge string"]
+ }
+
+ if {$state(step) == 0} {
+ return [list 1 "need to call the 'start' procedure first"]
+ } elseif {$state(step) == 1} {
+ if {![iscapable $token]} {
+ return [list 1 "missing one or more callbacks"]
+ }
+ array set challarr [parse_challenge $challenge]
+ if {![::info exists challarr(nonce)]} {
+ return [list 1 "challenge missing 'nonce' attribute"]
+ }
+ if {![::info exists challarr(algorithm)]} {
+ return [list 1 "challenge missing 'algorithm' attribute"]
+ }
+ request_userpars $token
+ set output [process_challenge $token [array get challarr]]
+ incr state(step)
+
+ # continue
+ set code 4
+ } else {
+ incr state(step)
+
+ # success
+ set output ""
+ set code 0
+ }
+ return [list $code $output]
+}
+
+proc saslmd5::method_setprop {token property value} {
+ variable $token
+ upvar 0 $token state
+
+ # empty
+}
+
+proc saslmd5::method_getprop {token property} {
+ variable $token
+ upvar 0 $token state
+
+ # empty
+ return
+}
+
+proc saslmd5::method_info {args} {
+
+ # empty
+ return {}
+}
+
+proc saslmd5::set_callbacks {token cblist} {
+ variable $token
+ upvar 0 $token state
+
+ # some of tclsasl's id's are different from the spec's!
+ # note that everyone must be utf-8 encoded!
+ foreach cbpair $cblist {
+ foreach {id cbproc} $cbpair {
+ set state(cb,$id) $cbproc
+ }
+ }
+}
+
+proc saslmd5::iscapable {token} {
+ variable $token
+ upvar 0 $token state
+ variable needed
+
+ set capable 1
+ foreach id $needed {
+ if {[::info exists state(cb,$id)] && ($state(cb,$id) != {})} {
+ # empty
+ } else {
+ set capable 0
+ break
+ }
+ }
+ return $capable
+}
+
+# saslmd5::request_userpars --
+#
+# Invokes the needed callbacks to get user's parameters.
+
+proc saslmd5::request_userpars {token} {
+ variable $token
+ upvar 0 $token state
+ variable needed
+
+ foreach id $needed {
+ if {[::info exists state(cb,$id)] && ($state(cb,$id) != {})} {
+ set plist [list id $id]
+ set state(upar,$id) [uplevel #0 $state(cb,$id) [list $plist]]
+ } else {
+ return -code error "missing one or more callbacks"
+ }
+ }
+}
+
+# saslmd5::process_challenge --
+#
+# Computes an output from a challenge using user's parameters.
+#
+# Arguments:
+# token
+# challenge
+#
+# Results:
+# the output string as clear text.
+
+proc saslmd5::process_challenge {token challenge} {
+ variable $token
+ upvar 0 $token state
+
+ array set charr $challenge
+
+ # users parameters
+ set username $state(upar,username)
+ set authzid $state(upar,authzid)
+ set pass $state(upar,pass)
+ set realm $state(upar,realm)
+
+ set host $state(serverFQDN)
+ set service $state(service)
+
+ # make a 'cnonce'
+ set bytes ""
+ for {set n 0} {$n < 32} {incr n} {
+ set r [expr {int(256*rand())}]
+ append bytes [binary format c $r]
+ }
+ set cnonce [encode64 $bytes]
+
+ # other
+ set realm $host
+ set nonce $charr(nonce)
+ set nc "00000001"
+ set diguri $service/$host
+ set qop "auth"
+
+ # build 'response' (2.1.2.1 Response-value in RFC 2831)
+ # try to be a bit general here (from Cyrus SASL)
+ #
+ # encoding is a bit unclear.
+ # from RFC 2831:
+ # If "charset=UTF-8" is present, and all the characters of either
+ # "username-value" or "passwd" are in the ISO 8859-1 character set,
+ # then it must be converted to ISO 8859-1 before being hashed.
+ #
+ # from Cyrus SASL:
+ # if the string is entirely in the 8859-1 subset of UTF-8, then translate
+ # to 8859-1 prior to MD5
+
+ set user_lat1 [encoding convertto iso8859-1 $username]
+ set realm_lat1 [encoding convertto iso8859-1 $realm]
+ set pass_lat1 [encoding convertto iso8859-1 $pass]
+ set secret ${user_lat1}:${realm_lat1}:${pass_lat1}
+ set secretmd5 [::md5::md5 $secret]
+ set A1 ${secretmd5}:${nonce}:${cnonce}
+ if {$authzid ne ""} {
+ append A1 :${authzid}
+ }
+ set A2 AUTHENTICATE:${diguri}
+ if {$qop ne "auth"} {
+ append A2 ":00000000000000000000000000000000"
+ }
+ set HA1 [string tolower [::md5::md5 -hex $A1]]
+ set HA2 [string tolower [::md5::md5 -hex $A2]]
+ set KD ${HA1}:${nonce}
+ if {$qop ne ""} {
+ append KD :${nc}:${cnonce}:${qop}:${HA2}
+ }
+ set response [string tolower [::md5::md5 -hex $KD]]
+
+ # build output
+ set output ""
+ append output "username=\"$username\""
+ append output ",realm=\"$realm\""
+ append output ",nonce=\"$nonce\""
+ append output ",cnonce=\"$cnonce\""
+ append output ",nc=\"$nc\""
+ append output ",serv-type=\"$service\""
+ append output ",host=\"$host\""
+ append output ",digest-uri=\"$diguri\""
+ append output ",qop=\"$qop\""
+ append output ",response=\"$response\""
+ append output ",charset=\"utf-8\""
+ if {$authzid ne ""} {
+ append output ",authzid=\"$authzid\""
+ }
+ return $output
+}
+
+# saslmd5::parse_challenge --
+#
+# Parses a clear text challenge string into a challenge list.
+
+proc saslmd5::parse_challenge {str} {
+ # RFC 2831 2.1
+ # Char categories as per spec...
+ # Build up a regexp for splitting the challenge into key value pairs.
+
+ set sep "\\\]\\\[\\\\()<>@,;:\\\"\\\?=\\\{\\\} \t"
+ set tok {0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\-\|\~\!\#\$\%\&\*\+\.\^\_\`}
+ set sqot {(?:\'(?:\\.|[^\'\\])*\')}
+ set dqot {(?:\"(?:\\.|[^\"\\])*\")}
+ set parameters {}
+ regsub -all "(\[${tok}\]+)=(${dqot}|(?:\[${tok}\]+))(?:\[${sep}\]+|$)" \
+ $str {\1 \2 } parameters
+ return $parameters
+}
+
+# RFC 2831 2.1
+# Char categories as per spec...
+# Build up a regexp for splitting the challenge into key value pairs.
+
+proc saslmd5::parse_challengePT {str} {
+ puts "str=$str"
+
+ set sep "\\\]\\\[\\\\()<>@,;:\\\"\\\?= \\\{\\\} \t"
+ set tok {0123456789ABCDEFGHIJKLMNOPQRS TUVWXYZabcdefghijklmnopqrstuvw xyz\-\|\~\!\#\$\%\&\*\+\.\^\_\ `}
+ set sqot {(?:\'(?:\\.|[^\'\\])*\')}
+ set dqot {(?:\"(?:\\.|[^\"\\])*\")}
+ set parameters {}
+ regsub -all "(\[${tok}\]+)=(${dqot}|(?:\[$ {tok}\]+))(?:\[${sep}\]+|$)" \
+ $str {\1 \2 } parameters
+ puts "parameters=$parameters"
+ return $parameters
+}
+
+# Fails when quotes are missing:
+# str=nonce="1142339597",qop="auth",charset=utf-8,algorithm=md5-sess
+# parameters=nonce "1142339597" qop "auth" charset=utf-8,algorithm=md5-sess
+
+proc saslmd5::free {token} {
+ variable $token
+ upvar 0 $token state
+
+ unset -nocomplain state
+}
+
--- /dev/null
+
+README-scripts
+--------------
+
+This folder is supposed to contain high level scripts using jabberlib to
+perform various actions normally implemented at application level, such as:
+
+ o register account
+ o remove account
+ o send message
+
--- /dev/null
+# message.tcl --
+#
+# Simple script that uses jabberlib to send a message.
+#
+# Copyright (c) 2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: message.tcl,v 1.2 2007/08/06 07:49:54 matben Exp $
+
+package require jlib
+package require jlib::connect
+
+package provide jlibs::message 0.1
+
+namespace eval jlibs::message {
+
+ variable sendOpts {-subject -thread -body -type -xlist}
+}
+
+interp alias {} jlibs::message {} jlibs::message::message
+
+# jlibs::message --
+#
+# Make a complete new session and send a message.
+# The options are passed on to 'connect' except:
+#
+
+proc jlibs::message::message {jid password to cmd args} {
+ variable sendOpts
+
+ set jlib [jlib::new [namespace code noop]]
+
+ variable $jlib
+ upvar 0 $jlib state
+
+ set state(jid) $jid
+ set state(password) $password
+ set state(to) $to
+ set state(cmd) $cmd
+ set state(args) $args
+ set state(jlib) $jlib
+
+ jlib::util::from args -command
+ jlib::util::from args -noauth
+
+ # Extract the message options.
+ foreach name $sendOpts {
+ set state($name) [jlib::util::from args $name]
+ }
+ eval {$jlib connect connect $jid $password \
+ -command [namespace code cmdC]} $args
+ return $jlib
+}
+
+proc jlibs::message::cmdC {jlib status {errcode ""} {errmsg ""}} {
+ variable sendOpts
+ variable $jlib
+ upvar 0 $jlib state
+
+ if {![info exists state]} {
+ return
+ }
+ if {$status eq "ok"} {
+ set opts [list]
+ foreach name $sendOpts {
+ if {$state($name) ne ""} {
+ lappend opts $name $state($name)
+ }
+ }
+ eval {$jlib send_message $state(to)} $opts
+ finish $jlib
+ } elseif {$status eq "error"} {
+ finish $jlib $errcode
+ }
+}
+
+proc jlibs::message::reset {jlib} {
+ finish $jlib reset
+}
+
+proc jlibs::message::finish {jlib {err ""}} {
+ variable $jlib
+ upvar 0 $jlib state
+
+ $jlib closestream
+
+ if {$err ne ""} {
+ uplevel #0 $state(cmd) [list $jlib error $err]
+ } else {
+ uplevel #0 $state(cmd) [list $jlib ok]
+ }
+ unset -nocomplain state
+}
+
+proc jlibs::message::noop {args} {}
+
+if {0} {
+ # Test:
+ proc cmd {args} {puts "---> $args"}
+ jlibs::message xyz@localhost xxx matben@localhost cmd -body Hej -subject Hej
+}
+
+
--- /dev/null
+# password.tcl --
+#
+# Simple script that uses jabberlib to change password.
+#
+# Copyright (c) 2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: password.tcl,v 1.1 2007/08/07 07:51:27 matben Exp $
+
+package require jlib
+package require jlib::connect
+
+package provide jlibs::password 0.1
+
+namespace eval jlibs::password {}
+
+interp alias {} jlibs::password {} jlibs::password::password
+
+# jlibs::password --
+#
+# Make a complete new session and change password.
+# The options are passed on to 'connect' except:
+#
+
+proc jlibs::password::password {jid password newpassword cmd args} {
+
+ set jlib [jlib::new [namespace code noop]]
+
+ variable $jlib
+ upvar 0 $jlib state
+
+ set state(jid) $jid
+ set state(password) $password
+ set state(newpassword) $newpassword
+ set state(cmd) $cmd
+ set state(args) $args
+ set state(jlib) $jlib
+
+ jlib::util::from args -command
+ jlib::util::from args -noauth
+
+ eval {$jlib connect connect $jid $password \
+ -command [namespace code cmdC]} $args
+ return $jlib
+}
+
+proc jlibs::password::cmdC {jlib status {errcode ""} {errmsg ""}} {
+ variable sendOpts
+ variable $jlib
+ upvar 0 $jlib state
+
+ if {![info exists state]} {
+ return
+ }
+ if {$status eq "ok"} {
+ jlib::splitjidex $state(jid) node server -
+ $jlib register_set $node $state(password) [namespace code cmdS] \
+ -to $server
+ } elseif {$status eq "error"} {
+ finish $jlib $errcode
+ }
+}
+
+proc jlibs::password::cmdS {jlib type iqchild args} {
+ variable $jlib
+ upvar 0 $jlib state
+
+ if {![info exists state]} {
+ return
+ }
+ if {$type eq "result"} {
+ finish $jlib
+ } else {
+ finish $jlib $iqchild
+ }
+}
+
+proc jlibs::password::reset {jlib} {
+ finish $jlib reset
+}
+
+proc jlibs::password::finish {jlib {err ""}} {
+ variable $jlib
+ upvar 0 $jlib state
+
+ $jlib closestream
+
+ if {$err ne ""} {
+ uplevel #0 $state(cmd) [list $jlib error $err]
+ } else {
+ uplevel #0 $state(cmd) [list $jlib ok]
+ }
+ unset -nocomplain state
+}
+
+proc jlibs::password::noop {args} {}
+
+if {0} {
+ # Test:
+ proc cmd {args} {puts "---> $args"}
+ jlibs::password xyz@localhost xxx yyy cmd
+}
+
+
--- /dev/null
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded jlibs::register 0.1 [list source [file join $dir register.tcl]]
+package ifneeded jlibs::unregister 0.1 [list source [file join $dir unregister.tcl]]
+package ifneeded jlibs::message 0.1 [list source [file join $dir message.tcl]]
--- /dev/null
+# register.tcl --
+#
+# Simple script that uses jabberlib to register an account.
+#
+# Copyright (c) 2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: register.tcl,v 1.4 2007/08/07 07:50:25 matben Exp $
+
+package require jlib
+package require jlib::connect
+
+package provide jlibs::register 0.1
+
+namespace eval jlibs::register {}
+
+interp alias {} jlibs::register {} jlibs::register::register
+
+# jlibs::register --
+#
+# Make a complete new session and register an account.
+# The options are passed on to 'connect'.
+
+proc jlibs::register::register {jid password cmd args} {
+
+ set jlib [jlib::new [namespace code noop]]
+
+ variable $jlib
+ upvar 0 $jlib state
+
+ set state(jid) $jid
+ set state(password) $password
+ set state(cmd) $cmd
+ set state(args) $args
+ set state(jlib) $jlib
+
+ jlib::util::from args -command
+ jlib::util::from args -noauth
+ jlib::splitjidex $jid node server -
+
+ eval {$jlib connect connect $server {} \
+ -noauth 1 -command [namespace code cmdC]} $args
+ return $jlib
+}
+
+proc jlibs::register::cmdC {jlib status {errcode ""} {errmsg ""}} {
+ variable $jlib
+ upvar 0 $jlib state
+
+ if {![info exists state]} {
+ return
+ }
+ if {$status eq "ok"} {
+ $jlib register_get [namespace code cmdG]
+ } elseif {$status eq "error"} {
+ finish $jlib $errcode
+ }
+}
+
+proc jlibs::register::cmdG {jlib type iqchild} {
+ variable $jlib
+ upvar 0 $jlib state
+
+ if {![info exists state]} {
+ return
+ }
+ if {$type eq "result"} {
+ jlib::splitjidex $state(jid) node server -
+
+ # Assuming minimal registration fields.
+ $jlib register_set $node $state(password) [namespace code cmdS]
+ } else {
+ finish $jlib $iqchild
+ }
+}
+
+proc jlibs::register::cmdS {jlib type iqchild args} {
+ variable $jlib
+ upvar 0 $jlib state
+
+ if {![info exists state]} {
+ return
+ }
+ if {$type eq "result"} {
+ finish $jlib
+ } else {
+ finish $jlib $iqchild
+ }
+}
+
+proc jlibs::register::reset {jlib} {
+ finish $jlib reset
+}
+
+proc jlibs::register::finish {jlib {err ""}} {
+ variable $jlib
+ upvar 0 $jlib state
+
+ $jlib closestream
+
+ if {$err ne ""} {
+ uplevel #0 $state(cmd) [list $jlib error $err]
+ } else {
+ uplevel #0 $state(cmd) [list $jlib ok]
+ }
+ unset -nocomplain state
+}
+
+proc jlibs::register::noop {args} {}
+
+if {0} {
+ # Test:
+ proc cmd {args} {puts "---> $args"}
+ jlibs::register xyz@localhost xxx cmd
+}
+
+
--- /dev/null
+# unregister.tcl --
+#
+# Simple script that uses jabberlib to unregister an account.
+#
+# Copyright (c) 2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: unregister.tcl,v 1.3 2007/08/06 07:49:54 matben Exp $
+
+package require jlib
+package require jlib::connect
+
+package provide jlibs::unregister 0.1
+
+namespace eval jlibs::unregister {}
+
+interp alias {} jlibs::unregister {} jlibs::unregister::unregister
+
+# jlibs::unregister --
+#
+# Make a complete new session and unregister an account.
+# The options are passed on to 'connect'.
+
+proc jlibs::unregister::unregister {jid password cmd args} {
+
+ #puts "jlibs::unregister::unregister"
+ set jlib [jlib::new [namespace code noop]]
+
+ variable $jlib
+ upvar 0 $jlib state
+
+ set state(jid) $jid
+ set state(password) $password
+ set state(cmd) $cmd
+ set state(args) $args
+ set state(jlib) $jlib
+
+ jlib::util::from args -command
+ jlib::util::from args -noauth
+
+ eval {$jlib connect connect $jid $password \
+ -command [namespace code cmdC]} $args
+ return $jlib
+}
+
+proc jlibs::unregister::cmdC {jlib status {errcode ""} {errmsg ""}} {
+ variable $jlib
+ upvar 0 $jlib state
+
+ if {![info exists state]} {
+ return
+ }
+ if {$status eq "ok"} {
+ jlib::splitjidex $state(jid) node server -
+ $jlib register_remove $server [namespace code cmdR]
+ } elseif {$status eq "error"} {
+ finish $jlib $errcode
+ }
+}
+
+proc jlibs::unregister::cmdR {jlib type subiq} {
+
+ if {$type eq "result"} {
+ finish $jlib
+ } else {
+ finish $jlib $subiq
+ }
+}
+
+proc jlibs::unregister::reset {jlib} {
+ finish $jlib reset
+}
+
+proc jlibs::unregister::finish {jlib {err ""}} {
+ variable $jlib
+ upvar 0 $jlib state
+
+ #puts "jlibs::unregister::finish"
+ $jlib closestream
+
+ if {$err ne ""} {
+ uplevel #0 $state(cmd) [list $jlib error $err]
+ } else {
+ uplevel #0 $state(cmd) [list $jlib ok]
+ }
+ unset -nocomplain state
+}
+
+proc jlibs::unregister::noop {args} {}
+
+if {0} {
+ # Test:
+ proc cmd {args} {puts "---> $args"}
+ jlibs::unregister xyz@localhost xxx cmd
+}
+
+
--- /dev/null
+# service.tcl --
+#
+# This is an abstraction layer for groupchat protocols gc-1.0/muc.
+# All except disco/muc are EOL!
+#
+# Copyright (c) 2004-2006 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: service.tcl,v 1.27 2008/02/06 13:57:25 matben Exp $
+#
+############################# USAGE ############################################
+#
+# NAME
+# service - protocol independent methods for groupchats/muc
+#
+# SYNOPSIS
+# jlib::service::init jlibName
+#
+# INSTANCE COMMANDS
+# jlibName service allroomsin
+# jlibName service exitroom room
+# jlibName service isroom jid
+# jlibName service nick jid
+# jlibName service register type name
+# jlibName service roomparticipants room
+# jlibName service setroomprotocol jid protocol
+# jlibName service unregister type name
+#
+#
+# VARIABLES
+#
+# serv:
+# serv(gcProtoPriority) : The groupchat protocol priority list.
+#
+# serv(gcprot,$jid) : Map a groupchat service jid to protocol:
+# (gc-1.0|muc)
+#
+# serv(prefgcprot,$jid) : Stores preferred groupchat protocol that
+# overrides the priority list.
+#
+############################# CHANGES ##########################################
+#
+# 0.1 first version
+
+package provide service 1.0
+
+namespace eval ::jlib {}
+
+namespace eval jlib::service {
+
+ # This is an abstraction layer for the groupchat protocols gc-1.0/muc.
+
+ # Cache the following services in particular.
+ variable services {search register groupchat conference muc}
+
+ # Maintain a priority list of groupchat protocols in decreasing priority.
+ # Entries must match: ( gc-1.0 | muc )
+ variable groupchatTypeExp {(gc-1.0|muc)}
+}
+
+proc jlib::service {jlibname cmd args} {
+ set ans [eval {[namespace current]::service::${cmd} $jlibname} $args]
+ return $ans
+}
+
+proc jlib::service::init {jlibname} {
+
+ upvar ${jlibname}::serv serv
+
+ # Init defaults.
+ array set serv {
+ disco 0
+ muc 0
+ }
+
+ # Maintain a priority list of groupchat protocols in decreasing priority.
+ # Entries must match: ( gc-1.0 | muc )
+ set serv(gcProtoPriority) {muc gc-1.0}
+}
+
+# jlib::service::register --
+#
+# Let components (browse/disco/muc etc.) register that their services
+# are available.
+
+proc jlib::service::register {jlibname type name} {
+ upvar ${jlibname}::serv serv
+
+ set serv($type) 1
+ set serv($type,name) $name
+}
+
+proc jlib::service::unregister {jlibname type} {
+ upvar ${jlibname}::serv serv
+
+ set serv($type) 0
+ array unset serv $type,*
+}
+
+proc jlib::service::get {jlibname type} {
+ upvar ${jlibname}::serv serv
+
+ if {$serv($type)} {
+ return $serv($type,name)
+ } else {
+ return
+ }
+}
+
+#-------------------------------------------------------------------------------
+#
+# A couple of routines that handle the selection of groupchat protocol for
+# each groupchat service.
+# A groupchat service may support more than a single protocol. For instance,
+# the MUC component supports both gc-1.0 and MUC.
+
+# Needs some more verification before using it for a dispatcher.
+
+
+# jlib::service::registergcprotocol --
+#
+# Register (sets) a groupchat service jid according to the priorities
+# presently set. Only called internally!
+
+proc jlib::service::registergcprotocol {jlibname jid gcprot} {
+ upvar ${jlibname}::serv serv
+
+ Debug 2 "jlib::registergcprotocol jid=$jid, gcprot=$gcprot"
+ set jid [jlib::jidmap $jid]
+
+ # If we already told jlib to use a groupchat protocol then...
+ if {[info exist serv(prefgcprot,$jid)]} {
+ return
+ }
+
+ # Set 'serv(gcprot,$jid)' according to the priority list.
+ foreach prot $serv(gcProtoPriority) {
+
+ # Do we have registered a groupchat protocol with higher priority?
+ if {[info exists serv(gcprot,$jid)] && \
+ [string equal $serv(gcprot,$jid) $prot]} {
+ return
+ }
+ if {[string equal $prot $gcprot]} {
+ set serv(gcprot,$jid) $prot
+ return
+ }
+ }
+}
+
+# jlib::service::setroomprotocol --
+#
+# Set the groupchat protocol in use for room. This acts only as a
+# dispatcher for 'service' commands.
+# Only called internally when entering a room!
+
+proc jlib::service::setroomprotocol {jlibname roomjid protocol} {
+ variable groupchatTypeExp
+ upvar ${jlibname}::serv serv
+
+ set roomjid [jlib::jidmap $roomjid]
+ if {![regexp $groupchatTypeExp $protocol]} {
+ return -code error "Unrecognized groupchat protocol \"$protocol\""
+ }
+ set serv(roomprot,$roomjid) $protocol
+}
+
+# jlib::service::isroom --
+#
+# Try to figure out if the jid is a room.
+# If we've browsed it it's been registered in our browse object.
+# If using agent(s) method, check the agent for this jid
+
+proc jlib::service::isroom {jlibname jid} {
+ upvar ${jlibname}::serv serv
+ upvar ${jlibname}::locals locals
+
+ # Check if domain name supports the 'groupchat' service.
+ # disco uses explicit children of conference, and muc cache
+ set isroom 0
+ if {!$isroom && $serv(disco) && [$jlibname disco isdiscoed info $locals(server)]} {
+ set isroom [$jlibname disco isroom $jid]
+ }
+ if {!$isroom && $serv(muc)} {
+ set isroom [$jlibname muc isroom $jid]
+ }
+ if {!$isroom} {
+ set isroom [jlib::groupchat::isroom $jlibname $jid]
+ }
+ return $isroom
+}
+
+# jlib::service::nick --
+#
+# Return nick name for ANY room participant, or the rooms name
+# if jid is a room.
+# Not very useful since old 'conference' protocol has gone but keep
+# it as an abstraction anyway.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: 'roomname@conference.jabber.org/nick' typically,
+# or just room jid.
+
+proc jlib::service::nick {jlibname jid} {
+ return [jlib::resourcejid $jid]
+}
+
+# jlib::service::mynick --
+#
+# A way to get our OWN nickname for a given room independent of protocol.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# room: 'roomname@conference.jabber.org' typically.
+#
+# Results:
+# mynickname
+
+proc jlib::service::mynick {jlibname room} {
+ upvar ${jlibname}::serv serv
+
+ set room [jlib::jidmap $room]
+
+ # All kind of conference components seem to support the old 'gc-1.0'
+ # protocol, and we therefore must query our method for entering the room.
+ if {![info exists serv(roomprot,$room)]} {
+ return -code error "Does not know which protocol to use in $room"
+ }
+
+ switch -- $serv(roomprot,$room) {
+ gc-1.0 {
+ set nick [$jlibname groupchat mynick $room]
+ }
+ muc {
+ set nick [$jlibname muc mynick $room]
+ }
+ }
+ return $nick
+}
+
+# jlib::service::setnick --
+
+proc jlib::service::setnick {jlibname room nick args} {
+ upvar ${jlibname}::serv serv
+
+ set room [jlib::jidmap $room]
+ if {![info exists serv(roomprot,$room)]} {
+ return -code error "Does not know which protocol to use in $room"
+ }
+
+ switch -- $serv(roomprot,$room) {
+ gc-1.0 {
+ eval {$jlibname groupchat setnick $room $nick} $args
+ }
+ muc {
+ eval {$jlibname muc setnick $room $nick} $args
+ }
+ }
+}
+
+# jlib::service::allroomsin --
+#
+#
+
+proc jlib::service::allroomsin {jlibname} {
+ upvar ${jlibname}::lib lib
+ upvar ${jlibname}::gchat gchat
+ upvar ${jlibname}::serv serv
+
+ set roomList [concat $gchat(allroomsin) \
+ [[namespace parent]::muc::allroomsin $jlibname]]
+ if {$serv(muc)} {
+ set roomList [concat $roomList [$jlibname muc allroomsin]]
+ }
+ return [lsort -unique $roomList]
+}
+
+proc jlib::service::roomparticipants {jlibname room} {
+ upvar ${jlibname}::locals locals
+ upvar ${jlibname}::serv serv
+
+ set room [jlib::jidmap $room]
+ if {![info exists serv(roomprot,$room)]} {
+ return -code error "Does not know which protocol to use in $room"
+ }
+
+ set everyone {}
+ if {![[namespace current]::isroom $jlibname $room]} {
+ return -code error "The jid \"$room\" is not a room"
+ }
+
+ switch -- $serv(roomprot,$room) {
+ gc-1.0 {
+ set everyone [[namespace parent]::groupchat::participants $jlibname $room]
+ }
+ muc {
+ set everyone [$jlibname muc participants $room]
+ }
+ }
+ return $everyone
+}
+
+proc jlib::service::exitroom {jlibname room} {
+ upvar ${jlibname}::locals locals
+ upvar ${jlibname}::serv serv
+
+ set room [jlib::jidmap $room]
+ if {![info exists serv(roomprot,$room)]} {
+ #return -code error "Does not know which protocol to use in $room"
+ # Not sure here???
+ set serv(roomprot,$room) "gc-1.0"
+ }
+
+ switch -- $serv(roomprot,$room) {
+ gc-1.0 {
+ [namespace parent]::groupchat::exit $jlibname $room
+ }
+ muc {
+ $jlibname muc exit $room
+ }
+ }
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# si.tcl --
+#
+# This file is part of the jabberlib.
+# It provides support for the stream initiation protocol (XEP-0095).
+#
+# Copyright (c) 2005-2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: si.tcl,v 1.26 2007/11/30 14:38:34 matben Exp $
+#
+# There are several layers involved when sending/receiving a file for
+# instance. Each layer reports only to the nearest layer above using
+# callbacks. From top to bottom:
+#
+# 1) application
+# 2) profiles, file-transfer etc.
+# 3) stream initiation (si)
+# 4) the streams, bytestreams (socks5), ibb, etc.
+# 5) jabberlib
+#
+# Each layer divides into two parts, the initiator and target.
+# Keep different state arrays for initiator (i) and target (t).
+# The si layer acts as a mediator between the profiles and the streams.
+# Each profile registers with si, and each stream registers with si.
+#
+# profiles ...
+# \ | /
+# \ | /
+# \ | /
+# si (stream initiation)
+# / | \
+# / | \
+# / | \
+# streams ...
+#
+# INITIATOR: each transport (stream) registers for open, send & close
+# using 'registertransport'. The profiles call these indirectly
+# through si. The profile gets feedback from streams using direct
+# callbacks.
+#
+# TARGET: each profile (file-transfer) registers for open, read & close
+# using 'registerprofile'. The transports register for element
+# handlers for their specific protocol. When activated, the transport
+# calls si which in turn calls the profile using its registered
+# handlers.
+#
+# Initiator: Target:
+#
+# profiles | : : /|\ : :
+# | : : | : :
+# \|/ : : | : :
+# si ============= <--------> =============
+# : | : : /|\ :
+# : | : : | :
+# streams : \|/ : : | :
+# o .......................> o
+#
+#
+############################# USAGE ############################################
+#
+# NAME
+# si - convenience command library for stream initiation.
+#
+# SYNOPSIS
+#
+#
+# OPTIONS
+#
+#
+# INSTANCE COMMANDS
+# jlibName si registertransport ...
+# jlibName si registerprofile ...
+# jlibName si send_set ...
+# jlibName si send_data ...
+# jlibName si send_close ...
+# jlibName si getstate sid
+#
+################################################################################
+
+package require jlib
+package require jlib::disco
+
+package provide jlib::si 0.1
+
+#--- generic si ----------------------------------------------------------------
+
+namespace eval jlib::si {
+
+ variable xmlns
+ set xmlns(si) "http://jabber.org/protocol/si"
+ set xmlns(neg) "http://jabber.org/protocol/feature-neg"
+ set xmlns(xdata) "jabber:x:data"
+ set xmlns(streams) "urn:ietf:params:xml:ns:xmpp-streams"
+
+ # Storage for registered transports.
+ variable trpt
+ set trpt(list) [list]
+
+ jlib::disco::registerfeature $xmlns(si)
+
+ # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::si::registertransport --
+#
+# Register transports on the initiator (sender) side.
+# This is used by the streams that do the actual job.
+# Typically 'name' and 'ns' are xml namespaces and identical.
+
+proc jlib::si::registertransport {name ns priority openProc closeProc} {
+ variable trpt
+ #puts "jlib::si::registertransport (i)"
+
+ lappend trpt(list) [list $name $priority]
+ set trpt(list) [lsort -unique -index 1 $trpt(list)]
+ set trpt($name,ns) $ns
+ set trpt($name,open) $openProc
+ set trpt($name,close) $closeProc
+
+ # Keep these in sync.
+ set trpt(names) [list]
+ set trpt(streams) [list]
+ foreach spec $trpt(list) {
+ set nm [lindex $spec 0]
+ lappend trpt(names) $nm
+ lappend trpt(streams) $trpt($nm,ns)
+ }
+}
+
+# jlib::si::registerreader --
+#
+# This lives on the initiator side.
+# Each profile must register a reader which is then used by the streams
+# (transport) when writing data to the network.
+# The streams shall limit its control to the data handling alone,
+# and the major control is still with the profile.
+# In particular, any close operation is initiated by the profile.
+# This is merely a layer to dispatch reading actions from the stream
+# to the profile.
+# NB: We could do with only a 'read' proc but this is a cleaner interface.
+
+proc jlib::si::registerreader {profile openProc readProc closeProc} {
+ variable reader
+ #puts "jlib::si::registerreader"
+
+ set reader($profile,open) $openProc
+ set reader($profile,read) $readProc
+ set reader($profile,close) $closeProc
+}
+
+# jlib::si::registerprofile --
+#
+# This is used by profiles to register handler when receiving a si set
+# with the specified profile. It contains handlers for 'set', 'read',
+# and 'close' streams. These belong to the target side.
+
+proc jlib::si::registerprofile {profile openProc readProc closeProc} {
+ variable prof
+ #puts "jlib::si::registerprofile (t)"
+
+ set prof($profile,open) $openProc
+ set prof($profile,read) $readProc
+ set prof($profile,close) $closeProc
+}
+
+# jlib::si::init --
+#
+# Instance init procedure.
+
+proc jlib::si::init {jlibname args} {
+ variable xmlns
+ #puts "jlib::si::init"
+
+ # Keep different state arrays for initiator (i) and receiver (r).
+ namespace eval ${jlibname}::si {
+ variable istate
+ variable tstate
+ }
+ $jlibname iq_register set $xmlns(si) [namespace current]::handle_set
+ $jlibname iq_register get $xmlns(si) [namespace current]::handle_get
+}
+
+proc jlib::si::cmdproc {jlibname cmd args} {
+
+ #puts "jlib::si::cmdproc jlibname=$jlibname, cmd='$cmd', args='$args'"
+
+ # Which command? Just dispatch the command to the right procedure.
+ return [eval {$cmd $jlibname} $args]
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a initiator (sender).
+
+# jlib::si::send_set --
+#
+# Makes a stream initiation (open).
+# It will eventually, if negotiation went ok, invoke the stream
+# 'open' method.
+# The 'args' ar transparently delivered to the streams 'open' method.
+
+proc jlib::si::send_set {jlibname jid sid mime profile profileE cmd args} {
+
+ #puts "jlib::si::send_set (i)"
+
+ set siE [i_constructor $jlibname $sid $jid $mime $profile $profileE $cmd]
+ jlib::send_iq $jlibname set [list $siE] -to $jid \
+ -command [list [namespace current]::send_set_cb $jlibname $sid]
+ return
+}
+
+# jlib::si::i_constructor --
+#
+# Makes a new si instance. Does everything except delivering it.
+# Returns the si element.
+
+proc jlib::si::i_constructor {jlibname sid jid mime profile profileE cmd args} {
+ upvar ${jlibname}::si::istate istate
+
+ set istate($sid,jid) $jid
+ set istate($sid,mime) $mime
+ set istate($sid,profile) $profile
+ set istate($sid,openCmd) $cmd
+ set istate($sid,args) $args
+ foreach {key val} $args {
+ set istate($sid,$key) $val
+ }
+
+ return [element $sid $mime $profile $profileE]
+}
+
+# jlib::si::element --
+#
+# Just create the si element. Nothing cached. Stateless.
+
+proc jlib::si::element {sid mime profile profileE} {
+ variable xmlns
+ variable trpt
+
+ set optionEL [list]
+ foreach name $trpt(names) {
+ set valueE [wrapper::createtag "value" -chdata $trpt($name,ns)]
+ lappend optionEL [wrapper::createtag "option" -subtags [list $valueE]]
+ }
+ set fieldE [wrapper::createtag "field" \
+ -attrlist {var stream-method type list-single} -subtags $optionEL]
+ set xE [wrapper::createtag "x" \
+ -attrlist {xmlns jabber:x:data type form} -subtags [list $fieldE]]
+ set featureE [wrapper::createtag "feature" \
+ -attrlist [list xmlns $xmlns(neg)] -subtags [list $xE]]
+ set siE [wrapper::createtag "si" \
+ -attrlist [list xmlns $xmlns(si) id $sid mime-type $mime profile $profile] \
+ -subtags [list $profileE $featureE]]
+
+ return $siE
+}
+
+# jlib::si::send_set_cb --
+#
+# Our internal callback handler when offered stream initiation.
+
+proc jlib::si::send_set_cb {jlibname sid type iqChild args} {
+ variable xmlns
+ variable trpt
+ upvar ${jlibname}::si::istate istate
+
+ #puts "jlib::si::send_set_cb (i)"
+
+ if {[string equal $type "error"]} {
+ eval $istate($sid,openCmd) [list $jlibname $type $sid $iqChild]
+ ifree $jlibname $sid
+ return
+ }
+ eval {i_handler $jlibname $sid $iqChild} $args
+}
+
+# jlib::si::handle_get --
+#
+# This handles incoming iq-get/si elements. The 'sid' must already exist
+# since this belongs to the initiator side! We obtain this call as a
+# response to an si element sent. It should behave as 'send_set_cb'.
+
+proc jlib::si::handle_get {jlibname from iqChild args} {
+ upvar ${jlibname}::si::istate istate
+ #puts "jlib::si::handle_get (i)"
+
+ array set argsA $args
+ array set attr [wrapper::getattrlist $iqChild]
+ if {![info exists attr(id)]} {
+ return 0
+ }
+ set sid $attr(id)
+ if {![info exists argsA(-id)]} {
+ return 0
+ }
+ set id $argsA(-id)
+
+ # Verify that we have actually initiated this stream.
+ if {![info exists istate($sid,jid)]} {
+ jlib::send_iq_error $jlibname $from $id 403 cancel forbidden
+ return 1
+ }
+ eval {i_handler $jlibname $sid $iqChild} $args
+
+ # We must respond ourselves.
+ $jlibname send_iq result {} -to $from -id $id
+
+ return 1
+}
+
+# jlib::si::i_handler --
+#
+# Handles both responses to an iq-set call and an incoming iq-get.
+
+proc jlib::si::i_handler {jlibname sid iqChild args} {
+ variable xmlns
+ variable trpt
+ upvar ${jlibname}::si::istate istate
+ #puts "jlib::si::i_handler (i)"
+
+ # Verify that it is consistent.
+ if {![string equal [wrapper::gettag $iqChild] "si"]} {
+
+ # @@@ errors ?
+ eval $istate($sid,openCmd) [list $jlibname error $sid {}]
+ ifree $jlibname $sid
+ return
+ }
+
+ set value ""
+ set valueE [wrapper::getchilddeep $iqChild [list \
+ [list "feature" $xmlns(neg)] [list "x" $xmlns(xdata)] "field" "value"]]
+ if {[llength $valueE]} {
+ set value [wrapper::getcdata $valueE]
+ }
+
+ # Find if matching transport.
+ if {[lsearch -exact $trpt(streams) $value] >= 0} {
+
+ # Open transport.
+ # We provide a callback for the transport when open is finished.
+ set istate($sid,stream) $value
+ set jid $istate($sid,jid)
+ set cmd [namespace current]::transport_open_cb
+ eval $trpt($value,open) [list $jlibname $jid $sid] \
+ $istate($sid,args)
+ } else {
+ eval $istate($sid,openCmd) [list $jlibname error $sid {}]
+ ifree $jlibname $sid
+ }
+}
+
+# jlib::si::transport_open_cb --
+#
+# This is a transports way of reporting result from it's 'open' method.
+
+proc jlib::si::transport_open_cb {jlibname sid type iqChild} {
+ upvar ${jlibname}::si::istate istate
+ #puts "jlib::si::transport_open_cb (i)"
+
+ # Just report this to the relevant profile.
+ eval $istate($sid,openCmd) [list $jlibname $type $sid $iqChild]
+}
+
+# jlib::si::getstate --
+#
+# Just an access function to the internal state variables.
+
+proc jlib::si::getstate {jlibname sid} {
+ upvar ${jlibname}::si::istate istate
+
+ set arr [list]
+ foreach {key value} [array get istate $sid,*] {
+ set name [string map [list "$sid," ""] $key]
+ lappend arr $name $value
+ }
+ return $arr
+}
+
+# jlib::si::open_data, read_data, close_data --
+#
+# These are all used by the streams (transports) to handle the data
+# stream it needs when transmitting.
+# This is merely a layer to dispatch reading actions from the stream
+# to the profile.
+
+proc jlib::si::open_data {jlibname sid} {
+ variable reader
+ upvar ${jlibname}::si::istate istate
+ #puts "jlib::si::open_data (i)"
+
+ set profile $istate($sid,profile)
+ $reader($profile,open) $jlibname $sid
+}
+
+proc jlib::si::read_data {jlibname sid} {
+ variable reader
+ upvar ${jlibname}::si::istate istate
+ #puts "jlib::si::read_data (i)"
+
+ set profile $istate($sid,profile)
+ return [$reader($profile,read) $jlibname $sid]
+}
+
+# This is also used to report any errors from transport to profile.
+
+proc jlib::si::close_data {jlibname sid {err ""}} {
+ variable reader
+ upvar ${jlibname}::si::istate istate
+ #puts "jlib::si::close_data (i)"
+
+ set profile $istate($sid,profile)
+ $reader($profile,close) $jlibname $sid $err
+}
+
+# jlib::si::send_close --
+#
+# Used by profile to close down the stream.
+
+proc jlib::si::send_close {jlibname sid cmd} {
+ variable trpt
+ upvar ${jlibname}::si::istate istate
+ #puts "jlib::si::send_close (i)"
+
+ set istate($sid,closeCmd) $cmd
+ set stream $istate($sid,stream)
+ eval $trpt($stream,close) [list $jlibname $sid]
+}
+
+# jlib::si::transport_close_cb --
+#
+# Called by tansport when closed operation is completed.
+# It is called as a response (callback) to 'send_close'.
+# This is our destructor.
+
+proc jlib::si::transport_close_cb {jlibname sid type iqChild} {
+ upvar ${jlibname}::si::istate istate
+ #puts "jlib::si::transport_close_cb (i)"
+
+ # Just report this to the relevant profile.
+ eval $istate($sid,closeCmd) [list $jlibname $type $sid $iqChild]
+
+ ifree $jlibname $sid
+}
+
+proc jlib::si::ifree {jlibname sid} {
+ upvar ${jlibname}::si::istate istate
+ #puts "jlib::si::ifree (i) sid=$sid"
+
+ array unset istate $sid,*
+}
+
+#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+#
+# These are all functions to use by a target (receiver) of a stream.
+
+# jlib::si::handle_set --
+#
+# Parse incoming si set element. Invokes registered callback for the
+# profile in question. It is the responsibility of this callback to
+# deliver the result via the command in its argument.
+
+proc jlib::si::handle_set {jlibname from siE args} {
+ variable xmlns
+ variable trpt
+ variable prof
+ upvar ${jlibname}::si::tstate tstate
+
+ #puts "jlib::si::handle_set (t)"
+
+ array set iqattr $args
+ if {![info exists iqattr(-id)]} {
+ return 0
+ }
+ set id $iqattr(-id)
+
+ # Note: there are two different 'id'!
+ # These are the attributes of the si element.
+ array set attr {
+ id ""
+ mime-type ""
+ profile ""
+ }
+ array set attr [wrapper::getattrlist $siE]
+ set sid $attr(id)
+ set profile $attr(profile)
+
+ # This is a profile we don't understand.
+ if {![info exists prof($profile,open)]} {
+ set errE [wrapper::createtag "bad-profile" \
+ -attrlist [list xmlns $xmlns(si)]]
+ send_error $jlibname $from $id $sid 400 cancel "bad-request" $errE
+ return 1
+ }
+
+ # Extract all streams and pick one with highest priority.
+ set stream [pick_stream $siE]
+
+ # No valid stream :-(
+ if {![string length $stream]} {
+ set errE [wrapper::createtag "no-valid-streams" \
+ -attrlist [list xmlns $xmlns(si)]]
+ send_error $jlibname $from $id $sid 400 cancel "bad-request" $errE
+ return 1
+ }
+
+ # Get profile element. Can have any tag but xmlns must be $profile.
+ set profileE [wrapper::getfirstchildwithxmlns $siE $profile]
+ if {![llength $profileE]} {
+ send_error $jlibname $from $id $sid 400 cancel "bad-request"
+ return 1
+ }
+
+ set tstate($sid,profile) $profile
+ set tstate($sid,stream) $stream
+ set tstate($sid,mime-type) $attr(mime-type)
+ foreach {key val} $args {
+ set tstate($sid,$key) $val
+ }
+ set jid $tstate($sid,-from)
+
+ # Invoke registered handler for this profile.
+ set respCmd [list [namespace current]::profile_response $jlibname $sid]
+ set rc [catch {
+ eval $prof($profile,open) [list $jlibname $sid $jid $siE $respCmd]
+ }]
+ if {$rc == 1} {
+ # error
+ return 0
+ } elseif {$rc == 3 || $rc == 4} {
+ # break or continue
+ return 0
+ }
+ return 1
+}
+
+# jlib::si::pick_stream --
+#
+# Extracts the highest priority stream from an si element. Empty if error.
+
+proc jlib::si::pick_stream {siE} {
+ variable xmlns
+ variable trpt
+
+ # Extract all streams and pick one with highest priority.
+ set values [list]
+ set fieldE [wrapper::getchilddeep $siE [list \
+ [list "feature" $xmlns(neg)] [list "x" $xmlns(xdata)] "field"]]
+ if {[llength $fieldE]} {
+ set optionEL [wrapper::getchildswithtag $fieldE "option"]
+ foreach c $optionEL {
+ set firstE [lindex [wrapper::getchildren $c] 0]
+ lappend values [wrapper::getcdata $firstE]
+ }
+ }
+
+ # Pick first matching since priority ordered.
+ set stream ""
+ foreach name $values {
+ if {[lsearch -exact $trpt(streams) $name] >= 0} {
+ set stream $name
+ break
+ }
+ }
+ return $stream
+}
+
+# jlib::si::profile_response --
+#
+# Invoked by the registered profile callback.
+#
+# Arguments:
+# type 'result' or 'error' if user accepts the stream or not.
+# profileE any extra profile element; can be empty.
+
+proc jlib::si::profile_response {jlibname sid type profileE args} {
+ variable xmlns
+ upvar ${jlibname}::si::tstate tstate
+
+ #puts "jlib::si::profile_response (t) type=$type"
+
+ set jid $tstate($sid,-from)
+ set id $tstate($sid,-id)
+
+ # Rejected stream initiation.
+ if {[string equal $type "error"]} {
+ # @@@ We could have a text element here...
+ send_error $jlibname $jid $id $sid 403 cancel forbidden
+ } else {
+
+ # Accepted stream initiation.
+ # Construct si element from selected profile.
+ set siE [t_element $jlibname $sid $profileE]
+ jlib::send_iq $jlibname result [list $siE] -to $jid -id $id
+ }
+ return
+}
+
+# jlib::si::t_element --
+#
+# Construct si element from selected profile.
+
+proc jlib::si::t_element {jlibname sid profileE} {
+ variable xmlns
+ upvar ${jlibname}::si::tstate tstate
+
+ set valueE [wrapper::createtag "value" -chdata $tstate($sid,stream)]
+ set fieldE [wrapper::createtag "field" \
+ -attrlist {var stream-method} -subtags [list $valueE]]
+ set xE [wrapper::createtag "x" \
+ -attrlist [list xmlns $xmlns(xdata) type submit] -subtags [list $fieldE]]
+ set featureE [wrapper::createtag "feature" \
+ -attrlist [list xmlns $xmlns(neg)] -subtags [list $xE]]
+
+ # Include 'profileE' if nonempty.
+ set subsiEL [list $featureE]
+ if {[llength $profileE]} {
+ lappend subsiEL $profileE
+ }
+ set siE [wrapper::createtag "si" \
+ -attrlist [list xmlns $xmlns(si) id $sid] -subtags $subsiEL]
+ return $siE
+}
+
+# jlib::si::reset --
+#
+# Used by profile when doing reset.
+
+proc jlib::si::reset {jlibname sid} {
+ upvar ${jlibname}::si::tstate tstate
+ #puts "jlib::si::reset (t)"
+
+ # @@@ Tell transport we are resetting???
+ # Brute force.
+
+ tfree $jlibname $sid
+}
+
+# jlib::si::havesi --
+#
+# The streams may need to know if we have got a si request (set).
+# @@@ Perhaps we should have timeout for incoming si requests that
+# cancels it all.
+
+proc jlib::si::havesi {jlibname sid} {
+ upvar ${jlibname}::si::tstate tstate
+ upvar ${jlibname}::si::istate istate
+
+ if {[info exists tstate($sid,profile)] || [info exists istate($sid,profile)]} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# jlib::si::stream_recv --
+#
+# Used by transports (streams) to deliver the actual data.
+
+proc jlib::si::stream_recv {jlibname sid data} {
+ variable prof
+ upvar ${jlibname}::si::tstate tstate
+ #puts "jlib::si::stream_recv (t)"
+
+ # Each stream should check that we exist before calling us!
+ set profile $tstate($sid,profile)
+ eval $prof($profile,read) [list $jlibname $sid $data]
+}
+
+# jlib::si::stream_closed --
+#
+# This should be the final stage for a succesful transfer.
+# Called by transports (streams).
+
+proc jlib::si::stream_closed {jlibname sid} {
+ variable prof
+ upvar ${jlibname}::si::tstate tstate
+ #puts "jlib::si::stream_closed (t)"
+
+ # Each stream should check that we exist before calling us!
+ set profile $tstate($sid,profile)
+ eval $prof($profile,close) [list $jlibname $sid]
+ tfree $jlibname $sid
+}
+
+# jlib::si::stream_error --
+#
+# Called by transports to report an error.
+
+proc jlib::si::stream_error {jlibname sid errmsg} {
+ variable prof
+ upvar ${jlibname}::si::tstate tstate
+ #puts "jlib::si::stream_error (t)"
+
+ set profile $tstate($sid,profile)
+ eval $prof($profile,close) [list $jlibname $sid $errmsg]
+ tfree $jlibname $sid
+}
+
+# jlib::si::send_error --
+#
+# Reply with iq error element.
+
+proc jlib::si::send_error {jlibname jid id sid errcode errtype stanza {extraElem {}}} {
+
+ #puts "jlib::si::send_error"
+
+ jlib::send_iq_error $jlibname $jid $id $errcode $errtype $stanza $extraElem
+ tfree $jlibname $sid
+}
+
+proc jlib::si::tfree {jlibname sid} {
+ upvar ${jlibname}::si::tstate tstate
+ #puts "jlib::si::tfree (t)"
+
+ array unset tstate $sid,*
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::si {
+
+ jlib::ensamble_register si \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# sipub.tcl --
+#
+# This file is part of the jabberlib.
+# It provides support for the sipub prootocol:
+# XEP-0137: Publishing Stream Initiation Requests
+#
+# Copyright (c) 2007 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: sipub.tcl,v 1.7 2007/11/25 15:48:54 matben Exp $
+#
+# NB: There are three different id's floating around:
+# 1) iq-get/result related
+# 2) sipub id (spid)
+# 3) si id (stream id, sid)
+#
+# @@@ TODO: Move some code to the profile instead since we have hardcoded
+# the 'filetransfer' profile.
+
+package require jlib
+package require jlib::si
+package require jlib::disco
+
+package provide jlib::sipub 0.2
+
+namespace eval jlib::sipub {
+
+ variable xmlns
+ set xmlns(sipub) "http://jabber.org/protocol/si-pub"
+
+ jlib::disco::registerfeature $xmlns(sipub)
+
+ # We use a static cache array that maps sipub id (spid) to file name and mime.
+ # This seems more practical since the jlib instances may vary between the
+ # sessions.
+ variable cache
+
+ # Note: jlib::ensamble_register is last in this file!
+}
+
+proc jlib::sipub::init {jlibname args} {
+ variable xmlns
+
+ $jlibname iq_register get $xmlns(sipub) [namespace current]::handle_get
+}
+
+proc jlib::sipub::cmdproc {jlibname cmd args} {
+ return [eval {$cmd $jlibname} $args]
+}
+
+#--- Initiator side ------------------------------------------------------------
+#
+# Initiator and target are dubious names here. With initiator we mean the part
+# that has a file to offer, and target the one who gets it.
+
+# jlib::sipub::set_cache, get_cache --
+#
+# Set or get the complete cache. Useful if we store the cache in a file
+# between sessions.
+
+proc jlib::sipub::set_cache {cacheL} {
+ variable cache
+ array set cache $cacheL
+}
+
+proc jlib::sipub::get_cache {} {
+ variable cache
+ return [array get cache]
+}
+
+# jlib::sipub::newcache --
+#
+# This just adds a reference to our cache. Used to construct xmpp uri
+# for 'recvfile'.
+
+proc jlib::sipub::newcache {fileName mime} {
+ variable cache
+
+ set spid [jlib::generateuuid]
+ set cache($spid,file) $fileName
+ set cache($spid,mime) $mime
+
+ return $spid
+}
+
+# jlib::sipub::element --
+#
+# Makes a sipub element for a local file and adds the reference to cache.
+# This is the constructor for a sipub object. Each object may generate
+# any number of file transfers instances, each with its unique 'sid'.
+# Once a sipub instance is created it can be made to live as long as
+# the cache is kept.
+# This shall be called from the profile or application layer.
+#
+# Results:
+# sipub element.
+
+# @@@ Shall it have jlibname?
+
+proc jlib::sipub::element {from profile profileE fileName mime} {
+ variable xmlns
+ variable cache
+
+ set spid [jlib::generateuuid]
+ set cache($spid,file) $fileName
+ set cache($spid,mime) $mime
+
+ set attr [list xmlns $xmlns(sipub) from $from id $spid mime-type $mime \
+ profile $profile]
+ set sipubE [wrapper::createtag "sipub" -attrlist $attr \
+ -subtags [list $profileE]]
+
+ return $sipubE
+}
+
+# jlib::sipub::handle_get --
+#
+# Handles incoming iq-get/start sipub stanzas.
+# There must be a sipub object with matching id (spid).
+# This has the corresponding role of the HTTP server side GET request.
+#
+# NB: We have hardcoded the 'filetransfer' profile.
+
+proc jlib::sipub::handle_get {jlibname from startE args} {
+ variable xmlns
+ variable cache
+
+ array set argsA $args
+ if {![info exists argsA(-id)]} {
+ return 0
+ }
+ set id $argsA(-id)
+ if {[wrapper::gettag $startE] ne "start"} {
+ return 0
+ }
+ array set attr [wrapper::getattrlist $startE]
+ if {![info exists attr(id)]} {
+ return 0
+ }
+ set spid $attr(id)
+ if {[info exists cache($spid,file)]} {
+
+ # We must pick the 'sid' here since it is also used in 'starting'.
+ set sid [jlib::generateuuid]
+ set startingE [wrapper::createtag "starting" \
+ -attrlist [list xmlns $xmlns(sipub) sid $sid]]
+ $jlibname send_iq result [list $startingE] -id $id -to $from
+
+ # This is the constructor of a file stream.
+ $jlibname filetransfer send $from [namespace code send_cb] -sid $sid \
+ -file $cache($spid,file) \
+ -mime $cache($spid,mime)
+ } else {
+ jlib::send_iq_error $jlibname $from $id 405 modify not-acceptable
+ }
+ return 1
+}
+
+proc jlib::sipub::send_cb {jlibname status sid {subiq ""}} {
+
+ # empty.
+}
+
+#--- Target side ---------------------------------------------------------------
+
+# jlib::sipub::have_sipub --
+#
+# Searches an element recursively to see if there is a sipub element.
+
+proc jlib::sipub::have_sipub {xmldata} {
+ variable xmlns
+
+ return [llength [wrapper::getchilddeep $xmldata \
+ [list [list sipub $xmlns(sipub)]]]]
+}
+
+proc jlib::sipub::get_element {xmldata} {
+ variable xmlns
+
+ return [wrapper::getchilddeep $xmldata [list [list sipub $xmlns(sipub)]]]
+}
+
+# NB: We have a separate 'start' command in order to catch the response and
+# obtain the 'sid' which is typically needed to control the file transfer.
+
+# Typical usage:
+#
+# jlib sipub start ... cb
+# proc cb {type startingE} {
+# set sid [wrapper::getattribute $startingE sid]
+# jlib sipub set_accept_handler $sid \
+# -channel ... -command ... -progress ...
+# }
+
+# jlib::sipub::start --
+#
+# Sends a start element. A iq-result/error is expected.
+# This 'id' must be a matching spid.
+
+proc jlib::sipub::start {jlibname jid id cmd} {
+ variable xmlns
+
+ set startE [wrapper::createtag "start" \
+ -attrlist [list xmlns $xmlns(sipub) id $id]]
+ $jlibname send_iq get [list $startE] -to $jid -command $cmd
+}
+
+# jlib::sipub::set_accept_handler --
+#
+# This is normally called as a response to the 'start' command's
+# callback when we get a sipub 'starting' element.
+# We shall typically provide -command, -progress, and -channel.
+#
+# Arguments:
+# xmldata complete message element or whatever.
+# args: -channel
+# -command
+# -progress
+#
+# Result:
+# none
+
+proc jlib::sipub::set_accept_handler {jlibname sid args} {
+ variable state
+
+ # This is just kept until we get the si-callback.
+ set state($sid,args) $args
+
+ # We shall be prepared to get the si-set request.
+ $jlibname filetransfer register_sid_handler $sid \
+ [namespace code [list si_handler $sid]]
+ return
+}
+
+proc jlib::sipub::si_handler {sid jlibname jid name size cmd args} {
+ variable state
+
+ #puts "jlib::sipub::si_handler sid=$sid"
+
+ # We requested this file using 'sipub::get' in the first place so
+ # therefore accept the stream.
+ # We also provide all the arguments -channel etc.
+ uplevel #0 $cmd 1 $state($sid,args)
+ unset state($sid,args)
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::sipub {
+
+ jlib::ensamble_register sipub \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+# Test:
+if {0} {
+ package require jlib::sipub
+ set jlib ::jlib::jlib1
+
+ # Initiator side:
+ set jid matben@localhost
+ set fileName /Users/matben/Desktop/splash.svg
+ set name [file tail $fileName]
+ set size [file size $fileName]
+ set fileE [jlib::ftrans::element $name $size]
+ set sipubE [jlib::sipub::element [$jlib myjid] $jlib::ftrans::xmlns(ftrans) \
+ $fileE $fileName image/svg]
+
+ $jlib send_message $jid -xlist [list $sipubE]
+
+ # Target side:
+ package require jlib::sipub
+ set jlib ::jlib::jlib1
+ proc progress {args} {puts "progress: $args"}
+ proc command {args} {puts "command: $args"}
+ proc msg {jlib xmlns xmldata args} {
+ puts "message: $xmldata"
+ set ::messageE $xmldata
+ return 0
+ }
+ $jlib message_register normal * msg
+
+ set fileName /Users/matben/Desktop/splash.svg
+ set fd [open $fileName.tmp w]
+
+ proc start_cb {type startingE} {
+ puts "start_cb type=$type"
+ if {$type eq "result"} {
+ set sid [wrapper::getattribute $startingE sid]
+ $::jlib sipub set_accept_handler $sid \
+ -channel $::fd -command command -progress progress
+ }
+ }
+ set sipubE [wrapper::getchilddeep $messageE \
+ [list [list sipub $jlib::sipub::xmlns(sipub)]]]
+ set from [wrapper::getattribute $sipubE from]
+ if {$from eq ""} {
+ set from [wrapper::getattribute $messageE from]
+ }
+ set spid [wrapper::getattribute $sipubE id]
+ $jlib sipub start $from $spid start_cb
+
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# stanzaerror.tcl --
+#
+# This file is part of the jabberlib. It provides english clear text
+# messages that gives some detail of 'urn:ietf:params:xml:ns:xmpp-stanzas'.
+#
+# Copyright (c) 2004 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: stanzaerror.tcl,v 1.9 2007/09/12 07:20:46 matben Exp $
+#
+
+package provide stanzaerror 1.0
+
+namespace eval stanzaerror {
+
+ # This maps Defined Conditions to clear text messages.
+ # Extensible Messaging and Presence Protocol (XMPP): Core (RFC 3920)
+ # 9.3.3 Defined Conditions
+ # Applications use the error tag directly for the key into a message catalog.
+
+ variable msg
+ array set msg {
+ bad-request {The sender has sent XML that is malformed or that cannot be processed.}
+ conflict {Access cannot be granted because an existing resource or session exists with the same name or address.}
+ feature-not-implemented {The feature requested is not implemented by the recipient or server and therefore cannot be processed.}
+ forbidden {The requesting entity does not possess the required permissions to perform the action.}
+ gone {The recipient or server can no longer be contacted at this address.}
+ internal-server-error {The server could not process the stanza because of a misconfiguration or an otherwise-undefined internal server error.}
+ item-not-found {The addressed JID or item requested cannot be found.}
+ jid-malformed {The sending entity has provided or communicated an XMPP address or aspect thereof that does not adhere to the syntax defined in Addressing Scheme.}
+ not-acceptable {The recipient or server understands the request but is refusing to process it because it does not meet criteria defined by the recipient or server.}
+ not-allowed {The recipient or server does not allow any entity to perform the action.}
+ not-authorized {The sender must provide proper credentials before being allowed to perform the action, or has provided improper credentials.}
+ payment-required {The requesting entity is not authorized to access the requested service because payment is required.}
+ recipient-unavailable {The intended recipient is temporarily unavailable.}
+ redirect {The recipient or server is redirecting requests for this information to another entity, usually temporarily.}
+ registration-required {The requesting entity is not authorized to access the requested service because registration is required.}
+ remote-server-not-found {A remote server or service specified as part or all of the JID of the intended recipient does not exist.}
+ remote-server-timeout {A remote server or service specified as part or all of the JID of the intended recipient (or required to fulfill a request) could not be contacted within a reasonable amount of time.}
+ resource-constraint {The server or recipient lacks the system resources necessary to service the request.}
+ service-unavailable {The server or recipient does not currently provide the requested service.}
+ subscription-required {The requesting entity is not authorized to access the requested service because a subscription is required.}
+ undefined-condition {The error condition is not one of those defined by the other conditions in this list.}
+ unexpected-request {The recipient or server understood the request but was not expecting it at this time (e.g., the request was out of order).}
+ }
+}
+
+# stanzaerror::getmsg --
+#
+# Return the english clear text message from a defined-condition.
+
+proc stanzaerror::getmsg {condition} {
+ variable msg
+
+ if {[info exists msg($condition)]} {
+ return $msg($condition)
+ } else {
+ return
+ }
+}
+
+#-------------------------------------------------------------------------------
+
--- /dev/null
+# streamerror.tcl --
+#
+# This file is part of the jabberlib. It provides english clear text
+# messages that gives some detail of 'urn:ietf:params:xml:ns:xmpp-streams'.
+#
+# Copyright (c) 2004 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: streamerror.tcl,v 1.7 2007/09/12 13:37:55 matben Exp $
+#
+
+# The syntax for stream errors is as follows:
+#
+# <stream:error>
+# <defined-condition xmlns='urn:ietf:params:xml:ns:xmpp-streams'/>
+# <text xmlns='urn:ietf:params:xml:ns:xmpp-streams'>
+# OPTIONAL descriptive text
+# </text>
+# [OPTIONAL application-specific condition element]
+# </stream:error>
+
+package provide streamerror 1.0
+
+namespace eval streamerror {
+
+ # This maps Defined Conditions to clear text messages.
+ # draft-ietf-xmpp-core23; 4.7.3 Defined Conditions
+ # Applications use the error tag directly for the key into a message catalog.
+
+ variable msg
+ array set msg {
+ bad-format {The entity has sent XML that cannot be processed.}
+ bad-namespace-prefix {The entity has sent a namespace prefix that is unsupported, or has sent no namespace prefix on an element that requires such a prefix.}
+ conflict {The server is closing the active stream for this entity because a new stream has been initiated that conflicts with the existing stream.}
+ connection-timeout {The entity has not generated any traffic over the stream for some period of time.}
+ host-gone {The value of the 'to' attribute provided by the initiating entity in the stream header corresponds to a hostname that is no longer hosted by the server.}
+ host-unknown {The value of the 'to' attribute provided by the initiating entity in the stream header does not correspond to a hostname that is hosted by the server.}
+ improper-addressing {A stanza sent between two servers lacks a 'to' or 'from' attribute.}
+ internal-server-error {The server has experienced a misconfiguration or an otherwise-undefined internal error that prevents it from servicing the stream.}
+ invalid-from {The JID or hostname provided in a 'from' address does not match an authorized JID or validated domain negotiated between servers via SASL or dialback, or between a client and a server via authentication and resource binding.}
+ invalid-id {The stream ID or dialback ID is invalid or does not match an ID previously provided.}
+ invalid-namespace {The streams namespace name is something other than "http://etherx.jabber.org/streams" or the dialback namespace name is something other than "jabber:server:dialback".}
+ invalid-xml {The entity has sent invalid XML over the stream to a server that performs validation.}
+ not-authorized {The entity has attempted to send data before the stream has been authenticated, or otherwise is not authorized to perform an action related to stream negotiation; the receiving entity MUST NOT process the offending stanza before sending the stream error.}
+ policy-violation {The entity has violated some local service policy; the server MAY choose to specify the policy in the <text/> element or an application-specific condition element.}
+ remote-connection-failed {The server is unable to properly connect to a remote entity that is required for authentication or authorization.}
+ resource-constraint {The server lacks the system resources necessary to service the stream.}
+ restricted-xml {The entity has attempted to send restricted XML features such as a comment, processing instruction, DTD, entity reference, or unescaped character.}
+ see-other-host {The server will not provide service to the initiating entity but is redirecting traffic to another host; the server SHOULD specify the alternate hostname or IP address (which MUST be a valid domain identifier) as the XML character data of the <see-other-host/> element.}
+ system-shutdown {The server is being shut down and all active streams are being closed.}
+ undefined-condition {The error condition is not one of those defined by the other conditions in this list; this error condition SHOULD be used only in conjunction with an application-specific condition.}
+ unsupported-encoding {The initiating entity has encoded the stream in an encoding that is not supported by the server.}
+ unsupported-stanza-type {The initiating entity has sent a first-level child of the stream that is not supported by the server.}
+ unsupported-version {The value of the 'version' attribute provided by the initiating entity in the stream header specifies a version of XMPP that is not supported by the server.}
+ xml-not-well-formed {The initiating entity has sent XML that is not well-formed as defined by [XML].}
+ }
+}
+
+# streamerror::getmsg --
+#
+# Return the english clear text message from a defined-condition.
+
+proc streamerror::getmsg {condition} {
+ variable msg
+
+ if {[info exists msg($condition)]} {
+ return $msg($condition)
+ } else {
+ return
+ }
+}
+
+#-------------------------------------------------------------------------------
+
--- /dev/null
+# tinydom.tcl ---
+#
+# This file is part of The Coccinella application. It implements
+# a tiny DOM model which wraps xml into tcl lists.
+#
+# Copyright (c) 2003 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: tinydom.tcl,v 1.14 2008/03/26 13:11:34 matben Exp $
+
+package require xml
+
+package provide tinydom 0.2
+
+# This is an attempt to make a minimal DOM thing to store xml data as
+# a hierarchical list which is better suited to Tcl.
+# @@@ Try make a common syntax with wrapper.
+
+namespace eval tinydom {
+ variable uid 0
+ variable cache
+}
+
+proc tinydom::parse {xml args} {
+ variable uid
+ variable cache
+
+ array set argsA {
+ -package xml
+ }
+ array set argsA $args
+ switch -- $argsA(-package) {
+ xml {
+ set xmlparser [xml::parser]
+ }
+ qdxml {
+ package require qdxml
+ set xmlparser [qdxml::create]
+ }
+ default {
+ return -code error "unknown -package \"$argsA(-package)\""
+ }
+ }
+
+ # Store in internal array and return token which is the array index.
+ set token [namespace current]::[incr uid]
+ upvar #0 $token state
+
+ set state(1) [list]
+ set state(level) 0
+
+ $xmlparser configure -reportempty 1 \
+ -elementstartcommand [namespace code [list ElementStart $token]] \
+ -elementendcommand [namespace code [list ElementEnd $token]] \
+ -characterdatacommand [namespace code [list CHdata $token]] \
+ -ignorewhitespace 1
+ $xmlparser parse $xml
+
+ set cache($token) $state(1)
+ unset state
+ return $token
+}
+
+proc tinydom::ElementStart {token tag attrlist args} {
+ upvar #0 $token state
+
+ array set argsA $args
+ if {[info exists argsA(-namespacedecls)]} {
+ lappend attrlist xmlns [lindex $argsA(-namespacedecls) 0]
+ }
+ set state([incr state(level)]) [list $tag $attrlist 0 {} {}]
+}
+
+proc tinydom::ElementEnd {token tagname args} {
+ upvar #0 $token state
+
+ set level $state(level)
+ if {$level > 1} {
+
+ # Insert the child tree in the parent tree.
+ Append $token [expr $level-1] $state($level)
+ }
+ incr state(level) -1
+}
+
+proc tinydom::CHdata {token chdata} {
+ upvar #0 $token state
+
+ set level $state(level)
+ set cdata [lindex $state($level) 3]
+ append cdata [xmldecrypt $chdata]
+ lset state($level) 3 $cdata
+}
+
+proc tinydom::Append {token plevel childtree} {
+ upvar #0 $token state
+
+ # Get child list at parent level (level).
+ set childlist [lindex $state($plevel) 4]
+ lappend childlist $childtree
+
+ # Build the new parent tree.
+ lset state($plevel) 4 $childlist
+}
+
+proc tinydom::xmldecrypt {chdata} {
+
+ return [string map {
+ {&} {&} {<} {<} {>} {>} {"} {"} {'} {'}} $chdata]
+}
+
+proc tinydom::documentElement {token} {
+ variable cache
+ return $cache($token)
+}
+
+proc tinydom::tagname {xmllist} {
+ return [lindex $xmllist 0]
+}
+
+proc tinydom::attrlist {xmllist} {
+ return [lindex $xmllist 1]
+}
+
+proc tinydom::chdata {xmllist} {
+ return [lindex $xmllist 3]
+}
+
+proc tinydom::children {xmllist} {
+ return [lindex $xmllist 4]
+}
+
+proc tinydom::getattribute {xmllist attrname} {
+ foreach {attr val} [lindex $xmllist 1] {
+ if {[string equal $attr $attrname]} {
+ return $val
+ }
+ }
+ return
+}
+
+proc tinydom::getfirstchildwithtag {xmllist tag} {
+ set c [list]
+ foreach celem [lindex $xmllist 4] {
+ if {[string equal [lindex $celem 0] $tag]} {
+ set c $celem
+ break
+ }
+ }
+ return $c
+}
+
+proc tinydom::cleanup {token} {
+ variable cache
+ unset -nocomplain cache($token)
+}
+
+#-------------------------------------------------------------------------------
--- /dev/null
+# util.tcl --
+#
+# This file is part of the jabberlib.
+# It provides small utility functions.
+#
+# Copyright (c) 2006 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: util.tcl,v 1.6 2007/09/06 13:20:47 matben Exp $
+
+package provide jlib::util 0.1
+
+namespace eval jlib::util {}
+
+# Standin for a 8.5 feature.
+if {![llength [info commands lassign]]} {
+ proc lassign {vals args} {uplevel 1 [list foreach $args $vals break] }
+}
+
+# jlib::util::lintersect --
+#
+# Picks out the common list elements from two lists, their intersection.
+
+proc jlib::util::lintersect {list1 list2} {
+ set lans [list]
+ foreach l $list1 {
+ if {[lsearch -exact $list2 $l] >= 0} {
+ lappend lans $l
+ }
+ }
+ return $lans
+}
+
+# jlib::util::lprune --
+#
+# Removes element from list, silently.
+
+proc jlib::util::lprune {listName elem} {
+ upvar $listName listValue
+ set idx [lsearch -exact $listValue $elem]
+ if {$idx >= 0} {
+ uplevel [list set $listName [lreplace $listValue $idx $idx]]
+ }
+ return
+}
+
+# jlib::util::from --
+#
+# The from command plucks an option value from a list of options and their
+# values. If it is found, it and its value are removed from the list,
+# and the value is returned.
+
+proc jlib::util::from {argvName option {defvalue ""}} {
+ upvar $argvName argv
+
+ set ioption [lsearch -exact $argv $option]
+ if {$ioption == -1} {
+ return $defvalue
+ } else {
+ set ivalue [expr {$ioption + 1}]
+ set value [lindex $argv $ivalue]
+ set argv [lreplace $argv $ioption $ivalue]
+ return $value
+ }
+}
--- /dev/null
+# vcard.tcl --
+#
+# This file is part of the jabberlib.
+# It handles vcard stuff and provides cache for it as well.
+#
+# Copyright (c) 2005-2006 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: vcard.tcl,v 1.14 2007/11/10 15:44:59 matben Exp $
+#
+############################# USAGE ############################################
+#
+# NAME
+# vcard - convenience command library for the vcard extension.
+#
+# SYNOPSIS
+# jlib::vcard::init jlibName ?-opt value ...?
+#
+# INSTANCE COMMANDS
+# jlibname vcard send_get jid callbackProc
+# jlibname vcard send_set jid callbackProc
+# jlibname vcard get_async jid callbackProc
+# jlibname vcard has_cache jid
+# jlibname vcard get_cache jid
+#
+################################################################################
+
+package require jlib
+
+package provide jlib::vcard 0.1
+
+namespace eval jlib::vcard {
+
+ # Note: jlib::ensamble_register is last in this file!
+}
+
+# jlib::vcard::init --
+#
+# Creates a new instance of a vcard object.
+#
+# Arguments:
+# jlibname: name of existing jabberlib instance
+# args:
+#
+# Results:
+# namespaced instance command
+
+proc jlib::vcard::init {jlibname args} {
+
+ variable xmlns
+ set xmlns(vcard) "vcard-temp"
+
+ # Instance specific arrays.
+ namespace eval ${jlibname}::vcard {
+ variable state
+ }
+ upvar ${jlibname}::vcard::state state
+
+ set state(cache) 1
+
+ return
+}
+
+# jlib::vcard::cmdproc --
+#
+# Just dispatches the command to the right procedure.
+#
+# Arguments:
+# jlibname: name of existing jabberlib instance
+# cmd:
+# args: all args to the cmd procedure.
+#
+# Results:
+# none.
+
+proc jlib::vcard::cmdproc {jlibname cmd args} {
+
+ # Which command? Just dispatch the command to the right procedure.
+ return [eval {$cmd $jlibname} $args]
+}
+
+# jlib::vcard::send_get --
+#
+# It implements the 'jabber:iq:vcard-temp' get method.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# jid: bare JID for other users, full jid for ourself.
+# cmd: client command to be executed at the iq "result" element.
+#
+# Results:
+# none.
+
+proc jlib::vcard::send_get {jlibname jid cmd} {
+ variable xmlns
+ upvar ${jlibname}::vcard::state state
+
+ set mjid [jlib::jidmap $jid]
+ set state(pending,$mjid) 1
+ set attrlist [list xmlns $xmlns(vcard)]
+ set xmllist [wrapper::createtag "vCard" -attrlist $attrlist]
+ jlib::send_iq $jlibname "get" [list $xmllist] -to $jid -command \
+ [list [namespace current]::send_get_cb $jlibname $jid $cmd]
+ return
+}
+
+# jlib::vcard::send_get_cb --
+#
+# Cache vcard info from above and call up.
+
+proc jlib::vcard::send_get_cb {jlibname jid cmd type subiq} {
+ upvar ${jlibname}::vcard::state state
+
+ set mjid [jlib::jidmap $jid]
+ unset -nocomplain state(pending,$mjid)
+ if {$state(cache)} {
+ set state(cache,$mjid) $subiq
+ }
+ InvokeStacked $jlibname $jid $type $subiq
+
+ uplevel #0 $cmd [list $jlibname $type $subiq]
+}
+
+# jlib::vcard::get_async --
+#
+# Get vcard async using 'cmd' callback.
+# If cached it is returned directly using 'cmd', if pending the cmd
+# is invoked when getting result, else we do a send_get.
+
+proc jlib::vcard::get_async {jlibname jid cmd} {
+ upvar ${jlibname}::vcard::state state
+
+ set mjid [jlib::jidmap $jid]
+ if {[info exists state(cache,$mjid)]} {
+ uplevel #0 $cmd [list $jlibname result $state(cache,$mjid)]
+ } elseif {[info exists state(pending,$mjid)]} {
+ lappend state(invoke,$mjid) $cmd
+ } else {
+ send_get $jlibname $jid $cmd
+ }
+ return
+}
+
+proc jlib::vcard::InvokeStacked {jlibname jid type subiq} {
+ upvar ${jlibname}::vcard::state state
+
+ set mjid [jlib::jidmap $jid]
+ if {[info exists state(invoke,$mjid)]} {
+ foreach cmd $state(invoke,$mjid) {
+ uplevel #0 $cmd [list $jlibname $type $subiq]
+ }
+ unset -nocomplain state(invoke,$mjid)
+ }
+}
+
+# jlib::vcard::get_own_async --
+#
+# Getting and setting owns vcard is special since lacks to attribute.
+
+proc jlib::vcard::get_own_async {jlibname cmd} {
+ upvar ${jlibname}::vcard::state state
+
+ set jid [$jlibname myjid2]
+ set mjid [jlib::jidmap $jid]
+ if {[info exists state(cache,$mjid)]} {
+ uplevel #0 $cmd [list $jlibname result $state(cache,$mjid)]
+ } elseif {[info exists state(pending,$mjid)]} {
+ lappend state(invoke,$mjid) $cmd
+ } else {
+ send_get_own $jlibname $cmd
+ }
+ return
+}
+
+proc jlib::vcard::send_get_own {jlibname cmd} {
+ variable xmlns
+
+ # A user may retrieve his or her own vCard by sending XML of the
+ # following form to his or her own JID (the 'to' attribute SHOULD NOT
+ # be included).
+ set attrlist [list xmlns $xmlns(vcard)]
+ set xmllist [wrapper::createtag "vCard" -attrlist $attrlist]
+ jlib::send_iq $jlibname "get" [list $xmllist] -command \
+ [list [namespace current]::send_get_own_cb $jlibname $cmd]
+}
+
+proc jlib::vcard::send_get_own_cb {jlibname cmd type subiq} {
+ upvar ${jlibname}::vcard::state state
+
+ set jid [$jlibname myjid2]
+ set mjid [jlib::jidmap $jid]
+ unset -nocomplain state(pending,$mjid)
+ if {$state(cache)} {
+ set state(cache,$mjid) $subiq
+ }
+ InvokeStacked $jlibname $jid $type $subiq
+
+ uplevel #0 $cmd [list $jlibname $type $subiq]
+}
+
+# jlib::vcard::set_my_photo --
+#
+# A utility to set our vCard photo.
+# If photo empty then remove photo from vCard.
+#
+# @@@ TODO: Perhaps we should use a cached vCard instead of getting it
+# each time? The cache would only need one request and then
+# set each time we set our usual vCard.
+
+proc jlib::vcard::set_my_photo {jlibname photo mime cmd} {
+
+ send_get_own $jlibname \
+ [list [namespace current]::get_my_photo_cb $photo $mime $cmd]
+}
+
+proc jlib::vcard::get_my_photo_cb {photo mime cmd jlibname type subiq} {
+ variable xmlns
+
+ # Replace or set an element:
+ #
+ # <PHOTO>
+ # <TYPE>image/jpeg</TYPE>
+ # <BINVAL>Base64-encoded-avatar-file-here!</BINVAL>
+ # </PHOTO>
+
+ if {$type eq "result"} {
+ if {[string length $photo]} {
+ set newphoto 1
+ set vcardE $subiq
+
+ # Replace or add photo. But only if different.
+ set photoE [wrapper::getfirstchildwithtag $vcardE "PHOTO"]
+ if {[llength $photoE]} {
+ set binE [wrapper::getfirstchildwithtag $photoE "BINVAL"]
+ if {[llength $binE]} {
+ set sphoto [wrapper::getcdata $binE]
+
+ # Base64 code can contain undefined spaces: decode!
+ set sdata [::base64::decode $sphoto]
+ set data [::base64::decode $photo]
+ if {[string equal $sdata $data]} {
+ set newphoto 0
+ }
+ }
+ }
+ if {$newphoto} {
+ lappend subElems [wrapper::createtag "TYPE" -chdata $mime]
+ lappend subElems [wrapper::createtag "BINVAL" -chdata $photo]
+ set photoE [wrapper::createtag "PHOTO" -subtags $subElems]
+ if {$vcardE eq {}} {
+ set xmllist [wrapper::createtag "vCard" \
+ -attrlist [list xmlns $xmlns(vcard)] \
+ -subtags [list $photoE]]
+ } else {
+ set xmllist [wrapper::setchildwithtag $vcardE $photoE]
+ }
+ jlib::send_iq $jlibname "set" [list $xmllist] -command \
+ [list [namespace current]::set_my_photo_cb $jlibname $cmd]
+ }
+ } else {
+
+ # Remove any photo. If there is no PHOTO no need to set.
+ set photoE [wrapper::getfirstchildwithtag $subiq "PHOTO"]
+ if {[llength $photoE]} {
+ set xmllist [wrapper::deletechildswithtag $subiq "PHOTO"]
+ jlib::send_iq $jlibname "set" [list $xmllist] -command \
+ [list [namespace current]::set_my_photo_cb $jlibname $cmd]
+ }
+ }
+ } else {
+ uplevel #0 $cmd [list $jlibname $type $subiq]
+ }
+}
+
+proc jlib::vcard::set_my_photo_cb {jlibname cmd type subiq} {
+
+ uplevel #0 $cmd [list $jlibname $type $subiq]
+}
+
+proc jlib::vcard::has_cache {jlibname jid} {
+ upvar ${jlibname}::vcard::state state
+
+ set mjid [jlib::jidmap $jid]
+ return [info exists state(cache,$mjid)]
+}
+
+proc jlib::vcard::get_cache {jlibname jid} {
+ upvar ${jlibname}::vcard::state state
+
+ set mjid [jlib::jidmap $jid]
+ if {[info exists state(cache,$mjid)]} {
+ return $state(cache,$mjid)
+ } else {
+ return
+ }
+}
+
+# jlib::vcard::send_set, createvcard --
+#
+# Sends our vCard to the server. Internally we use all lower case
+# but the spec (XEP-0054) says that all tags be all upper case.
+#
+# Arguments:
+# jlibname: the instance of this jlib.
+# cmd: client command to be executed at the iq "result" element.
+# args: All keys are named so that the element hierarchy becomes
+# vcardElement_subElement_subsubElement ... and so on;
+# all lower case.
+#
+# Results:
+# none.
+
+proc jlib::vcard::send_set {jlibname cmd args} {
+ upvar ${jlibname}::vcard::state state
+
+ set jid [$jlibname myjid2]
+ set xmllist [eval {create $jlibname} $args]
+ set state(cache,$jid) $xmllist
+ jlib::send_iq $jlibname "set" [list $xmllist] -command \
+ [list [namespace current]::send_set_cb $jlibname $cmd]
+ return
+}
+
+proc jlib::vcard::create {jlibname args} {
+ variable xmlns
+
+ set attrlist [list xmlns $xmlns(vcard)]
+
+ # Form all the sub elements by inspecting the -key.
+ array set arr $args
+ set subE [list]
+
+ # All "sub" elements with no children.
+ foreach tag {fn nickname bday url title role desc} {
+ if {[info exists arr(-$tag)]} {
+ lappend subE [wrapper::createtag [string toupper $tag] \
+ -chdata $arr(-$tag)]
+ }
+ }
+ if {[info exists arr(-email_internet_pref)]} {
+ set elem [list]
+ lappend elem [wrapper::createtag "INTERNET"]
+ lappend elem [wrapper::createtag "PREF"]
+ lappend subE [wrapper::createtag "EMAIL" \
+ -chdata $arr(-email_internet_pref) -subtags $elem]
+ }
+ if {[info exists arr(-email_internet)]} {
+ foreach email $arr(-email_internet) {
+ set elem [list]
+ lappend elem [wrapper::createtag "INTERNET"]
+ lappend subE [wrapper::createtag "EMAIL" \
+ -chdata $email -subtags $elem]
+ }
+ }
+
+ # All "subsub" elements.
+ foreach tag {n org} {
+ set elem [list]
+ foreach key [array names arr "-${tag}_*"] {
+ regexp -- "-${tag}_(.+)" $key match sub
+ lappend elem [wrapper::createtag [string toupper $sub] \
+ -chdata $arr($key)]
+ }
+
+ # Insert subsub elements where they belong.
+ if {[llength $elem]} {
+ lappend subE [wrapper::createtag [string toupper $tag] \
+ -subtags $elem]
+ }
+ }
+
+ # The <adr><home/>, <adr><work/> sub elements.
+ foreach tag {adr_home adr_work} {
+ regexp -- {([^_]+)_(.+)} $tag match head sub
+ set elem [list [wrapper::createtag [string toupper $sub]]]
+ set haveThisTag 0
+ foreach key [array names arr "-${tag}_*"] {
+ set haveThisTag 1
+ regexp -- "-${tag}_(.+)" $key match sub
+ lappend elem [wrapper::createtag [string toupper $sub] \
+ -chdata $arr($key)]
+ }
+ if {$haveThisTag} {
+ lappend subE [wrapper::createtag [string toupper $head] \
+ -subtags $elem]
+ }
+ }
+
+ # The <tel> sub elements.
+ foreach tag [array names arr "-tel_*"] {
+ if {[regexp -- {-tel_([^_]+)_([^_]+)} $tag match second third]} {
+ set elem {}
+ lappend elem [wrapper::createtag [string toupper $second]]
+ lappend elem [wrapper::createtag [string toupper $third]]
+ lappend subE [wrapper::createtag "TEL" -chdata $arr($tag) \
+ -subtags $elem]
+ }
+ }
+
+ # The <photo> sub elements.
+ if {[info exists arr(-photo_binval)]} {
+ set elem {}
+ lappend elem [wrapper::createtag "BINVAL" -chdata $arr(-photo_binval)]
+ if {[info exists arr(-photo_type)]} {
+ lappend elem [wrapper::createtag "TYPE" -chdata $arr(-photo_type)]
+ }
+ lappend subE [wrapper::createtag "PHOTO" -subtags $elem]
+ }
+
+ return [wrapper::createtag "vCard" -attrlist $attrlist -subtags $subE]
+}
+
+proc jlib::vcard::send_set_cb {jlibname cmd type subiq args} {
+
+ uplevel #0 $cmd [list $jlibname $type $subiq]
+}
+
+proc jlib::vcard::cache {jlibname args} {
+ upvar ${jlibname}::vcard::state state
+
+ if {[llength $args] == 1} {
+ set state(cache) [lindex $args 0]
+ }
+ return $state(cache)
+}
+
+proc jlib::vcard::clear {jlibname {jid ""}} {
+ upvar ${jlibname}::vcard::state state
+
+ if {$jid eq ""} {
+ array unset state "cache,*"
+ } else {
+ set mjid [jlib::jidmap $jid]
+ array unset state "cache,[jlib::ESC $mjid]"
+ }
+}
+
+# We have to do it here since need the initProc before doing this.
+
+namespace eval jlib::vcard {
+
+ jlib::ensamble_register vcard \
+ [namespace current]::init \
+ [namespace current]::cmdproc
+}
+
+
+
--- /dev/null
+################################################################################
+#
+# wrapper.tcl
+#
+# This file defines wrapper procedures. These
+# procedures are called by functions in jabberlib, and
+# they in turn call the TclXML library functions.
+#
+# Copyright (c) 2002-2008 Mats Bengtsson
+#
+# This file is distributed under BSD style license.
+#
+# $Id: wrapper.tcl,v 1.41 2008/03/26 15:37:23 matben Exp $
+#
+# ########################### INTERNALS ########################################
+#
+# The whole parse tree is stored as a hierarchy of lists as:
+#
+# parent = {tag attrlist isempty cdata {child1 child2 ...}}
+#
+# where the childs are in turn a list of identical structure:
+#
+# child1 = {tag attrlist isempty cdata {grandchild1 grandchild2 ...}}
+# child2 = {tag attrlist isempty cdata {grandchild1 grandchild2 ...}}
+#
+# etc.
+#
+# ########################### USAGE ############################################
+#
+# NAME
+# wrapper::new - a wrapper for the TclXML parser.
+# SYNOPSIS
+# wrapper::new streamstartcmd streamendcmd parsecmd errorcmd
+# OPTIONS
+# none
+# COMMANDS
+# wrapper::reset wrapID
+# wrapper::createxml xmllist
+# wrapper::createtag tagname ?args?
+# wrapper::getattr attrlist attrname
+# wrapper::setattr attrlist attrname value
+# wrapper::parse id xml
+# wrapper::xmlcrypt chdata
+# wrapper::gettag xmllist
+# wrapper::getattrlist xmllist
+# wrapper::getisempty xmllist
+# wrapper::getcdata xmllist
+# wrapper::getchildren xmllist
+# wrapper::getattribute xmllist attrname
+# wrapper::setattrlist xmllist attrlist
+# wrapper::setcdata xmllist cdata
+# wrapper::splitxml xmllist tagVar attrVar cdataVar childVar
+#
+# ########################### LIMITATIONS ######################################
+#
+# Mixed elements of character data and elements are not working.
+#
+# ########################### CHANGES ##########################################
+#
+# 0.* by Kerem HADIMLI and Todd Bradley
+# 1.0a1 complete rewrite, and first release by Mats Bengtsson
+# 1.0a2 a few fixes
+# 1.0a3 wrapper::reset was not right, -ignorewhitespace,
+# -defaultexpandinternalentities
+# 1.0b1 added wrapper::parse command, configured for expat,
+# return break at stream end
+# 1.0b2 fix to make parser reentrant
+# 030910 added accessor functions to get/set xmllist elements
+# 031103 added splitxml command
+
+
+if {[catch {package require tdom}]} {
+ package require xml 3.1
+}
+
+namespace eval wrapper {
+
+ # The public interface.
+ namespace export what
+
+ # Keep all internal data in this array, with 'id' as first index.
+ variable wrapper
+
+ # Running id that is never reused; start from 0.
+ set wrapper(uid) 0
+
+ # Keep all 'id's in this list.
+ set wrapper(list) [list]
+
+ variable xmldefaults {-isempty 1 -attrlist {} -chdata {} -subtags {}}
+}
+
+# wrapper::new --
+#
+# Contains initializations needed for the wrapper.
+# Sets up callbacks via the XML parser.
+#
+# Arguments:
+# streamstartcmd: callback when level one start tag received
+# streamendcmd: callback when level one end tag received
+# parsecmd: callback when level two end tag received
+# errorcmd callback when receiving an error from the XML parser.
+# Must all be fully qualified names.
+#
+# Results:
+# A unique wrapper id.
+
+proc wrapper::new {streamstartcmd streamendcmd parsecmd errorcmd} {
+ variable wrapper
+
+ # Handle id of the wrapper.
+ set id wrap[incr wrapper(uid)]
+ lappend wrapper(list) $id
+
+ set wrapper($id,streamstartcmd) $streamstartcmd
+ set wrapper($id,streamendcmd) $streamendcmd
+ set wrapper($id,parsecmd) $parsecmd
+ set wrapper($id,errorcmd) $errorcmd
+
+ # Create the actual XML parser. It is created in our present namespace,
+ # at least for the tcl parser!!!
+
+ if {[llength [package provide tdom]]} {
+ #set wrapper($id,parser) [xml::parser -namespace 1]
+ set wrapper($id,parser) [expat -namespace 1]
+ set wrapper($id,class) "tdom"
+ $wrapper($id,parser) configure \
+ -final 0 \
+ -elementstartcommand [list [namespace current]::elementstart $id] \
+ -elementendcommand [list [namespace current]::elementend $id] \
+ -characterdatacommand [list [namespace current]::chdata $id] \
+ -ignorewhitespace 0
+ } else {
+ set wrapper($id,parser) [xml::parser]
+
+ # Investigate which parser class we've got, and act consequently.
+ set classes [::xml::parserclass info names]
+ if {[lsearch $classes "expat"] >= 0} {
+ set wrapper($id,class) "expat"
+ $wrapper($id,parser) configure \
+ -final 0 \
+ -reportempty 1 \
+ -elementstartcommand [list [namespace current]::elementstart $id] \
+ -elementendcommand [list [namespace current]::elementend $id] \
+ -characterdatacommand [list [namespace current]::chdata $id] \
+ -ignorewhitespace 1 \
+ -defaultexpandinternalentities 0
+ } else {
+ set wrapper($id,class) "tcl"
+ $wrapper($id,parser) configure \
+ -final 0 \
+ -reportempty 1 \
+ -elementstartcommand [list [namespace current]::elementstart $id] \
+ -elementendcommand [list [namespace current]::elementend $id] \
+ -characterdatacommand [list [namespace current]::chdata $id] \
+ -errorcommand [list [namespace current]::xmlerror $id] \
+ -ignorewhitespace 1 \
+ -defaultexpandinternalentities 0
+ }
+ }
+
+ # Experiment.
+ if {0} {
+ package require qdxml
+ set token [qdxml::create \
+ -elementstartcommand [list [namespace current]::elementstart $id] \
+ -elementendcommand [list [namespace current]::elementend $id] \
+ -characterdatacommand [list [namespace current]::chdata $id]]
+ set wrapper($id,parser) $token
+ }
+
+ # Current level; 0 before root tag; 1 just after root tag, 2 after
+ # command tag, etc.
+ set wrapper($id,level) 0
+ set wrapper($id,levelonetag) ""
+
+ # Level 1 is the main tag, <stream:stream>, and level 2
+ # is the command tag, such as <message>. We don't handle level 1 xmldata.
+ set wrapper($id,tree,2) [list]
+
+ set wrapper($id,refcount) 0
+ set wrapper($id,stack) ""
+
+ return $id
+}
+
+# wrapper::parse --
+#
+# For parsing xml.
+#
+# Arguments:
+# id: the wrapper id.
+# xml: raw xml data to be parsed.
+#
+# Results:
+# none.
+
+proc wrapper::parse {id xml} {
+ variable wrapper
+
+ # This is not as innocent as it looks; the 'tcl' parser proc is created in
+ # the creators namespace (wrapper::), but the 'expat' parser ???
+ parsereentrant $id $xml
+ return
+}
+
+# wrapper::parsereentrant --
+#
+# Forces parsing to be serialized in an event driven environment.
+# If we read xml from socket and happen to trigger a read (and parse)
+# event right from an element callback, everyhting will be out of sync.
+#
+# Arguments:
+# id: the wrapper id
+# xml: raw xml data to be parsed.
+#
+# Results:
+# none.
+
+proc wrapper::parsereentrant {id xml} {
+ variable wrapper
+
+ set p $wrapper($id,parser)
+ set refcount [incr wrapper($id,refcount)]
+
+ if {$refcount == 1} {
+
+ # This is the main entry: do parse original xml.
+ $p parse $xml
+
+ # Parse everything on the stack (until empty?).
+ while {[string length $wrapper($id,stack)] > 0} {
+ set tmp $wrapper($id,stack)
+ set wrapper($id,stack) ""
+ $p parse $tmp
+ }
+ } else {
+
+ # Reentry, put on stack for delayed execution.
+ append wrapper($id,stack) $xml
+ }
+
+ # If we was reset from callback 'refcount' can have been reset to 0.
+ incr wrapper($id,refcount) -1
+ if {$wrapper($id,refcount) < 0} {
+ set wrapper($id,refcount) 0
+ }
+ return
+}
+
+# wrapper::elementstart --
+#
+# Callback proc for all element start.
+#
+# Arguments:
+# id: the wrapper id.
+# tagname: the element (tag) name.
+# attrlist: list of attributes {key value key value ...}
+# args: additional arguments given by the parser.
+#
+# Results:
+# none.
+
+proc wrapper::elementstart {id tagname attrlist args} {
+ variable wrapper
+
+ # Check args, to see if empty element and/or namespace.
+ # Put xmlns in attribute list.
+ array set argsarr $args
+ set isempty 0
+ if {[info exists argsarr(-empty)]} {
+ set isempty $argsarr(-empty)
+ }
+ if {[info exists argsarr(-namespacedecls)]} {
+ lappend attrlist xmlns [lindex $argsarr(-namespacedecls) 0]
+ }
+
+ if {$wrapper($id,class) eq "tdom"} {
+ if {[set ndx [string last : $tagname]] != -1} {
+ set ns [string range $tagname 0 [expr {$ndx - 1}]]
+ set tagname [string range $tagname [incr ndx] end]
+ lappend attrlist xmlns $ns
+ }
+ }
+
+ if {$wrapper($id,level) == 0} {
+
+ # We got a root tag, such as <stream:stream>
+ set wrapper($id,level) 1
+ set wrapper($id,levelonetag) $tagname
+ set wrapper($id,tree,1) [list $tagname $attrlist $isempty {} {}]
+
+ # Do the registered callback at the global level.
+ uplevel #0 $wrapper($id,streamstartcmd) $attrlist
+
+ } else {
+
+ # This is either a level 2 command tag, such as 'presence', 'iq', or 'message',
+ # or we have got a new tag beyond level 2.
+ # It is time to start building the parse tree.
+ set level [incr wrapper($id,level)]
+ set wrapper($id,tree,$level) [list $tagname $attrlist $isempty {} {}]
+ }
+}
+
+# wrapper::elementend --
+#
+# Callback proc for all element ends.
+#
+# Arguments:
+# id: the wrapper id.
+# tagname: the element (tag) name.
+# args: additional arguments given by the parser.
+#
+# Results:
+# none.
+
+proc wrapper::elementend {id tagname args} {
+ variable wrapper
+
+ # tclxml doesn't do the reset properly but continues to send us endtags.
+ # qdxml behaves better!
+ if {!$wrapper($id,level)} {
+ return
+ }
+
+ # Check args, to see if empty element
+ set isempty 0
+ set ind [lsearch -exact $args {-empty}]
+ if {$ind >= 0} {
+ set isempty [lindex $args [expr {$ind + 1}]]
+ }
+ if {$wrapper($id,level) == 1} {
+
+ # End of the root tag (</stream:stream>).
+ # Do the registered callback at the global level.
+ uplevel #0 $wrapper($id,streamendcmd)
+
+ incr wrapper($id,level) -1
+
+ # We are in the middle of parsing, need to break.
+ reset $id
+ return -code 3
+ } else {
+
+ # We are finshed with this child tree.
+ set childlevel $wrapper($id,level)
+
+ # Insert the child tree in the parent tree.
+ # Avoid adding to the level 1 else we just consume memory forever [PT]
+ set level [incr wrapper($id,level) -1]
+ if {$level > 1} {
+ append_child $id $level $wrapper($id,tree,$childlevel)
+ } elseif {$level == 1} {
+
+ # We've got an end tag of a command tag, and it's time to
+ # deliver our parse tree to the registered callback proc.
+ uplevel #0 $wrapper($id,parsecmd) [list $wrapper($id,tree,2)]
+ }
+ }
+}
+
+# wrapper::append_child --
+#
+# Inserts a child element data in level temp data.
+#
+# Arguments:
+# id: the wrapper id.
+# level: the parent level, child is level+1.
+# childtree: the tree to append.
+#
+# Results:
+# none.
+
+proc wrapper::append_child {id level childtree} {
+ variable wrapper
+
+ # Get child list at parent level (level).
+ set childlist [lindex $wrapper($id,tree,$level) 4]
+ lappend childlist $childtree
+
+ # Build the new parent tree.
+ set wrapper($id,tree,$level) [lreplace $wrapper($id,tree,$level) 4 4 \
+ $childlist]
+}
+
+# wrapper::chdata --
+#
+# Appends character data to the tree level xml chdata.
+# It makes also internal entity replacements on character data.
+# Callback from the XML parser.
+#
+# Arguments:
+# id: the wrapper id.
+# chardata: the character data.
+#
+# Results:
+# none.
+
+proc wrapper::chdata {id chardata} {
+ variable wrapper
+
+ set level $wrapper($id,level)
+
+ # If we receive CHDATA before any root element,
+ # or after the last root element, discard.
+ if {$level <= 0} {
+ return
+ }
+ set chdata [lindex $wrapper($id,tree,$level) 3]
+
+ # Make standard entity replacements.
+ append chdata [xmldecrypt $chardata]
+ set wrapper($id,tree,$level) \
+ [lreplace $wrapper($id,tree,$level) 3 3 "$chdata"]
+}
+
+# wrapper::free --
+#
+# tdom doesn't permit freeing a parser from within a callback. So
+# we keep trying until it works.
+#
+
+proc wrapper::free {id} {
+ if {[catch {$id free}]} {
+ after 100 [list [namespace origin free] $id]
+ }
+}
+
+# wrapper::reset --
+#
+# Resets the wrapper and XML parser to be prepared for a fresh new
+# document.
+# If done while parsing be sure to return a break (3) from callback.
+#
+# Arguments:
+# id: the wrapper id.
+#
+# Results:
+# none.
+
+proc wrapper::reset {id} {
+ variable wrapper
+
+ if {$wrapper($id,class) eq "tdom"} {
+
+ # We cannot reset a tdom expat parser from within a callback. However,
+ # we can always replace it with a new one.
+ set old $wrapper($id,parser)
+ after idle [list [namespace origin free] $old]
+ #set wrapper($id,parser) [xml::parser -namespace 1]
+ set wrapper($id,parser) [expat -namespace 1]
+
+ $wrapper($id,parser) configure \
+ -final 0 \
+ -elementstartcommand [list [namespace current]::elementstart $id] \
+ -elementendcommand [list [namespace current]::elementend $id] \
+ -characterdatacommand [list [namespace current]::chdata $id] \
+ -ignorewhitespace 0
+ } else {
+
+ # This resets the actual XML parser. Not sure this is actually needed.
+ $wrapper($id,parser) reset
+
+ # Unfortunately it also removes all our callbacks and options.
+ if {$wrapper($id,class) eq "expat"} {
+ $wrapper($id,parser) configure \
+ -final 0 \
+ -reportempty 1 \
+ -elementstartcommand [list [namespace current]::elementstart $id] \
+ -elementendcommand [list [namespace current]::elementend $id] \
+ -characterdatacommand [list [namespace current]::chdata $id] \
+ -ignorewhitespace 1 \
+ -defaultexpandinternalentities 0
+ } else {
+ $wrapper($id,parser) configure \
+ -final 0 \
+ -reportempty 1 \
+ -elementstartcommand [list [namespace current]::elementstart $id] \
+ -elementendcommand [list [namespace current]::elementend $id] \
+ -characterdatacommand [list [namespace current]::chdata $id] \
+ -errorcommand [list [namespace current]::xmlerror $id] \
+ -ignorewhitespace 1 \
+ -defaultexpandinternalentities 0
+ }
+ }
+
+ # Cleanup internal state vars.
+ array unset wrapper $id,tree,*
+
+ # Reset also our internal wrapper to its initial position.
+ set wrapper($id,level) 0
+ set wrapper($id,levelonetag) ""
+ set wrapper($id,tree,2) [list]
+
+ set wrapper($id,refcount) 0
+ set wrapper($id,stack) ""
+}
+
+# wrapper::xmlerror --
+#
+# Callback from the XML parser when error received. Resets wrapper,
+# and makes a 'streamend' command callback.
+#
+# Arguments:
+# id: the wrapper id.
+#
+# Results:
+# none.
+
+proc wrapper::xmlerror {id args} {
+ variable wrapper
+
+ uplevel #0 $wrapper($id,errorcmd) $args
+}
+
+# wrapper::createxml --
+#
+# Creates raw xml data from a hierarchical list of xml code.
+# This proc gets called recursively for each child.
+# It makes also internal entity replacements on character data.
+# Mixed elements aren't treated correctly generally.
+#
+# Arguments:
+# xmllist a list of xml code in the format described in the header.
+#
+# Results:
+# raw xml data.
+
+proc wrapper::createxml {xmllist} {
+
+ # Extract the XML data items.
+ foreach {tag attrlist isempty chdata childlist} $xmllist { break }
+ set attrlist [xmlcrypt $attrlist]
+ set rawxml "<$tag"
+ foreach {attr value} $attrlist {
+ append rawxml " $attr='$value'"
+ }
+ if {$isempty} {
+ append rawxml "/>"
+ } else {
+ append rawxml ">"
+
+ # Call ourselves recursively for each child element.
+ # There is an arbitrary choice here where childs are put before PCDATA.
+ foreach child $childlist {
+ append rawxml [createxml $child]
+ }
+
+ # Make standard entity replacements.
+ if {[string length $chdata]} {
+ append rawxml [xmlcrypt $chdata]
+ }
+ append rawxml "</$tag>"
+ }
+ return $rawxml
+}
+
+# wrapper::formatxml, formattag --
+#
+# Creates formatted raw xml data from a xml list.
+
+proc wrapper::formatxml {xmllist args} {
+ variable tabs
+ variable nl
+ variable prefix
+
+ array set argsA {
+ -prefix ""
+ }
+ array set argsA $args
+ set prefix $argsA(-prefix)
+ set nl ""
+ set tabs ""
+ formattag $xmllist
+}
+
+proc wrapper::formattag {xmllist} {
+ variable tabs
+ variable nl
+ variable prefix
+
+ foreach {tag attrlist isempty chdata childlist} $xmllist { break }
+ set attrlist [xmlcrypt $attrlist]
+ set rawxml "$nl$prefix$tabs<$tag"
+ foreach {attr value} $attrlist {
+ append rawxml " $attr='$value'"
+ }
+ set nl "\n"
+ if {$isempty} {
+ append rawxml "/>"
+ } else {
+ append rawxml ">"
+ if {[llength $childlist]} {
+ append tabs "\t"
+ foreach child $childlist {
+ append rawxml [formattag $child]
+ }
+ set tabs [string range $tabs 0 end-1]
+ append rawxml "$nl$prefix$tabs</$tag>"
+ } else {
+ if {[string length $chdata]} {
+ append rawxml [xmlcrypt $chdata]
+ }
+ append rawxml "</$tag>"
+ }
+ }
+ return $rawxml
+}
+
+# wrapper::createtag --
+#
+# Build an element list given the tag and the args.
+#
+# Arguments:
+# tagname: the name of this element.
+# args:
+# -empty 0|1 Is this an empty tag? If $chdata
+# and $subtags are empty, then whether
+# to make the tag empty or not is decided
+# here. (default: 1)
+# -attrlist {attr1 value1 attr2 value2 ..} Vars is a list
+# consisting of attr/value pairs, as shown.
+# -chdata $chdata ChData of tag (default: "").
+# -subtags {$subchilds $subchilds ...} is a list containing xmldata
+# of $tagname's subtags. (default: no sub-tags)
+#
+# Results:
+# a list suitable for wrapper::createxml.
+
+proc wrapper::createtag {tagname args} {
+ variable xmldefaults
+
+ # Fill in the defaults.
+ array set xmlarr $xmldefaults
+
+ # Override the defults with actual values.
+ if {[llength $args]} {
+ array set xmlarr $args
+ }
+ if {[string length $xmlarr(-chdata)] || [llength $xmlarr(-subtags)]} {
+ set xmlarr(-isempty) 0
+ }
+
+ # Build sub elements list.
+ set sublist [list]
+ foreach child $xmlarr(-subtags) {
+ lappend sublist $child
+ }
+ set xmllist [list $tagname $xmlarr(-attrlist) $xmlarr(-isempty) \
+ $xmlarr(-chdata) $sublist]
+ return $xmllist
+}
+
+# wrapper::validxmllist --
+#
+# Makes a primitive check to see if this is a valid xmllist.
+
+proc wrapper::validxmllist {xmllist} {
+ return [expr ([llength $xmllist] == 5) ? 1 : 0]
+}
+
+# wrapper::getattr --
+#
+# This proc returns the value of 'attrname' from 'attrlist'.
+#
+# Arguments:
+# attrlist: a list of key value pairs for the attributes.
+# attrname: the name of the attribute which value we query.
+#
+# Results:
+# value of the attribute or empty.
+
+proc wrapper::getattr {attrlist attrname} {
+
+ foreach {attr val} $attrlist {
+ if {[string equal $attr $attrname]} {
+ return $val
+ }
+ }
+ return
+}
+
+proc wrapper::getattribute {xmllist attrname} {
+
+ foreach {attr val} [lindex $xmllist 1] {
+ if {[string equal $attr $attrname]} {
+ return $val
+ }
+ }
+ return
+}
+
+proc wrapper::isattr {attrlist attrname} {
+
+ foreach {attr val} $attrlist {
+ if {[string equal $attr $attrname]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+proc wrapper::isattribute {xmllist attrname} {
+
+ foreach {attr val} [lindex $xmllist 1] {
+ if {[string equal $attr $attrname]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+proc wrapper::setattr {attrlist attrname value} {
+
+ array set attrArr $attrlist
+ set attrArr($attrname) $value
+ return [array get attrArr]
+}
+
+# wrapper::gettag, getattrlist, getisempty, getcdata, getchildren --
+#
+# Accessor functions for 'xmllist'.
+# {tag attrlist isempty cdata {grandchild1 grandchild2 ...}}
+#
+# Arguments:
+# xmllist: an xml hierarchical list.
+#
+# Results:
+# list of childrens if any.
+
+proc wrapper::gettag {xmllist} {
+ return [lindex $xmllist 0]
+}
+
+proc wrapper::getattrlist {xmllist} {
+ return [lindex $xmllist 1]
+}
+
+proc wrapper::getisempty {xmllist} {
+ return [lindex $xmllist 2]
+}
+
+proc wrapper::getcdata {xmllist} {
+ return [lindex $xmllist 3]
+}
+
+proc wrapper::getchildren {xmllist} {
+ return [lindex $xmllist 4]
+}
+
+proc wrapper::splitxml {xmllist tagVar attrVar cdataVar childVar} {
+
+ foreach {tag attr empty cdata children} $xmllist break
+ uplevel 1 [list set $tagVar $tag]
+ uplevel 1 [list set $attrVar $attr]
+ uplevel 1 [list set $cdataVar $cdata]
+ uplevel 1 [list set $childVar $children]
+}
+
+proc wrapper::getchildswithtag {xmllist tag} {
+
+ set clist [list]
+ foreach celem [lindex $xmllist 4] {
+ if {[string equal [lindex $celem 0] $tag]} {
+ lappend clist $celem
+ }
+ }
+ return $clist
+}
+
+proc wrapper::getfirstchildwithtag {xmllist tag} {
+
+ set c [list]
+ foreach celem [lindex $xmllist 4] {
+ if {[string equal [lindex $celem 0] $tag]} {
+ set c $celem
+ break
+ }
+ }
+ return $c
+}
+
+proc wrapper::havechildtag {xmllist tag} {
+ return [llength [getfirstchildwithtag $xmllist $tag]]
+}
+
+proc wrapper::getfirstchildwithxmlns {xmllist ns} {
+
+ set c [list]
+ foreach celem [lindex $xmllist 4] {
+ unset -nocomplain attr
+ array set attr [lindex $celem 1]
+ if {[info exists attr(xmlns)] && [string equal $attr(xmlns) $ns]} {
+ set c $celem
+ break
+ }
+ }
+ return $c
+}
+
+proc wrapper::getchildswithtagandxmlns {xmllist tag ns} {
+
+ set clist [list]
+ foreach celem [lindex $xmllist 4] {
+ if {[string equal [lindex $celem 0] $tag]} {
+ unset -nocomplain attr
+ array set attr [lindex $celem 1]
+ if {[info exists attr(xmlns)] && [string equal $attr(xmlns) $ns]} {
+ lappend clist $celem
+ }
+ }
+ }
+ return $clist
+}
+
+proc wrapper::getfirstchild {xmllist tag ns} {
+
+ set elem [list]
+ foreach celem [lindex $xmllist 4] {
+ if {[string equal [lindex $celem 0] $tag]} {
+ unset -nocomplain attr
+ array set attr [lindex $celem 1]
+ if {[info exists attr(xmlns)] && [string equal $attr(xmlns) $ns]} {
+ set elem $celem
+ break
+ }
+ }
+ }
+ return $elem
+}
+
+proc wrapper::getfromchilds {childs tag} {
+
+ set clist [list]
+ foreach celem $childs {
+ if {[string equal [lindex $celem 0] $tag]} {
+ lappend clist $celem
+ }
+ }
+ return $clist
+}
+
+proc wrapper::deletefromchilds {childs tag} {
+
+ set clist [list]
+ foreach celem $childs {
+ if {![string equal [lindex $celem 0] $tag]} {
+ lappend clist $celem
+ }
+ }
+ return $clist
+}
+
+proc wrapper::getnamespacefromchilds {childs tag ns} {
+
+ set clist [list]
+ foreach celem $childs {
+ if {[string equal [lindex $celem 0] $tag]} {
+ unset -nocomplain attr
+ array set attr [lindex $celem 1]
+ if {[info exists attr(xmlns)] && [string equal $attr(xmlns) $ns]} {
+ lappend clist $celem
+ break
+ }
+ }
+ }
+ return $clist
+}
+
+# wrapper::getchilddeep --
+#
+# Searches recursively for the first child with matching tags and
+# optionally matching xmlns attributes.
+#
+# Arguments:
+# xmllist: an xml hierarchical list.
+# specs: {{tag ?xmlns?} {tag ?xmlns?} ...}
+#
+# Results:
+# first found matching child element or empty if not found
+
+proc wrapper::getchilddeep {xmllist specs} {
+
+ set xlist $xmllist
+
+ foreach cspec $specs {
+ set tag [lindex $cspec 0]
+ set xmlns [lindex $cspec 1]
+ set match 0
+
+ foreach c [lindex $xlist 4] {
+ if {[string equal $tag [lindex $c 0]]} {
+ if {[string length $xmlns]} {
+ array unset attr
+ array set attr [lindex $c 1]
+ if {[info exists attr(xmlns)] && \
+ [string equal $xmlns $attr(xmlns)]} {
+ set xlist $c
+ set match 1
+ break
+ } else {
+ # tag matched but not xmlns; go for next child.
+ continue
+ }
+ }
+ set xlist $c
+ set match 1
+ break
+ }
+ }
+ # No matches found.
+ if {!$match} {
+ return
+ }
+ }
+ return $xlist
+}
+
+proc wrapper::setattrlist {xmllist attrlist} {
+ return [lreplace $xmllist 1 1 $attrlist]
+}
+
+proc wrapper::setcdata {xmllist cdata} {
+ return [lreplace $xmllist 3 3 $cdata]
+}
+
+proc wrapper::setchildlist {xmllist childlist} {
+ return [lreplace $xmllist 4 4 $childlist]
+}
+
+# wrapper::setchildwithtag --
+#
+# Replaces any element with same tag.
+# If not there it will be added.
+# xmllist must be nonempty.
+
+proc wrapper::setchildwithtag {xmllist elem} {
+ set tag [lindex $elem 0]
+ set clist [list]
+ foreach c [lindex $xmllist 4] {
+ if {[lindex $c 0] ne $tag} {
+ lappend clist $c
+ }
+ }
+ lappend clist $elem
+ # IMPORTANT:
+ lset xmllist 2 0
+ return [lreplace $xmllist 4 4 $clist]
+}
+
+# wrapper::deletechildswithtag --
+#
+# Deletes any element with tag.
+# xmllist must be nonempty.
+
+proc wrapper::deletechildswithtag {xmllist tag} {
+ set clist [list]
+ foreach c [lindex $xmllist 4] {
+ if {[lindex $c 0] ne $tag} {
+ lappend clist $c
+ }
+ }
+ return [lreplace $xmllist 4 4 $clist]
+}
+
+# wrapper::xmlcrypt --
+#
+# Makes standard XML entity replacements.
+#
+# Arguments:
+# chdata: character data.
+#
+# Results:
+# chdata with XML standard entities replaced.
+
+proc wrapper::xmlcrypt {chdata} {
+
+ # RFC 3454 (STRINGPREP):
+ # C.2.1 ASCII control characters
+ # 0000-001F; [CONTROL CHARACTERS]
+ # 007F; DELETE
+
+ return [string map {& & < < > > \" " ' '
+ \x00 " " \x01 " " \x02 " " \x03 " "
+ \x04 " " \x05 " " \x06 " " \x07 " "
+ \x08 " " \x0B " "
+ \x0C " " \x0E " " \x0F " "
+ \x10 " " \x11 " " \x12 " " \x13 " "
+ \x14 " " \x15 " " \x16 " " \x17 " "
+ \x18 " " \x19 " " \x1A " " \x1B " "
+ \x1C " " \x1D " " \x1E " " \x1F " "
+ \x7F " "} $chdata]
+}
+
+# wrapper::xmldecrypt --
+#
+# Replaces the XML standard entities with real characters.
+#
+# Arguments:
+# chdata: character data.
+#
+# Results:
+# chdata without any XML standard entities.
+
+proc wrapper::xmldecrypt {chdata} {
+
+ return [string map {
+ {&} {&} {<} {<} {>} {>} {"} {"} {'} {'}} $chdata]
+ #'"
+}
+
+# wrapper::parse_xmllist_to_array --
+#
+# Takes a hierarchical list of xml data and parses the character data
+# into array elements. The array key of each element is constructed as:
+# rootTag_subTag_subSubTag.
+# Repetitative elements are not parsed correctly.
+# Mixed elements of chdata and tags are not allowed.
+# This is typically called without a 'key' argument.
+#
+# Arguments:
+# xmllist: a hierarchical list of xml data as defined above.
+# arrName:
+# key: (optional) the rootTag, typically only used internally.
+#
+# Results:
+# none. Array elements filled.
+
+proc wrapper::parse_xmllist_to_array {xmllist arrName {key {}}} {
+
+ upvar #0 $arrName locArr
+
+ # Return if empty element.
+ if {[lindex $xmllist 2]} {
+ return
+ }
+ if {[string length $key]} {
+ set und {_}
+ } else {
+ set und {}
+ }
+
+ set childs [lindex $xmllist 4]
+ if {[llength $childs]} {
+ foreach c $childs {
+ set newkey "${key}${und}[lindex $c 0]"
+
+ # Call ourselves recursively.
+ parse_xmllist_to_array $c $arrName $newkey
+ }
+ } else {
+
+ # This is a leaf of the tree structure.
+ set locArr($key) [lindex $xmllist 3]
+ }
+ return
+}
+
+#-------------------------------------------------------------------------------
+package provide wrapper 1.2
+
--- /dev/null
+# log.tcl --
+#
+# Tcl implementation of a general logging facility
+# (Reaped from Pool_Base and modified to fit into tcllib)
+#
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# See the file license.terms.
+
+package require Tcl 8
+package provide log 1.2
+
+# ### ### ### ######### ######### #########
+
+namespace eval ::log {
+ namespace export levels lv2longform lv2color lv2priority
+ namespace export lv2cmd lv2channel lvCompare
+ namespace export lvSuppress lvSuppressLE lvIsSuppressed
+ namespace export lvCmd lvCmdForall
+ namespace export lvChannel lvChannelForall lvColor lvColorForall
+ namespace export log logMsg logError
+
+ # The known log-levels.
+
+ variable levels [list \
+ emergency \
+ alert \
+ critical \
+ error \
+ warning \
+ notice \
+ info \
+ debug]
+
+ # Array mapping from all unique prefixes for log levels to their
+ # corresponding long form.
+
+ # *future* Use a procedure from 'textutil' to calculate the
+ # prefixes and to fill the map.
+
+ variable levelMap
+ array set levelMap {
+ a alert
+ al alert
+ ale alert
+ aler alert
+ alert alert
+ c critical
+ cr critical
+ cri critical
+ crit critical
+ criti critical
+ critic critical
+ critica critical
+ critical critical
+ d debug
+ de debug
+ deb debug
+ debu debug
+ debug debug
+ em emergency
+ eme emergency
+ emer emergency
+ emerg emergency
+ emerge emergency
+ emergen emergency
+ emergenc emergency
+ emergency emergency
+ er error
+ err error
+ erro error
+ error error
+ i info
+ in info
+ inf info
+ info info
+ n notice
+ no notice
+ not notice
+ noti notice
+ notic notice
+ notice notice
+ w warning
+ wa warning
+ war warning
+ warn warning
+ warni warning
+ warnin warning
+ warning warning
+ }
+
+ # Map from log-levels to the commands to execute when a message
+ # with that level arrives in the system. The standard command for
+ # all levels is '::log::Puts' which writes the message to either
+ # stdout or stderr, depending on the level. The decision about the
+ # channel is stored in another map and modifiable by the user of
+ # the package.
+
+ variable cmdMap
+ array set cmdMap {}
+
+ variable lv
+ foreach lv $levels {set cmdMap($lv) ::log::Puts}
+ unset lv
+
+ # Map from log-levels to the channels ::log::Puts shall write
+ # messages with that level to. The map can be queried and changed
+ # by the user.
+
+ variable channelMap
+ array set channelMap {
+ emergency stderr
+ alert stderr
+ critical stderr
+ error stderr
+ warning stdout
+ notice stdout
+ info stdout
+ debug stdout
+ }
+
+ # Graphical user interfaces may want to colorize messages based
+ # upon their level. The following array stores a map from levels
+ # to colors. The map can be queried and changed by the user.
+
+ variable colorMap
+ array set colorMap {
+ emergency red
+ alert red
+ critical red
+ error red
+ warning yellow
+ notice seagreen
+ info {}
+ debug lightsteelblue
+ }
+
+ # To allow an easy comparison of the relative importance of a
+ # level the following array maps from levels to a numerical
+ # priority. The higher the number the more important the
+ # level. The user cannot change this map (for now). This package
+ # uses the priorities to allow the user to supress messages based
+ # upon their levels.
+
+ variable priorityMap
+ array set priorityMap {
+ emergency 7
+ alert 6
+ critical 5
+ error 4
+ warning 3
+ notice 2
+ info 1
+ debug 0
+ }
+
+ # The following array is internal and holds the information about
+ # which levels are suppressed, i.e. may not be written.
+ #
+ # 0 - messages with with level are written out.
+ # 1 - messages with this level are suppressed.
+
+ variable suppressed
+ array set suppressed {
+ emergency 0
+ alert 0
+ critical 0
+ error 0
+ warning 0
+ notice 0
+ info 0
+ debug 0
+ }
+
+ # Internal static information. Map from levels to a string of
+ # spaces. The number of spaces in each string is just enough to
+ # make all level names together with their string of the same
+ # length.
+
+ variable fill
+ array set fill {
+ emergency "" alert " " critical " " error " "
+ warning " " notice " " info " " debug " "
+ }
+}
+
+
+# log::levels --
+#
+# Retrieves the names of all known levels.
+#
+# Arguments:
+# None.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# A list containing the names of all known levels,
+# alphabetically sorted.
+
+proc ::log::levels {} {
+ variable levels
+ return [lsort $levels]
+}
+
+# log::lv2longform --
+#
+# Converts any unique abbreviation of a level name to the full
+# level name.
+#
+# Arguments:
+# level The prefix of a level name to convert.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# Returns the full name to the specified abbreviation or an
+# error.
+
+proc ::log::lv2longform {level} {
+ variable levelMap
+
+ if {[info exists levelMap($level)]} {
+ return $levelMap($level)
+ }
+
+ return -code error "\"$level\" is no unique abbreviation of a level name"
+}
+
+# log::lv2color --
+#
+# Converts any level name including unique abbreviations to the
+# corresponding color.
+#
+# Arguments:
+# level The level to convert into a color.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# The name of a color or an error.
+
+proc ::log::lv2color {level} {
+ variable colorMap
+ set level [lv2longform $level]
+ return $colorMap($level)
+}
+
+# log::lv2priority --
+#
+# Converts any level name including unique abbreviations to the
+# corresponding priority.
+#
+# Arguments:
+# level The level to convert into a priority.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# The numerical priority of the level or an error.
+
+proc ::log::lv2priority {level} {
+ variable priorityMap
+ set level [lv2longform $level]
+ return $priorityMap($level)
+}
+
+# log::lv2cmd --
+#
+# Converts any level name including unique abbreviations to the
+# command prefix used to write messages with that level.
+#
+# Arguments:
+# level The level to convert into a command prefix.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# A string containing a command prefix or an error.
+
+proc ::log::lv2cmd {level} {
+ variable cmdMap
+ set level [lv2longform $level]
+ return $cmdMap($level)
+}
+
+# log::lv2channel --
+#
+# Converts any level name including unique abbreviations to the
+# channel used by ::log::Puts to write messages with that level.
+#
+# Arguments:
+# level The level to convert into a channel.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# A string containing a channel handle or an error.
+
+proc ::log::lv2channel {level} {
+ variable channelMap
+ set level [lv2longform $level]
+ return $channelMap($level)
+}
+
+# log::lvCompare --
+#
+# Compares two levels (including unique abbreviations) with
+# respect to their priority. This command can be used by the
+# -command option of lsort.
+#
+# Arguments:
+# level1 The first of the levels to compare.
+# level2 The second of the levels to compare.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# One of -1, 0 or 1 or an error. A result of -1 signals that
+# level1 is of less priority than level2. 0 signals that both
+# levels have the same priority. 1 signals that level1 has
+# higher priority than level2.
+
+proc ::log::lvCompare {level1 level2} {
+ variable priorityMap
+
+ set level1 $priorityMap([lv2longform $level1])
+ set level2 $priorityMap([lv2longform $level2])
+
+ if {$level1 < $level2} {
+ return -1
+ } elseif {$level1 > $level2} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# log::lvSuppress --
+#
+# (Un)suppresses the output of messages having the specified
+# level. Unique abbreviations for the level are allowed here
+# too.
+#
+# Arguments:
+# level The name of the level to suppress or
+# unsuppress. Unique abbreviations are allowed
+# too.
+# suppress Boolean flag. Optional. Defaults to the value
+# 1, which means to suppress the level. The
+# value 0 on the other hand unsuppresses the
+# level.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvSuppress {level {suppress 1}} {
+ variable suppressed
+ set level [lv2longform $level]
+
+ switch -exact -- $suppress {
+ 0 - 1 {} default {
+ return -code error "\"$suppress\" is not a member of \{0, 1\}"
+ }
+ }
+
+ set suppressed($level) $suppress
+ return
+}
+
+# log::lvSuppressLE --
+#
+# (Un)suppresses the output of messages having the specified
+# level or one of lesser priority. Unique abbreviations for the
+# level are allowed here too.
+#
+# Arguments:
+# level The name of the level to suppress or
+# unsuppress. Unique abbreviations are allowed
+# too.
+# suppress Boolean flag. Optional. Defaults to the value
+# 1, which means to suppress the specified
+# levels. The value 0 on the other hand
+# unsuppresses the levels.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvSuppressLE {level {suppress 1}} {
+ variable suppressed
+ variable levels
+ variable priorityMap
+
+ set level [lv2longform $level]
+
+ switch -exact -- $suppress {
+ 0 - 1 {} default {
+ return -code error "\"$suppress\" is not a member of \{0, 1\}"
+ }
+ }
+
+ set prio [lv2priority $level]
+
+ foreach l $levels {
+ if {$priorityMap($l) <= $prio} {
+ set suppressed($l) $suppress
+ }
+ }
+ return
+}
+
+# log::lvIsSuppressed --
+#
+# Asks the package wether the specified level is currently
+# suppressed. Unique abbreviations of level names are allowed.
+#
+# Arguments:
+# level The level to query.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# None.
+
+proc ::log::lvIsSuppressed {level} {
+ variable suppressed
+ set level [lv2longform $level]
+ return $suppressed($level)
+}
+
+# log::lvCmd --
+#
+# Defines for the specified level with which command to write
+# the messages having this level. Unique abbreviations of level
+# names are allowed. The command is actually a command prefix
+# and this facility will append 2 arguments before calling it,
+# the level of the message and the message itself, in this
+# order.
+#
+# Arguments:
+# level The level the command prefix is for.
+# cmd The command prefix to use for the specified level.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvCmd {level cmd} {
+ variable cmdMap
+ set level [lv2longform $level]
+ set cmdMap($level) $cmd
+ return
+}
+
+# log::lvCmdForall --
+#
+# Defines for all known levels with which command to write the
+# messages having this level. The command is actually a command
+# prefix and this facility will append 2 arguments before
+# calling it, the level of the message and the message itself,
+# in this order.
+#
+# Arguments:
+# cmd The command prefix to use for all levels.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvCmdForall {cmd} {
+ variable cmdMap
+ variable levels
+
+ foreach l $levels {
+ set cmdMap($l) $cmd
+ }
+ return
+}
+
+# log::lvChannel --
+#
+# Defines for the specified level into which channel ::log::Puts
+# (the standard command) shall write the messages having this
+# level. Unique abbreviations of level names are allowed. The
+# command is actually a command prefix and this facility will
+# append 2 arguments before calling it, the level of the message
+# and the message itself, in this order.
+#
+# Arguments:
+# level The level the channel is for.
+# chan The channel to use for the specified level.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvChannel {level chan} {
+ variable channelMap
+ set level [lv2longform $level]
+ set channelMap($level) $chan
+ return
+}
+
+# log::lvChannelForall --
+#
+# Defines for all known levels with which which channel
+# ::log::Puts (the standard command) shall write the messages
+# having this level. The command is actually a command prefix
+# and this facility will append 2 arguments before calling it,
+# the level of the message and the message itself, in this
+# order.
+#
+# Arguments:
+# chan The channel to use for all levels.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvChannelForall {chan} {
+ variable channelMap
+ variable levels
+
+ foreach l $levels {
+ set channelMap($l) $chan
+ }
+ return
+}
+
+# log::lvColor --
+#
+# Defines for the specified level the color to return for it in
+# a call to ::log::lv2color. Unique abbreviations of level names
+# are allowed.
+#
+# Arguments:
+# level The level the color is for.
+# color The color to use for the specified level.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvColor {level color} {
+ variable colorMap
+ set level [lv2longform $level]
+ set colorMap($level) $color
+ return
+}
+
+# log::lvColorForall --
+#
+# Defines for all known levels the color to return for it in a
+# call to ::log::lv2color. Unique abbreviations of level names
+# are allowed.
+#
+# Arguments:
+# color The color to use for all levels.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvColorForall {color} {
+ variable colorMap
+ variable levels
+
+ foreach l $levels {
+ set colorMap($l) $color
+ }
+ return
+}
+
+# log::logarray --
+#
+# Similar to parray, except that the contents of the array
+# printed out through the log system instead of directly
+# to stdout.
+#
+# See also 'log::log' for a general explanation
+#
+# Arguments:
+# level The level of the message.
+# arrayvar The name of the array varaibe to dump
+# pattern Optional pattern to restrict the dump
+# to certain elements in the array.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::logarray {level arrayvar {pattern *}} {
+ variable cmdMap
+
+ if {[lvIsSuppressed $level]} {
+ # Ignore messages for suppressed levels.
+ return
+ }
+
+ set level [lv2longform $level]
+
+ set cmd $cmdMap($level)
+ if {$cmd == {}} {
+ # Ignore messages for levels without a command
+ return
+ }
+
+ upvar 1 $arrayvar array
+ if {![array exists array]} {
+ error "\"$arrayvar\" isn't an array"
+ }
+ set maxl 0
+ foreach name [lsort [array names array $pattern]] {
+ if {[string length $name] > $maxl} {
+ set maxl [string length $name]
+ }
+ }
+ set maxl [expr {$maxl + [string length $arrayvar] + 2}]
+ foreach name [lsort [array names array $pattern]] {
+ set nameString [format %s(%s) $arrayvar $name]
+
+ eval [linsert $cmd end $level \
+ [format "%-*s = %s" $maxl $nameString $array($name)]]
+ }
+ return
+}
+
+# log::loghex --
+#
+# Like 'log::log', except that the logged data is assumed to
+# be binary and is logged as a block of hex numbers.
+#
+# See also 'log::log' for a general explanation
+#
+# Arguments:
+# level The level of the message.
+# text Message printed before the hex block
+# data Binary data to show as hex.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::loghex {level text data} {
+ variable cmdMap
+
+ if {[lvIsSuppressed $level]} {
+ # Ignore messages for suppressed levels.
+ return
+ }
+
+ set level [lv2longform $level]
+
+ set cmd $cmdMap($level)
+ if {$cmd == {}} {
+ # Ignore messages for levels without a command
+ return
+ }
+
+ # Format the messages and print them.
+
+ set len [string length $data]
+
+ eval [linsert $cmd end $level "$text ($len bytes):"]
+
+ set address ""
+ set hexnums ""
+ set ascii ""
+
+ for {set i 0} {$i < $len} {incr i} {
+ set v [string index $data $i]
+ binary scan $v H2 hex
+ binary scan $v c num
+ set num [expr {($num + 0x100) % 0x100}]
+
+ set text .
+ if {$num > 31} {set text $v}
+
+ if {($i % 16) == 0} {
+ if {$address != ""} {
+ eval [linsert $cmd end $level [format "%4s %-48s |%s|" $address $hexnums $ascii]]
+ set address ""
+ set hexnums ""
+ set ascii ""
+ }
+ append address [format "%04d" $i]
+ }
+ append hexnums "$hex "
+ append ascii $text
+ }
+ if {$address != ""} {
+ eval [linsert $cmd end $level [format "%4s %-48s |%s|" $address $hexnums $ascii]]
+ }
+ eval [linsert $cmd end $level ""]
+ return
+}
+
+# log::log --
+#
+# Log a message according to the specifications for commands,
+# channels and suppression. In other words: The command will do
+# nothing if the specified level is suppressed. If it is not
+# suppressed the actual logging is delegated to the specified
+# command. If there is no command specified for the level the
+# message won't be logged. The standard command ::log::Puts will
+# write the message to the channel specified for the given
+# level. If no channel is specified for the level the message
+# won't be logged. Unique abbreviations of level names are
+# allowed. Errors in the actual logging command are *not*
+# catched, but propagated to the caller, as they may indicate
+# misconfigurations of the log facility or errors in the callers
+# code itself.
+#
+# Arguments:
+# level The level of the message.
+# text The message to log.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::log {level text} {
+ variable cmdMap
+
+ if {[lvIsSuppressed $level]} {
+ # Ignore messages for suppressed levels.
+ return
+ }
+
+ set level [lv2longform $level]
+
+ set cmd $cmdMap($level)
+ if {$cmd == {}} {
+ # Ignore messages for levels without a command
+ return
+ }
+
+ # Delegate actual logging to the command.
+ # Handle multi-line messages correctly.
+
+ foreach line [split $text \n] {
+ eval [linsert $cmd end $level $line]
+ }
+ return
+}
+
+# log::logMsg --
+#
+# Convenience wrapper around ::log::log. Equivalent to
+# '::log::log info text'.
+#
+# Arguments:
+# text The message to log.
+#
+# Side Effects:
+# See ::log::log.
+#
+# Results:
+# None.
+
+proc ::log::logMsg {text} {
+ log info $text
+}
+
+# log::logError --
+#
+# Convenience wrapper around ::log::log. Equivalent to
+# '::log::log error text'.
+#
+# Arguments:
+# text The message to log.
+#
+# Side Effects:
+# See ::log::log.
+#
+# Results:
+# None.
+
+proc ::log::logError {text} {
+ log error $text
+}
+
+
+# log::Puts --
+#
+# Standard log command, writing messages and levels to
+# user-specified channels. Assumes that the supression checks
+# were done by the caller. Expects full level names,
+# abbreviations are *not allowed*.
+#
+# Arguments:
+# level The level of the message.
+# text The message to log.
+#
+# Side Effects:
+# Writes into channels.
+#
+# Results:
+# None.
+
+proc ::log::Puts {level text} {
+ variable channelMap
+ variable fill
+
+ set chan $channelMap($level)
+ if {$chan == {}} {
+ # Ignore levels without channel.
+ return
+ }
+
+ puts $chan "$level$fill($level) $text"
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Initialization code. Disable logging for the lower levels by
+## default.
+
+## log::lvSuppressLE emergency
+log::lvSuppressLE warning
--- /dev/null
+# logger.tcl --
+#
+# Tcl implementation of a general logging facility.
+#
+# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com>
+# Copyright (c) 2004-2007 by Michael Schlenker <mic42@users.sourceforge.net>
+# Copyright (c) 2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file license.terms.
+
+# The logger package provides an 'object oriented' log facility that
+# lets you have trees of services, that inherit from one another.
+# This is accomplished through the use of Tcl namespaces.
+
+
+package require Tcl 8.2
+package provide logger 0.8
+
+namespace eval ::logger {
+ namespace eval tree {}
+ namespace export init enable disable services servicecmd import
+
+ # The active services.
+ variable services {}
+
+ # The log 'levels'.
+ variable levels [list debug info notice warn error critical alert emergency]
+
+ # The default global log level used for new logging services
+ variable enabled "debug"
+
+ # Tcl return codes (in numeric order)
+ variable RETURN_CODES [list "ok" "error" "return" "break" "continue"]
+}
+
+# ::logger::_nsExists --
+#
+# Workaround for missing namespace exists in Tcl 8.2 and 8.3.
+#
+
+if {[package vcompare [package provide Tcl] 8.4] < 0} {
+ proc ::logger::_nsExists {ns} {
+ expr {![catch {namespace parent $ns}]}
+ }
+} else {
+ proc ::logger::_nsExists {ns} {
+ namespace exists $ns
+ }
+}
+
+# ::logger::_cmdPrefixExists --
+#
+# Utility function to check if a given callback prefix exists,
+# this should catch all oddities in prefix names, including spaces,
+# glob patterns, non normalized namespaces etc.
+#
+# Arguments:
+# prefix - The command prefix to check
+#
+# Results:
+# 1 or 0 for yes or no
+#
+proc ::logger::_cmdPrefixExists {prefix} {
+ set cmd [lindex $prefix 0]
+ set full [namespace eval :: namespace which [list $cmd]]
+ if {[string equal $full ""]} {return 0} else {return 1}
+ # normalize namespaces
+ set ns [namespace qualifiers $cmd]
+ set cmd ${ns}::[namespace tail $cmd]
+ set matches [::info commands ${ns}::*]
+ if {[lsearch -exact $matches $cmd] != -1} {return 1}
+ return 0
+}
+
+# ::logger::walk --
+#
+# Walk namespaces, starting in 'start', and evaluate 'code' in
+# them.
+#
+# Arguments:
+# start - namespace to start in.
+# code - code to execute in namespaces walked.
+#
+# Side Effects:
+# Side effects of code executed.
+#
+# Results:
+# None.
+
+proc ::logger::walk { start code } {
+ set children [namespace children $start]
+ foreach c $children {
+ logger::walk $c $code
+ namespace eval $c $code
+ }
+}
+
+proc ::logger::init {service} {
+ variable levels
+ variable services
+ variable enabled
+
+ # We create a 'tree' namespace to house all the services, so
+ # they are in a 'safe' namespace sandbox, and won't overwrite
+ # any commands.
+ namespace eval tree::${service} {
+ variable service
+ variable levels
+ variable oldname
+ variable enabled
+ }
+
+ lappend services $service
+
+ set [namespace current]::tree::${service}::service $service
+ set [namespace current]::tree::${service}::levels $levels
+ set [namespace current]::tree::${service}::oldname $service
+ set [namespace current]::tree::${service}::enabled $enabled
+
+ namespace eval tree::${service} {
+ # Callback to use when the service in question is shut down.
+ variable delcallback [namespace current]::no-op
+
+ # Callback when the loglevel is changed
+ variable levelchangecallback [namespace current]::no-op
+
+ # State variable to decide when to call levelcallback
+ variable inSetLevel 0
+
+ # The currently configured levelcommands
+ variable lvlcmds
+ array set lvlcmds {}
+
+ # List of procedures registered via the trace command
+ variable traceList ""
+
+ # Flag indicating whether or not tracing is currently enabled
+ variable tracingEnabled 0
+
+ # We use this to disable a service completely. In Tcl 8.4
+ # or greater, by using this, disabled log calls are a
+ # no-op!
+
+ proc no-op args {}
+
+
+ proc stdoutcmd {level text} {
+ variable service
+ puts "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'"
+ }
+
+ proc stderrcmd {level text} {
+ variable service
+ puts stderr "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'"
+ }
+
+
+ # setlevel --
+ #
+ # This command differs from enable and disable in that
+ # it disables all the levels below that selected, and
+ # then enables all levels above it, which enable/disable
+ # do not do.
+ #
+ # Arguments:
+ # lv - the level, as defined in $levels.
+ #
+ # Side Effects:
+ # Runs disable for the level, and then enable, in order
+ # to ensure that all levels are set correctly.
+ #
+ # Results:
+ # None.
+
+
+ proc setlevel {lv} {
+ variable inSetLevel 1
+ set oldlvl [currentloglevel]
+
+ # do not allow enable and disable to do recursion
+ if {[catch {
+ disable $lv 0
+ set newlvl [enable $lv 0]
+ } msg] == 1} {
+ return -code error -errorcode $::errorCode $msg
+ }
+ # do the recursion here
+ logger::walk [namespace current] [list setlevel $lv]
+
+ set inSetLevel 0
+ lvlchangewrapper $oldlvl $newlvl
+ return
+ }
+
+ # enable --
+ #
+ # Enable a particular 'level', and above, for the
+ # service, and its 'children'.
+ #
+ # Arguments:
+ # lv - the level, as defined in $levels.
+ #
+ # Side Effects:
+ # Enables logging for the particular level, and all
+ # above it (those more important). It also walks
+ # through all services that are 'children' and enables
+ # them at the same level or above.
+ #
+ # Results:
+ # None.
+
+ proc enable {lv {recursion 1}} {
+ variable levels
+ set lvnum [lsearch -exact $levels $lv]
+ if { $lvnum == -1 } {
+ return -code error "Invalid level '$lv' - levels are $levels"
+ }
+
+ variable enabled
+ set newlevel $enabled
+ set elnum [lsearch -exact $levels $enabled]
+ if {($elnum == -1) || ($elnum > $lvnum)} {
+ set newlevel $lv
+ }
+
+ variable service
+ while { $lvnum < [llength $levels] } {
+ interp alias {} [namespace current]::[lindex $levels $lvnum] \
+ {} [namespace current]::[lindex $levels $lvnum]cmd
+ incr lvnum
+ }
+
+ if {$recursion} {
+ logger::walk [namespace current] [list enable $lv]
+ }
+ lvlchangewrapper $enabled $newlevel
+ set enabled $newlevel
+ }
+
+ # disable --
+ #
+ # Disable a particular 'level', and below, for the
+ # service, and its 'children'.
+ #
+ # Arguments:
+ # lv - the level, as defined in $levels.
+ #
+ # Side Effects:
+ # Disables logging for the particular level, and all
+ # below it (those less important). It also walks
+ # through all services that are 'children' and disables
+ # them at the same level or below.
+ #
+ # Results:
+ # None.
+
+ proc disable {lv {recursion 1}} {
+ variable levels
+ set lvnum [lsearch -exact $levels $lv]
+ if { $lvnum == -1 } {
+ return -code error "Invalid level '$lv' - levels are $levels"
+ }
+
+ variable enabled
+ set newlevel $enabled
+ set elnum [lsearch -exact $levels $enabled]
+ if {($elnum > -1) && ($elnum <= $lvnum)} {
+ if {$lvnum+1 >= [llength $levels]} {
+ set newlevel "none"
+ } else {
+ set newlevel [lindex $levels [expr {$lvnum+1}]]
+ }
+ }
+
+ while { $lvnum >= 0 } {
+
+ interp alias {} [namespace current]::[lindex $levels $lvnum] {} \
+ [namespace current]::no-op
+ incr lvnum -1
+ }
+ if {$recursion} {
+ logger::walk [namespace current] [list disable $lv]
+ }
+ lvlchangewrapper $enabled $newlevel
+ set enabled $newlevel
+ }
+
+ # currentloglevel --
+ #
+ # Get the currently enabled log level for this service.
+ #
+ # Arguments:
+ # none
+ #
+ # Side Effects:
+ # none
+ #
+ # Results:
+ # current log level
+ #
+
+ proc currentloglevel {} {
+ variable enabled
+ return $enabled
+ }
+
+ # lvlchangeproc --
+ #
+ # Set or introspect a callback for when the logger instance
+ # changes its loglevel.
+ #
+ # Arguments:
+ # cmd - the Tcl command to call, it is called with two parameters, old and new log level.
+ # or none for introspection
+ #
+ # Side Effects:
+ # None.
+ #
+ # Results:
+ # If no arguments are given return the current callback cmd.
+
+ proc lvlchangeproc {args} {
+ variable levelchangecallback
+
+ switch -exact -- [llength [::info level 0]] {
+ 1 {return $levelchangecallback}
+ 2 {
+ if {[::logger::_cmdPrefixExists [lindex $args 0]]} {
+ set levelchangecallback [lindex $args 0]
+ } else {
+ return -code error "Invalid cmd '[lindex $args 0]' - does not exist"
+ }
+ }
+ default {
+ return -code error "Wrong # of arguments. Usage: \${log}::lvlchangeproc ?cmd?"
+ }
+ }
+ }
+
+ proc lvlchangewrapper {old new} {
+ variable inSetLevel
+
+ # we are called after disable and enable are finished
+ if {$inSetLevel} {return}
+
+ # no action if level does not change
+ if {[string equal $old $new]} {return}
+
+ variable levelchangecallback
+ # no action if levelchangecallback isn't a valid command
+ if {[::logger::_cmdPrefixExists $levelchangecallback]} {
+ catch {
+ uplevel \#0 [linsert $levelchangecallback end $old $new]
+ }
+ }
+ }
+
+ # logproc --
+ #
+ # Command used to create a procedure that is executed to
+ # perform the logging. This could write to disk, out to
+ # the network, or something else.
+ # If two arguments are given, use an existing command.
+ # If three arguments are given, create a proc.
+ #
+ # Arguments:
+ # lv - the level to log, which must be one of $levels.
+ # args - either zero, one or two arguments.
+ # if zero this returns the current command registered
+ # if one, this is a cmd name that is called for this level
+ # if two, these are an argument and proc body
+ #
+ # Side Effects:
+ # Creates a logging command to take care of the details
+ # of logging an event.
+ #
+ # Results:
+ # If called with zero length args, returns the name of the currently
+ # configured logging procedure.
+ #
+ #
+
+ proc logproc {lv args} {
+ variable levels
+ variable lvlcmds
+
+ set lvnum [lsearch -exact $levels $lv]
+ if { ($lvnum == -1) && ($lv != "trace") } {
+ return -code error "Invalid level '$lv' - levels are $levels"
+ }
+ switch -exact -- [llength $args] {
+ 0 {
+ return $lvlcmds($lv)
+ }
+ 1 {
+ set cmd [lindex $args 0]
+ if {[string equal "[namespace current]::${lv}cmd" $cmd]} {return}
+ if {[llength [::info commands $cmd]]} {
+ proc ${lv}cmd {args} "uplevel 1 \[list $cmd \[lindex \$args end\]\]"
+ } else {
+ return -code error "Invalid cmd '$cmd' - does not exist"
+ }
+ set lvlcmds($lv) $cmd
+ }
+ 2 {
+ foreach {arg body} $args {break}
+ proc ${lv}cmd {args} "_setservicename \$args;
+ set val \[${lv}customcmd \[lindex \$args end\]\] ;
+ _restoreservice; set val"
+ proc ${lv}customcmd $arg $body
+ set lvlcmds($lv) [namespace current]::${lv}customcmd
+ }
+ default {
+ return -code error "Usage: \${log}::logproc level ?cmd?\nor \${log}::logproc level argname body"
+ }
+ }
+ }
+
+
+ # delproc --
+ #
+ # Set or introspect a callback for when the logger instance
+ # is deleted.
+ #
+ # Arguments:
+ # cmd - the Tcl command to call.
+ # or none for introspection
+ #
+ # Side Effects:
+ # None.
+ #
+ # Results:
+ # If no arguments are given return the current callback cmd.
+
+ proc delproc {args} {
+ variable delcallback
+
+ switch -exact -- [llength [::info level 0]] {
+ 1 {return $delcallback}
+ 2 { if {[::logger::_cmdPrefixExists [lindex $args 0]]} {
+ set delcallback [lindex $args 0]
+ } else {
+ return -code error "Invalid cmd '[lindex $args 0]' - does not exist"
+ }
+ }
+ default {
+ return -code error "Wrong # of arguments. Usage: \${log}::delproc ?cmd?"
+ }
+ }
+ }
+
+
+ # delete --
+ #
+ # Delete the namespace and its children.
+
+ proc delete {} {
+ variable delcallback
+ variable service
+
+ logger::walk [namespace current] delete
+ if {[::logger::_cmdPrefixExists $delcallback]} {
+ uplevel \#0 [lrange $delcallback 0 end]
+ }
+ # clean up the global services list
+ set idx [lsearch -exact [logger::services] $service]
+ if {$idx !=-1} {
+ set ::logger::services [lreplace [logger::services] $idx $idx]
+ }
+
+ namespace delete [namespace current]
+
+ }
+
+ # services --
+ #
+ # Return all child services
+
+ proc services {} {
+ variable service
+
+ set children [list]
+ foreach srv [logger::services] {
+ if {[string match "${service}::*" $srv]} {
+ lappend children $srv
+ }
+ }
+ return $children
+ }
+
+ # servicename --
+ #
+ # Return the name of the service
+
+ proc servicename {} {
+ variable service
+ return $service
+ }
+
+ proc _setservicename {arg} {
+ variable service
+ variable oldname
+ if {[llength $arg] <= 1} {
+ return
+ } else {
+ set oldname $service
+ set service [lindex $arg end-1]
+ }
+ }
+
+ proc _restoreservice {} {
+ variable service
+ variable oldname
+ set service $oldname
+ return
+ }
+
+ proc trace { action args } {
+ variable service
+
+ # Allow other boolean values (true, false, yes, no, 0, 1) to be used
+ # as synonymns for "on" and "off".
+
+ if {[string is boolean $action]} {
+ set xaction [expr {($action && 1) ? "on" : "off"}]
+ } else {
+ set xaction $action
+ }
+
+ # Check for required arguments for actions/subcommands and dispatch
+ # to the appropriate procedure.
+
+ switch -- $xaction {
+ "status" {
+ return [uplevel 1 [list logger::_trace_status $service $args]]
+ }
+ "on" {
+ if {[llength $args]} {
+ return -code error "wrong # args: should be \"trace on\""
+ }
+ return [logger::_trace_on $service]
+ }
+ "off" {
+ if {[llength $args]} {
+ return -code error "wrong # args: should be \"trace off\""
+ }
+ return [logger::_trace_off $service]
+ }
+ "add" {
+ if {![llength $args]} {
+ return -code error \
+ "wrong # args: should be \"trace add ?-ns? <proc> ...\""
+ }
+ return [uplevel 1 [list ::logger::_trace_add $service $args]]
+ }
+ "remove" {
+ if {![llength $args]} {
+ return -code error \
+ "wrong # args: should be \"trace remove ?-ns? <proc> ...\""
+ }
+ return [uplevel 1 [list ::logger::_trace_remove $service $args]]
+ }
+
+ default {
+ return -code error \
+ "Invalid action \"$action\": must be status, add, remove,\
+ on, or off"
+ }
+ }
+ }
+
+ # Walk the parent service namespaces to see first, if they
+ # exist, and if any are enabled, and then, as a
+ # consequence, enable this one
+ # too.
+
+ enable $enabled
+ variable parent [namespace parent]
+ while {[string compare $parent "::logger::tree"]} {
+ # If the 'enabled' variable doesn't exist, create the
+ # whole thing.
+ if { ! [::info exists ${parent}::enabled] } {
+
+ logger::init [string range $parent 16 end]
+ }
+ set enabled [set ${parent}::enabled]
+ enable $enabled
+ set parent [namespace parent $parent]
+ }
+ }
+
+ # Now create the commands for different levels.
+
+ namespace eval tree::${service} {
+ set parent [namespace parent]
+
+ # We 'inherit' the commands from the parents. This
+ # means that, if you want to share the same methods with
+ # children, they should be instantiated after the parent's
+ # methods have been defined.
+ if {[string compare $parent "::logger::tree"]} {
+ foreach lvl [::logger::levels] {
+ # OPTIMIZE: do not allow multiple aliases in the hierarchy
+ # they can always be replaced by more efficient
+ # direct aliases to the target procs.
+ interp alias {} [namespace current]::${lvl}cmd {} ${parent}::${lvl}cmd $service
+ }
+ # inherit the starting loglevel of the parent service
+ setlevel [${parent}::currentloglevel]
+
+ } else {
+ foreach lvl [concat [::logger::levels] "trace"] {
+ proc ${lvl}cmd {args} "_setservicename \$args ;
+ set val \[stdoutcmd $lvl \[lindex \$args end\]\] ;
+ _restoreservice; set val"
+ set lvlcmds($lvl) [namespace current]::${lvl}cmd
+ }
+ }
+ }
+
+
+ return ::logger::tree::${service}
+}
+
+# ::logger::services --
+#
+# Returns a list of all active services.
+#
+# Arguments:
+# None.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# List of active services.
+
+proc ::logger::services {} {
+ variable services
+ return $services
+}
+
+# ::logger::enable --
+#
+# Global enable for a certain level. NOTE - this implementation
+# isn't terribly effective at the moment, because it might hit
+# children before their parents, who will then walk down the
+# tree attempting to disable the children again.
+#
+# Arguments:
+# lv - level above which to enable logging.
+#
+# Side Effects:
+# Enables logging in a given level, and all higher levels.
+#
+# Results:
+# None.
+
+proc ::logger::enable {lv} {
+ variable services
+ if {[catch {
+ foreach sv $services {
+ ::logger::tree::${sv}::enable $lv
+ }
+ } msg] == 1} {
+ return -code error -errorcode $::errorCode $msg
+ }
+}
+
+proc ::logger::disable {lv} {
+ variable services
+ if {[catch {
+ foreach sv $services {
+ ::logger::tree::${sv}::disable $lv
+ }
+ } msg] == 1} {
+ return -code error -errorcode $::errorCode $msg
+ }
+}
+
+proc ::logger::setlevel {lv} {
+ variable services
+ variable enabled
+ variable levels
+ if {[lsearch -exact $levels $lv] == -1} {
+ return -code error "Invalid level '$lv' - levels are $levels"
+ }
+ set enabled $lv
+ if {[catch {
+ foreach sv $services {
+ ::logger::tree::${sv}::setlevel $lv
+ }
+ } msg] == 1} {
+ return -code error -errorcode $::errorCode $msg
+ }
+}
+
+# ::logger::levels --
+#
+# Introspect the available log levels. Provided so a caller does
+# not need to know implementation details or code the list
+# himself.
+#
+# Arguments:
+# None.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# levels - The list of valid log levels accepted by enable and disable
+
+proc ::logger::levels {} {
+ variable levels
+ return $levels
+}
+
+# ::logger::servicecmd --
+#
+# Get the command token for a given service name.
+#
+# Arguments:
+# service - name of the service.
+#
+# Side Effects:
+# none
+#
+# Results:
+# log - namespace token for this service
+
+proc ::logger::servicecmd {service} {
+ variable services
+ if {[lsearch -exact $services $service] == -1} {
+ return -code error "Service \"$service\" does not exist."
+ }
+ return "::logger::tree::${service}"
+}
+
+# ::logger::import --
+#
+# Import the logging commands.
+#
+# Arguments:
+# service - name of the service.
+#
+# Side Effects:
+# creates aliases in the target namespace
+#
+# Results:
+# none
+
+proc ::logger::import {args} {
+ variable services
+
+ if {[llength $args] == 0 || [llength $args] > 7} {
+ return -code error "Wrong # of arguments: \"logger::import ?-all?\
+ ?-force?\
+ ?-prefix prefix? ?-namespace namespace? service\""
+ }
+
+ # process options
+ #
+ set import_all 0
+ set force 0
+ set prefix ""
+ set ns [uplevel 1 namespace current]
+ while {[llength $args] > 1} {
+ set opt [lindex $args 0]
+ set args [lrange $args 1 end]
+ switch -exact -- $opt {
+ -all { set import_all 1}
+ -prefix { set prefix [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -namespace {
+ set ns [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -force {
+ set force 1
+ }
+ default {
+ return -code error "Unknown argument: \"$opt\" :\nUsage:\
+ \"logger::import ?-all? ?-force?\
+ ?-prefix prefix? ?-namespace namespace? service\""
+ }
+ }
+ }
+
+ #
+ # build the list of commands to import
+ #
+
+ set cmds [logger::levels]
+ lappend cmds "trace"
+ if {$import_all} {
+ lappend cmds setlevel enable disable logproc delproc services
+ lappend cmds servicename currentloglevel delete
+ }
+
+ #
+ # check the service argument
+ #
+
+ set service [lindex $args 0]
+ if {[lsearch -exact $services $service] == -1} {
+ return -code error "Service \"$service\" does not exist."
+ }
+
+ #
+ # setup the namespace for the import
+ #
+
+ set sourcens [logger::servicecmd $service]
+ set localns [uplevel 1 namespace current]
+
+ if {[string match ::* $ns]} {
+ set importns $ns
+ } else {
+ set importns ${localns}::$ns
+ }
+
+ # fake namespace exists for Tcl 8.2 - 8.3
+ if {![_nsExists $importns]} {
+ namespace eval $importns {}
+ }
+
+
+ #
+ # prepare the import
+ #
+
+ set imports ""
+ foreach cmd $cmds {
+ set cmdname ${importns}::${prefix}$cmd
+ set collision [llength [info commands $cmdname]]
+ if {$collision && !$force} {
+ return -code error "can't import command \"$cmdname\": already exists"
+ }
+ lappend imports ${importns}::${prefix}$cmd ${sourcens}::${cmd}
+ }
+
+ #
+ # and execute the aliasing after checking all is well
+ #
+
+ foreach {target source} $imports {
+ proc $target {args} "uplevel 1 \[linsert \$args 0 $source \]"
+ }
+}
+
+# ::logger::initNamespace --
+#
+# Creates a logger for the specified namespace and makes the log
+# commands available to said namespace as well. Allows the initial
+# setting of a default log level.
+#
+# Arguments:
+# ns - Namespace to initialize, is also the service name, modulo a ::-prefix
+# level - Initial log level, optional, defaults to 'warn'.
+#
+# Side Effects:
+# creates aliases in the target namespace
+#
+# Results:
+# none
+
+proc ::logger::initNamespace {ns {level warn}} {
+ set service [string trimleft $ns :]
+ namespace eval $ns [list ::logger::init $service]
+ namespace eval $ns [list ::logger::import -force -all -namespace log $service]
+ namespace eval $ns [list log::setlevel $level]
+ return
+}
+
+# This procedure handles the "logger::trace status" command. Given no
+# arguments, returns a list of all procedures that have been registered
+# via "logger::trace add". Given one or more procedure names, it will
+# return 1 if all were registered, or 0 if any were not.
+
+proc ::logger::_trace_status { service procList } {
+ upvar #0 ::logger::tree::${service}::traceList traceList
+
+ # If no procedure names were given, just return the registered list
+
+ if {![llength $procList]} {
+ return $traceList
+ }
+
+ # Get caller's namespace for qualifying unqualified procedure names
+
+ set caller_ns [uplevel 1 namespace current]
+ set caller_ns [string trimright $caller_ns ":"]
+
+ # Search for any specified proc names that are *not* registered
+
+ foreach procName $procList {
+ # Make sure the procedure namespace is qualified
+
+ if {![string match "::*" $procName]} {
+ set procName ${caller_ns}::$procName
+ }
+
+ # Check if the procedure has been registered for tracing
+
+ if {[lsearch -exact $traceList $procName] == -1} {
+ return 0
+ }
+ }
+
+ return 1
+}
+
+# This procedure handles the "logger::trace on" command. If tracing
+# is turned off, it will enable Tcl trace handlers for all of the procedures
+# registered via "logger::trace add". Does nothing if tracing is already
+# turned on.
+
+proc ::logger::_trace_on { service } {
+ set tcl_version [package provide Tcl]
+
+ if {[package vcompare $tcl_version "8.4"] < 0} {
+ return -code error \
+ "execution tracing is not available in Tcl $tcl_version"
+ }
+
+ namespace eval ::logger::tree::${service} {
+ if {!$tracingEnabled} {
+ set tracingEnabled 1
+ ::logger::_enable_traces $service $traceList
+ }
+ }
+
+ return 1
+}
+
+# This procedure handles the "logger::trace off" command. If tracing
+# is turned on, it will disable Tcl trace handlers for all of the procedures
+# registered via "logger::trace add", leaving them in the list so they
+# tracing on all of them can be enabled again with "logger::trace on".
+# Does nothing if tracing is already turned off.
+
+proc ::logger::_trace_off { service } {
+ namespace eval ::logger::tree::${service} {
+ if {$tracingEnabled} {
+ ::logger::_disable_traces $service $traceList
+ set tracingEnabled 0
+ }
+ }
+
+ return 1
+}
+
+# This procedure is used by the logger::trace add and remove commands to
+# process the arguments in a common fashion. If the -ns switch is given
+# first, this procedure will return a list of all existing procedures in
+# all of the namespaces given in remaining arguments. Otherwise, each
+# argument is taken to be either a pattern for a glob-style search of
+# procedure names or, failing that, a namespace, in which case this
+# procedure returns a list of all the procedures matching the given
+# pattern (or all in the named namespace, if no procedures match).
+
+proc ::logger::_trace_get_proclist { inputList } {
+ set procList ""
+
+ if {[string equal [lindex $inputList 0] "-ns"]} {
+ # Verify that at least one target namespace was supplied
+
+ set inputList [lrange $inputList 1 end]
+ if {![llength $inputList]} {
+ return -code error "Must specify at least one namespace target"
+ }
+
+ # Rebuild the argument list to contain namespace procedures
+
+ foreach namespace $inputList {
+ # Don't allow tracing of the logger (or child) namespaces
+
+ if {![string match "::logger::*" $namespace]} {
+ set nsProcList [::info procs ${namespace}::*]
+ set procList [concat $procList $nsProcList]
+ }
+ }
+ } else {
+ # Search for procs or namespaces matching each of the specified
+ # patterns.
+
+ foreach pattern $inputList {
+ set matches [uplevel 1 ::info proc $pattern]
+
+ if {![llength $matches]} {
+ if {[uplevel 1 namespace exists $pattern]} {
+ set matches [::info procs ${pattern}::*]
+ }
+
+ # Matched procs will be qualified due to above pattern
+
+ set procList [concat $procList $matches]
+ } elseif {[string match "::*" $pattern]} {
+ # Patterns were pre-qualified - add them directly
+
+ set procList [concat $procList $matches]
+ } else {
+ # Qualify each proc with the namespace it was in
+
+ set ns [uplevel 1 namespace current]
+ if {$ns == "::"} {
+ set ns ""
+ }
+ foreach proc $matches {
+ lappend procList ${ns}::$proc
+ }
+ }
+ }
+ }
+
+ return $procList
+}
+
+# This procedure handles the "logger::trace add" command. If the tracing
+# feature is enabled, it will enable the Tcl entry and leave trace handlers
+# for each procedure specified that isn't already being traced. Each
+# procedure is added to the list of procedures that the logger trace feature
+# should log when tracing is enabled.
+
+proc ::logger::_trace_add { service procList } {
+ upvar #0 ::logger::tree::${service}::traceList traceList
+
+ # Handle -ns switch and glob search patterns for procedure names
+
+ set procList [uplevel 1 [list logger::_trace_get_proclist $procList]]
+
+ # Enable tracing for each procedure that has not previously been
+ # specified via logger::trace add. If tracing is off, this will just
+ # store the name of the procedure for later when tracing is turned on.
+
+ foreach procName $procList {
+ if {[lsearch -exact $traceList $procName] == -1} {
+ lappend traceList $procName
+ ::logger::_enable_traces $service [list $procName]
+ }
+ }
+}
+
+# This procedure handles the "logger::trace remove" command. If the tracing
+# feature is enabled, it will remove the Tcl entry and leave trace handlers
+# for each procedure specified. Each procedure is removed from the list
+# of procedures that the logger trace feature should log when tracing is
+# enabled.
+
+proc ::logger::_trace_remove { service procList } {
+ upvar #0 ::logger::tree::${service}::traceList traceList
+
+ # Handle -ns switch and glob search patterns for procedure names
+
+ set procList [uplevel 1 [list logger::_trace_get_proclist $procList]]
+
+ # Disable tracing for each proc that previously had been specified
+ # via logger::trace add. If tracing is off, this will just
+ # remove the name of the procedure from the trace list so that it
+ # will be excluded when tracing is turned on.
+
+ foreach procName $procList {
+ set index [lsearch -exact $traceList $procName]
+ if {$index != -1} {
+ set traceList [lreplace $traceList $index $index]
+ ::logger::_disable_traces $service [list $procName]
+ }
+ }
+}
+
+# This procedure enables Tcl trace handlers for all procedures specified.
+# It is used both to enable Tcl's tracing for a single procedure when
+# removed via "logger::trace add", as well as to enable all traces
+# via "logger::trace on".
+
+proc ::logger::_enable_traces { service procList } {
+ upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled
+
+ if {$tracingEnabled} {
+ foreach procName $procList {
+ ::trace add execution $procName enter \
+ [list ::logger::_trace_enter $service]
+ ::trace add execution $procName leave \
+ [list ::logger::_trace_leave $service]
+ }
+ }
+}
+
+# This procedure disables Tcl trace handlers for all procedures specified.
+# It is used both to disable Tcl's tracing for a single procedure when
+# removed via "logger::trace remove", as well as to disable all traces
+# via "logger::trace off".
+
+proc ::logger::_disable_traces { service procList } {
+ upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled
+
+ if {$tracingEnabled} {
+ foreach procName $procList {
+ ::trace remove execution $procName enter \
+ [list ::logger::_trace_enter $service]
+ ::trace remove execution $procName leave \
+ [list ::logger::_trace_leave $service]
+ }
+ }
+}
+
+########################################################################
+# Trace Handlers
+########################################################################
+
+# This procedure is invoked upon entry into a procedure being traced
+# via "logger::trace add" when tracing is enabled via "logger::trace on"
+# to log information about how the procedure was called.
+
+proc ::logger::_trace_enter { service cmd op } {
+ # Parse the command
+ set procName [uplevel 1 namespace origin [lindex $cmd 0]]
+ set args [lrange $cmd 1 end]
+
+ # Display the message prefix
+ set callerLvl [expr {[::info level] - 1}]
+ set calledLvl [::info level]
+
+ lappend message "proc" $procName
+ lappend message "level" $calledLvl
+ lappend message "script" [uplevel ::info script]
+
+ # Display the caller information
+ set caller ""
+ if {$callerLvl >= 1} {
+ # Display the name of the caller proc w/prepended namespace
+ catch {
+ set callerProcName [lindex [::info level $callerLvl] 0]
+ set caller [uplevel 2 namespace origin $callerProcName]
+ }
+ }
+
+ lappend message "caller" $caller
+
+ # Display the argument names and values
+ set argSpec [uplevel 1 ::info args $procName]
+ set argList ""
+ if {[llength $argSpec]} {
+ foreach argName $argSpec {
+ lappend argList $argName
+
+ if {$argName == "args"} {
+ lappend argList $args
+ break
+ } else {
+ lappend argList [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ }
+ }
+
+ lappend message "procargs" $argList
+ set message [list $op $message]
+
+ ::logger::tree::${service}::tracecmd $message
+}
+
+# This procedure is invoked upon leaving into a procedure being traced
+# via "logger::trace add" when tracing is enabled via "logger::trace on"
+# to log information about the result of the procedure call.
+
+proc ::logger::_trace_leave { service cmd status rc op } {
+ variable RETURN_CODES
+
+ # Parse the command
+ set procName [uplevel 1 namespace origin [lindex $cmd 0]]
+
+ # Gather the caller information
+ set callerLvl [expr {[::info level] - 1}]
+ set calledLvl [::info level]
+
+ lappend message "proc" $procName "level" $calledLvl
+ lappend message "script" [uplevel ::info script]
+
+ # Get the name of the proc being returned to w/prepended namespace
+ set caller ""
+ catch {
+ set callerProcName [lindex [::info level $callerLvl] 0]
+ set caller [uplevel 2 namespace origin $callerProcName]
+ }
+
+ lappend message "caller" $caller
+
+ # Convert the return code from numeric to verbal
+
+ if {$status < [llength $RETURN_CODES]} {
+ set status [lindex $RETURN_CODES $status]
+ }
+
+ lappend message "status" $status
+ lappend message "result" $rc
+
+ # Display the leave message
+
+ set message [list $op $message]
+ ::logger::tree::${service}::tracecmd $message
+
+ return 1
+}
+
--- /dev/null
+##Library Header
+#
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::appender
+#
+# Purpose:
+# collection of appenders for tcllib logger
+#
+# Author:
+# Aamer Akhter / aakhter@cisco.com
+#
+# Support Alias:
+# aakhter@cisco.com
+#
+# Usage:
+# package require logger::appender
+#
+# Description:
+# set of logger templates
+#
+# Requirements:
+# package require logger
+# package require md5
+#
+# Variables:
+# namespace ::loggerExtension::
+# id: CVS ID: keyword extraction
+# version: current version of package
+# packageDir: directory where package is located
+# log: instance log
+#
+# Notes:
+# 1.
+#
+# Keywords:
+#
+#
+# Category:
+#
+#
+# End of Header
+
+package require md5
+
+namespace eval ::logger::appender {
+ variable fgcolor
+ array set fgcolor {
+ red {31m}
+ red-bold {1;31m}
+ black {m}
+ blue {1m}
+ green {32m}
+ yellow {33m}
+ cyan {36m}
+ }
+
+ variable levelToColor
+ array set levelToColor {
+ debug cyan
+ info blue
+ notice black
+ warn red
+ error red
+ critical red-bold
+ alert red-bold
+ emergency red-bold
+ }
+}
+
+
+
+##Procedure Header
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::appender::console
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::appender::console -level <level> -service <service> [options]
+#
+# Arguments:
+# -level <level>
+# name of level to fill in as 'priority' in log proc
+# -service <service>
+# name of service to fill in as 'category' in log proc
+# -appenderArgs <appenderArgs>
+# any additional args in list form
+# -conversionPattern <conversionPattern>
+# log pattern to use (see genLogProc)
+# -procName <procName>
+# explicitly set the proc name
+# -procNameVar <procNameVar>
+# name of variable to set in the calling context
+# variable has name of proc
+#
+#
+# Return Values:
+# a runnable command
+#
+# Description:
+#
+#
+# Examples:
+#
+#
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::appender::console {args} {
+ set usage {console
+ ?-level level?
+ ?-service service?
+ ?-appenderArgs appenderArgs?
+ }
+ set bargs $args
+ set conversionPattern {\[%d\] \[%c\] \[%M\] \[%p\] %m}
+ while {[llength $args] > 1} {
+ set opt [lindex $args 0]
+ set args [lrange $args 1 end]
+ switch -exact -- $opt {
+ -level { set level [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -service { set service [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -appenderArgs {
+ set appenderArgs [lindex $args 0]
+ set args [lrange $args 1 end]
+ set args [concat $args $appenderArgs]
+ }
+ -conversionPattern {
+ set conversionPattern [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -procName {
+ set procName [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -procNameVar {
+ set procNameVar [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ default {
+ return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+ %s" $opt $usage]
+ }
+ }
+ }
+ if {![info exists procName]} {
+ set procName [genProcName $bargs]
+ }
+ if {[info exists procNameVar]} {
+ upvar $procNameVar myProcNameVar
+ }
+ set procText \
+ [ ::logger::utils::createLogProc \
+ -procName $procName \
+ -conversionPattern $conversionPattern \
+ -category $service \
+ -priority $level ]
+ set myProcNameVar $procName
+ return $procText
+}
+
+
+
+##Procedure Header
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::appender::colorConsole
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::appender::console -level <level> -service <service> [options]
+#
+# Arguments:
+# -level <level>
+# name of level to fill in as 'priority' in log proc
+# -service <service>
+# name of service to fill in as 'category' in log proc
+# -appenderArgs <appenderArgs>
+# any additional args in list form
+# -conversionPattern <conversionPattern>
+# log pattern to use (see genLogProc)
+# -procName <procName>
+# explicitly set the proc name
+# -procNameVar <procNameVar>
+# name of variable to set in the calling context
+# variable has name of proc
+#
+#
+# Return Values:
+# a runnable command
+#
+# Description:
+# provides colorized logs
+#
+# Examples:
+#
+#
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::appender::colorConsole {args} {
+ variable fgcolor
+ set usage {console
+ ?-level level?
+ ?-service service?
+ ?-appenderArgs appenderArgs?
+ }
+ set bargs $args
+ set conversionPattern {\[%d\] \[%c\] \[%M\] \[%p\] %m}
+ upvar 0 ::logger::appender::levelToColor colorMap
+ while {[llength $args] > 1} {
+ set opt [lindex $args 0]
+ set args [lrange $args 1 end]
+ switch -exact -- $opt {
+ -level { set level [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -service { set service [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -appenderArgs {
+ set appenderArgs [lindex $args 0]
+ set args [lrange $args 1 end]
+ set args [concat $args $appenderArgs]
+ }
+ -conversionPattern {
+ set conversionPattern [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -procName {
+ set procName [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -procNameVar {
+ set procNameVar [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ default {
+ return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+ %s" $opt $usage]
+ }
+ }
+ }
+ if {![info exists procName]} {
+ set procName [genProcName $bargs]
+ }
+ upvar $procNameVar myProcNameVar
+ if {[info exists level]} {
+ #apply color
+ set colorCode $colorMap($level)
+ append newCPattern {\033\[} $fgcolor($colorCode) $conversionPattern {\033\[0m}
+ set conversionPattern $newCPattern
+ }
+ set procText \
+ [ ::logger::utils::createLogProc \
+ -procName $procName \
+ -conversionPattern $conversionPattern \
+ -category $service \
+ -priority $level ]
+ set myProcNameVar $procName
+ return $procText
+}
+
+##Procedure Header
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::appender::fileAppend
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::appender::fileAppend -level <level> -service <service> -outputChannel <channel> [options]
+#
+# Arguments:
+# -level <level>
+# name of level to fill in as 'priority' in log proc
+# -service <service>
+# name of service to fill in as 'category' in log proc
+# -appenderArgs <appenderArgs>
+# any additional args in list form
+# -conversionPattern <conversionPattern>
+# log pattern to use (see genLogProc)
+# -procName <procName>
+# explicitly set the proc name
+# -procNameVar <procNameVar>
+# name of variable to set in the calling context
+# variable has name of proc
+# -outputChannel <channel>
+# name of output channel (eg stdout, file handle)
+#
+#
+# Return Values:
+# a runnable command
+#
+# Description:
+#
+#
+# Examples:
+#
+#
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::appender::fileAppend {args} {
+ set usage {console
+ ?-level level?
+ ?-service service?
+ ?-outputChannel channel?
+ ?-appenderArgs appenderArgs?
+ }
+ set bargs $args
+ set conversionPattern {\[%d\] \[%c\] \[%M\] \[%p\] %m}
+ while {[llength $args] > 1} {
+ set opt [lindex $args 0]
+ set args [lrange $args 1 end]
+ switch -exact -- $opt {
+ -level { set level [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -service { set service [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -appenderArgs {
+ set appenderArgs [lindex $args 0]
+ set args [lrange $args 1 end]
+ set args [concat $args $appenderArgs]
+ }
+ -conversionPattern {
+ set conversionPattern [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -procName {
+ set procName [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -procNameVar {
+ set procNameVar [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -outputChannel {
+ set outputChannel [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ default {
+ return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+ %s" $opt $usage]
+ }
+ }
+ }
+ if {![info exists procName]} {
+ set procName [genProcName $bargs]
+ }
+ if {[info exists procNameVar]} {
+ upvar $procNameVar myProcNameVar
+ }
+ set procText \
+ [ ::logger::utils::createLogProc \
+ -procName $procName \
+ -conversionPattern $conversionPattern \
+ -category $service \
+ -outputChannel $outputChannel \
+ -priority $level ]
+ set myProcNameVar $procName
+ return $procText
+}
+
+
+
+
+##Internal Procedure Header
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::appender::genProcName
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::appender::genProcName <args>
+#
+# Arguments:
+# <formatString>
+# string composed of formatting chars (see description)
+#
+#
+# Return Values:
+# a runnable command
+#
+# Description:
+#
+#
+# Examples:
+# ::loggerExtension::new param1
+# ::loggerExtension::new param2
+# ::loggerExtension::new param3 <option1>
+#
+#
+# Sample Input:
+# (Optional) Sample of input to the proc provided by its argument values.
+#
+# Sample Output:
+# (Optional) For procs that output to files, provide
+# sample of format of output produced.
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::appender::genProcName {args} {
+ set name [md5::md5 -hex $args]
+ return "::logger::appender::logProc-$name"
+}
+
+
+package provide logger::appender 1.3
+
+# ;;; Local Variables: ***
+# ;;; mode: tcl ***
+# ;;; End: ***
--- /dev/null
+##Library Header
+#
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::utils::
+#
+# Purpose:
+# an extension to the tcllib logger module
+#
+# Author:
+# Aamer Akhter / aakhter@cisco.com
+#
+# Support Alias:
+# aakhter@cisco.com
+#
+# Usage:
+# package require logger::utils
+#
+# Description:
+# this extension adds template based appenders
+#
+# Requirements:
+# package require logger
+#
+# Variables:
+# namespace ::logger::utils::
+# id: CVS ID: keyword extraction
+# version: current version of package
+# packageDir: directory where package is located
+# log: instance log
+#
+# Notes:
+# 1.
+#
+# Keywords:
+#
+#
+# Category:
+#
+#
+# End of Header
+
+package require Tcl 8.4
+package require logger
+package require logger::appender
+package require msgcat
+
+namespace eval ::logger::utils {
+
+ variable packageDir [file dirname [info script]]
+ variable log [logger::init logger::utils]
+
+ logger::import -force -namespace log logger::utils
+
+ # @mdgen OWNER: msgs/*.msg
+ ::msgcat::mcload [file join $packageDir msgs]
+}
+
+##Internal Procedure Header
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::utils::createFormatCmd
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::utils::createFormatCmd <formatString>
+#
+# Arguments:
+# <formatString>
+# string composed of formatting chars (see description)
+#
+#
+# Return Values:
+# a runnable command
+#
+# Description:
+# createFormatCmd translates <formatString> into an expandable
+# command string.
+#
+# The following are the known substitutions (from log4perl):
+# %c category of the logging event
+# %C fully qualified name of logging event
+# %d current date in yyyy/MM/dd hh:mm:ss
+# %H hostname
+# %m message to be logged
+# %M method where logging event was issued
+# %p priority of logging event
+# %P pid of current process
+#
+#
+# Examples:
+# ::logger::new param1
+# ::logger::new param2
+# ::logger::new param3 <option1>
+#
+#
+# Sample Input:
+# (Optional) Sample of input to the proc provided by its argument values.
+#
+# Sample Output:
+# (Optional) For procs that output to files, provide
+# sample of format of output produced.
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::utils::createFormatCmd {text args} {
+ variable log
+ array set opt $args
+
+ regsub -all -- \
+ {%P} \
+ $text \
+ [pid] \
+ text
+
+ regsub -all -- \
+ {%H} \
+ $text \
+ [info hostname] \
+ text
+
+
+ #the %d subst has to happen at the end
+ regsub -all -- \
+ {%d} \
+ $text \
+ {[clock format [clock seconds] -format {%Y/%m/%d %H:%M:%S}]} \
+ text
+
+ if {[info exists opt(-category)]} {
+ regsub -all -- \
+ {%c} \
+ $text \
+ $opt(-category) \
+ text
+
+ regsub -all -- \
+ {%C} \
+ $text \
+ [lindex [split $opt(-category) :: ] 0] \
+ text
+ }
+
+ if {[info exists opt(-priority)]} {
+ regsub -all -- \
+ {%p} \
+ $text \
+ $opt(-priority) \
+ text
+ }
+
+ return $text
+}
+
+
+
+##Procedure Header
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::utils::createLogProc
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::utils::createLogProc -procName <procName> [options]
+#
+# Arguments:
+# -procName <procName>
+# name of proc to create
+# -conversionPattern <pattern>
+# see createFormatCmd for <pattern>
+# -category <category>
+# the category (service)
+# -priority <priority>
+# the priority (level)
+# -outputChannel <channel>
+# channel to output on (default stdout)
+#
+#
+# Return Values:
+# a runnable command
+#
+# Description:
+# createFormatCmd translates <formatString> into an expandable
+# command string.
+#
+# The following are the known substitutions (from log4perl):
+# %c category of the logging event
+# %C fully qualified name of logging event
+# %d current date in yyyy/MM/dd hh:mm:ss
+# %H hostname
+# %m message to be logged
+# %M method where logging event was issued
+# %p priority of logging event
+# %P pid of current process
+#
+#
+# Examples:
+#
+#
+# Sample Input:
+# (Optional) Sample of input to the proc provided by its argument values.
+#
+# Sample Output:
+# (Optional) For procs that output to files, provide
+# sample of format of output produced.
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::utils::createLogProc {args} {
+ variable log
+ array set opt $args
+
+ set formatText ""
+ set methodText ""
+ if {[info exists opt(-conversionPattern)]} {
+ set text $opt(-conversionPattern)
+
+ regsub -all -- \
+ {%P} \
+ $text \
+ [pid] \
+ text
+
+ regsub -all -- \
+ {%H} \
+ $text \
+ [info hostname] \
+ text
+
+ if {[info exists opt(-category)]} {
+ regsub -all -- \
+ {%c} \
+ $text \
+ $opt(-category) \
+ text
+
+ regsub -all -- \
+ {%C} \
+ $text \
+ [lindex [split $opt(-category) :: ] 0] \
+ text
+ }
+
+ if {[info exists opt(-priority)]} {
+ regsub -all -- \
+ {%p} \
+ $text \
+ $opt(-priority) \
+ text
+ }
+
+
+ if {[regexp {%M} $text]} {
+ set methodText {
+ if {[info level] < 2} {
+ set method "global"
+ } else {
+ set method [lindex [info level -1] 0]
+ }
+
+ }
+
+ regsub -all -- \
+ {%M} \
+ $text \
+ {$method} \
+ text
+ }
+
+ regsub -all -- \
+ {%m} \
+ $text \
+ {$text} \
+ text
+
+ regsub -all -- \
+ {%d} \
+ $text \
+ {[clock format [clock seconds] -format {%Y/%m/%d %H:%M:%S}]} \
+ text
+
+ }
+
+ if {[info exists opt(-outputChannel)]} {
+ set outputChannel $opt(-outputChannel)
+ } else {
+ set outputChannel stdout
+ }
+
+ set formatText $text
+ set outputCommand puts
+
+ set procText {
+ proc $opt(-procName) {text} {
+ $methodText
+ $outputCommand $outputChannel \"$formatText\"
+ }
+ }
+
+ set procText [subst $procText]
+ return $procText
+}
+
+
+##Procedure Header
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::utils::applyAppender
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::utils::applyAppender -appender <appenderType> [options]
+#
+# Arguments:
+# -service <logger service names>
+# -serviceCmd <logger serviceCmds>
+# name of logger instance to modify
+# -serviceCmd takes as input the return of logger::init
+#
+# -appender <appenderType>
+# type of appender to use
+# console|colorConsole...
+#
+# -conversionPattern <pattern>
+# see createLogProc for format
+# if not provided the default pattern
+# is used:
+# {\[%d\] \[%c\] \[%M\] \[%p\] %m}
+#
+# -levels <levels to apply to>
+# list of levels to apply this appender to
+# by default all levels are applied to
+#
+# Return Values:
+#
+#
+# Description:
+# applyAppender will create an appender for the specified
+# logger services. If not service is specified then the
+# appender will be added as the default appender for
+# the specified levels. If no levels are specified, then
+# all levels are assumed.
+#
+# The following are the known substitutions (from log4perl):
+# %c category of the logging event
+# %C fully qualified name of logging event
+# %d current date in yyyy/MM/dd hh:mm:ss
+# %H hostname
+# %m message to be logged
+# %M method where logging event was issued
+# %p priority of logging event
+# %P pid of current process
+#
+#
+# Examples:
+# % set log [logger::init testLog]
+# ::logger::tree::testLog
+# % logger::utils::applyAppender -appender console -serviceCmd $log
+# % ${log}::error "this is error"
+# [2005/08/22 10:14:13] [testLog] [global] [error] this is error
+#
+#
+# End of Procedure Header
+
+
+proc ::logger::utils::applyAppender {args} {
+ set usage {logger::utils::applyAppender
+ -appender appender
+ ?-instance?
+ ?-levels levels?
+ ?-appenderArgs appenderArgs?
+ }
+ set levels [logger::levels]
+ set appenderArgs {}
+ set bargs $args
+ while {[llength $args] > 1} {
+ set opt [lindex $args 0]
+ set args [lrange $args 1 end]
+ switch -exact -- $opt {
+ -appender { set appender [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -serviceCmd { set serviceCmd [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -service { set serviceCmd [logger::servicecmd [lindex $args 0]]
+ set args [lrange $args 1 end]
+ }
+ -levels { set levels [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -appenderArgs {
+ set appenderArgs [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ default {
+ return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+ %s" $opt $usage]
+ }
+ }
+ }
+
+ set appender ::logger::appender::${appender}
+ if {[info commands $appender] == {}} {
+ return -code error [msgcat::mc "could not find appender '%s'" $appender]
+ }
+
+ #if service is not specified make all future services with this appender
+ # spec
+ if {![info exists serviceCmd]} {
+ set ::logger::utils::autoApplyAppenderArgs $bargs
+ #add trace
+ #check to see if trace is already set
+ if {[lsearch [trace info execution logger::init] \
+ {leave ::logger::utils::autoApplyAppender} ] == -1} {
+ trace add execution ::logger::init leave ::logger::utils::autoApplyAppender
+ }
+ return
+ }
+
+
+ #foreach service specified, apply the appender for each of the levels
+ # specified
+ foreach srvCmd $serviceCmd {
+
+ foreach lvl $levels {
+ set procText [$appender -appenderArgs $appenderArgs \
+ -level $lvl \
+ -service [${srvCmd}::servicename] \
+ -procNameVar procName
+ ]
+ eval $procText
+ ${srvCmd}::logproc $lvl $procName
+ }
+ }
+}
+
+
+##Internal Procedure Header
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::utils::autoApplyAppender
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::utils::autoApplyAppender <command> <command-string> <log> <op> <args>
+#
+# Arguments:
+# <command>
+# <command-string>
+# <log>
+# servicecmd generated by logger:init
+# <op>
+# <args>
+#
+# Return Values:
+# <log>
+#
+# Description:
+# autoApplyAppender is designed to be added via trace leave
+# to logger::init calls
+#
+# autoApplyAppender will look at preconfigred state (via applyAppender)
+# to autocreate appenders for newly created logger instances
+#
+# Examples:
+# logger::utils::applyAppender -appender console
+# set log [logger::init applyAppender-3]
+# ${log}::error "this is error"
+#
+#
+# Sample Input:
+#
+# Sample Output:
+#
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::utils::autoApplyAppender {command command-string log op args} {
+ variable autoApplyAppenderArgs
+ set bAppArgs $autoApplyAppenderArgs
+ set levels [logger::levels]
+ set appenderArgs {}
+ while {[llength $bAppArgs] > 1} {
+ set opt [lindex $bAppArgs 0]
+ set bAppArgs [lrange $bAppArgs 1 end]
+ switch -exact -- $opt {
+ -appender { set appender [lindex $bAppArgs 0]
+ set bAppArgs [lrange $bAppArgs 1 end]
+ }
+ -levels { set levels [lindex $bAppArgs 0]
+ set bAppArgs [lrange $bAppArgs 1 end]
+ }
+ -appenderArgs {
+ set appenderArgs [lindex $bAppArgs 0]
+ set bAppArgs [lrange $bAppArgs 1 end]
+ }
+ default {
+ return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+ %s" $opt $usage]
+ }
+ }
+ }
+ if {![info exists appender]} {
+ return -code error [msgcat::mc "need to specify -appender"]
+ }
+ logger::utils::applyAppender -appender $appender -serviceCmd $log \
+ -levels $levels -appenderArgs $appenderArgs
+ return $log
+}
+
+
+package provide logger::utils 1.3
+
+# ;;; Local Variables: ***
+# ;;; mode: tcl ***
+# ;;; End: ***
--- /dev/null
+# -*- tcl -*-
+# loggerperformance.tcl
+
+# $Id: loggerperformance,v 1.2 2004/01/15 06:36:13 andreas_kupries Exp $
+
+# This code is for benchmarking the performance of the log tools.
+
+set auto_path "[file dirname [info script]] $auto_path"
+package require logger
+package require log
+
+# Set up logger
+set log [logger::init date]
+
+# Create a custom log routine, so we don't deal with the overhead of
+# the default one, which does some system calls itself.
+
+${log}::logproc notice txt {
+ puts "$txt"
+}
+
+# Basic output.
+proc Test1 {} {
+ set date [clock format [clock seconds]]
+ puts "Date is now $date"
+}
+
+# No output at all. This is the benchmark by which 'turned off' log
+# systems should be judged.
+proc Test2 {} {
+ set date [clock format [clock seconds]]
+}
+
+# Use logger.
+proc Test3 {} {
+ set date [clock format [clock seconds]]
+ ${::log}::notice "Date is now $date"
+}
+
+# Use log.
+proc Test4 {} {
+ set date [clock format [clock seconds]]
+ log::log notice "Date is now $date"
+}
+
+set res1 [time {
+ Test1
+} 1000]
+
+set res2 [time {
+ Test2
+} 1000]
+
+set res3 [time {
+ Test3
+} 1000]
+
+${log}::disable notice
+
+set res4 [time {
+ Test3
+} 1000]
+
+set res5 [time {
+ Test4
+} 1000]
+
+log::lvSuppressLE notice
+
+set res6 [time {
+ Test4
+} 1000]
+
+puts "Puts output: $res1"
+puts "No output: $res2"
+puts "Logger: $res3"
+puts "Logger disabled: $res4"
+puts "Log: $res5"
+puts "Log disabled: $res6"
--- /dev/null
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset en "Unknown argument: \"%s\" :\nUsage: %s" "Unknown argument: \"%s\" :\nUsage: %s"
+mcset en "could not find appender '%s'" "could not find appender '%s'"
+mcset en "need to specify -appender" "need to specify -appender"
--- /dev/null
+if {![package vsatisfies [package provide Tcl] 8]} {return}
+package ifneeded log 1.2 [list source [file join $dir log.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded logger 0.8 [list source [file join $dir logger.tcl]]
+package ifneeded logger::appender 1.3 [list source [file join $dir loggerAppender.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded logger::utils 1.3 [list source [file join $dir loggerUtils.tcl]]
--- /dev/null
+##################################################
+#
+# md5.tcl - MD5 in Tcl
+# Author: Don Libes <libes@nist.gov>, July 1999
+# Version 1.2.0
+#
+# MD5 defined by RFC 1321, "The MD5 Message-Digest Algorithm"
+# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
+#
+# Most of the comments below come right out of RFC 1321; That's why
+# they have such peculiar numbers. In addition, I have retained
+# original syntax, bugs in documentation (yes, really), etc. from the
+# RFC. All remaining bugs are mine.
+#
+# HMAC implementation by D. J. Hagberg <dhagberg@millibits.com> and
+# is based on C code in RFC 2104.
+#
+# For more info, see: http://expect.nist.gov/md5pure
+#
+# - Don
+#
+# Modified by Miguel Sofer to use inlines and simple variables
+##################################################
+
+# @mdgen EXCLUDE: md5c.tcl
+
+package require Tcl 8.2
+namespace eval ::md5 {
+}
+
+if {![catch {package require Trf 2.0}] && ![catch {::md5 -- test}]} {
+ # Trf is available, so implement the functionality provided here
+ # in terms of calls to Trf for speed.
+
+ proc ::md5::md5 {msg} {
+ string tolower [::hex -mode encode -- [::md5 -- $msg]]
+ }
+
+ # hmac: hash for message authentication
+
+ # MD5 of Trf and MD5 as defined by this package have slightly
+ # different results. Trf returns the digest in binary, here we get
+ # it as hex-string. In the computation of the HMAC the latter
+ # requires back conversion into binary in some places. With Trf we
+ # can use omit these.
+
+ proc ::md5::hmac {key text} {
+ # if key is longer than 64 bytes, reset it to MD5(key). If shorter,
+ # pad it out with null (\x00) chars.
+ set keyLen [string length $key]
+ if {$keyLen > 64} {
+ #old: set key [binary format H32 [md5 $key]]
+ set key [::md5 -- $key]
+ set keyLen [string length $key]
+ }
+
+ # ensure the key is padded out to 64 chars with nulls.
+ set padLen [expr {64 - $keyLen}]
+ append key [binary format "a$padLen" {}]
+
+ # Split apart the key into a list of 16 little-endian words
+ binary scan $key i16 blocks
+
+ # XOR key with ipad and opad values
+ set k_ipad {}
+ set k_opad {}
+ foreach i $blocks {
+ append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
+ append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
+ }
+
+ # Perform inner md5, appending its results to the outer key
+ append k_ipad $text
+ #old: append k_opad [binary format H* [md5 $k_ipad]]
+ append k_opad [::md5 -- $k_ipad]
+
+ # Perform outer md5
+ #old: md5 $k_opad
+ string tolower [::hex -mode encode -- [::md5 -- $k_opad]]
+ }
+
+} else {
+ # Without Trf use the all-tcl implementation by Don Libes.
+
+ # T will be inlined after the definition of md5body
+
+ # test md5
+ #
+ # This proc is not necessary during runtime and may be omitted if you
+ # are simply inserting this file into a production program.
+ #
+ proc ::md5::test {} {
+ foreach {msg expected} {
+ ""
+ "d41d8cd98f00b204e9800998ecf8427e"
+ "a"
+ "0cc175b9c0f1b6a831c399e269772661"
+ "abc"
+ "900150983cd24fb0d6963f7d28e17f72"
+ "message digest"
+ "f96b697d7cb7938d525a2f31aaf161d0"
+ "abcdefghijklmnopqrstuvwxyz"
+ "c3fcd3d76192e4007dfb496cca67e13b"
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ "d174ab98d277d9f5a5611c2c9f419d9f"
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "57edf4a22be3c955ac49da2e2107b67a"
+ } {
+ puts "testing: md5 \"$msg\""
+ set computed [md5 $msg]
+ puts "expected: $expected"
+ puts "computed: $computed"
+ if {0 != [string compare $computed $expected]} {
+ puts "FAILED"
+ } else {
+ puts "SUCCEEDED"
+ }
+ }
+ }
+
+ # time md5
+ #
+ # This proc is not necessary during runtime and may be omitted if you
+ # are simply inserting this file into a production program.
+ #
+ proc ::md5::time {} {
+ foreach len {10 50 100 500 1000 5000 10000} {
+ set time [::time {md5 [format %$len.0s ""]} 100]
+ set msec [lindex $time 0]
+ puts "input length $len: [expr {$msec/1000}] milliseconds per interation"
+ }
+ }
+
+ #
+ # We just define the body of md5pure::md5 here; later we
+ # regsub to inline a few function calls for speed
+ #
+
+ set ::md5::md5body {
+
+ #
+ # 3.1 Step 1. Append Padding Bits
+ #
+
+ set msgLen [string length $msg]
+
+ set padLen [expr {56 - $msgLen%64}]
+ if {$msgLen % 64 > 56} {
+ incr padLen 64
+ }
+
+ # pad even if no padding required
+ if {$padLen == 0} {
+ incr padLen 64
+ }
+
+ # append single 1b followed by 0b's
+ append msg [binary format "a$padLen" \200]
+
+ #
+ # 3.2 Step 2. Append Length
+ #
+
+ # RFC doesn't say whether to use little- or big-endian
+ # code demonstrates little-endian
+ # This step limits our input to size 2^32b or 2^24B
+ append msg [binary format "i1i1" [expr {8*$msgLen}] 0]
+
+ #
+ # 3.3 Step 3. Initialize MD Buffer
+ #
+
+ set A [expr 0x67452301]
+ set B [expr 0xefcdab89]
+ set C [expr 0x98badcfe]
+ set D [expr 0x10325476]
+
+ #
+ # 3.4 Step 4. Process Message in 16-Word Blocks
+ #
+
+ # process each 16-word block
+ # RFC doesn't say whether to use little- or big-endian
+ # code says little-endian
+ binary scan $msg i* blocks
+
+ # loop over the message taking 16 blocks at a time
+
+ foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {
+
+ # Save A as AA, B as BB, C as CC, and D as DD.
+ set AA $A
+ set BB $B
+ set CC $C
+ set DD $D
+
+ # Round 1.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s).
+ # [ABCD 0 7 1] [DABC 1 12 2] [CDAB 2 17 3] [BCDA 3 22 4]
+ set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X0 + $T01}] 7]}]
+ set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X1 + $T02}] 12]}]
+ set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X2 + $T03}] 17]}]
+ set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X3 + $T04}] 22]}]
+ # [ABCD 4 7 5] [DABC 5 12 6] [CDAB 6 17 7] [BCDA 7 22 8]
+ set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X4 + $T05}] 7]}]
+ set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X5 + $T06}] 12]}]
+ set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X6 + $T07}] 17]}]
+ set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X7 + $T08}] 22]}]
+ # [ABCD 8 7 9] [DABC 9 12 10] [CDAB 10 17 11] [BCDA 11 22 12]
+ set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X8 + $T09}] 7]}]
+ set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X9 + $T10}] 12]}]
+ set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X10 + $T11}] 17]}]
+ set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X11 + $T12}] 22]}]
+ # [ABCD 12 7 13] [DABC 13 12 14] [CDAB 14 17 15] [BCDA 15 22 16]
+ set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X12 + $T13}] 7]}]
+ set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X13 + $T14}] 12]}]
+ set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X14 + $T15}] 17]}]
+ set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X15 + $T16}] 22]}]
+
+ # Round 2.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s).
+ # Do the following 16 operations.
+ # [ABCD 1 5 17] [DABC 6 9 18] [CDAB 11 14 19] [BCDA 0 20 20]
+ set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X1 + $T17}] 5]}]
+ set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X6 + $T18}] 9]}]
+ set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X11 + $T19}] 14]}]
+ set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X0 + $T20}] 20]}]
+ # [ABCD 5 5 21] [DABC 10 9 22] [CDAB 15 14 23] [BCDA 4 20 24]
+ set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X5 + $T21}] 5]}]
+ set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X10 + $T22}] 9]}]
+ set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X15 + $T23}] 14]}]
+ set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X4 + $T24}] 20]}]
+ # [ABCD 9 5 25] [DABC 14 9 26] [CDAB 3 14 27] [BCDA 8 20 28]
+ set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X9 + $T25}] 5]}]
+ set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X14 + $T26}] 9]}]
+ set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X3 + $T27}] 14]}]
+ set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X8 + $T28}] 20]}]
+ # [ABCD 13 5 29] [DABC 2 9 30] [CDAB 7 14 31] [BCDA 12 20 32]
+ set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X13 + $T29}] 5]}]
+ set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X2 + $T30}] 9]}]
+ set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X7 + $T31}] 14]}]
+ set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X12 + $T32}] 20]}]
+
+ # Round 3.
+ # Let [abcd k s t] [sic] denote the operation
+ # a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s).
+ # Do the following 16 operations.
+ # [ABCD 5 4 33] [DABC 8 11 34] [CDAB 11 16 35] [BCDA 14 23 36]
+ set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X5 + $T33}] 4]}]
+ set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X8 + $T34}] 11]}]
+ set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X11 + $T35}] 16]}]
+ set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X14 + $T36}] 23]}]
+ # [ABCD 1 4 37] [DABC 4 11 38] [CDAB 7 16 39] [BCDA 10 23 40]
+ set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X1 + $T37}] 4]}]
+ set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X4 + $T38}] 11]}]
+ set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X7 + $T39}] 16]}]
+ set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X10 + $T40}] 23]}]
+ # [ABCD 13 4 41] [DABC 0 11 42] [CDAB 3 16 43] [BCDA 6 23 44]
+ set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X13 + $T41}] 4]}]
+ set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X0 + $T42}] 11]}]
+ set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X3 + $T43}] 16]}]
+ set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X6 + $T44}] 23]}]
+ # [ABCD 9 4 45] [DABC 12 11 46] [CDAB 15 16 47] [BCDA 2 23 48]
+ set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X9 + $T45}] 4]}]
+ set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X12 + $T46}] 11]}]
+ set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X15 + $T47}] 16]}]
+ set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X2 + $T48}] 23]}]
+
+ # Round 4.
+ # Let [abcd k s t] [sic] denote the operation
+ # a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s).
+ # Do the following 16 operations.
+ # [ABCD 0 6 49] [DABC 7 10 50] [CDAB 14 15 51] [BCDA 5 21 52]
+ set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X0 + $T49}] 6]}]
+ set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X7 + $T50}] 10]}]
+ set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X14 + $T51}] 15]}]
+ set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X5 + $T52}] 21]}]
+ # [ABCD 12 6 53] [DABC 3 10 54] [CDAB 10 15 55] [BCDA 1 21 56]
+ set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X12 + $T53}] 6]}]
+ set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X3 + $T54}] 10]}]
+ set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X10 + $T55}] 15]}]
+ set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X1 + $T56}] 21]}]
+ # [ABCD 8 6 57] [DABC 15 10 58] [CDAB 6 15 59] [BCDA 13 21 60]
+ set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X8 + $T57}] 6]}]
+ set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X15 + $T58}] 10]}]
+ set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X6 + $T59}] 15]}]
+ set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X13 + $T60}] 21]}]
+ # [ABCD 4 6 61] [DABC 11 10 62] [CDAB 2 15 63] [BCDA 9 21 64]
+ set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X4 + $T61}] 6]}]
+ set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X11 + $T62}] 10]}]
+ set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X2 + $T63}] 15]}]
+ set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X9 + $T64}] 21]}]
+
+ # Then perform the following additions. (That is increment each
+ # of the four registers by the value it had before this block
+ # was started.)
+ incr A $AA
+ incr B $BB
+ incr C $CC
+ incr D $DD
+ }
+ # 3.5 Step 5. Output
+
+ # ... begin with the low-order byte of A, and end with the high-order byte
+ # of D.
+
+ return [bytes $A][bytes $B][bytes $C][bytes $D]
+ }
+
+ #
+ # Here we inline/regsub the functions F, G, H, I and <<<
+ #
+
+ namespace eval ::md5 {
+ #proc md5pure::F {x y z} {expr {(($x & $y) | ((~$x) & $z))}}
+ regsub -all -- {\[ *F +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \2) | ((~\1) \& \3))} md5body
+
+ #proc md5pure::G {x y z} {expr {(($x & $z) | ($y & (~$z)))}}
+ regsub -all -- {\[ *G +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \3) | (\2 \& (~\3)))} md5body
+
+ #proc md5pure::H {x y z} {expr {$x ^ $y ^ $z}}
+ regsub -all -- {\[ *H +(\$.) +(\$.) +(\$.) *\]} $md5body {(\1 ^ \2 ^ \3)} md5body
+
+ #proc md5pure::I {x y z} {expr {$y ^ ($x | (~$z))}}
+ regsub -all -- {\[ *I +(\$.) +(\$.) +(\$.) *\]} $md5body {(\2 ^ (\1 | (~\3)))} md5body
+
+ # bitwise left-rotate
+ if {0} {
+ proc md5pure::<<< {x i} {
+ # This works by bitwise-ORing together right piece and left
+ # piece so that the (original) right piece becomes the left
+ # piece and vice versa.
+ #
+ # The (original) right piece is a simple left shift.
+ # The (original) left piece should be a simple right shift
+ # but Tcl does sign extension on right shifts so we
+ # shift it 1 bit, mask off the sign, and finally shift
+ # it the rest of the way.
+
+ # expr {($x << $i) | ((($x >> 1) & 0x7fffffff) >> (31-$i))}
+
+ #
+ # New version, faster when inlining
+ # We replace inline (computing at compile time):
+ # R$i -> (32 - $i)
+ # S$i -> (0x7fffffff >> (31-$i))
+ #
+
+ expr { ($x << $i) | (($x >> [set R$i]) & [set S$i])}
+ }
+ }
+ # inline <<<
+ regsub -all -- {\[ *<<< +\[ *expr +({[^\}]*})\] +([0-9]+) *\]} $md5body {(([set x [expr \1]] << \2) | (($x >> R\2) \& S\2))} md5body
+
+ # now replace the R and S
+ set map {}
+ foreach i {
+ 7 12 17 22
+ 5 9 14 20
+ 4 11 16 23
+ 6 10 15 21
+ } {
+ lappend map R$i [expr {32 - $i}] S$i [expr {0x7fffffff >> (31-$i)}]
+ }
+
+ # inline the values of T
+ foreach \
+ tName {
+ T01 T02 T03 T04 T05 T06 T07 T08 T09 T10
+ T11 T12 T13 T14 T15 T16 T17 T18 T19 T20
+ T21 T22 T23 T24 T25 T26 T27 T28 T29 T30
+ T31 T32 T33 T34 T35 T36 T37 T38 T39 T40
+ T41 T42 T43 T44 T45 T46 T47 T48 T49 T50
+ T51 T52 T53 T54 T55 T56 T57 T58 T59 T60
+ T61 T62 T63 T64 } \
+ tVal {
+ 0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee
+ 0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501
+ 0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be
+ 0x6b901122 0xfd987193 0xa679438e 0x49b40821
+
+ 0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa
+ 0xd62f105d 0x2441453 0xd8a1e681 0xe7d3fbc8
+ 0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed
+ 0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a
+
+ 0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c
+ 0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70
+ 0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05
+ 0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665
+
+ 0xf4292244 0x432aff97 0xab9423a7 0xfc93a039
+ 0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1
+ 0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1
+ 0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391
+ } {
+ lappend map \$$tName $tVal
+ }
+ set md5body [string map $map $md5body]
+
+
+ # Finally, define the proc
+ proc md5 {msg} $md5body
+
+ # unset auxiliary variables
+ unset md5body tName tVal map
+ }
+
+ proc ::md5::byte0 {i} {expr {0xff & $i}}
+ proc ::md5::byte1 {i} {expr {(0xff00 & $i) >> 8}}
+ proc ::md5::byte2 {i} {expr {(0xff0000 & $i) >> 16}}
+ proc ::md5::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}}
+
+ proc ::md5::bytes {i} {
+ format %0.2x%0.2x%0.2x%0.2x [byte0 $i] [byte1 $i] [byte2 $i] [byte3 $i]
+ }
+
+ # hmac: hash for message authentication
+ proc ::md5::hmac {key text} {
+ # if key is longer than 64 bytes, reset it to MD5(key). If shorter,
+ # pad it out with null (\x00) chars.
+ set keyLen [string length $key]
+ if {$keyLen > 64} {
+ set key [binary format H32 [md5 $key]]
+ set keyLen [string length $key]
+ }
+
+ # ensure the key is padded out to 64 chars with nulls.
+ set padLen [expr {64 - $keyLen}]
+ append key [binary format "a$padLen" {}]
+
+ # Split apart the key into a list of 16 little-endian words
+ binary scan $key i16 blocks
+
+ # XOR key with ipad and opad values
+ set k_ipad {}
+ set k_opad {}
+ foreach i $blocks {
+ append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
+ append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
+ }
+
+ # Perform inner md5, appending its results to the outer key
+ append k_ipad $text
+ append k_opad [binary format H* [md5 $k_ipad]]
+
+ # Perform outer md5
+ md5 $k_opad
+ }
+}
+
+package provide md5 1.4.4
--- /dev/null
+# md5.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# MD5 defined by RFC 1321, "The MD5 Message-Digest Algorithm"
+# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
+#
+# This is an implementation of MD5 based upon the example code given in
+# RFC 1321 and upon the tcllib MD4 implementation and taking some ideas
+# from the earlier tcllib md5 version by Don Libes.
+#
+# This implementation permits incremental updating of the hash and
+# provides support for external compiled implementations either using
+# critcl (md5c) or Trf.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: md5x.tcl,v 1.17 2006/09/19 23:36:17 andreas_kupries Exp $
+
+package require Tcl 8.2; # tcl minimum version
+
+namespace eval ::md5 {
+ variable version 2.0.5
+ variable rcsid {$Id: md5x.tcl,v 1.17 2006/09/19 23:36:17 andreas_kupries Exp $}
+ variable accel
+ array set accel {critcl 0 cryptkit 0 trf 0}
+
+ namespace export md5 hmac MD5Init MD5Update MD5Final
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# MD5Init --
+#
+# Create and initialize an MD5 state variable. This will be
+# cleaned up when we call MD5Final
+#
+proc ::md5::MD5Init {} {
+ variable accel
+ variable uid
+ set token [namespace current]::[incr uid]
+ upvar #0 $token state
+
+ # RFC1321:3.3 - Initialize MD5 state structure
+ array set state \
+ [list \
+ A [expr {0x67452301}] \
+ B [expr {0xefcdab89}] \
+ C [expr {0x98badcfe}] \
+ D [expr {0x10325476}] \
+ n 0 i "" ]
+ if {$accel(cryptkit)} {
+ cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_MD5
+ } elseif {$accel(trf)} {
+ set s {}
+ switch -exact -- $::tcl_platform(platform) {
+ windows { set s [open NUL w] }
+ unix { set s [open /dev/null w] }
+ }
+ if {$s != {}} {
+ fconfigure $s -translation binary -buffering none
+ ::md5 -attach $s -mode write \
+ -read-type variable \
+ -read-destination [subst $token](trfread) \
+ -write-type variable \
+ -write-destination [subst $token](trfwrite)
+ array set state [list trfread 0 trfwrite 0 trf $s]
+ }
+ }
+ return $token
+}
+
+# MD5Update --
+#
+# This is called to add more data into the hash. You may call this
+# as many times as you require. Note that passing in "ABC" is equivalent
+# to passing these letters in as separate calls -- hence this proc
+# permits hashing of chunked data
+#
+# If we have a C-based implementation available, then we will use
+# it here in preference to the pure-Tcl implementation.
+#
+proc ::md5::MD5Update {token data} {
+ variable accel
+ upvar #0 $token state
+
+ if {$accel(critcl)} {
+ if {[info exists state(md5c)]} {
+ set state(md5c) [md5c $data $state(md5c)]
+ } else {
+ set state(md5c) [md5c $data]
+ }
+ return
+ } elseif {[info exists state(ckctx)]} {
+ if {[string length $data] > 0} {
+ cryptkit::cryptEncrypt $state(ckctx) $data
+ }
+ return
+ } elseif {[info exists state(trf)]} {
+ puts -nonewline $state(trf) $data
+ return
+ }
+
+ # Update the state values
+ incr state(n) [string length $data]
+ append state(i) $data
+
+ # Calculate the hash for any complete blocks
+ set len [string length $state(i)]
+ for {set n 0} {($n + 64) <= $len} {} {
+ MD5Hash $token [string range $state(i) $n [incr n 64]]
+ }
+
+ # Adjust the state for the blocks completed.
+ set state(i) [string range $state(i) $n end]
+ return
+}
+
+# MD5Final --
+#
+# This procedure is used to close the current hash and returns the
+# hash data. Once this procedure has been called the hash context
+# is freed and cannot be used again.
+#
+# Note that the output is 128 bits represented as binary data.
+#
+proc ::md5::MD5Final {token} {
+ upvar #0 $token state
+
+ # Check for either of the C-compiled versions.
+ if {[info exists state(md5c)]} {
+ set r $state(md5c)
+ unset state
+ return $r
+ } elseif {[info exists state(ckctx)]} {
+ cryptkit::cryptEncrypt $state(ckctx) ""
+ cryptkit::cryptGetAttributeString $state(ckctx) \
+ CRYPT_CTXINFO_HASHVALUE r 16
+ cryptkit::cryptDestroyContext $state(ckctx)
+ # If nothing was hashed, we get no r variable set!
+ if {[info exists r]} {
+ unset state
+ return $r
+ }
+ } elseif {[info exists state(trf)]} {
+ close $state(trf)
+ set r $state(trfwrite)
+ unset state
+ return $r
+ }
+
+ # RFC1321:3.1 - Padding
+ #
+ set len [string length $state(i)]
+ set pad [expr {56 - ($len % 64)}]
+ if {$len % 64 > 56} {
+ incr pad 64
+ }
+ if {$pad == 0} {
+ incr pad 64
+ }
+ append state(i) [binary format a$pad \x80]
+
+ # RFC1321:3.2 - Append length in bits as little-endian wide int.
+ append state(i) [binary format ii [expr {8 * $state(n)}] 0]
+
+ # Calculate the hash for the remaining block.
+ set len [string length $state(i)]
+ for {set n 0} {($n + 64) <= $len} {} {
+ MD5Hash $token [string range $state(i) $n [incr n 64]]
+ }
+
+ # RFC1321:3.5 - Output
+ set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)]
+ unset state
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# HMAC Hashed Message Authentication (RFC 2104)
+#
+# hmac = H(K xor opad, H(K xor ipad, text))
+#
+
+# HMACInit --
+#
+# This is equivalent to the MD5Init procedure except that a key is
+# added into the algorithm
+#
+proc ::md5::HMACInit {K} {
+
+ # Key K is adjusted to be 64 bytes long. If K is larger, then use
+ # the MD5 digest of K and pad this instead.
+ set len [string length $K]
+ if {$len > 64} {
+ set tok [MD5Init]
+ MD5Update $tok $K
+ set K [MD5Final $tok]
+ set len [string length $K]
+ }
+ set pad [expr {64 - $len}]
+ append K [string repeat \0 $pad]
+
+ # Cacluate the padding buffers.
+ set Ki {}
+ set Ko {}
+ binary scan $K i16 Ks
+ foreach k $Ks {
+ append Ki [binary format i [expr {$k ^ 0x36363636}]]
+ append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]]
+ }
+
+ set tok [MD5Init]
+ MD5Update $tok $Ki; # initialize with the inner pad
+
+ # preserve the Ko value for the final stage.
+ # FRINK: nocheck
+ set [subst $tok](Ko) $Ko
+
+ return $tok
+}
+
+# HMACUpdate --
+#
+# Identical to calling MD5Update
+#
+proc ::md5::HMACUpdate {token data} {
+ MD5Update $token $data
+ return
+}
+
+# HMACFinal --
+#
+# This is equivalent to the MD5Final procedure. The hash context is
+# closed and the binary representation of the hash result is returned.
+#
+proc ::md5::HMACFinal {token} {
+ upvar #0 $token state
+
+ set tok [MD5Init]; # init the outer hashing function
+ MD5Update $tok $state(Ko); # prepare with the outer pad.
+ MD5Update $tok [MD5Final $token]; # hash the inner result
+ return [MD5Final $tok]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# This is the core MD5 algorithm. It is a lot like the MD4 algorithm but
+# includes an extra round and a set of constant modifiers throughout.
+#
+# Note:
+# This function body is substituted later on to inline some of the
+# procedures and to make is a bit more comprehensible.
+#
+set ::md5::MD5Hash_body {
+ variable $token
+ upvar 0 $token state
+
+ # RFC1321:3.4 - Process Message in 16-Word Blocks
+ binary scan $msg i* blocks
+ foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {
+ set A $state(A)
+ set B $state(B)
+ set C $state(C)
+ set D $state(D)
+
+ # Round 1
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s).
+ # Do the following 16 operations.
+ # [ABCD 0 7 1] [DABC 1 12 2] [CDAB 2 17 3] [BCDA 3 22 4]
+ set A [expr {$B + (($A + [F $B $C $D] + $X0 + $T01) <<< 7)}]
+ set D [expr {$A + (($D + [F $A $B $C] + $X1 + $T02) <<< 12)}]
+ set C [expr {$D + (($C + [F $D $A $B] + $X2 + $T03) <<< 17)}]
+ set B [expr {$C + (($B + [F $C $D $A] + $X3 + $T04) <<< 22)}]
+ # [ABCD 4 7 5] [DABC 5 12 6] [CDAB 6 17 7] [BCDA 7 22 8]
+ set A [expr {$B + (($A + [F $B $C $D] + $X4 + $T05) <<< 7)}]
+ set D [expr {$A + (($D + [F $A $B $C] + $X5 + $T06) <<< 12)}]
+ set C [expr {$D + (($C + [F $D $A $B] + $X6 + $T07) <<< 17)}]
+ set B [expr {$C + (($B + [F $C $D $A] + $X7 + $T08) <<< 22)}]
+ # [ABCD 8 7 9] [DABC 9 12 10] [CDAB 10 17 11] [BCDA 11 22 12]
+ set A [expr {$B + (($A + [F $B $C $D] + $X8 + $T09) <<< 7)}]
+ set D [expr {$A + (($D + [F $A $B $C] + $X9 + $T10) <<< 12)}]
+ set C [expr {$D + (($C + [F $D $A $B] + $X10 + $T11) <<< 17)}]
+ set B [expr {$C + (($B + [F $C $D $A] + $X11 + $T12) <<< 22)}]
+ # [ABCD 12 7 13] [DABC 13 12 14] [CDAB 14 17 15] [BCDA 15 22 16]
+ set A [expr {$B + (($A + [F $B $C $D] + $X12 + $T13) <<< 7)}]
+ set D [expr {$A + (($D + [F $A $B $C] + $X13 + $T14) <<< 12)}]
+ set C [expr {$D + (($C + [F $D $A $B] + $X14 + $T15) <<< 17)}]
+ set B [expr {$C + (($B + [F $C $D $A] + $X15 + $T16) <<< 22)}]
+
+ # Round 2.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + G(b,c,d) + X[k] + Ti) <<< s)
+ # Do the following 16 operations.
+ # [ABCD 1 5 17] [DABC 6 9 18] [CDAB 11 14 19] [BCDA 0 20 20]
+ set A [expr {$B + (($A + [G $B $C $D] + $X1 + $T17) <<< 5)}]
+ set D [expr {$A + (($D + [G $A $B $C] + $X6 + $T18) <<< 9)}]
+ set C [expr {$D + (($C + [G $D $A $B] + $X11 + $T19) <<< 14)}]
+ set B [expr {$C + (($B + [G $C $D $A] + $X0 + $T20) <<< 20)}]
+ # [ABCD 5 5 21] [DABC 10 9 22] [CDAB 15 14 23] [BCDA 4 20 24]
+ set A [expr {$B + (($A + [G $B $C $D] + $X5 + $T21) <<< 5)}]
+ set D [expr {$A + (($D + [G $A $B $C] + $X10 + $T22) <<< 9)}]
+ set C [expr {$D + (($C + [G $D $A $B] + $X15 + $T23) <<< 14)}]
+ set B [expr {$C + (($B + [G $C $D $A] + $X4 + $T24) <<< 20)}]
+ # [ABCD 9 5 25] [DABC 14 9 26] [CDAB 3 14 27] [BCDA 8 20 28]
+ set A [expr {$B + (($A + [G $B $C $D] + $X9 + $T25) <<< 5)}]
+ set D [expr {$A + (($D + [G $A $B $C] + $X14 + $T26) <<< 9)}]
+ set C [expr {$D + (($C + [G $D $A $B] + $X3 + $T27) <<< 14)}]
+ set B [expr {$C + (($B + [G $C $D $A] + $X8 + $T28) <<< 20)}]
+ # [ABCD 13 5 29] [DABC 2 9 30] [CDAB 7 14 31] [BCDA 12 20 32]
+ set A [expr {$B + (($A + [G $B $C $D] + $X13 + $T29) <<< 5)}]
+ set D [expr {$A + (($D + [G $A $B $C] + $X2 + $T30) <<< 9)}]
+ set C [expr {$D + (($C + [G $D $A $B] + $X7 + $T31) <<< 14)}]
+ set B [expr {$C + (($B + [G $C $D $A] + $X12 + $T32) <<< 20)}]
+
+ # Round 3.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s)
+ # Do the following 16 operations.
+ # [ABCD 5 4 33] [DABC 8 11 34] [CDAB 11 16 35] [BCDA 14 23 36]
+ set A [expr {$B + (($A + [H $B $C $D] + $X5 + $T33) <<< 4)}]
+ set D [expr {$A + (($D + [H $A $B $C] + $X8 + $T34) <<< 11)}]
+ set C [expr {$D + (($C + [H $D $A $B] + $X11 + $T35) <<< 16)}]
+ set B [expr {$C + (($B + [H $C $D $A] + $X14 + $T36) <<< 23)}]
+ # [ABCD 1 4 37] [DABC 4 11 38] [CDAB 7 16 39] [BCDA 10 23 40]
+ set A [expr {$B + (($A + [H $B $C $D] + $X1 + $T37) <<< 4)}]
+ set D [expr {$A + (($D + [H $A $B $C] + $X4 + $T38) <<< 11)}]
+ set C [expr {$D + (($C + [H $D $A $B] + $X7 + $T39) <<< 16)}]
+ set B [expr {$C + (($B + [H $C $D $A] + $X10 + $T40) <<< 23)}]
+ # [ABCD 13 4 41] [DABC 0 11 42] [CDAB 3 16 43] [BCDA 6 23 44]
+ set A [expr {$B + (($A + [H $B $C $D] + $X13 + $T41) <<< 4)}]
+ set D [expr {$A + (($D + [H $A $B $C] + $X0 + $T42) <<< 11)}]
+ set C [expr {$D + (($C + [H $D $A $B] + $X3 + $T43) <<< 16)}]
+ set B [expr {$C + (($B + [H $C $D $A] + $X6 + $T44) <<< 23)}]
+ # [ABCD 9 4 45] [DABC 12 11 46] [CDAB 15 16 47] [BCDA 2 23 48]
+ set A [expr {$B + (($A + [H $B $C $D] + $X9 + $T45) <<< 4)}]
+ set D [expr {$A + (($D + [H $A $B $C] + $X12 + $T46) <<< 11)}]
+ set C [expr {$D + (($C + [H $D $A $B] + $X15 + $T47) <<< 16)}]
+ set B [expr {$C + (($B + [H $C $D $A] + $X2 + $T48) <<< 23)}]
+
+ # Round 4.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s)
+ # Do the following 16 operations.
+ # [ABCD 0 6 49] [DABC 7 10 50] [CDAB 14 15 51] [BCDA 5 21 52]
+ set A [expr {$B + (($A + [I $B $C $D] + $X0 + $T49) <<< 6)}]
+ set D [expr {$A + (($D + [I $A $B $C] + $X7 + $T50) <<< 10)}]
+ set C [expr {$D + (($C + [I $D $A $B] + $X14 + $T51) <<< 15)}]
+ set B [expr {$C + (($B + [I $C $D $A] + $X5 + $T52) <<< 21)}]
+ # [ABCD 12 6 53] [DABC 3 10 54] [CDAB 10 15 55] [BCDA 1 21 56]
+ set A [expr {$B + (($A + [I $B $C $D] + $X12 + $T53) <<< 6)}]
+ set D [expr {$A + (($D + [I $A $B $C] + $X3 + $T54) <<< 10)}]
+ set C [expr {$D + (($C + [I $D $A $B] + $X10 + $T55) <<< 15)}]
+ set B [expr {$C + (($B + [I $C $D $A] + $X1 + $T56) <<< 21)}]
+ # [ABCD 8 6 57] [DABC 15 10 58] [CDAB 6 15 59] [BCDA 13 21 60]
+ set A [expr {$B + (($A + [I $B $C $D] + $X8 + $T57) <<< 6)}]
+ set D [expr {$A + (($D + [I $A $B $C] + $X15 + $T58) <<< 10)}]
+ set C [expr {$D + (($C + [I $D $A $B] + $X6 + $T59) <<< 15)}]
+ set B [expr {$C + (($B + [I $C $D $A] + $X13 + $T60) <<< 21)}]
+ # [ABCD 4 6 61] [DABC 11 10 62] [CDAB 2 15 63] [BCDA 9 21 64]
+ set A [expr {$B + (($A + [I $B $C $D] + $X4 + $T61) <<< 6)}]
+ set D [expr {$A + (($D + [I $A $B $C] + $X11 + $T62) <<< 10)}]
+ set C [expr {$D + (($C + [I $D $A $B] + $X2 + $T63) <<< 15)}]
+ set B [expr {$C + (($B + [I $C $D $A] + $X9 + $T64) <<< 21)}]
+
+ # Then perform the following additions. (That is, increment each
+ # of the four registers by the value it had before this block
+ # was started.)
+ incr state(A) $A
+ incr state(B) $B
+ incr state(C) $C
+ incr state(D) $D
+ }
+
+ return
+}
+
+proc ::md5::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}}
+proc ::md5::bytes {v} {
+ #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v]
+ format %c%c%c%c \
+ [expr {0xFF & $v}] \
+ [expr {(0xFF00 & $v) >> 8}] \
+ [expr {(0xFF0000 & $v) >> 16}] \
+ [expr {((0xFF000000 & $v) >> 24) & 0xFF}]
+}
+
+# 32bit rotate-left
+proc ::md5::<<< {v n} {
+ return [expr {((($v << $n) \
+ | (($v >> (32 - $n)) \
+ & (0x7FFFFFFF >> (31 - $n))))) \
+ & 0xFFFFFFFF}]
+}
+
+# Convert our <<< pseudo-operator into a procedure call.
+regsub -all -line \
+ {\[expr {(\$[ABCD]) \+ \(\((.*)\)\s+<<<\s+(\d+)\)}\]} \
+ $::md5::MD5Hash_body \
+ {[expr {int(\1 + [<<< [expr {\2}] \3])}]} \
+ ::md5::MD5Hash_bodyX
+
+# RFC1321:3.4 - function F
+proc ::md5::F {X Y Z} {
+ return [expr {($X & $Y) | ((~$X) & $Z)}]
+}
+
+# Inline the F function
+regsub -all -line \
+ {\[F (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md5::MD5Hash_bodyX \
+ {( (\1 \& \2) | ((~\1) \& \3) )} \
+ ::md5::MD5Hash_bodyX
+
+# RFC1321:3.4 - function G
+proc ::md5::G {X Y Z} {
+ return [expr {(($X & $Z) | ($Y & (~$Z)))}]
+}
+
+# Inline the G function
+regsub -all -line \
+ {\[G (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md5::MD5Hash_bodyX \
+ {(((\1 \& \3) | (\2 \& (~\3))))} \
+ ::md5::MD5Hash_bodyX
+
+# RFC1321:3.4 - function H
+proc ::md5::H {X Y Z} {
+ return [expr {$X ^ $Y ^ $Z}]
+}
+
+# Inline the H function
+regsub -all -line \
+ {\[H (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md5::MD5Hash_bodyX \
+ {(\1 ^ \2 ^ \3)} \
+ ::md5::MD5Hash_bodyX
+
+# RFC1321:3.4 - function I
+proc ::md5::I {X Y Z} {
+ return [expr {$Y ^ ($X | (~$Z))}]
+}
+
+# Inline the I function
+regsub -all -line \
+ {\[I (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md5::MD5Hash_bodyX \
+ {(\2 ^ (\1 | (~\3)))} \
+ ::md5::MD5Hash_bodyX
+
+
+# RFC 1321:3.4 step 4: inline the set of constant modifiers.
+namespace eval md5 {
+ foreach tName {
+ T01 T02 T03 T04 T05 T06 T07 T08 T09 T10
+ T11 T12 T13 T14 T15 T16 T17 T18 T19 T20
+ T21 T22 T23 T24 T25 T26 T27 T28 T29 T30
+ T31 T32 T33 T34 T35 T36 T37 T38 T39 T40
+ T41 T42 T43 T44 T45 T46 T47 T48 T49 T50
+ T51 T52 T53 T54 T55 T56 T57 T58 T59 T60
+ T61 T62 T63 T64
+ } tVal {
+ 0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee
+ 0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501
+ 0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be
+ 0x6b901122 0xfd987193 0xa679438e 0x49b40821
+
+ 0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa
+ 0xd62f105d 0x2441453 0xd8a1e681 0xe7d3fbc8
+ 0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed
+ 0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a
+
+ 0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c
+ 0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70
+ 0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05
+ 0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665
+
+ 0xf4292244 0x432aff97 0xab9423a7 0xfc93a039
+ 0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1
+ 0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1
+ 0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391
+ } {
+ lappend map \$$tName $tVal
+ }
+ set ::md5::MD5Hash_bodyX [string map $map $::md5::MD5Hash_bodyX]
+ unset map
+}
+
+# Define the MD5 hashing procedure with inline functions.
+proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_bodyX
+
+# -------------------------------------------------------------------------
+
+if {[package provide Trf] != {}} {
+ interp alias {} ::md5::Hex {} ::hex -mode encode --
+} else {
+ proc ::md5::Hex {data} {
+ binary scan $data H* result
+ return [string toupper $result]
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# LoadAccelerator --
+#
+# This package can make use of a number of compiled extensions to
+# accelerate the digest computation. This procedure manages the
+# use of these extensions within the package. During normal usage
+# this should not be called, but the test package manipulates the
+# list of enabled accelerators.
+#
+proc ::md5::LoadAccelerator {name} {
+ variable accel
+ set r 0
+ switch -exact -- $name {
+ critcl {
+ if {![catch {package require tcllibc}]
+ || ![catch {package require md5c}]} {
+ set r [expr {[info command ::md5::md5c] != {}}]
+ }
+ }
+ cryptkit {
+ if {![catch {package require cryptkit}]} {
+ set r [expr {![catch {cryptkit::cryptInit}]}]
+ }
+ }
+ trf {
+ if {![catch {package require Trf}]} {
+ set r [expr {![catch {::md5 aa} msg]}]
+ }
+ }
+ default {
+ return -code error "invalid accelerator package:\
+ must be one of [join [array names accel] {, }]"
+ }
+ }
+ set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::md5::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# fileevent handler for chunked file hashing.
+#
+proc ::md5::Chunk {token channel {chunksize 4096}} {
+ upvar #0 $token state
+
+ if {[eof $channel]} {
+ fileevent $channel readable {}
+ set state(reading) 0
+ }
+
+ MD5Update $token [read $channel $chunksize]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::md5::md5 {args} {
+ array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -hex { set opts(-hex) 1 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -channel { set opts(-channel) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err\nlen: [llength $args]"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ should be \"md5 ?-hex? -filename file | string\""
+ }
+ set tok [MD5Init]
+ MD5Update $tok [lindex $args 0]
+ set r [MD5Final $tok]
+
+ } else {
+
+ set tok [MD5Init]
+ # FRINK: nocheck
+ set [subst $tok](reading) 1
+ fileevent $opts(-channel) readable \
+ [list [namespace origin Chunk] \
+ $tok $opts(-channel) $opts(-chunksize)]
+ vwait [subst $tok](reading)
+ set r [MD5Final $tok]
+
+ # If we opened the channel - we should close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::md5::hmac {args} {
+ array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -key { set opts(-key) [Pop args 1] }
+ -hex { set opts(-hex) 1 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -channel { set opts(-channel) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+
+ if {![info exists opts(-key)]} {
+ return -code error "wrong # args:\
+ should be \"hmac ?-hex? -key key -filename file | string\""
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ should be \"hmac ?-hex? -key key -filename file | string\""
+ }
+ set tok [HMACInit $opts(-key)]
+ HMACUpdate $tok [lindex $args 0]
+ set r [HMACFinal $tok]
+
+ } else {
+
+ set tok [HMACInit $opts(-key)]
+ # FRINK: nocheck
+ set [subst $tok](reading) 1
+ fileevent $opts(-channel) readable \
+ [list [namespace origin Chunk] \
+ $tok $opts(-channel) $opts(-chunksize)]
+ vwait [subst $tok](reading)
+ set r [HMACFinal $tok]
+
+ # If we opened the channel - we should close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::md5 {
+ foreach e {critcl cryptkit trf} { if {[LoadAccelerator $e]} { break } }
+}
+
+package provide md5 $::md5::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
+
+
--- /dev/null
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded md5 2.0.5 [list source [file join $dir md5x.tcl]]
+package ifneeded md5 1.4.4 [list source [file join $dir md5.tcl]]
--- /dev/null
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded sha256 1.0.2 [list source [file join $dir sha256.tcl]]
+package ifneeded sha1 2.0.3 [list source [file join $dir sha1.tcl]]
+package ifneeded sha1 1.1.0 [list source [file join $dir sha1v1.tcl]]
--- /dev/null
+# sha1.tcl -
+#
+# Copyright (C) 2001 Don Libes <libes@nist.gov>
+# Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm"
+# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
+#
+# This is an implementation of SHA1 based upon the example code given in
+# FIPS 180-1 and upon the tcllib MD4 implementation and taking some ideas
+# and methods from the earlier tcllib sha1 version by Don Libes.
+#
+# This implementation permits incremental updating of the hash and
+# provides support for external compiled implementations either using
+# critcl (sha1c) or Trf.
+#
+# ref: http://www.itl.nist.gov/fipspubs/fip180-1.htm
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: sha1.tcl,v 1.21 2007/05/03 21:41:10 andreas_kupries Exp $
+
+# @mdgen EXCLUDE: sha1c.tcl
+
+package require Tcl 8.2; # tcl minimum version
+
+namespace eval ::sha1 {
+ variable version 2.0.3
+ variable rcsid {$Id: sha1.tcl,v 1.21 2007/05/03 21:41:10 andreas_kupries Exp $}
+
+ variable accel
+ array set accel {tcl 0 critcl 0 cryptkit 0 trf 0}
+ variable loaded {}
+ variable active
+ array set active {tcl 0 critcl 0 cryptkit 0 trf 0}
+
+ namespace export sha1 hmac SHA1Init SHA1Update SHA1Final
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+# -------------------------------------------------------------------------
+# Management of sha1 implementations.
+
+# LoadAccelerator --
+#
+# This package can make use of a number of compiled extensions to
+# accelerate the digest computation. This procedure manages the
+# use of these extensions within the package. During normal usage
+# this should not be called, but the test package manipulates the
+# list of enabled accelerators.
+#
+proc ::sha1::LoadAccelerator {name} {
+ variable accel
+ set r 0
+ switch -exact -- $name {
+ tcl {
+ # Already present (this file)
+ set r 1
+ }
+ critcl {
+ if {![catch {package require tcllibc}]
+ || ![catch {package require sha1c}]} {
+ set r [expr {[info command ::sha1::sha1c] != {}}]
+ }
+ }
+ cryptkit {
+ if {![catch {package require cryptkit}]} {
+ set r [expr {![catch {cryptkit::cryptInit}]}]
+ }
+ }
+ trf {
+ if {![catch {package require Trf}]} {
+ set r [expr {![catch {::sha1 aa} msg]}]
+ }
+ }
+ default {
+ return -code error "invalid accelerator $key:\
+ must be one of [join [KnownImplementations] {, }]"
+ }
+ }
+ set accel($name) $r
+ return $r
+}
+
+# ::sha1::Implementations --
+#
+# Determines which implementations are
+# present, i.e. loaded.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A list of implementation keys.
+
+proc ::sha1::Implementations {} {
+ variable accel
+ set res {}
+ foreach n [array names accel] {
+ if {!$accel($n)} continue
+ lappend res $n
+ }
+ return $res
+}
+
+# ::sha1::KnownImplementations --
+#
+# Determines which implementations are known
+# as possible implementations.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A list of implementation keys. In the order
+# of preference, most prefered first.
+
+proc ::sha1::KnownImplementations {} {
+ return {critcl cryptkit trf tcl}
+}
+
+proc ::sha1::Names {} {
+ return {
+ critcl {tcllibc based}
+ cryptkit {cryptkit based}
+ trf {Trf based}
+ tcl {pure Tcl}
+ }
+}
+
+# ::sha1::SwitchTo --
+#
+# Activates a loaded named implementation.
+#
+# Arguments:
+# key Name of the implementation to activate.
+#
+# Results:
+# None.
+
+proc ::sha1::SwitchTo {key} {
+ variable accel
+ variable active
+ variable loaded
+
+ if {[string equal $key $loaded]} {
+ # No change, nothing to do.
+ return
+ } elseif {![string equal $key ""]} {
+ # Validate the target implementation of the switch.
+
+ if {![info exists accel($key)]} {
+ return -code error "Unable to activate unknown implementation \"$key\""
+ } elseif {![info exists accel($key)] || !$accel($key)} {
+ return -code error "Unable to activate missing implementation \"$key\""
+ }
+ }
+
+ if {![string equal $loaded ""]} {
+ set active($loaded) 0
+ }
+ if {![string equal $key ""]} {
+ set active($key) 1
+ }
+
+ # Remember the active implementation, for deactivation by future
+ # switches.
+
+ set loaded $key
+ return
+}
+
+# -------------------------------------------------------------------------
+
+# SHA1Init --
+#
+# Create and initialize an SHA1 state variable. This will be
+# cleaned up when we call SHA1Final
+#
+
+proc ::sha1::SHA1Init {} {
+ variable active
+ variable uid
+ set token [namespace current]::[incr uid]
+ upvar #0 $token state
+
+ # FIPS 180-1: 7 - Initialize the hash state
+ array set state \
+ [list \
+ A [expr {int(0x67452301)}] \
+ B [expr {int(0xEFCDAB89)}] \
+ C [expr {int(0x98BADCFE)}] \
+ D [expr {int(0x10325476)}] \
+ E [expr {int(0xC3D2E1F0)}] \
+ n 0 i "" ]
+ if {$active(cryptkit)} {
+ cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_SHA
+ } elseif {$active(trf)} {
+ set s {}
+ switch -exact -- $::tcl_platform(platform) {
+ windows { set s [open NUL w] }
+ unix { set s [open /dev/null w] }
+ }
+ if {$s != {}} {
+ fconfigure $s -translation binary -buffering none
+ ::sha1 -attach $s -mode write \
+ -read-type variable \
+ -read-destination [subst $token](trfread) \
+ -write-type variable \
+ -write-destination [subst $token](trfwrite)
+ array set state [list trfread 0 trfwrite 0 trf $s]
+ }
+ }
+ return $token
+}
+
+# SHA1Update --
+#
+# This is called to add more data into the hash. You may call this
+# as many times as you require. Note that passing in "ABC" is equivalent
+# to passing these letters in as separate calls -- hence this proc
+# permits hashing of chunked data
+#
+# If we have a C-based implementation available, then we will use
+# it here in preference to the pure-Tcl implementation.
+#
+proc ::sha1::SHA1Update {token data} {
+ variable active
+ upvar #0 $token state
+
+ if {$active(critcl)} {
+ if {[info exists state(sha1c)]} {
+ set state(sha1c) [sha1c $data $state(sha1c)]
+ } else {
+ set state(sha1c) [sha1c $data]
+ }
+ return
+ } elseif {[info exists state(ckctx)]} {
+ if {[string length $data] > 0} {
+ cryptkit::cryptEncrypt $state(ckctx) $data
+ }
+ return
+ } elseif {[info exists state(trf)]} {
+ puts -nonewline $state(trf) $data
+ return
+ }
+
+ # Update the state values
+ incr state(n) [string length $data]
+ append state(i) $data
+
+ # Calculate the hash for any complete blocks
+ set len [string length $state(i)]
+ for {set n 0} {($n + 64) <= $len} {} {
+ SHA1Transform $token [string range $state(i) $n [incr n 64]]
+ }
+
+ # Adjust the state for the blocks completed.
+ set state(i) [string range $state(i) $n end]
+ return
+}
+
+# SHA1Final --
+#
+# This procedure is used to close the current hash and returns the
+# hash data. Once this procedure has been called the hash context
+# is freed and cannot be used again.
+#
+# Note that the output is 160 bits represented as binary data.
+#
+proc ::sha1::SHA1Final {token} {
+ upvar #0 $token state
+
+ # Check for either of the C-compiled versions.
+ if {[info exists state(sha1c)]} {
+ set r $state(sha1c)
+ unset state
+ return $r
+ } elseif {[info exists state(ckctx)]} {
+ cryptkit::cryptEncrypt $state(ckctx) ""
+ cryptkit::cryptGetAttributeString $state(ckctx) \
+ CRYPT_CTXINFO_HASHVALUE r 20
+ cryptkit::cryptDestroyContext $state(ckctx)
+ # If nothing was hashed, we get no r variable set!
+ if {[info exists r]} {
+ unset state
+ return $r
+ }
+ } elseif {[info exists state(trf)]} {
+ close $state(trf)
+ set r $state(trfwrite)
+ unset state
+ return $r
+ }
+
+ # Padding
+ #
+ set len [string length $state(i)]
+ set pad [expr {56 - ($len % 64)}]
+ if {$len % 64 > 56} {
+ incr pad 64
+ }
+ if {$pad == 0} {
+ incr pad 64
+ }
+ append state(i) [binary format a$pad \x80]
+
+ # Append length in bits as big-endian wide int.
+ set dlen [expr {8 * $state(n)}]
+ append state(i) [binary format II 0 $dlen]
+
+ # Calculate the hash for the remaining block.
+ set len [string length $state(i)]
+ for {set n 0} {($n + 64) <= $len} {} {
+ SHA1Transform $token [string range $state(i) $n [incr n 64]]
+ }
+
+ # Output
+ set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)][bytes $state(E)]
+ unset state
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# HMAC Hashed Message Authentication (RFC 2104)
+#
+# hmac = H(K xor opad, H(K xor ipad, text))
+#
+
+# HMACInit --
+#
+# This is equivalent to the SHA1Init procedure except that a key is
+# added into the algorithm
+#
+proc ::sha1::HMACInit {K} {
+
+ # Key K is adjusted to be 64 bytes long. If K is larger, then use
+ # the SHA1 digest of K and pad this instead.
+ set len [string length $K]
+ if {$len > 64} {
+ set tok [SHA1Init]
+ SHA1Update $tok $K
+ set K [SHA1Final $tok]
+ set len [string length $K]
+ }
+ set pad [expr {64 - $len}]
+ append K [string repeat \0 $pad]
+
+ # Cacluate the padding buffers.
+ set Ki {}
+ set Ko {}
+ binary scan $K i16 Ks
+ foreach k $Ks {
+ append Ki [binary format i [expr {$k ^ 0x36363636}]]
+ append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]]
+ }
+
+ set tok [SHA1Init]
+ SHA1Update $tok $Ki; # initialize with the inner pad
+
+ # preserve the Ko value for the final stage.
+ # FRINK: nocheck
+ set [subst $tok](Ko) $Ko
+
+ return $tok
+}
+
+# HMACUpdate --
+#
+# Identical to calling SHA1Update
+#
+proc ::sha1::HMACUpdate {token data} {
+ SHA1Update $token $data
+ return
+}
+
+# HMACFinal --
+#
+# This is equivalent to the SHA1Final procedure. The hash context is
+# closed and the binary representation of the hash result is returned.
+#
+proc ::sha1::HMACFinal {token} {
+ upvar #0 $token state
+
+ set tok [SHA1Init]; # init the outer hashing function
+ SHA1Update $tok $state(Ko); # prepare with the outer pad.
+ SHA1Update $tok [SHA1Final $token]; # hash the inner result
+ return [SHA1Final $tok]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# This is the core SHA1 algorithm. It is a lot like the MD4 algorithm but
+# includes an extra round and a set of constant modifiers throughout.
+#
+set ::sha1::SHA1Transform_body {
+ upvar #0 $token state
+
+ # FIPS 180-1: 7a: Process Message in 16-Word Blocks
+ binary scan $msg I* blocks
+ set blockLen [llength $blocks]
+ for {set i 0} {$i < $blockLen} {incr i 16} {
+ set W [lrange $blocks $i [expr {$i+15}]]
+
+ # FIPS 180-1: 7b: Expand the input into 80 words
+ # For t = 16 to 79
+ # let Wt = (Wt-3 ^ Wt-8 ^ Wt-14 ^ Wt-16) <<< 1
+ set t3 12
+ set t8 7
+ set t14 1
+ set t16 -1
+ for {set t 16} {$t < 80} {incr t} {
+ set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \
+ [lindex $W [incr t14]] ^ [lindex $W [incr t16]]}]
+ lappend W [expr {int(($x << 1) | (($x >> 31) & 1))}]
+ }
+
+ # FIPS 180-1: 7c: Copy hash state.
+ set A $state(A)
+ set B $state(B)
+ set C $state(C)
+ set D $state(D)
+ set E $state(E)
+
+ # FIPS 180-1: 7d: Do permutation rounds
+ # For t = 0 to 79 do
+ # TEMP = (A<<<5) + ft(B,C,D) + E + Wt + Kt;
+ # E = D; D = C; C = S30(B); B = A; A = TEMP;
+
+ # Round 1: ft(B,C,D) = (B & C) | (~B & D) ( 0 <= t <= 19)
+ for {set t 0} {$t < 20} {incr t} {
+ set TEMP [F1 $A $B $C $D $E [lindex $W $t]]
+ set E $D
+ set D $C
+ set C [rotl32 $B 30]
+ set B $A
+ set A $TEMP
+ }
+
+ # Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39)
+ for {} {$t < 40} {incr t} {
+ set TEMP [F2 $A $B $C $D $E [lindex $W $t]]
+ set E $D
+ set D $C
+ set C [rotl32 $B 30]
+ set B $A
+ set A $TEMP
+ }
+
+ # Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59)
+ for {} {$t < 60} {incr t} {
+ set TEMP [F3 $A $B $C $D $E [lindex $W $t]]
+ set E $D
+ set D $C
+ set C [rotl32 $B 30]
+ set B $A
+ set A $TEMP
+ }
+
+ # Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79)
+ for {} {$t < 80} {incr t} {
+ set TEMP [F4 $A $B $C $D $E [lindex $W $t]]
+ set E $D
+ set D $C
+ set C [rotl32 $B 30]
+ set B $A
+ set A $TEMP
+ }
+
+ # Then perform the following additions. (That is, increment each
+ # of the four registers by the value it had before this block
+ # was started.)
+ incr state(A) $A
+ incr state(B) $B
+ incr state(C) $C
+ incr state(D) $D
+ incr state(E) $E
+ }
+
+ return
+}
+
+proc ::sha1::F1 {A B C D E W} {
+ expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
+ + ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff}
+}
+
+proc ::sha1::F2 {A B C D E W} {
+ expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
+ + ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff}
+}
+
+proc ::sha1::F3 {A B C D E W} {
+ expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
+ + (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff}
+}
+
+proc ::sha1::F4 {A B C D E W} {
+ expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
+ + ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff}
+}
+
+proc ::sha1::rotl32 {v n} {
+ return [expr {((($v << $n) \
+ | (($v >> (32 - $n)) \
+ & (0x7FFFFFFF >> (31 - $n))))) \
+ & 0xFFFFFFFF}]
+}
+
+
+# -------------------------------------------------------------------------
+#
+# In order to get this code to go as fast as possible while leaving
+# the main code readable we can substitute the above function bodies
+# into the transform procedure. This inlines the code for us an avoids
+# a procedure call overhead within the loops.
+#
+# We can do some minor tweaking to improve speed on Tcl < 8.5 where we
+# know our arithmetic is limited to 64 bits. On > 8.5 we may have
+# unconstrained integer arithmetic and must avoid letting it run away.
+#
+
+regsub -all -line \
+ {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body \
+ {[expr {(rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999) \& 0xffffffff}]} \
+ ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+ {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body_tmp \
+ {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1) \& 0xffffffff}]} \
+ ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+ {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body_tmp \
+ {[expr {(rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc) \& 0xffffffff}]} \
+ ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+ {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body_tmp \
+ {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6) \& 0xffffffff}]} \
+ ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+ {rotl32\(\$A,5\)} \
+ $::sha1::SHA1Transform_body_tmp \
+ {((($A << 5) \& 0xffffffff) | (($A >> 27) \& 0x1f))} \
+ ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+ {\[rotl32 \$B 30\]} \
+ $::sha1::SHA1Transform_body_tmp \
+ {[expr {int(($B << 30) | (($B >> 2) \& 0x3fffffff))}]} \
+ ::sha1::SHA1Transform_body_tmp
+#
+# Version 2 avoids a few truncations to 32 bits in non-essential places.
+#
+regsub -all -line \
+ {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body \
+ {[expr {rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999}]} \
+ ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+ {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body_tmp2 \
+ {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1}]} \
+ ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+ {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body_tmp2 \
+ {[expr {rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc}]} \
+ ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+ {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body_tmp2 \
+ {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6}]} \
+ ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+ {rotl32\(\$A,5\)} \
+ $::sha1::SHA1Transform_body_tmp2 \
+ {(($A << 5) | (($A >> 27) \& 0x1f))} \
+ ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+ {\[rotl32 \$B 30\]} \
+ $::sha1::SHA1Transform_body_tmp2 \
+ {[expr {($B << 30) | (($B >> 2) \& 0x3fffffff)}]} \
+ ::sha1::SHA1Transform_body_tmp2
+
+if {[package vsatisfies [package provide Tcl] 8.5]} {
+ proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp
+} else {
+ proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp2
+}
+
+unset ::sha1::SHA1Transform_body
+unset ::sha1::SHA1Transform_body_tmp
+unset ::sha1::SHA1Transform_body_tmp2
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}}
+proc ::sha1::bytes {v} {
+ #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v]
+ format %c%c%c%c \
+ [expr {((0xFF000000 & $v) >> 24) & 0xFF}] \
+ [expr {(0xFF0000 & $v) >> 16}] \
+ [expr {(0xFF00 & $v) >> 8}] \
+ [expr {0xFF & $v}]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::Hex {data} {
+ binary scan $data H* result
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::sha1::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# fileevent handler for chunked file hashing.
+#
+proc ::sha1::Chunk {token channel {chunksize 4096}} {
+ upvar #0 $token state
+
+ if {[eof $channel]} {
+ fileevent $channel readable {}
+ set state(reading) 0
+ }
+
+ SHA1Update $token [read $channel $chunksize]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::sha1 {args} {
+ array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+ if {[llength $args] == 1} {
+ set opts(-hex) 1
+ } else {
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -hex { set opts(-hex) 1 }
+ -bin { set opts(-hex) 0 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -channel { set opts(-channel) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set err [join [lsort [concat -bin [array names opts]]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ should be \"sha1 ?-hex? -filename file | string\""
+ }
+ set tok [SHA1Init]
+ SHA1Update $tok [lindex $args 0]
+ set r [SHA1Final $tok]
+
+ } else {
+
+ set tok [SHA1Init]
+ # FRINK: nocheck
+ set [subst $tok](reading) 1
+ fileevent $opts(-channel) readable \
+ [list [namespace origin Chunk] \
+ $tok $opts(-channel) $opts(-chunksize)]
+ # FRINK: nocheck
+ vwait [subst $tok](reading)
+ set r [SHA1Final $tok]
+
+ # If we opened the channel - we should close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::hmac {args} {
+ array set opts {-hex 1 -filename {} -channel {} -chunksize 4096}
+ if {[llength $args] != 2} {
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -key { set opts(-key) [Pop args 1] }
+ -hex { set opts(-hex) 1 }
+ -bin { set opts(-hex) 0 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -channel { set opts(-channel) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+ }
+
+ if {[llength $args] == 2} {
+ set opts(-key) [Pop args]
+ }
+
+ if {![info exists opts(-key)]} {
+ return -code error "wrong # args:\
+ should be \"hmac ?-hex? -key key -filename file | string\""
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ should be \"hmac ?-hex? -key key -filename file | string\""
+ }
+ set tok [HMACInit $opts(-key)]
+ HMACUpdate $tok [lindex $args 0]
+ set r [HMACFinal $tok]
+
+ } else {
+
+ set tok [HMACInit $opts(-key)]
+ # FRINK: nocheck
+ set [subst $tok](reading) 1
+ fileevent $opts(-channel) readable \
+ [list [namespace origin Chunk] \
+ $tok $opts(-channel) $opts(-chunksize)]
+ # FRINK: nocheck
+ vwait [subst $tok](reading)
+ set r [HMACFinal $tok]
+
+ # If we opened the channel - we should close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::sha1 {
+ variable e {}
+ foreach e [KnownImplementations] {
+ if {[LoadAccelerator $e]} {
+ SwitchTo $e
+ break
+ }
+ }
+ unset e
+}
+
+package provide sha1 $::sha1::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+# sha1.tcl -
+#
+# Copyright (C) 2001 Don Libes <libes@nist.gov>
+# Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm"
+# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
+#
+# This is an implementation of SHA1 based upon the example code given in
+# FIPS 180-1 and upon the tcllib MD4 implementation and taking some ideas
+# and methods from the earlier tcllib sha1 version by Don Libes.
+#
+# This implementation permits incremental updating of the hash and
+# provides support for external compiled implementations either using
+# critcl (sha1c) or Trf.
+#
+# ref: http://www.itl.nist.gov/fipspubs/fip180-1.htm
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+# $Id: sha1v1.tcl,v 1.1 2006/03/12 22:46:13 andreas_kupries Exp $
+
+# @mdgen EXCLUDE: sha1c.tcl
+
+package require Tcl 8.2; # tcl minimum version
+
+namespace eval ::sha1 {
+ variable version 1.1.0
+ variable rcsid {$Id: sha1v1.tcl,v 1.1 2006/03/12 22:46:13 andreas_kupries Exp $}
+ variable accel
+ array set accel {critcl 0 cryptkit 0 trf 0}
+
+ namespace export sha1 hmac SHA1Init SHA1Update SHA1Final
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# SHA1Init --
+#
+# Create and initialize an SHA1 state variable. This will be
+# cleaned up when we call SHA1Final
+#
+proc ::sha1::SHA1Init {} {
+ variable accel
+ variable uid
+ set token [namespace current]::[incr uid]
+ upvar #0 $token state
+
+ # FIPS 180-1: 7 - Initialize the hash state
+ array set state \
+ [list \
+ A [expr {int(0x67452301)}] \
+ B [expr {int(0xEFCDAB89)}] \
+ C [expr {int(0x98BADCFE)}] \
+ D [expr {int(0x10325476)}] \
+ E [expr {int(0xC3D2E1F0)}] \
+ n 0 i "" ]
+ if {$accel(cryptkit)} {
+ cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_SHA
+ } elseif {$accel(trf)} {
+ set s {}
+ switch -exact -- $::tcl_platform(platform) {
+ windows { set s [open NUL w] }
+ unix { set s [open /dev/null w] }
+ }
+ if {$s != {}} {
+ fconfigure $s -translation binary -buffering none
+ ::sha1 -attach $s -mode write \
+ -read-type variable \
+ -read-destination [subst $token](trfread) \
+ -write-type variable \
+ -write-destination [subst $token](trfwrite)
+ array set state [list trfread 0 trfwrite 0 trf $s]
+ }
+ }
+ return $token
+}
+
+# SHA1Update --
+#
+# This is called to add more data into the hash. You may call this
+# as many times as you require. Note that passing in "ABC" is equivalent
+# to passing these letters in as separate calls -- hence this proc
+# permits hashing of chunked data
+#
+# If we have a C-based implementation available, then we will use
+# it here in preference to the pure-Tcl implementation.
+#
+proc ::sha1::SHA1Update {token data} {
+ variable accel
+ upvar #0 $token state
+
+ if {$accel(critcl)} {
+ if {[info exists state(sha1c)]} {
+ set state(sha1c) [sha1c $data $state(sha1c)]
+ } else {
+ set state(sha1c) [sha1c $data]
+ }
+ return
+ } elseif {[info exists state(ckctx)]} {
+ if {[string length $data] > 0} {
+ cryptkit::cryptEncrypt $state(ckctx) $data
+ }
+ return
+ } elseif {[info exists state(trf)]} {
+ puts -nonewline $state(trf) $data
+ return
+ }
+
+ # Update the state values
+ incr state(n) [string length $data]
+ append state(i) $data
+
+ # Calculate the hash for any complete blocks
+ set len [string length $state(i)]
+ for {set n 0} {($n + 64) <= $len} {} {
+ SHA1Transform $token [string range $state(i) $n [incr n 64]]
+ }
+
+ # Adjust the state for the blocks completed.
+ set state(i) [string range $state(i) $n end]
+ return
+}
+
+# SHA1Final --
+#
+# This procedure is used to close the current hash and returns the
+# hash data. Once this procedure has been called the hash context
+# is freed and cannot be used again.
+#
+# Note that the output is 160 bits represented as binary data.
+#
+proc ::sha1::SHA1Final {token} {
+ upvar #0 $token state
+
+ # Check for either of the C-compiled versions.
+ if {[info exists state(sha1c)]} {
+ set r $state(sha1c)
+ unset state
+ return $r
+ } elseif {[info exists state(ckctx)]} {
+ cryptkit::cryptEncrypt $state(ckctx) ""
+ cryptkit::cryptGetAttributeString $state(ckctx) \
+ CRYPT_CTXINFO_HASHVALUE r 20
+ cryptkit::cryptDestroyContext $state(ckctx)
+ # If nothing was hashed, we get no r variable set!
+ if {[info exists r]} {
+ unset state
+ return $r
+ }
+ } elseif {[info exists state(trf)]} {
+ close $state(trf)
+ set r $state(trfwrite)
+ unset state
+ return $r
+ }
+
+ # Padding
+ #
+ set len [string length $state(i)]
+ set pad [expr {56 - ($len % 64)}]
+ if {$len % 64 > 56} {
+ incr pad 64
+ }
+ if {$pad == 0} {
+ incr pad 64
+ }
+ append state(i) [binary format a$pad \x80]
+
+ # Append length in bits as big-endian wide int.
+ set dlen [expr {8 * $state(n)}]
+ append state(i) [binary format II 0 $dlen]
+
+ # Calculate the hash for the remaining block.
+ set len [string length $state(i)]
+ for {set n 0} {($n + 64) <= $len} {} {
+ SHA1Transform $token [string range $state(i) $n [incr n 64]]
+ }
+
+ # Output
+ set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)][bytes $state(E)]
+ unset state
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# HMAC Hashed Message Authentication (RFC 2104)
+#
+# hmac = H(K xor opad, H(K xor ipad, text))
+#
+
+# HMACInit --
+#
+# This is equivalent to the SHA1Init procedure except that a key is
+# added into the algorithm
+#
+proc ::sha1::HMACInit {K} {
+
+ # Key K is adjusted to be 64 bytes long. If K is larger, then use
+ # the SHA1 digest of K and pad this instead.
+ set len [string length $K]
+ if {$len > 64} {
+ set tok [SHA1Init]
+ SHA1Update $tok $K
+ set K [SHA1Final $tok]
+ set len [string length $K]
+ }
+ set pad [expr {64 - $len}]
+ append K [string repeat \0 $pad]
+
+ # Cacluate the padding buffers.
+ set Ki {}
+ set Ko {}
+ binary scan $K i16 Ks
+ foreach k $Ks {
+ append Ki [binary format i [expr {$k ^ 0x36363636}]]
+ append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]]
+ }
+
+ set tok [SHA1Init]
+ SHA1Update $tok $Ki; # initialize with the inner pad
+
+ # preserve the Ko value for the final stage.
+ # FRINK: nocheck
+ set [subst $tok](Ko) $Ko
+
+ return $tok
+}
+
+# HMACUpdate --
+#
+# Identical to calling SHA1Update
+#
+proc ::sha1::HMACUpdate {token data} {
+ SHA1Update $token $data
+ return
+}
+
+# HMACFinal --
+#
+# This is equivalent to the SHA1Final procedure. The hash context is
+# closed and the binary representation of the hash result is returned.
+#
+proc ::sha1::HMACFinal {token} {
+ upvar #0 $token state
+
+ set tok [SHA1Init]; # init the outer hashing function
+ SHA1Update $tok $state(Ko); # prepare with the outer pad.
+ SHA1Update $tok [SHA1Final $token]; # hash the inner result
+ return [SHA1Final $tok]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# This is the core SHA1 algorithm. It is a lot like the MD4 algorithm but
+# includes an extra round and a set of constant modifiers throughout.
+#
+set ::sha1::SHA1Transform_body {
+ upvar #0 $token state
+
+ # FIPS 180-1: 7a: Process Message in 16-Word Blocks
+ binary scan $msg I* blocks
+ set blockLen [llength $blocks]
+ for {set i 0} {$i < $blockLen} {incr i 16} {
+ set W [lrange $blocks $i [expr {$i+15}]]
+
+ # FIPS 180-1: 7b: Expand the input into 80 words
+ # For t = 16 to 79
+ # let Wt = (Wt-3 ^ Wt-8 ^ Wt-14 ^ Wt-16) <<< 1
+ set t3 12
+ set t8 7
+ set t14 1
+ set t16 -1
+ for {set t 16} {$t < 80} {incr t} {
+ set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \
+ [lindex $W [incr t14]] ^ [lindex $W [incr t16]]}]
+ lappend W [expr {int(($x << 1) | (($x >> 31) & 1))}]
+ }
+
+ # FIPS 180-1: 7c: Copy hash state.
+ set A $state(A)
+ set B $state(B)
+ set C $state(C)
+ set D $state(D)
+ set E $state(E)
+
+ # FIPS 180-1: 7d: Do permutation rounds
+ # For t = 0 to 79 do
+ # TEMP = (A<<<5) + ft(B,C,D) + E + Wt + Kt;
+ # E = D; D = C; C = S30(B); B = A; A = TEMP;
+
+ # Round 1: ft(B,C,D) = (B & C) | (~B & D) ( 0 <= t <= 19)
+ for {set t 0} {$t < 20} {incr t} {
+ set TEMP [F1 $A $B $C $D $E [lindex $W $t]]
+ set E $D
+ set D $C
+ set C [rotl32 $B 30]
+ set B $A
+ set A $TEMP
+ }
+
+ # Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39)
+ for {} {$t < 40} {incr t} {
+ set TEMP [F2 $A $B $C $D $E [lindex $W $t]]
+ set E $D
+ set D $C
+ set C [rotl32 $B 30]
+ set B $A
+ set A $TEMP
+ }
+
+ # Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59)
+ for {} {$t < 60} {incr t} {
+ set TEMP [F3 $A $B $C $D $E [lindex $W $t]]
+ set E $D
+ set D $C
+ set C [rotl32 $B 30]
+ set B $A
+ set A $TEMP
+ }
+
+ # Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79)
+ for {} {$t < 80} {incr t} {
+ set TEMP [F4 $A $B $C $D $E [lindex $W $t]]
+ set E $D
+ set D $C
+ set C [rotl32 $B 30]
+ set B $A
+ set A $TEMP
+ }
+
+ # Then perform the following additions. (That is, increment each
+ # of the four registers by the value it had before this block
+ # was started.)
+ incr state(A) $A
+ incr state(B) $B
+ incr state(C) $C
+ incr state(D) $D
+ incr state(E) $E
+ }
+
+ return
+}
+
+proc ::sha1::F1 {A B C D E W} {
+ expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
+ + ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff}
+}
+
+proc ::sha1::F2 {A B C D E W} {
+ expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
+ + ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff}
+}
+
+proc ::sha1::F3 {A B C D E W} {
+ expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
+ + (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff}
+}
+
+proc ::sha1::F4 {A B C D E W} {
+ expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
+ + ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff}
+}
+
+proc ::sha1::rotl32 {v n} {
+ return [expr {((($v << $n) \
+ | (($v >> (32 - $n)) \
+ & (0x7FFFFFFF >> (31 - $n))))) \
+ & 0xFFFFFFFF}]
+}
+
+
+# -------------------------------------------------------------------------
+#
+# In order to get this code to go as fast as possible while leaving
+# the main code readable we can substitute the above function bodies
+# into the transform procedure. This inlines the code for us an avoids
+# a procedure call overhead within the loops.
+#
+# We can do some minor tweaking to improve speed on Tcl < 8.5 where we
+# know our arithmetic is limited to 64 bits. On > 8.5 we may have
+# unconstrained integer arithmetic and must avoid letting it run away.
+#
+
+regsub -all -line \
+ {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body \
+ {[expr {(rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999) \& 0xffffffff}]} \
+ ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+ {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body_tmp \
+ {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1) \& 0xffffffff}]} \
+ ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+ {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body_tmp \
+ {[expr {(rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc) \& 0xffffffff}]} \
+ ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+ {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body_tmp \
+ {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6) \& 0xffffffff}]} \
+ ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+ {rotl32\(\$A,5\)} \
+ $::sha1::SHA1Transform_body_tmp \
+ {((($A << 5) \& 0xffffffff) | (($A >> 27) \& 0x1f))} \
+ ::sha1::SHA1Transform_body_tmp
+
+regsub -all -line \
+ {\[rotl32 \$B 30\]} \
+ $::sha1::SHA1Transform_body_tmp \
+ {[expr {int(($B << 30) | (($B >> 2) \& 0x3fffffff))}]} \
+ ::sha1::SHA1Transform_body_tmp
+#
+# Version 2 avoids a few truncations to 32 bits in non-essential places.
+#
+regsub -all -line \
+ {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body \
+ {[expr {rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999}]} \
+ ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+ {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body_tmp2 \
+ {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1}]} \
+ ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+ {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body_tmp2 \
+ {[expr {rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc}]} \
+ ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+ {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
+ $::sha1::SHA1Transform_body_tmp2 \
+ {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6}]} \
+ ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+ {rotl32\(\$A,5\)} \
+ $::sha1::SHA1Transform_body_tmp2 \
+ {(($A << 5) | (($A >> 27) \& 0x1f))} \
+ ::sha1::SHA1Transform_body_tmp2
+
+regsub -all -line \
+ {\[rotl32 \$B 30\]} \
+ $::sha1::SHA1Transform_body_tmp2 \
+ {[expr {($B << 30) | (($B >> 2) \& 0x3fffffff)}]} \
+ ::sha1::SHA1Transform_body_tmp2
+
+if {[package vsatisfies [package provide Tcl] 8.5]} {
+ proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp
+} else {
+ proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp2
+}
+
+unset ::sha1::SHA1Transform_body_tmp
+unset ::sha1::SHA1Transform_body_tmp2
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}}
+proc ::sha1::bytes {v} {
+ #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v]
+ format %c%c%c%c \
+ [expr {((0xFF000000 & $v) >> 24) & 0xFF}] \
+ [expr {(0xFF0000 & $v) >> 16}] \
+ [expr {(0xFF00 & $v) >> 8}] \
+ [expr {0xFF & $v}]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::Hex {data} {
+ binary scan $data H* result
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+# LoadAccelerator --
+#
+# This package can make use of a number of compiled extensions to
+# accelerate the digest computation. This procedure manages the
+# use of these extensions within the package. During normal usage
+# this should not be called, but the test package manipulates the
+# list of enabled accelerators.
+#
+proc ::sha1::LoadAccelerator {name} {
+ variable accel
+ set r 0
+ switch -exact -- $name {
+ critcl {
+ if {![catch {package require tcllibc}]
+ || ![catch {package require sha1c}]} {
+ set r [expr {[info command ::sha1::sha1c] != {}}]
+ }
+ }
+ cryptkit {
+ if {![catch {package require cryptkit}]} {
+ set r [expr {![catch {cryptkit::cryptInit}]}]
+ }
+ }
+ trf {
+ if {![catch {package require Trf}]} {
+ set r [expr {![catch {::sha1 aa} msg]}]
+ }
+ }
+ default {
+ return -code error "invalid accelerator package:\
+ must be one of [join [array names accel] {, }]"
+ }
+ }
+ set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::sha1::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# fileevent handler for chunked file hashing.
+#
+proc ::sha1::Chunk {token channel {chunksize 4096}} {
+ upvar #0 $token state
+
+ if {[eof $channel]} {
+ fileevent $channel readable {}
+ set state(reading) 0
+ }
+
+ SHA1Update $token [read $channel $chunksize]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::sha1 {args} {
+ array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+ if {[llength $args] == 1} {
+ set opts(-hex) 1
+ } else {
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -hex { set opts(-hex) 1 }
+ -bin { set opts(-hex) 0 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -channel { set opts(-channel) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set err [join [lsort [concat -bin [array names opts]]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ should be \"sha1 ?-hex? -filename file | string\""
+ }
+ set tok [SHA1Init]
+ SHA1Update $tok [lindex $args 0]
+ set r [SHA1Final $tok]
+
+ } else {
+
+ set tok [SHA1Init]
+ # FRINK: nocheck
+ set [subst $tok](reading) 1
+ fileevent $opts(-channel) readable \
+ [list [namespace origin Chunk] \
+ $tok $opts(-channel) $opts(-chunksize)]
+ # FRINK: nocheck
+ vwait [subst $tok](reading)
+ set r [SHA1Final $tok]
+
+ # If we opened the channel - we should close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::sha1::hmac {args} {
+ array set opts {-hex 1 -filename {} -channel {} -chunksize 4096}
+ if {[llength $args] != 2} {
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -key { set opts(-key) [Pop args 1] }
+ -hex { set opts(-hex) 1 }
+ -bin { set opts(-hex) 0 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -channel { set opts(-channel) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+ }
+
+ if {[llength $args] == 2} {
+ set opts(-key) [Pop args]
+ }
+
+ if {![info exists opts(-key)]} {
+ return -code error "wrong # args:\
+ should be \"hmac ?-hex? -key key -filename file | string\""
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ should be \"hmac ?-hex? -key key -filename file | string\""
+ }
+ set tok [HMACInit $opts(-key)]
+ HMACUpdate $tok [lindex $args 0]
+ set r [HMACFinal $tok]
+
+ } else {
+
+ set tok [HMACInit $opts(-key)]
+ # FRINK: nocheck
+ set [subst $tok](reading) 1
+ fileevent $opts(-channel) readable \
+ [list [namespace origin Chunk] \
+ $tok $opts(-channel) $opts(-chunksize)]
+ # FRINK: nocheck
+ vwait [subst $tok](reading)
+ set r [HMACFinal $tok]
+
+ # If we opened the channel - we should close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::sha1 {
+ foreach e {critcl cryptkit trf} { if {[LoadAccelerator $e]} { break } }
+}
+
+package provide sha1 $::sha1::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
+
+
--- /dev/null
+# Tcl package index file - handcrafted
+#
+# $Id: pkgIndex.tcl.in,v 1.13 2003/12/03 20:06:34 balls Exp $
+
+package ifneeded xml::c 3.1 [list load [file join $dir Tclxml30.dll]]
+package ifneeded xml::tcl 3.1 [list source [file join $dir xml__tcl.tcl]]
+package ifneeded sgmlparser 1.0 [list source [file join $dir sgmlparser.tcl]]
+package ifneeded xpath 1.0 [list source [file join $dir xpath.tcl]]
+package ifneeded xmldep 1.0 [list source [file join $dir xmldep.tcl]]
+
+# The C parsers are provided through their own packages and indices,
+# and thus do not have to be listed here. This index may require them
+# in certain places, but does not provide them. This is part of the
+# work refactoring the build system of TclXML to create clean
+# packages, and not require a jumble (jungle?) of things in one Makefile.
+#
+#package ifneeded xml::expat 3.1 [list load [file join $dir @expat_TCL_LIB_FILE@]]
+#package ifneeded xml::xerces 2.0 [list load [file join $dir @xerces_TCL_LIB_FILE@]]
+#package ifneeded xml::libxml2 3.1 [list load [file join $dir @TclXML_libxml2_LIB_FILE@]]
+
+namespace eval ::xml {}
+
+# Requesting a specific package means we want it to be the default parser class.
+# This is achieved by loading it last.
+
+# expat and libxml2 packages must have xml::c package loaded
+package ifneeded expat 3.1 {
+ package require xml::c 3.1
+ package require xmldefs
+ package require xml::tclparser 3.1
+ catch {package require xml::libxml2 3.1}
+ package require xml::expat 3.1
+ package provide expat 3.1
+}
+package ifneeded libxml2 3.1 {
+ package require xml::c 3.1
+ package require xmldefs
+ package require xml::tclparser 3.1
+ catch {package require xml::expat 3.1}
+ package require xml::libxml2 3.1
+ package provide libxml2 3.1
+}
+
+# tclparser works with either xml::c or xml::tcl
+package ifneeded tclparser 3.1 {
+ if {[catch {package require xml::c 3.1}]} {
+ # No point in trying to load expat or libxml2
+ package require xml::tcl 3.1
+ package require xmldefs
+ package require xml::tclparser 3.1
+ } else {
+ package require xmldefs
+ catch {package require xml::expat 3.1}
+ catch {package require xml::libxml2 3.1}
+ package require xml::tclparser
+ }
+ package provide tclparser 3.1
+}
+
+# use tcl only (mainly for testing)
+package ifneeded puretclparser 3.1 {
+ package require xml::tcl 3.1
+ package require xmldefs
+ package require xml::tclparser 3.1
+ package provide puretclparser 3.1
+}
+
+# Requesting the generic package leaves the choice of default parser automatic
+
+package ifneeded xml 3.1 {
+ if {[catch {package require xml::c 3.1}]} {
+ package require xml::tcl 3.1
+ package require xmldefs
+ # Only choice is tclparser
+ package require xml::tclparser 3.1
+ } else {
+ package require xmldefs
+ package require xml::tclparser 3.1
+ # libxml2 is favoured since it provides more features
+ catch {package require xml::expat 3.1}
+ catch {package require xml::libxml2 3.1}
+ }
+ package provide xml 3.1
+}
+
+if {[info tclversion] <= 8.0} {
+ package ifneeded sgml 1.9 [list source [file join $dir sgml-8.0.tcl]]
+ package ifneeded xmldefs 3.1 [list source [file join $dir xml-8.0.tcl]]
+ package ifneeded xml::tclparser 3.1 [list source [file join $dir tclparser-8.0.tcl]]
+} else {
+ package ifneeded sgml 1.9 [list source [file join $dir sgml-8.1.tcl]]
+ package ifneeded xmldefs 3.1 [list source [file join $dir xml-8.1.tcl]]
+ package ifneeded xml::tclparser 3.1 [list source [file join $dir tclparser-8.1.tcl]]
+}
+
+
+
--- /dev/null
+# sgml-8.1.tcl --
+#
+# This file provides generic parsing services for SGML-based
+# languages, namely HTML and XML.
+# This file supports Tcl 8.1 characters and regular expressions.
+#
+# NB. It is a misnomer. There is no support for parsing
+# arbitrary SGML as such.
+#
+# Copyright (c) 1998-2003 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: sgml-8.1.tcl,v 1.7 2003/12/09 04:43:15 balls Exp $
+
+package require Tcl 8.1
+
+package provide sgml 1.9
+
+namespace eval sgml {
+
+ # Convenience routine
+ proc cl x {
+ return "\[$x\]"
+ }
+
+ # Define various regular expressions
+
+ # Character classes
+ variable Char \t\n\r\ -\uD7FF\uE000-\uFFFD\u10000-\u10FFFF
+ variable BaseChar \u0041-\u005A\u0061-\u007A\u00C0-\u00D6\u00D8-\u00F6\u00F8-\u00FF\u0100-\u0131\u0134-\u013E\u0141-\u0148\u014A-\u017E\u0180-\u01C3\u01CD-\u01F0\u01F4-\u01F5\u01FA-\u0217\u0250-\u02A8\u02BB-\u02C1\u0386\u0388-\u038A\u038C\u038E-\u03A1\u03A3-\u03CE\u03D0-\u03D6\u03DA\u03DC\u03DE\u03E0\u03E2-\u03F3\u0401-\u040C\u040E-\u044F\u0451-\u045C\u045E-\u0481\u0490-\u04C4\u04C7-\u04C8\u04CB-\u04CC\u04D0-\u04EB\u04EE-\u04F5\u04F8-\u04F9\u0531-\u0556\u0559\u0561-\u0586\u05D0-\u05EA\u05F0-\u05F2\u0621-\u063A\u0641-\u064A\u0671-\u06B7\u06BA-\u06BE\u06C0-\u06CE\u06D0-\u06D3\u06D5\u06E5-\u06E6\u0905-\u0939\u093D\u0958-\u0961\u0985-\u098C\u098F-\u0990\u0993-\u09A8\u09AA-\u09B0\u09B2\u09B6-\u09B9\u09DC-\u09DD\u09DF-\u09E1\u09F0-\u09F1\u0A05-\u0A0A\u0A0F-\u0A10\u0A13-\u0A28\u0A2A-\u0A30\u0A32-\u0A33\u0A35-\u0A36\u0A38-\u0A39\u0A59-\u0A5C\u0A5E\u0A72-\u0A74\u0A85-\u0A8B\u0A8D\u0A8F-\u0A91\u0A93-\u0AA8\u0AAA-\u0AB0\u0AB2-\u0AB3\u0AB5-\u0AB9\u0ABD\u0AE0\u0B05-\u0B0C\u0B0F-\u0B10\u0B13-\u0B28\u0B2A-\u0B30\u0B32-\u0B33\u0B36-\u0B39\u0B3D\u0B5C-\u0B5D\u0B5F-\u0B61\u0B85-\u0B8A\u0B8E-\u0B90\u0B92-\u0B95\u0B99-\u0B9A\u0B9C\u0B9E-\u0B9F\u0BA3-\u0BA4\u0BA8-\u0BAA\u0BAE-\u0BB5\u0BB7-\u0BB9\u0C05-\u0C0C\u0C0E-\u0C10\u0C12-\u0C28\u0C2A-\u0C33\u0C35-\u0C39\u0C60-\u0C61\u0C85-\u0C8C\u0C8E-\u0C90\u0C92-\u0CA8\u0CAA-\u0CB3\u0CB5-\u0CB9\u0CDE\u0CE0-\u0CE1\u0D05-\u0D0C\u0D0E-\u0D10\u0D12-\u0D28\u0D2A-\u0D39\u0D60-\u0D61\u0E01-\u0E2E\u0E30\u0E32-\u0E33\u0E40-\u0E45\u0E81-\u0E82\u0E84\u0E87-\u0E88\u0E8A\u0E8D\u0E94-\u0E97\u0E99-\u0E9F\u0EA1-\u0EA3\u0EA5\u0EA7\u0EAA-\u0EAB\u0EAD-\u0EAE\u0EB0\u0EB2-\u0EB3\u0EBD\u0EC0-\u0EC4\u0F40-\u0F47\u0F49-\u0F69\u10A0-\u10C5\u10D0-\u10F6\u1100\u1102-\u1103\u1105-\u1107\u1109\u110B-\u110C\u110E-\u1112\u113C\u113E\u1140\u114C\u114E\u1150\u1154-\u1155\u1159\u115F-\u1161\u1163\u1165\u1167\u1169\u116D-\u116E\u1172-\u1173\u1175\u119E\u11A8\u11AB\u11AE-\u11AF\u11B7-\u11B8\u11BA\u11BC-\u11C2\u11EB\u11F0\u11F9\u1E00-\u1E9B\u1EA0-\u1EF9\u1F00-\u1F15\u1F18-\u1F1D\u1F20-\u1F45\u1F48-\u1F4D\u1F50-\u1F57\u1F59\u1F5B\u1F5D\u1F5F-\u1F7D\u1F80-\u1FB4\u1FB6-\u1FBC\u1FBE\u1FC2-\u1FC4\u1FC6-\u1FCC\u1FD0-\u1FD3\u1FD6-\u1FDB\u1FE0-\u1FEC\u1FF2-\u1FF4\u1FF6-\u1FFC\u2126\u212A-\u212B\u212E\u2180-\u2182\u3041-\u3094\u30A1-\u30FA\u3105-\u312C\uAC00-\uD7A3
+ variable Ideographic \u4E00-\u9FA5\u3007\u3021-\u3029
+ variable CombiningChar \u0300-\u0345\u0360-\u0361\u0483-\u0486\u0591-\u05A1\u05A3-\u05B9\u05BB-\u05BD\u05BF\u05C1-\u05C2\u05C4\u064B-\u0652\u0670\u06D6-\u06DC\u06DD-\u06DF\u06E0-\u06E4\u06E7-\u06E8\u06EA-\u06ED\u0901-\u0903\u093C\u093E-\u094C\u094D\u0951-\u0954\u0962-\u0963\u0981-\u0983\u09BC\u09BE\u09BF\u09C0-\u09C4\u09C7-\u09C8\u09CB-\u09CD\u09D7\u09E2-\u09E3\u0A02\u0A3C\u0A3E\u0A3F\u0A40-\u0A42\u0A47-\u0A48\u0A4B-\u0A4D\u0A70-\u0A71\u0A81-\u0A83\u0ABC\u0ABE-\u0AC5\u0AC7-\u0AC9\u0ACB-\u0ACD\u0B01-\u0B03\u0B3C\u0B3E-\u0B43\u0B47-\u0B48\u0B4B-\u0B4D\u0B56-\u0B57\u0B82-\u0B83\u0BBE-\u0BC2\u0BC6-\u0BC8\u0BCA-\u0BCD\u0BD7\u0C01-\u0C03\u0C3E-\u0C44\u0C46-\u0C48\u0C4A-\u0C4D\u0C55-\u0C56\u0C82-\u0C83\u0CBE-\u0CC4\u0CC6-\u0CC8\u0CCA-\u0CCD\u0CD5-\u0CD6\u0D02-\u0D03\u0D3E-\u0D43\u0D46-\u0D48\u0D4A-\u0D4D\u0D57\u0E31\u0E34-\u0E3A\u0E47-\u0E4E\u0EB1\u0EB4-\u0EB9\u0EBB-\u0EBC\u0EC8-\u0ECD\u0F18-\u0F19\u0F35\u0F37\u0F39\u0F3E\u0F3F\u0F71-\u0F84\u0F86-\u0F8B\u0F90-\u0F95\u0F97\u0F99-\u0FAD\u0FB1-\u0FB7\u0FB9\u20D0-\u20DC\u20E1\u302A-\u302F\u3099\u309A
+ variable Digit \u0030-\u0039\u0660-\u0669\u06F0-\u06F9\u0966-\u096F\u09E6-\u09EF\u0A66-\u0A6F\u0AE6-\u0AEF\u0B66-\u0B6F\u0BE7-\u0BEF\u0C66-\u0C6F\u0CE6-\u0CEF\u0D66-\u0D6F\u0E50-\u0E59\u0ED0-\u0ED9\u0F20-\u0F29
+ variable Extender \u00B7\u02D0\u02D1\u0387\u0640\u0E46\u0EC6\u3005\u3031-\u3035\u309D-\u309E\u30FC-\u30FE
+ variable Letter $BaseChar|$Ideographic
+
+ # white space
+ variable Wsp " \t\r\n"
+ variable noWsp [cl ^$Wsp]
+
+ # Various XML names
+ variable NameChar \[-$Letter$Digit._:$CombiningChar$Extender\]
+ variable Name \[_:$BaseChar$Ideographic\]$NameChar*
+ variable Names ${Name}(?:$Wsp$Name)*
+ variable Nmtoken $NameChar+
+ variable Nmtokens ${Nmtoken}(?:$Wsp$Nmtoken)*
+
+ # table of predefined entities for XML
+
+ variable EntityPredef
+ array set EntityPredef {
+ lt < gt > amp & quot \" apos '
+ }
+
+}
+
+# These regular expressions are defined here once for better performance
+
+namespace eval sgml {
+ variable Wsp
+
+ # Watch out for case-sensitivity
+
+ set attlist_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#REQUIRED|#IMPLIED)
+ set attlist_enum_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*\\(([cl ^)]*)\\)[cl $Wsp]*("([cl ^")]*)")? ;# "
+ set attlist_fixed_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#FIXED)[cl $Wsp]*([cl ^$Wsp]+)
+
+ set param_entity_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^"$Wsp]*)[cl $Wsp]*"([cl ^"]*)"
+
+ set notation_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(.*)
+
+}
+
+### Utility procedures
+
+# sgml::noop --
+#
+# A do-nothing proc
+#
+# Arguments:
+# args arguments
+#
+# Results:
+# Nothing.
+
+proc sgml::noop args {
+ return 0
+}
+
+# sgml::identity --
+#
+# Identity function.
+#
+# Arguments:
+# a arbitrary argument
+#
+# Results:
+# $a
+
+proc sgml::identity a {
+ return $a
+}
+
+# sgml::Error --
+#
+# Throw an error
+#
+# Arguments:
+# args arguments
+#
+# Results:
+# Error return condition.
+
+proc sgml::Error args {
+ uplevel return -code error [list $args]
+}
+
+### Following procedures are based on html_library
+
+# sgml::zapWhite --
+#
+# Convert multiple white space into a single space.
+#
+# Arguments:
+# data plain text
+#
+# Results:
+# As above
+
+proc sgml::zapWhite data {
+ regsub -all "\[ \t\r\n\]+" $data { } data
+ return $data
+}
+
+proc sgml::Boolean value {
+ regsub {1|true|yes|on} $value 1 value
+ regsub {0|false|no|off} $value 0 value
+ return $value
+}
+
--- /dev/null
+# sgmlparser.tcl --
+#
+# This file provides the generic part of a parser for SGML-based
+# languages, namely HTML and XML.
+#
+# NB. It is a misnomer. There is no support for parsing
+# arbitrary SGML as such.
+#
+# See sgml.tcl for variable definitions.
+#
+# Copyright (c) 1998-2003 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: sgmlparser.tcl,v 1.32 2003/12/09 04:43:15 balls Exp $
+
+package require sgml 1.9
+
+package require uri 1.1
+
+package provide sgmlparser 1.0
+
+namespace eval sgml {
+ namespace export tokenise parseEvent
+
+ namespace export parseDTD
+
+ # NB. Most namespace variables are defined in sgml-8.[01].tcl
+ # to account for differences between versions of Tcl.
+ # This especially includes the regular expressions used.
+
+ variable ParseEventNum
+ if {![info exists ParseEventNum]} {
+ set ParseEventNum 0
+ }
+ variable ParseDTDnum
+ if {![info exists ParseDTDNum]} {
+ set ParseDTDNum 0
+ }
+
+ variable declExpr [cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)
+ variable EntityExpr [cl $::sgml::Wsp]*(%[cl $::sgml::Wsp])?[cl $::sgml::Wsp]*($::sgml::Name)[cl $::sgml::Wsp]+(.*)
+
+ #variable MarkupDeclExpr <([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp]+)[cl $::sgml::Wsp]*([cl ^>]*)>
+ #variable MarkupDeclSub "} {\\1} {\\2} {\\3} {"
+ variable MarkupDeclExpr <[cl $::sgml::Wsp]*([cl ^$::sgml::Wsp>]+)[cl $::sgml::Wsp]*([cl ^>]*)>
+ variable MarkupDeclSub "\} {\\1} {\\2} \{"
+
+ variable ExternalEntityExpr ^(PUBLIC|SYSTEM)[cl $::sgml::Wsp]+("|')(.*?)\\2([cl $::sgml::Wsp]+("|')(.*?)\\2)?([cl $::sgml::Wsp]+NDATA[cl $::sgml::Wsp]+($::xml::Name))?\$
+
+ variable StdOptions
+ array set StdOptions [list \
+ -elementstartcommand [namespace current]::noop \
+ -elementendcommand [namespace current]::noop \
+ -characterdatacommand [namespace current]::noop \
+ -processinginstructioncommand [namespace current]::noop \
+ -externalentitycommand {} \
+ -xmldeclcommand [namespace current]::noop \
+ -doctypecommand [namespace current]::noop \
+ -commentcommand [namespace current]::noop \
+ -entitydeclcommand [namespace current]::noop \
+ -unparsedentitydeclcommand [namespace current]::noop \
+ -parameterentitydeclcommand [namespace current]::noop \
+ -notationdeclcommand [namespace current]::noop \
+ -elementdeclcommand [namespace current]::noop \
+ -attlistdeclcommand [namespace current]::noop \
+ -paramentityparsing 1 \
+ -defaultexpandinternalentities 1 \
+ -startdoctypedeclcommand [namespace current]::noop \
+ -enddoctypedeclcommand [namespace current]::noop \
+ -entityreferencecommand {} \
+ -warningcommand [namespace current]::noop \
+ -errorcommand [namespace current]::Error \
+ -final 1 \
+ -validate 0 \
+ -baseuri {} \
+ -name {} \
+ -cmd {} \
+ -emptyelement [namespace current]::EmptyElement \
+ -parseattributelistcommand [namespace current]::noop \
+ -parseentitydeclcommand [namespace current]::noop \
+ -normalize 1 \
+ -internaldtd {} \
+ -reportempty 0 \
+ -ignorewhitespace 0 \
+ ]
+}
+
+# sgml::tokenise --
+#
+# Transform the given HTML/XML text into a Tcl list.
+#
+# Arguments:
+# sgml text to tokenize
+# elemExpr RE to recognise tags
+# elemSub transform for matched tags
+# args options
+#
+# Valid Options:
+# -internaldtdvariable
+# -final boolean True if no more data is to be supplied
+# -statevariable varName Name of a variable used to store info
+#
+# Results:
+# Returns a Tcl list representing the document.
+
+proc sgml::tokenise {sgml elemExpr elemSub args} {
+ array set options {-final 1}
+ array set options $args
+ set options(-final) [Boolean $options(-final)]
+
+ # If the data is not final then there must be a variable to store
+ # unused data.
+ if {!$options(-final) && ![info exists options(-statevariable)]} {
+ return -code error {option "-statevariable" required if not final}
+ }
+
+ # Pre-process stage
+ #
+ # Extract the internal DTD subset, if any
+
+ catch {upvar #0 $options(-internaldtdvariable) dtd}
+ if {[regexp {<!DOCTYPE[^[<]+\[([^]]+)\]} $sgml discard dtd]} {
+ regsub {(<!DOCTYPE[^[<]+)(\[[^]]+\])} $sgml {\1\&xml:intdtd;} sgml
+ }
+
+ # Protect Tcl special characters
+ regsub -all {([{}\\])} $sgml {\\\1} sgml
+
+ # Do the translation
+
+ if {[info exists options(-statevariable)]} {
+ # Mats: Several rewrites here to handle -final 0 option.
+ # If any cached unparsed xml (state(leftover)), prepend it.
+ upvar #0 $options(-statevariable) state
+ if {[string length $state(leftover)]} {
+ regsub -all $elemExpr $state(leftover)$sgml $elemSub sgml
+ set state(leftover) {}
+ } else {
+ regsub -all $elemExpr $sgml $elemSub sgml
+ }
+ set sgml "{} {} {} \{$sgml\}"
+
+ # Performance note (Tcl 8.0):
+ # Use of lindex, lreplace will cause parsing to list object
+
+ # This RE only fixes chopped inside tags, not chopped text.
+ if {[regexp {^([^<]*)(<[^>]*$)} [lindex $sgml end] x text rest]} {
+ set sgml [lreplace $sgml end end $text]
+ # Mats: unmatched stuff means that it is chopped off. Cache it for next round.
+ set state(leftover) $rest
+ }
+
+ ## Patch from bug report #596959, Marshall Rose
+ # This patch was for use when the caller of this function used lrange
+ # 5 -end on thresult. This is no longer the case [PT]
+ #if {[string compare [lindex $sgml 4] ""]} {
+ # set sgml [linsert $sgml 0 {} {} {} {} {}]
+ #}
+
+ } else {
+
+ # Performance note (Tcl 8.0):
+ # In this case, no conversion to list object is performed
+
+ # Mats: This fails if not -final and $sgml is chopped off right in a tag.
+ regsub -all $elemExpr $sgml $elemSub sgml
+ set sgml "{} {} {} \{$sgml\}"
+ }
+
+ return $sgml
+
+}
+
+# sgml::parseEvent --
+#
+# Produces an event stream for a XML/HTML document,
+# given the Tcl list format returned by tokenise.
+#
+# This procedure checks that the document is well-formed,
+# and throws an error if the document is found to be not
+# well formed. Warnings are passed via the -warningcommand script.
+#
+# The procedure only check for well-formedness,
+# no DTD is required. However, facilities are provided for entity expansion.
+#
+# Arguments:
+# sgml Instance data, as a Tcl list.
+# args option/value pairs
+#
+# Valid Options:
+# -final Indicates end of document data
+# -validate Boolean to enable validation
+# -baseuri URL for resolving relative URLs
+# -elementstartcommand Called when an element starts
+# -elementendcommand Called when an element ends
+# -characterdatacommand Called when character data occurs
+# -entityreferencecommand Called when an entity reference occurs
+# -processinginstructioncommand Called when a PI occurs
+# -externalentitycommand Called for an external entity reference
+#
+# -xmldeclcommand Called when the XML declaration occurs
+# -doctypecommand Called when the document type declaration occurs
+# -commentcommand Called when a comment occurs
+# -entitydeclcommand Called when a parsed entity is declared
+# -unparsedentitydeclcommand Called when an unparsed external entity is declared
+# -parameterentitydeclcommand Called when a parameter entity is declared
+# -notationdeclcommand Called when a notation is declared
+# -elementdeclcommand Called when an element is declared
+# -attlistdeclcommand Called when an attribute list is declared
+# -paramentityparsing Boolean to enable/disable parameter entity substitution
+# -defaultexpandinternalentities Boolean to enable/disable expansion of entities declared in internal DTD subset
+#
+# -startdoctypedeclcommand Called when the Doc Type declaration starts (see also -doctypecommand)
+# -enddoctypedeclcommand Called when the Doc Type declaration ends (see also -doctypecommand)
+#
+# -errorcommand Script to evaluate for a fatal error
+# -warningcommand Script to evaluate for a reportable warning
+# -statevariable global state variable
+# -normalize whether to normalize names
+# -reportempty whether to include an indication of empty elements
+# -ignorewhitespace whether to automatically strip whitespace
+#
+# Results:
+# The various callback scripts are invoked.
+# Returns empty string.
+#
+# BUGS:
+# If command options are set to empty string then they should not be invoked.
+
+proc sgml::parseEvent {sgml args} {
+ variable Wsp
+ variable noWsp
+ variable Nmtoken
+ variable Name
+ variable ParseEventNum
+ variable StdOptions
+
+ array set options [array get StdOptions]
+ catch {array set options $args}
+
+ # Mats:
+ # If the data is not final then there must be a variable to persistently store the parse state.
+ if {!$options(-final) && ![info exists options(-statevariable)]} {
+ return -code error {option "-statevariable" required if not final}
+ }
+
+ foreach {opt value} [array get options *command] {
+ if {[string compare $opt "-externalentitycommand"] && ![string length $value]} {
+ set options($opt) [namespace current]::noop
+ }
+ }
+
+ if {![info exists options(-statevariable)]} {
+ set options(-statevariable) [namespace current]::ParseEvent[incr ParseEventNum]
+ }
+ if {![info exists options(entities)]} {
+ set options(entities) [namespace current]::Entities$ParseEventNum
+ array set $options(entities) [array get [namespace current]::EntityPredef]
+ }
+ if {![info exists options(extentities)]} {
+ set options(extentities) [namespace current]::ExtEntities$ParseEventNum
+ }
+ if {![info exists options(parameterentities)]} {
+ set options(parameterentities) [namespace current]::ParamEntities$ParseEventNum
+ }
+ if {![info exists options(externalparameterentities)]} {
+ set options(externalparameterentities) [namespace current]::ExtParamEntities$ParseEventNum
+ }
+ if {![info exists options(elementdecls)]} {
+ set options(elementdecls) [namespace current]::ElementDecls$ParseEventNum
+ }
+ if {![info exists options(attlistdecls)]} {
+ set options(attlistdecls) [namespace current]::AttListDecls$ParseEventNum
+ }
+ if {![info exists options(notationdecls)]} {
+ set options(notationdecls) [namespace current]::NotationDecls$ParseEventNum
+ }
+ if {![info exists options(namespaces)]} {
+ set options(namespaces) [namespace current]::Namespaces$ParseEventNum
+ }
+
+ # For backward-compatibility
+ catch {set options(-baseuri) $options(-baseurl)}
+
+ # Choose an external entity resolver
+
+ if {![string length $options(-externalentitycommand)]} {
+ if {$options(-validate)} {
+ set options(-externalentitycommand) [namespace code ResolveEntity]
+ } else {
+ set options(-externalentitycommand) [namespace code noop]
+ }
+ }
+
+ upvar #0 $options(-statevariable) state
+ upvar #0 $options(entities) entities
+
+ # Mats:
+ # The problem is that the state is not maintained when -final 0 !
+ # I've switched back to an older version here.
+
+ if {![info exists state(line)]} {
+ # Initialise the state variable
+ array set state {
+ mode normal
+ haveXMLDecl 0
+ haveDocElement 0
+ inDTD 0
+ context {}
+ stack {}
+ line 0
+ defaultNS {}
+ defaultNSURI {}
+ }
+ }
+
+ foreach {tag close param text} $sgml {
+
+ # Keep track of lines in the input
+ incr state(line) [regsub -all \n $param {} discard]
+ incr state(line) [regsub -all \n $text {} discard]
+
+ # If the current mode is cdata or comment then we must undo what the
+ # regsub has done to reconstitute the data
+
+ set empty {}
+ switch $state(mode) {
+ comment {
+ # This had "[string length $param] && " as a guard -
+ # can't remember why :-(
+ if {[regexp ([cl ^-]*)--\$ $tag discard comm1]} {
+ # end of comment (in tag)
+ set tag {}
+ set close {}
+ set state(mode) normal
+ DeProtect1 $options(-commentcommand) $state(commentdata)<$comm1
+ unset state(commentdata)
+ } elseif {[regexp ([cl ^-]*)--\$ $param discard comm1]} {
+ # end of comment (in attributes)
+ DeProtect1 $options(-commentcommand) $state(commentdata)<$close$tag>$comm1
+ unset state(commentdata)
+ set tag {}
+ set param {}
+ set close {}
+ set state(mode) normal
+ } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm1 text]} {
+ # end of comment (in text)
+ DeProtect1 $options(-commentcommand) $state(commentdata)<$close$tag$param>$comm1
+ unset state(commentdata)
+ set tag {}
+ set param {}
+ set close {}
+ set state(mode) normal
+ } else {
+ # comment continues
+ append state(commentdata) <$close$tag$param>$text
+ continue
+ }
+ }
+ cdata {
+ if {[string length $param] && [regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $tag discard cdata1]} {
+ # end of CDATA (in tag)
+ PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$cdata1]
+ set text [subst -novariable -nocommand $text]
+ set tag {}
+ unset state(cdata)
+ set state(mode) normal
+ } elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $param discard cdata1]} {
+ # end of CDATA (in attributes)
+ PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$cdata1]
+ set text [subst -novariable -nocommand $text]
+ set tag {}
+ set param {}
+ unset state(cdata)
+ set state(mode) normal
+ } elseif {[regexp (.*)\]\][cl $Wsp]*>(.*) $text discard cdata1 text]} {
+ # end of CDATA (in text)
+ PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$param>$cdata1]
+ set text [subst -novariable -nocommand $text]
+ set tag {}
+ set param {}
+ set close {}
+ unset state(cdata)
+ set state(mode) normal
+ } else {
+ # CDATA continues
+ append state(cdata) [subst -nocommand -novariable <$close$tag$param>$text]
+ continue
+ }
+ }
+ continue {
+ # We're skipping elements looking for the close tag
+ switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close {
+ 0,* {
+ continue
+ }
+ *,0, {
+ if {![string compare $tag $state(continue:tag)]} {
+ set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
+ if {![string length $empty]} {
+ incr state(continue:level)
+ }
+ }
+ continue
+ }
+ *,0,/ {
+ if {![string compare $tag $state(continue:tag)]} {
+ incr state(continue:level) -1
+ }
+ if {!$state(continue:level)} {
+ unset state(continue:tag)
+ unset state(continue:level)
+ set state(mode) {}
+ }
+ }
+ default {
+ continue
+ }
+ }
+ }
+ default {
+ # The trailing slash on empty elements can't be automatically separated out
+ # in the RE, so we must do it here.
+ regexp (.*)(/)[cl $Wsp]*$ $param discard param empty
+ }
+ }
+
+ # default: normal mode
+
+ # Bug: if the attribute list has a right angle bracket then the empty
+ # element marker will not be seen
+
+ set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
+
+ switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close,$empty {
+
+ 0,0,, {
+ # Ignore empty tag - dealt with non-normal mode above
+ }
+ *,0,, {
+
+ # Start tag for an element.
+
+ # Check if the internal DTD entity is in an attribute value
+ regsub -all &xml:intdtd\; $param \[$options(-internaldtd)\] param
+
+ set code [catch {ParseEvent:ElementOpen $tag $param [array get options]} msg]
+ set state(haveDocElement) 1
+ switch $code {
+ 0 {# OK}
+ 3 {
+ # break
+ return {}
+ }
+ 4 {
+ # continue
+ # Remember this tag and look for its close
+ set state(continue:tag) $tag
+ set state(continue:level) 1
+ set state(mode) continue
+ continue
+ }
+ default {
+ return -code $code -errorinfo $::errorInfo $msg
+ }
+ }
+
+ }
+
+ *,0,/, {
+
+ # End tag for an element.
+
+ set code [catch {ParseEvent:ElementClose $tag [array get options]} msg]
+ switch $code {
+ 0 {# OK}
+ 3 {
+ # break
+ return {}
+ }
+ 4 {
+ # continue
+ # skip sibling nodes
+ set state(continue:tag) [lindex $state(stack) end]
+ set state(continue:level) 1
+ set state(mode) continue
+ continue
+ }
+ default {
+ return -code $code -errorinfo $::errorInfo $msg
+ }
+ }
+
+ }
+
+ *,0,,/ {
+
+ # Empty element
+
+ # The trailing slash sneaks through into the param variable
+ regsub -all /[cl $::sgml::Wsp]*\$ $param {} param
+
+ set code [catch {ParseEvent:ElementOpen $tag $param [array get options] -empty 1} msg]
+ set state(haveDocElement) 1
+ switch $code {
+ 0 {# OK}
+ 3 {
+ # break
+ return {}
+ }
+ 4 {
+ # continue
+ # Pretty useless since it closes straightaway
+ }
+ default {
+ return -code $code -errorinfo $::errorInfo $msg
+ }
+ }
+ set code [catch {ParseEvent:ElementClose $tag [array get options] -empty 1} msg]
+ switch $code {
+ 0 {# OK}
+ 3 {
+ # break
+ return {}
+ }
+ 4 {
+ # continue
+ # skip sibling nodes
+ set state(continue:tag) [lindex $state(stack) end]
+ set state(continue:level) 1
+ set state(mode) continue
+ continue
+ }
+ default {
+ return -code $code -errorinfo $::errorInfo $msg
+ }
+ }
+
+ }
+
+ *,1,* {
+ # Processing instructions or XML declaration
+ switch -glob -- $tag {
+
+ {\?xml} {
+ # XML Declaration
+ if {$state(haveXMLDecl)} {
+ uplevel #0 $options(-errorcommand) [list illegalcharacter "unexpected characters \"<$tag\" around line $state(line)"]
+ } elseif {![regexp {\?$} $param]} {
+ uplevel #0 $options(-errorcommand) [list missingcharacters "XML Declaration missing characters \"?>\" around line $state(line)"]
+ } else {
+
+ # We can do the parsing in one step with Tcl 8.1 RE's
+ # This has the benefit of performing better WF checking
+
+ set adv_re [format {^[%s]*version[%s]*=[%s]*("|')(-+|[a-zA-Z0-9_.:]+)\1([%s]+encoding[%s]*=[%s]*("|')([A-Za-z][-A-Za-z0-9._]*)\4)?([%s]*standalone[%s]*=[%s]*("|')(yes|no)\7)?[%s]*\?$} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp]
+
+ if {[catch {regexp $adv_re $param discard delimiter version discard delimiter encoding discard delimiter standalone} matches]} {
+ # Otherwise we must fallback to 8.0.
+ # This won't detect certain well-formedness errors
+
+ # Get the version number
+ if {[regexp [format {[%s]*version[%s]*=[%s]*"(-+|[a-zA-Z0-9_.:]+)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version] || [regexp [format {[%s]*version[%s]*=[%s]*'(-+|[a-zA-Z0-9_.:]+)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version]} {
+ if {[string compare $version "1.0"]} {
+ # Should we support future versions?
+ # At least 1.X?
+ uplevel #0 $options(-errorcommand) [list versionincompatibility "document XML version \"$version\" is incompatible with XML version 1.0"]
+ }
+ } else {
+ uplevel #0 $options(-errorcommand) [list missingversion "XML Declaration missing version information around line $state(line)"]
+ }
+
+ # Get the encoding declaration
+ set encoding {}
+ regexp [format {[%s]*encoding[%s]*=[%s]*"([A-Za-z]([A-Za-z0-9._]|-)*)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding
+ regexp [format {[%s]*encoding[%s]*=[%s]*'([A-Za-z]([A-Za-z0-9._]|-)*)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding
+
+ # Get the standalone declaration
+ set standalone {}
+ regexp [format {[%s]*standalone[%s]*=[%s]*"(yes|no)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone
+ regexp [format {[%s]*standalone[%s]*=[%s]*'(yes|no)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone
+
+ # Invoke the callback
+ uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]
+
+ } elseif {$matches == 0} {
+ uplevel #0 $options(-errorcommand) [list illformeddeclaration "XML Declaration not well-formed around line $state(line)"]
+ } else {
+
+ # Invoke the callback
+ uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]
+
+ }
+
+ }
+
+ }
+
+ {\?*} {
+ # Processing instruction
+ set tag [string range $tag 1 end]
+ if {[regsub {\?$} $tag {} tag]} {
+ if {[string length [string trim $param]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$param\" in processing instruction around line $state(line)"]
+ }
+ } elseif {![regexp ^$Name\$ $tag]} {
+ uplevel #0 $options(-errorcommand) [list illegalcharacter "illegal character in processing instruction target \"$tag\""]
+ } elseif {[regexp {[xX][mM][lL]} $tag]} {
+ uplevel #0 $options(-errorcommand) [list illegalcharacters "characters \"xml\" not permitted in processing instruction target \"$tag\""]
+ } elseif {![regsub {\?$} $param {} param]} {
+ uplevel #0 $options(-errorcommand) [list missingquestion "PI: expected '?' character around line $state(line)"]
+ }
+ set code [catch {uplevel #0 $options(-processinginstructioncommand) [list $tag [string trimleft $param]]} msg]
+ switch $code {
+ 0 {# OK}
+ 3 {
+ # break
+ return {}
+ }
+ 4 {
+ # continue
+ # skip sibling nodes
+ set state(continue:tag) [lindex $state(stack) end]
+ set state(continue:level) 1
+ set state(mode) continue
+ continue
+ }
+ default {
+ return -code $code -errorinfo $::errorInfo $msg
+ }
+ }
+ }
+
+ !DOCTYPE {
+ # External entity reference
+ # This should move into xml.tcl
+ # Parse the params supplied. Looking for Name, ExternalID and MarkupDecl
+ set matched [regexp ^[cl $Wsp]*($Name)[cl $Wsp]*(.*) $param x state(doc_name) param]
+ set state(doc_name) [Normalize $state(doc_name) $options(-normalize)]
+ set externalID {}
+ set pubidlit {}
+ set systemlit {}
+ set externalID {}
+ if {[regexp -nocase ^[cl $Wsp]*(SYSTEM|PUBLIC)(.*) $param x id param]} {
+ switch [string toupper $id] {
+ SYSTEM {
+ if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
+ set externalID [list SYSTEM $systemlit] ;# "
+ } else {
+ uplevel #0 $options(-errorcommand) {syntaxerror {syntax error: SYSTEM identifier not followed by literal}}
+ }
+ }
+ PUBLIC {
+ if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x pubidlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x pubidlit param]} {
+ if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
+ set externalID [list PUBLIC $pubidlit $systemlit]
+ } else {
+ uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by system literal around line $state(line)"]
+ }
+ } else {
+ uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by literal around line $state(line)"]
+ }
+ }
+ }
+ if {[regexp -nocase ^[cl $Wsp]+NDATA[cl $Wsp]+($Name)(.*) $param x notation param]} {
+ lappend externalID $notation
+ }
+ }
+
+ set state(inDTD) 1
+
+ ParseEvent:DocTypeDecl [array get options] $state(doc_name) $pubidlit $systemlit $options(-internaldtd)
+
+ set state(inDTD) 0
+
+ }
+
+ !--* {
+
+ # Start of a comment
+ # See if it ends in the same tag, otherwise change the
+ # parsing mode
+
+ regexp {!--(.*)} $tag discard comm1
+ if {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $comm1 discard comm1_1]} {
+ # processed comment (end in tag)
+ uplevel #0 $options(-commentcommand) [list $comm1_1]
+ } elseif {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $param discard comm2]} {
+ # processed comment (end in attributes)
+ uplevel #0 $options(-commentcommand) [list $comm1$comm2]
+ } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm2 text]} {
+ # processed comment (end in text)
+ uplevel #0 $options(-commentcommand) [list $comm1$param$empty>$comm2]
+ } else {
+ # start of comment
+ set state(mode) comment
+ set state(commentdata) "$comm1$param$empty>$text"
+ continue
+ }
+ }
+
+ {!\[CDATA\[*} {
+
+ regexp {!\[CDATA\[(.*)} $tag discard cdata1
+ if {[regexp {(.*)]]$} $cdata1 discard cdata2]} {
+ # processed CDATA (end in tag)
+ PCDATA [array get options] [subst -novariable -nocommand $cdata2]
+ set text [subst -novariable -nocommand $text]
+ } elseif {[regexp {(.*)]]$} $param discard cdata2]} {
+ # processed CDATA (end in attribute)
+ # Backslashes in param are quoted at this stage
+ PCDATA [array get options] $cdata1[subst -novariable -nocommand $cdata2]
+ set text [subst -novariable -nocommand $text]
+ } elseif {[regexp {(.*)]]>(.*)} $text discard cdata2 text]} {
+ # processed CDATA (end in text)
+ # Backslashes in param and text are quoted at this stage
+ PCDATA [array get options] $cdata1[subst -novariable -nocommand $param]$empty>[subst -novariable -nocommand $cdata2]
+ set text [subst -novariable -nocommand $text]
+ } else {
+ # start CDATA
+ set state(cdata) "$cdata1$param>$text"
+ set state(mode) cdata
+ continue
+ }
+
+ }
+
+ !ELEMENT -
+ !ATTLIST -
+ !ENTITY -
+ !NOTATION {
+ uplevel #0 $options(-errorcommand) [list illegaldeclaration "[string range $tag 1 end] declaration not expected in document instance around line $state(line)"]
+ }
+
+ default {
+ uplevel #0 $options(-errorcommand) [list unknowninstruction "unknown processing instruction \"<$tag>\" around line $state(line)"]
+ }
+ }
+ }
+ *,1,* -
+ *,0,/,/ {
+ # Syntax error
+ uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: closed/empty tag: tag $tag param $param empty $empty close $close around line $state(line)"]
+ }
+ }
+
+ # Mats: we could have been reset from any of the callbacks!
+ if {![info exists state(haveDocElement)]} {
+ return {}
+ }
+
+ # Process character data
+ if {$state(haveDocElement) && [llength $state(stack)]} {
+
+ # Check if the internal DTD entity is in the text
+ regsub -all &xml:intdtd\; $text \[$options(-internaldtd)\] text
+
+ # Look for entity references
+ if {([array size entities] || \
+ [string length $options(-entityreferencecommand)]) && \
+ $options(-defaultexpandinternalentities) && \
+ [regexp {&[^;]+;} $text]} {
+
+ # protect Tcl specials
+ # NB. braces and backslashes may already be protected
+ regsub -all {\\({|}|\\)} $text {\1} text
+ regsub -all {([][$\\{}])} $text {\\\1} text
+
+ # Mark entity references
+ regsub -all {&([^;]+);} $text [format {%s; %s {\1} ; %s %s} \}\} [namespace code [list Entity [array get options] $options(-entityreferencecommand) [namespace code [list PCDATA [array get options]]] $options(entities)]] [namespace code [list DeProtect [namespace code [list PCDATA [array get options]]]]] \{\{] text
+ set text "uplevel #0 [namespace code [list DeProtect1 [namespace code [list PCDATA [array get options]]]]] {{$text}}"
+ eval $text
+ } else {
+
+ # Restore protected special characters
+ regsub -all {\\([][{}\\])} $text {\1} text
+ PCDATA [array get options] $text
+ }
+ } elseif {[string length [string trim $text]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\" in document prolog around line $state(line)"]
+ }
+
+ }
+
+ # If this is the end of the document, close all open containers
+ if {$options(-final) && [llength $state(stack)]} {
+ eval $options(-errorcommand) [list unclosedelement "element [lindex $state(stack) end] remains unclosed around line $state(line)"]
+ }
+
+ return {}
+}
+
+# sgml::DeProtect --
+#
+# Invoke given command after removing protecting backslashes
+# from given text.
+#
+# Arguments:
+# cmd Command to invoke
+# text Text to deprotect
+#
+# Results:
+# Depends on command
+
+proc sgml::DeProtect1 {cmd text} {
+ if {[string compare {} $text]} {
+ regsub -all {\\([]$[{}\\])} $text {\1} text
+ uplevel #0 $cmd [list $text]
+ }
+}
+proc sgml::DeProtect {cmd text} {
+ set text [lindex $text 0]
+ if {[string compare {} $text]} {
+ regsub -all {\\([]$[{}\\])} $text {\1} text
+ uplevel #0 $cmd [list $text]
+ }
+}
+
+# sgml::ParserDelete --
+#
+# Free all memory associated with parser
+#
+# Arguments:
+# var global state array
+#
+# Results:
+# Variables unset
+
+proc sgml::ParserDelete var {
+ upvar #0 $var state
+
+ if {![info exists state]} {
+ return -code error "unknown parser"
+ }
+
+ catch {unset $state(entities)}
+ catch {unset $state(parameterentities)}
+ catch {unset $state(elementdecls)}
+ catch {unset $state(attlistdecls)}
+ catch {unset $state(notationdecls)}
+ catch {unset $state(namespaces)}
+
+ unset state
+
+ return {}
+}
+
+# sgml::ParseEvent:ElementOpen --
+#
+# Start of an element.
+#
+# Arguments:
+# tag Element name
+# attr Attribute list
+# opts Options
+# args further configuration options
+#
+# Options:
+# -empty boolean
+# indicates whether the element was an empty element
+#
+# Results:
+# Modify state and invoke callback
+
+proc sgml::ParseEvent:ElementOpen {tag attr opts args} {
+ variable Name
+ variable Wsp
+
+ array set options $opts
+ upvar #0 $options(-statevariable) state
+ array set cfg {-empty 0}
+ array set cfg $args
+ set handleEmpty 0
+
+ if {$options(-normalize)} {
+ set tag [string toupper $tag]
+ }
+
+ # Update state
+ lappend state(stack) $tag
+
+ # Parse attribute list into a key-value representation
+ if {[string compare $options(-parseattributelistcommand) {}]} {
+ if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $opts $attr]} attr]} {
+ if {[string compare [lindex $attr 0] "unterminated attribute value"]} {
+ uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
+ set attr {}
+ } else {
+
+ # It is most likely that a ">" character was in an attribute value.
+ # This manifests itself by ">" appearing in the element's text.
+ # In this case the callback should return a three element list;
+ # the message "unterminated attribute value", the attribute list it
+ # did manage to parse and the remainder of the attribute list.
+
+ foreach {msg attlist brokenattr} $attr break
+
+ upvar text elemText
+ if {[string first > $elemText] >= 0} {
+
+ # Now piece the attribute list back together
+ regexp [cl $Wsp]*($Name)[cl $Wsp]*=[cl $Wsp]*("|')(.*) $brokenattr discard attname delimiter attvalue
+ regexp (.*)>([cl ^>]*)\$ $elemText discard remattlist elemText
+ regexp ([cl ^$delimiter]*)${delimiter}(.*) $remattlist discard remattvalue remattlist
+
+ # Gotcha: watch out for empty element syntax
+ if {[string match */ [string trimright $remattlist]]} {
+ set remattlist [string range $remattlist 0 end-1]
+ set handleEmpty 1
+ set cfg(-empty) 1
+ }
+
+ append attvalue >$remattvalue
+ lappend attlist $attname $attvalue
+
+ # Complete parsing the attribute list
+ if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $options(-statevariable) $remattlist]} attr]} {
+ uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
+ set attr {}
+ set attlist {}
+ } else {
+ eval lappend attlist $attr
+ }
+
+ set attr $attlist
+
+ } else {
+ uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
+ set attr {}
+ }
+ }
+ }
+ }
+
+ set empty {}
+ if {$cfg(-empty) && $options(-reportempty)} {
+ set empty {-empty 1}
+ }
+
+ # Check for namespace declarations
+ upvar #0 $options(namespaces) namespaces
+ set nsdecls {}
+ if {[llength $attr]} {
+ array set attrlist $attr
+ foreach {attrName attrValue} [array get attrlist xmlns*] {
+ unset attrlist($attrName)
+ set colon [set prefix {}]
+ if {[regexp {^xmlns(:(.+))?$} $attrName discard colon prefix]} {
+ switch -glob [string length $colon],[string length $prefix] {
+ 0,0 {
+ # default NS declaration
+ lappend state(defaultNSURI) $attrValue
+ lappend state(defaultNS) [llength $state(stack)]
+ lappend nsdecls $attrValue {}
+ }
+ 0,* {
+ # Huh?
+ }
+ *,0 {
+ # Error
+ uplevel #0 $state(-warningcommand) "no prefix specified for namespace URI \"$attrValue\" in element \"$tag\""
+ }
+ default {
+ set namespaces($prefix,[llength $state(stack)]) $attrValue
+ lappend nsdecls $attrValue $prefix
+ }
+ }
+ }
+ }
+ if {[llength $nsdecls]} {
+ set nsdecls [list -namespacedecls $nsdecls]
+ }
+ set attr [array get attrlist]
+ }
+
+ # Check whether this element has an expanded name
+ set ns {}
+ if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
+ set nsspec [lsort -dictionary -decreasing [array names namespaces $prefix,*]]
+ if {[llength $nsspec]} {
+ set nsuri $namespaces([lindex $nsspec 0])
+ set ns [list -namespace $nsuri]
+ } else {
+ uplevel #0 $options(-errorcommand) [list namespaceundeclared "no namespace declared for prefix \"$prefix\" in element $tag"]
+ }
+ } elseif {[llength $state(defaultNSURI)]} {
+ set ns [list -namespace [lindex $state(defaultNSURI) end]]
+ }
+
+ # Invoke callback
+ set code [catch {uplevel #0 $options(-elementstartcommand) [list $tag $attr] $empty $ns $nsdecls} msg]
+
+ # Sometimes empty elements must be handled here (see above)
+ if {$code == 0 && $handleEmpty} {
+ ParseEvent:ElementClose $tag $opts -empty 1
+ }
+
+ return -code $code -errorinfo $::errorInfo $msg
+}
+
+# sgml::ParseEvent:ElementClose --
+#
+# End of an element.
+#
+# Arguments:
+# tag Element name
+# opts Options
+# args further configuration options
+#
+# Options:
+# -empty boolean
+# indicates whether the element as an empty element
+#
+# Results:
+# Modify state and invoke callback
+
+proc sgml::ParseEvent:ElementClose {tag opts args} {
+ array set options $opts
+ upvar #0 $options(-statevariable) state
+ array set cfg {-empty 0}
+ array set cfg $args
+
+ # WF check
+ if {[string compare $tag [lindex $state(stack) end]]} {
+ uplevel #0 $options(-errorcommand) [list illegalendtag "end tag \"$tag\" does not match open element \"[lindex $state(stack) end]\" around line $state(line)"]
+ return
+ }
+
+ # Check whether this element has an expanded name
+ upvar #0 $options(namespaces) namespaces
+ set ns {}
+ if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
+ set nsuri $namespaces([lindex [lsort -dictionary -decreasing [array names namespaces $prefix,*]] 0])
+ set ns [list -namespace $nsuri]
+ } elseif {[llength $state(defaultNSURI)]} {
+ set ns [list -namespace [lindex $state(defaultNSURI) end]]
+ }
+
+ # Pop namespace stacks, if any
+ if {[llength $state(defaultNS)]} {
+ if {[llength $state(stack)] == [lindex $state(defaultNS) end]} {
+ set state(defaultNS) [lreplace $state(defaultNS) end end]
+ }
+ }
+ foreach nsspec [array names namespaces *,[llength $state(stack)]] {
+ unset namespaces($nsspec)
+ }
+
+ # Update state
+ set state(stack) [lreplace $state(stack) end end]
+
+ set empty {}
+ if {$cfg(-empty) && $options(-reportempty)} {
+ set empty {-empty 1}
+ }
+
+ # Invoke callback
+ # Mats: Shall be same as sgml::ParseEvent:ElementOpen to handle exceptions in callback.
+ set code [catch {uplevel #0 $options(-elementendcommand) [list $tag] $empty $ns} msg]
+ return -code $code -errorinfo $::errorInfo $msg
+}
+
+# sgml::PCDATA --
+#
+# Process PCDATA before passing to application
+#
+# Arguments:
+# opts options
+# pcdata Character data to be processed
+#
+# Results:
+# Checks that characters are legal,
+# checks -ignorewhitespace setting.
+
+proc sgml::PCDATA {opts pcdata} {
+ array set options $opts
+
+ if {$options(-ignorewhitespace) && \
+ ![string length [string trim $pcdata]]} {
+ return {}
+ }
+
+ if {![regexp ^[cl $::sgml::Char]*\$ $pcdata]} {
+ upvar \#0 $options(-statevariable) state
+ uplevel \#0 $options(-errorcommand) [list illegalcharacters "illegal, non-Unicode characters found in text \"$pcdata\" around line $state(line)"]
+ }
+
+ uplevel \#0 $options(-characterdatacommand) [list $pcdata]
+}
+
+# sgml::Normalize --
+#
+# Perform name normalization if required
+#
+# Arguments:
+# name name to normalize
+# req normalization required
+#
+# Results:
+# Name returned as upper-case if normalization required
+
+proc sgml::Normalize {name req} {
+ if {$req} {
+ return [string toupper $name]
+ } else {
+ return $name
+ }
+}
+
+# sgml::Entity --
+#
+# Resolve XML entity references (syntax: &xxx;).
+#
+# Arguments:
+# opts options
+# entityrefcmd application callback for entity references
+# pcdatacmd application callback for character data
+# entities name of array containing entity definitions.
+# ref entity reference (the "xxx" bit)
+#
+# Results:
+# Returns substitution text for given entity.
+
+proc sgml::Entity {opts entityrefcmd pcdatacmd entities ref} {
+ array set options $opts
+ upvar #0 $options(-statevariable) state
+
+ if {![string length $entities]} {
+ set entities [namespace current]::EntityPredef
+ }
+
+ switch -glob -- $ref {
+ %* {
+ # Parameter entity - not recognised outside of a DTD
+ }
+ #x* {
+ # Character entity - hex
+ if {[catch {format %c [scan [string range $ref 2 end] %x tmp; set tmp]} char]} {
+ return -code error "malformed character entity \"$ref\""
+ }
+ uplevel #0 $pcdatacmd [list $char]
+
+ return {}
+
+ }
+ #* {
+ # Character entity - decimal
+ if {[catch {format %c [scan [string range $ref 1 end] %d tmp; set tmp]} char]} {
+ return -code error "malformed character entity \"$ref\""
+ }
+ uplevel #0 $pcdatacmd [list $char]
+
+ return {}
+
+ }
+ default {
+ # General entity
+ upvar #0 $entities map
+ if {[info exists map($ref)]} {
+
+ if {![regexp {<|&} $map($ref)]} {
+
+ # Simple text replacement - optimise
+ uplevel #0 $pcdatacmd [list $map($ref)]
+
+ return {}
+
+ }
+
+ # Otherwise an additional round of parsing is required.
+ # This only applies to XML, since HTML doesn't have general entities
+
+ # Must parse the replacement text for start & end tags, etc
+ # This text must be self-contained: balanced closing tags, and so on
+
+ set tokenised [tokenise $map($ref) $::xml::tokExpr $::xml::substExpr]
+ set options(-final) 0
+ eval parseEvent [list $tokenised] [array get options]
+
+ return {}
+
+ } elseif {[string compare $entityrefcmd "::sgml::noop"]} {
+
+ set result [uplevel #0 $entityrefcmd [list $ref]]
+
+ if {[string length $result]} {
+ uplevel #0 $pcdatacmd [list $result]
+ }
+
+ return {}
+
+ } else {
+
+ # Reconstitute entity reference
+
+ uplevel #0 $options(-errorcommand) [list illegalentity "undefined entity reference \"$ref\""]
+
+ return {}
+
+ }
+ }
+ }
+
+ # If all else fails leave the entity reference untouched
+ uplevel #0 $pcdatacmd [list &$ref\;]
+
+ return {}
+}
+
+####################################
+#
+# DTD parser for SGML (XML).
+#
+# This DTD actually only handles XML DTDs. Other language's
+# DTD's, such as HTML, must be written in terms of a XML DTD.
+#
+####################################
+
+# sgml::ParseEvent:DocTypeDecl --
+#
+# Entry point for DTD parsing
+#
+# Arguments:
+# opts configuration options
+# docEl document element name
+# pubId public identifier
+# sysId system identifier (a URI)
+# intSSet internal DTD subset
+
+proc sgml::ParseEvent:DocTypeDecl {opts docEl pubId sysId intSSet} {
+ array set options {}
+ array set options $opts
+
+ set code [catch {uplevel #0 $options(-doctypecommand) [list $docEl $pubId $sysId $intSSet]} err]
+ switch $code {
+ 3 {
+ # break
+ return {}
+ }
+ 0 -
+ 4 {
+ # continue
+ }
+ default {
+ return -code $code $err
+ }
+ }
+
+ # Otherwise we'll parse the DTD and report it piecemeal
+
+ # The internal DTD subset is processed first (XML 2.8)
+ # During this stage, parameter entities are only allowed
+ # between markup declarations
+
+ ParseDTD:Internal [array get options] $intSSet
+
+ # The external DTD subset is processed last (XML 2.8)
+ # During this stage, parameter entities may occur anywhere
+
+ # We must resolve the external identifier to obtain the
+ # DTD data. The application may supply its own resolver.
+
+ if {[string length $pubId] || [string length $sysId]} {
+ uplevel #0 $options(-externalentitycommand) [list $options(-cmd) $options(-baseuri) $sysId $pubId]
+ }
+
+ return {}
+}
+
+# sgml::ParseDTD:Internal --
+#
+# Parse the internal DTD subset.
+#
+# Parameter entities are only allowed between markup declarations.
+#
+# Arguments:
+# opts configuration options
+# dtd DTD data
+#
+# Results:
+# Markup declarations parsed may cause callback invocation
+
+proc sgml::ParseDTD:Internal {opts dtd} {
+ variable MarkupDeclExpr
+ variable MarkupDeclSub
+
+ array set options {}
+ array set options $opts
+
+ upvar #0 $options(-statevariable) state
+ upvar #0 $options(parameterentities) PEnts
+ upvar #0 $options(externalparameterentities) ExtPEnts
+
+ # Bug 583947: remove comments before further processing
+ regsub -all {<!--.*?-->} $dtd {} dtd
+
+ # Tokenize the DTD
+
+ # Protect Tcl special characters
+ regsub -all {([{}\\])} $dtd {\\\1} dtd
+
+ regsub -all $MarkupDeclExpr $dtd $MarkupDeclSub dtd
+
+ # Entities may have angle brackets in their replacement
+ # text, which breaks the RE processing. So, we must
+ # use a similar technique to processing doc instances
+ # to rebuild the declarations from the pieces
+
+ set mode {} ;# normal
+ set delimiter {}
+ set name {}
+ set param {}
+
+ set state(inInternalDTD) 1
+
+ # Process the tokens
+ foreach {decl value text} [lrange "{} {} \{$dtd\}" 3 end] {
+
+ # Keep track of line numbers
+ incr state(line) [regsub -all \n $text {} discard]
+
+ ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
+
+ ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode replText text param
+
+ # There may be parameter entity references between markup decls
+
+ if {[regexp {%.*;} $text]} {
+
+ # Protect Tcl special characters
+ regsub -all {([{}\\])} $text {\\\1} text
+
+ regsub -all %($::sgml::Name)\; $text "\} {\\1} \{" text
+
+ set PElist "\{$text\}"
+ set PElist [lreplace $PElist end end]
+ foreach {text entref} $PElist {
+ if {[string length [string trim $text]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text in internal DTD subset around line $state(line)"]
+ }
+
+ # Expand parameter entity and recursively parse
+ # BUG: no checks yet for recursive entity references
+
+ if {[info exists PEnts($entref)]} {
+ set externalParser [$options(-cmd) entityparser]
+ $externalParser parse $PEnts($entref) -dtdsubset internal
+ } elseif {[info exists ExtPEnts($entref)]} {
+ set externalParser [$options(-cmd) entityparser]
+ $externalParser parse $ExtPEnts($entref) -dtdsubset external
+ #$externalParser free
+ } else {
+ uplevel #0 $options(-errorcommand) [list illegalreference "reference to undeclared parameter entity \"$entref\""]
+ }
+ }
+
+ }
+
+ }
+
+ return {}
+}
+
+# sgml::ParseDTD:EntityMode --
+#
+# Perform special processing for various parser modes
+#
+# Arguments:
+# opts configuration options
+# modeVar pass-by-reference mode variable
+# replTextVar pass-by-ref
+# declVar pass-by-ref
+# valueVar pass-by-ref
+# textVar pass-by-ref
+# delimiter delimiter currently in force
+# name
+# param
+#
+# Results:
+# Depends on current mode
+
+proc sgml::ParseDTD:EntityMode {opts modeVar replTextVar declVar valueVar textVar delimiter name param} {
+ upvar 1 $modeVar mode
+ upvar 1 $replTextVar replText
+ upvar 1 $declVar decl
+ upvar 1 $valueVar value
+ upvar 1 $textVar text
+ array set options $opts
+
+ switch $mode {
+ {} {
+ # Pass through to normal processing section
+ }
+ entity {
+ # Look for closing delimiter
+ if {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $decl discard val1 remainder]} {
+ append replText <$val1
+ DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
+ set decl /
+ set text $remainder\ $value>$text
+ set value {}
+ set mode {}
+ } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $value discard val2 remainder]} {
+ append replText <$decl\ $val2
+ DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
+ set decl /
+ set text $remainder>$text
+ set value {}
+ set mode {}
+ } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $text discard val3 remainder]} {
+ append replText <$decl\ $value>$val3
+ DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
+ set decl /
+ set text $remainder
+ set value {}
+ set mode {}
+ } else {
+
+ # Remain in entity mode
+ append replText <$decl\ $value>$text
+ return -code continue
+
+ }
+ }
+
+ ignore {
+ upvar #0 $options(-statevariable) state
+
+ if {[regexp {]](.*)$} $decl discard remainder]} {
+ set state(condSections) [lreplace $state(condSections) end end]
+ set decl $remainder
+ set mode {}
+ } elseif {[regexp {]](.*)$} $value discard remainder]} {
+ set state(condSections) [lreplace $state(condSections) end end]
+ regexp <[cl $::sgml::Wsp]*($::sgml::Name)(.*) $remainder discard decl value
+ set mode {}
+ } elseif {[regexp {]]>(.*)$} $text discard remainder]} {
+ set state(condSections) [lreplace $state(condSections) end end]
+ set decl /
+ set value {}
+ set text $remainder
+ #regexp <[cl $::sgml::Wsp]*($::sgml::Name)([cl ^>]*)>(.*) $remainder discard decl value text
+ set mode {}
+ } else {
+ set decl /
+ }
+
+ }
+
+ comment {
+ # Look for closing comment delimiter
+
+ upvar #0 $options(-statevariable) state
+
+ if {[regexp (.*?)--(.*)\$ $decl discard data1 remainder]} {
+ } elseif {[regexp (.*?)--(.*)\$ $value discard data1 remainder]} {
+ } elseif {[regexp (.*?)--(.*)\$ $text discard data1 remainder]} {
+ } else {
+ # comment continues
+ append state(commentdata) <$decl\ $value>$text
+ set decl /
+ set value {}
+ set text {}
+ }
+ }
+
+ }
+
+ return {}
+}
+
+# sgml::ParseDTD:ProcessMarkupDecl --
+#
+# Process a single markup declaration
+#
+# Arguments:
+# opts configuration options
+# declVar pass-by-ref
+# valueVar pass-by-ref
+# delimiterVar pass-by-ref for current delimiter in force
+# nameVar pass-by-ref
+# modeVar pass-by-ref for current parser mode
+# replTextVar pass-by-ref
+# textVar pass-by-ref
+# paramVar pass-by-ref
+#
+# Results:
+# Depends on markup declaration. May change parser mode
+
+proc sgml::ParseDTD:ProcessMarkupDecl {opts declVar valueVar delimiterVar nameVar modeVar replTextVar textVar paramVar} {
+ upvar 1 $modeVar mode
+ upvar 1 $replTextVar replText
+ upvar 1 $textVar text
+ upvar 1 $declVar decl
+ upvar 1 $valueVar value
+ upvar 1 $nameVar name
+ upvar 1 $delimiterVar delimiter
+ upvar 1 $paramVar param
+
+ variable declExpr
+ variable ExternalEntityExpr
+
+ array set options $opts
+ upvar #0 $options(-statevariable) state
+
+ switch -glob -- $decl {
+
+ / {
+ # continuation from entity processing
+ }
+
+ !ELEMENT {
+ # Element declaration
+ if {[regexp $declExpr $value discard tag cmodel]} {
+ DTD:ELEMENT [array get options] $tag $cmodel
+ } else {
+ uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed element declaration around line $state(line)"]
+ }
+ }
+
+ !ATTLIST {
+ # Attribute list declaration
+ variable declExpr
+ if {[regexp $declExpr $value discard tag attdefns]} {
+ if {[catch {DTD:ATTLIST [array get options] $tag $attdefns} err]} {
+ #puts stderr "Stack trace: $::errorInfo\n***\n"
+ # Atttribute parsing has bugs at the moment
+ #return -code error "$err around line $state(line)"
+ return {}
+ }
+ } else {
+ uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed attribute list declaration around line $state(line)"]
+ }
+ }
+
+ !ENTITY {
+ # Entity declaration
+ variable EntityExpr
+
+ if {[regexp $EntityExpr $value discard param name value]} {
+
+ # Entity replacement text may have a '>' character.
+ # In this case, the real delimiter will be in the following
+ # text. This is complicated by the possibility of there
+ # being several '<','>' pairs in the replacement text.
+ # At this point, we are searching for the matching quote delimiter.
+
+ if {[regexp $ExternalEntityExpr $value]} {
+ DTD:ENTITY [array get options] $name [string trim $param] $value
+ } elseif {[regexp ("|')(.*?)\\1(.*) $value discard delimiter replText value]} {
+
+ if {[string length [string trim $value]]} {
+ uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
+ } else {
+ DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
+ }
+ } elseif {[regexp ("|')(.*) $value discard delimiter replText]} {
+ append replText >$text
+ set text {}
+ set mode entity
+ } else {
+ uplevel #0 $options(-errorcommand) [list illegaldeclaration "no delimiter for entity declaration around line $state(line)"]
+ }
+
+ } else {
+ uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
+ }
+ }
+
+ !NOTATION {
+ # Notation declaration
+ if {[regexp $declExpr param discard tag notation]} {
+ DTD:ENTITY [array get options] $tag $notation
+ } else {
+ uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
+ }
+ }
+
+ !--* {
+ # Start of a comment
+
+ if {[regexp !--(.*?)--\$ $decl discard data]} {
+ if {[string length [string trim $value]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$value\""]
+ }
+ uplevel #0 $options(-commentcommand) [list $data]
+ set decl /
+ set value {}
+ } elseif {[regexp -- ^(.*?)--\$ $value discard data2]} {
+ regexp !--(.*)\$ $decl discard data1
+ uplevel #0 $options(-commentcommand) [list $data1\ $data2]
+ set decl /
+ set value {}
+ } elseif {[regexp (.*?)-->(.*)\$ $text discard data3 remainder]} {
+ regexp !--(.*)\$ $decl discard data1
+ uplevel #0 $options(-commentcommand) [list $data1\ $value>$data3]
+ set decl /
+ set value {}
+ set text $remainder
+ } else {
+ regexp !--(.*)\$ $decl discard data1
+ set state(commentdata) $data1\ $value>$text
+ set decl /
+ set value {}
+ set text {}
+ set mode comment
+ }
+ }
+
+ !*INCLUDE* -
+ !*IGNORE* {
+ if {$state(inInternalDTD)} {
+ uplevel #0 $options(-errorcommand) [list illegalsection "conditional section not permitted in internal DTD subset around line $state(line)"]
+ }
+
+ if {[regexp {^!\[INCLUDE\[(.*)} $decl discard remainder]} {
+ # Push conditional section stack, popped by ]]> sequence
+
+ if {[regexp {(.*?)]]$} $remainder discard r2]} {
+ # section closed immediately
+ if {[string length [string trim $r2]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
+ }
+ } elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} {
+ # section closed immediately
+ if {[string length [string trim $r2]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
+ }
+ if {[string length [string trim $r3]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r3\" in conditional section"]
+ }
+ } else {
+
+ lappend state(condSections) INCLUDE
+
+ set parser [$options(-cmd) entityparser]
+ $parser parse $remainder\ $value> -dtdsubset external
+ #$parser free
+
+ if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} {
+ if {[string length [string trim $t1]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
+ }
+ if {![llength $state(condSections)]} {
+ uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
+ }
+ set state(condSections) [lreplace $state(condSections) end end]
+ set text $t2
+ }
+
+ }
+ } elseif {[regexp {^!\[IGNORE\[(.*)} $decl discard remainder]} {
+ # Set ignore mode. Still need a stack
+ set mode ignore
+
+ if {[regexp {(.*?)]]$} $remainder discard r2]} {
+ # section closed immediately
+ if {[string length [string trim $r2]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
+ }
+ } elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} {
+ # section closed immediately
+ if {[string length [string trim $r2]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
+ }
+ if {[string length [string trim $r3]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r3\" in conditional section"]
+ }
+ } else {
+
+ lappend state(condSections) IGNORE
+
+ if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} {
+ if {[string length [string trim $t1]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
+ }
+ if {![llength $state(condSections)]} {
+ uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
+ }
+ set state(condSections) [lreplace $state(condSections) end end]
+ set text $t2
+ }
+
+ }
+ } else {
+ uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\" around line $state(line)"]
+ }
+
+ }
+
+ default {
+ if {[regexp {^\?(.*)} $decl discard target]} {
+ # Processing instruction
+ } else {
+ uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\""]
+ }
+ }
+ }
+
+ return {}
+}
+
+# sgml::ParseDTD:External --
+#
+# Parse the external DTD subset.
+#
+# Parameter entities are allowed anywhere.
+#
+# Arguments:
+# opts configuration options
+# dtd DTD data
+#
+# Results:
+# Markup declarations parsed may cause callback invocation
+
+proc sgml::ParseDTD:External {opts dtd} {
+ variable MarkupDeclExpr
+ variable MarkupDeclSub
+ variable declExpr
+
+ array set options $opts
+ upvar #0 $options(parameterentities) PEnts
+ upvar #0 $options(externalparameterentities) ExtPEnts
+ upvar #0 $options(-statevariable) state
+
+ # As with the internal DTD subset, watch out for
+ # entities with angle brackets
+ set mode {} ;# normal
+ set delimiter {}
+ set name {}
+ set param {}
+
+ set oldState 0
+ catch {set oldState $state(inInternalDTD)}
+ set state(inInternalDTD) 0
+
+ # Initialise conditional section stack
+ if {![info exists state(condSections)]} {
+ set state(condSections) {}
+ }
+ set startCondSectionDepth [llength $state(condSections)]
+
+ while {[string length $dtd]} {
+ set progress 0
+ set PEref {}
+ if {![string compare $mode "ignore"]} {
+ set progress 1
+ if {[regexp {]]>(.*)} $dtd discard dtd]} {
+ set remainder {}
+ set mode {} ;# normal
+ set state(condSections) [lreplace $state(condSections) end end]
+ continue
+ } else {
+ uplevel #0 $options(-errorcommand) [list missingdelimiter "IGNORE conditional section closing delimiter not found"]
+ }
+ } elseif {[regexp ^(.*?)%($::sgml::Name)\;(.*)\$ $dtd discard data PEref remainder]} {
+ set progress 1
+ } else {
+ set data $dtd
+ set dtd {}
+ set remainder {}
+ }
+
+ # Tokenize the DTD (so far)
+
+ # Protect Tcl special characters
+ regsub -all {([{}\\])} $data {\\\1} dataP
+
+ set n [regsub -all $MarkupDeclExpr $dataP $MarkupDeclSub dataP]
+
+ if {$n} {
+ set progress 1
+ # All but the last markup declaration should have no text
+ set dataP [lrange "{} {} \{$dataP\}" 3 end]
+ if {[llength $dataP] > 3} {
+ foreach {decl value text} [lrange $dataP 0 [expr [llength $dataP] - 4]] {
+ ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
+ ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param
+
+ if {[string length [string trim $text]]} {
+ # check for conditional section close
+ if {[regexp {]]>(.*)$} $text discard text]} {
+ if {[string length [string trim $text]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\""]
+ }
+ if {![llength $state(condSections)]} {
+ uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
+ }
+ set state(condSections) [lreplace $state(condSections) end end]
+ if {![string compare $mode "ignore"]} {
+ set mode {} ;# normal
+ }
+ } else {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\""]
+ }
+ }
+ }
+ }
+ # Do the last declaration
+ foreach {decl value text} [lrange $dataP [expr [llength $dataP] - 3] end] {
+ ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
+ ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param
+ }
+ }
+
+ # Now expand the PE reference, if any
+ switch -glob $mode,[string length $PEref],$n {
+ ignore,0,* {
+ set dtd $text
+ }
+ ignore,*,* {
+ set dtd $text$remainder
+ }
+ *,0,0 {
+ set dtd $data
+ }
+ *,0,* {
+ set dtd $text
+ }
+ *,*,0 {
+ if {[catch {append data $PEnts($PEref)}]} {
+ if {[info exists ExtPEnts($PEref)]} {
+ set externalParser [$options(-cmd) entityparser]
+ $externalParser parse $ExtPEnts($PEref) -dtdsubset external
+ #$externalParser free
+ } else {
+ uplevel #0 $options(-errorcommand) [list entityundeclared "parameter entity \"$PEref\" not declared"]
+ }
+ }
+ set dtd $data$remainder
+ }
+ default {
+ if {[catch {append text $PEnts($PEref)}]} {
+ if {[info exists ExtPEnts($PEref)]} {
+ set externalParser [$options(-cmd) entityparser]
+ $externalParser parse $ExtPEnts($PEref) -dtdsubset external
+ #$externalParser free
+ } else {
+ uplevel #0 $options(-errorcommand) [list entityundeclared "parameter entity \"$PEref\" not declared"]
+ }
+ }
+ set dtd $text$remainder
+ }
+ }
+
+ # Check whether a conditional section has been terminated
+ if {[regexp {^(.*?)]]>(.*)$} $dtd discard t1 t2]} {
+ if {![regexp <.*> $t1]} {
+ if {[string length [string trim $t1]]} {
+ uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
+ }
+ if {![llength $state(condSections)]} {
+ uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
+ }
+ set state(condSections) [lreplace $state(condSections) end end]
+ if {![string compare $mode "ignore"]} {
+ set mode {} ;# normal
+ }
+ set dtd $t2
+ set progress 1
+ }
+ }
+
+ if {!$progress} {
+ # No parameter entity references were found and
+ # the text does not contain a well-formed markup declaration
+ # Avoid going into an infinite loop
+ upvar #0 $options(-errorcommand) [list syntaxerror "external entity does not contain well-formed markup declaration"]
+ break
+ }
+ }
+
+ set state(inInternalDTD) $oldState
+
+ # Check that conditional sections have been closed properly
+ if {[llength $state(condSections)] > $startCondSectionDepth} {
+ uplevel #0 $options(-errorcommand) [list syntaxerror "[lindex $state(condSections) end] conditional section not closed"]
+ }
+ if {[llength $state(condSections)] < $startCondSectionDepth} {
+ uplevel #0 $options(-errorcommand) [list syntaxerror "too many conditional section closures"]
+ }
+
+ return {}
+}
+
+# Procedures for handling the various declarative elements in a DTD.
+# New elements may be added by creating a procedure of the form
+# parse:DTD:_element_
+
+# For each of these procedures, the various regular expressions they use
+# are created outside of the proc to avoid overhead at runtime
+
+# sgml::DTD:ELEMENT --
+#
+# <!ELEMENT ...> defines an element.
+#
+# The content model for the element is stored in the contentmodel array,
+# indexed by the element name. The content model is parsed into the
+# following list form:
+#
+# {} Content model is EMPTY.
+# Indicated by an empty list.
+# * Content model is ANY.
+# Indicated by an asterix.
+# {ELEMENT ...}
+# Content model is element-only.
+# {MIXED {element1 element2 ...}}
+# Content model is mixed (PCDATA and elements).
+# The second element of the list contains the
+# elements that may occur. #PCDATA is assumed
+# (ie. the list is normalised).
+#
+# Arguments:
+# opts configuration options
+# name element GI
+# modspec unparsed content model specification
+
+proc sgml::DTD:ELEMENT {opts name modspec} {
+ variable Wsp
+ array set options $opts
+
+ upvar #0 $options(elementdecls) elements
+
+ if {$options(-validate) && [info exists elements($name)]} {
+ eval $options(-errorcommand) [list elementdeclared "element \"$name\" already declared"]
+ } else {
+ switch -- $modspec {
+ EMPTY {
+ set elements($name) {}
+ uplevel #0 $options(-elementdeclcommand) $name {{}}
+ }
+ ANY {
+ set elements($name) *
+ uplevel #0 $options(-elementdeclcommand) $name *
+ }
+ default {
+ # Don't parse the content model for now,
+ # just pass the model to the application
+ if {0 && [regexp [format {^\([%s]*#PCDATA[%s]*(\|([^)]+))?[%s]*\)*[%s]*$} $Wsp $Wsp $Wsp $Wsp] discard discard mtoks]} {
+ set cm($name) [list MIXED [split $mtoks |]]
+ } elseif {0} {
+ if {[catch {CModelParse $state(state) $value} result]} {
+ eval $options(-errorcommand) [list element? $result]
+ } else {
+ set cm($id) [list ELEMENT $result]
+ }
+ } else {
+ set elements($name) $modspec
+ uplevel #0 $options(-elementdeclcommand) $name [list $modspec]
+ }
+ }
+ }
+ }
+}
+
+# sgml::CModelParse --
+#
+# Parse an element content model (non-mixed).
+# A syntax tree is constructed.
+# A transition table is built next.
+#
+# This is going to need alot of work!
+#
+# Arguments:
+# state state array variable
+# value the content model data
+#
+# Results:
+# A Tcl list representing the content model.
+
+proc sgml::CModelParse {state value} {
+ upvar #0 $state var
+
+ # First build syntax tree
+ set syntaxTree [CModelMakeSyntaxTree $state $value]
+
+ # Build transition table
+ set transitionTable [CModelMakeTransitionTable $state $syntaxTree]
+
+ return [list $syntaxTree $transitionTable]
+}
+
+# sgml::CModelMakeSyntaxTree --
+#
+# Construct a syntax tree for the regular expression.
+#
+# Syntax tree is represented as a Tcl list:
+# rep {:choice|:seq {{rep list1} {rep list2} ...}}
+# where: rep is repetition character, *, + or ?. {} for no repetition
+# listN is nested expression or Name
+#
+# Arguments:
+# spec Element specification
+#
+# Results:
+# Syntax tree for element spec as nested Tcl list.
+#
+# Examples:
+# (memo)
+# {} {:seq {{} memo}}
+# (front, body, back?)
+# {} {:seq {{} front} {{} body} {? back}}
+# (head, (p | list | note)*, div2*)
+# {} {:seq {{} head} {* {:choice {{} p} {{} list} {{} note}}} {* div2}}
+# (p | a | ul)+
+# + {:choice {{} p} {{} a} {{} ul}}
+
+proc sgml::CModelMakeSyntaxTree {state spec} {
+ upvar #0 $state var
+ variable Wsp
+ variable name
+
+ # Translate the spec into a Tcl list.
+
+ # None of the Tcl special characters are allowed in a content model spec.
+ if {[regexp {\$|\[|\]|\{|\}} $spec]} {
+ return -code error "illegal characters in specification"
+ }
+
+ regsub -all [format {(%s)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $name $Wsp $Wsp] $spec [format {%sCModelSTname %s {\1} {\2} {\3}} \n $state] spec
+ regsub -all {\(} $spec "\nCModelSTopenParen $state " spec
+ regsub -all [format {\)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $Wsp $Wsp] $spec [format {%sCModelSTcloseParen %s {\1} {\2}} \n $state] spec
+
+ array set var {stack {} state start}
+ eval $spec
+
+ # Peel off the outer seq, its redundant
+ return [lindex [lindex $var(stack) 1] 0]
+}
+
+# sgml::CModelSTname --
+#
+# Processes a name in a content model spec.
+#
+# Arguments:
+# state state array variable
+# name name specified
+# rep repetition operator
+# cs choice or sequence delimiter
+#
+# Results:
+# See CModelSTcp.
+
+proc sgml::CModelSTname {state name rep cs args} {
+ if {[llength $args]} {
+ return -code error "syntax error in specification: \"$args\""
+ }
+
+ CModelSTcp $state $name $rep $cs
+}
+
+# sgml::CModelSTcp --
+#
+# Process a content particle.
+#
+# Arguments:
+# state state array variable
+# name name specified
+# rep repetition operator
+# cs choice or sequence delimiter
+#
+# Results:
+# The content particle is added to the current group.
+
+proc sgml::CModelSTcp {state cp rep cs} {
+ upvar #0 $state var
+
+ switch -glob -- [lindex $var(state) end]=$cs {
+ start= {
+ set var(state) [lreplace $var(state) end end end]
+ # Add (dummy) grouping, either choice or sequence will do
+ CModelSTcsSet $state ,
+ CModelSTcpAdd $state $cp $rep
+ }
+ :choice= -
+ :seq= {
+ set var(state) [lreplace $var(state) end end end]
+ CModelSTcpAdd $state $cp $rep
+ }
+ start=| -
+ start=, {
+ set var(state) [lreplace $var(state) end end [expr {$cs == "," ? ":seq" : ":choice"}]]
+ CModelSTcsSet $state $cs
+ CModelSTcpAdd $state $cp $rep
+ }
+ :choice=| -
+ :seq=, {
+ CModelSTcpAdd $state $cp $rep
+ }
+ :choice=, -
+ :seq=| {
+ return -code error "syntax error in specification: incorrect delimiter after \"$cp\", should be \"[expr {$cs == "," ? "|" : ","}]\""
+ }
+ end=* {
+ return -code error "syntax error in specification: no delimiter before \"$cp\""
+ }
+ default {
+ return -code error "syntax error"
+ }
+ }
+
+}
+
+# sgml::CModelSTcsSet --
+#
+# Start a choice or sequence on the stack.
+#
+# Arguments:
+# state state array
+# cs choice oir sequence
+#
+# Results:
+# state is modified: end element of state is appended.
+
+proc sgml::CModelSTcsSet {state cs} {
+ upvar #0 $state var
+
+ set cs [expr {$cs == "," ? ":seq" : ":choice"}]
+
+ if {[llength $var(stack)]} {
+ set var(stack) [lreplace $var(stack) end end $cs]
+ } else {
+ set var(stack) [list $cs {}]
+ }
+}
+
+# sgml::CModelSTcpAdd --
+#
+# Append a content particle to the top of the stack.
+#
+# Arguments:
+# state state array
+# cp content particle
+# rep repetition
+#
+# Results:
+# state is modified: end element of state is appended.
+
+proc sgml::CModelSTcpAdd {state cp rep} {
+ upvar #0 $state var
+
+ if {[llength $var(stack)]} {
+ set top [lindex $var(stack) end]
+ lappend top [list $rep $cp]
+ set var(stack) [lreplace $var(stack) end end $top]
+ } else {
+ set var(stack) [list $rep $cp]
+ }
+}
+
+# sgml::CModelSTopenParen --
+#
+# Processes a '(' in a content model spec.
+#
+# Arguments:
+# state state array
+#
+# Results:
+# Pushes stack in state array.
+
+proc sgml::CModelSTopenParen {state args} {
+ upvar #0 $state var
+
+ if {[llength $args]} {
+ return -code error "syntax error in specification: \"$args\""
+ }
+
+ lappend var(state) start
+ lappend var(stack) [list {} {}]
+}
+
+# sgml::CModelSTcloseParen --
+#
+# Processes a ')' in a content model spec.
+#
+# Arguments:
+# state state array
+# rep repetition
+# cs choice or sequence delimiter
+#
+# Results:
+# Stack is popped, and former top of stack is appended to previous element.
+
+proc sgml::CModelSTcloseParen {state rep cs args} {
+ upvar #0 $state var
+
+ if {[llength $args]} {
+ return -code error "syntax error in specification: \"$args\""
+ }
+
+ set cp [lindex $var(stack) end]
+ set var(stack) [lreplace $var(stack) end end]
+ set var(state) [lreplace $var(state) end end]
+ CModelSTcp $state $cp $rep $cs
+}
+
+# sgml::CModelMakeTransitionTable --
+#
+# Given a content model's syntax tree, constructs
+# the transition table for the regular expression.
+#
+# See "Compilers, Principles, Techniques, and Tools",
+# Aho, Sethi and Ullman. Section 3.9, algorithm 3.5.
+#
+# Arguments:
+# state state array variable
+# st syntax tree
+#
+# Results:
+# The transition table is returned, as a key/value Tcl list.
+
+proc sgml::CModelMakeTransitionTable {state st} {
+ upvar #0 $state var
+
+ # Construct nullable, firstpos and lastpos functions
+ array set var {number 0}
+ foreach {nullable firstpos lastpos} [ \
+ TraverseDepth1st $state $st {
+ # Evaluated for leaf nodes
+ # Compute nullable(n)
+ # Compute firstpos(n)
+ # Compute lastpos(n)
+ set nullable [nullable leaf $rep $name]
+ set firstpos [list {} $var(number)]
+ set lastpos [list {} $var(number)]
+ set var(pos:$var(number)) $name
+ } {
+ # Evaluated for nonterminal nodes
+ # Compute nullable, firstpos, lastpos
+ set firstpos [firstpos $cs $firstpos $nullable]
+ set lastpos [lastpos $cs $lastpos $nullable]
+ set nullable [nullable nonterm $rep $cs $nullable]
+ } \
+ ] break
+
+ set accepting [incr var(number)]
+ set var(pos:$accepting) #
+
+ # var(pos:N) maps from position to symbol.
+ # Construct reverse map for convenience.
+ # NB. A symbol may appear in more than one position.
+ # var is about to be reset, so use different arrays.
+
+ foreach {pos symbol} [array get var pos:*] {
+ set pos [lindex [split $pos :] 1]
+ set pos2symbol($pos) $symbol
+ lappend sym2pos($symbol) $pos
+ }
+
+ # Construct the followpos functions
+ catch {unset var}
+ followpos $state $st $firstpos $lastpos
+
+ # Construct transition table
+ # Dstates is [union $marked $unmarked]
+ set unmarked [list [lindex $firstpos 1]]
+ while {[llength $unmarked]} {
+ set T [lindex $unmarked 0]
+ lappend marked $T
+ set unmarked [lrange $unmarked 1 end]
+
+ # Find which input symbols occur in T
+ set symbols {}
+ foreach pos $T {
+ if {$pos != $accepting && [lsearch $symbols $pos2symbol($pos)] < 0} {
+ lappend symbols $pos2symbol($pos)
+ }
+ }
+ foreach a $symbols {
+ set U {}
+ foreach pos $sym2pos($a) {
+ if {[lsearch $T $pos] >= 0} {
+ # add followpos($pos)
+ if {$var($pos) == {}} {
+ lappend U $accepting
+ } else {
+ eval lappend U $var($pos)
+ }
+ }
+ }
+ set U [makeSet $U]
+ if {[llength $U] && [lsearch $marked $U] < 0 && [lsearch $unmarked $U] < 0} {
+ lappend unmarked $U
+ }
+ set Dtran($T,$a) $U
+ }
+
+ }
+
+ return [list [array get Dtran] [array get sym2pos] $accepting]
+}
+
+# sgml::followpos --
+#
+# Compute the followpos function, using the already computed
+# firstpos and lastpos.
+#
+# Arguments:
+# state array variable to store followpos functions
+# st syntax tree
+# firstpos firstpos functions for the syntax tree
+# lastpos lastpos functions
+#
+# Results:
+# followpos functions for each leaf node, in name/value format
+
+proc sgml::followpos {state st firstpos lastpos} {
+ upvar #0 $state var
+
+ switch -- [lindex [lindex $st 1] 0] {
+ :seq {
+ for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
+ followpos $state [lindex [lindex $st 1] $i] \
+ [lindex [lindex $firstpos 0] [expr $i - 1]] \
+ [lindex [lindex $lastpos 0] [expr $i - 1]]
+ foreach pos [lindex [lindex [lindex $lastpos 0] [expr $i - 1]] 1] {
+ eval lappend var($pos) [lindex [lindex [lindex $firstpos 0] $i] 1]
+ set var($pos) [makeSet $var($pos)]
+ }
+ }
+ }
+ :choice {
+ for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
+ followpos $state [lindex [lindex $st 1] $i] \
+ [lindex [lindex $firstpos 0] [expr $i - 1]] \
+ [lindex [lindex $lastpos 0] [expr $i - 1]]
+ }
+ }
+ default {
+ # No action at leaf nodes
+ }
+ }
+
+ switch -- [lindex $st 0] {
+ ? {
+ # We having nothing to do here ! Doing the same as
+ # for * effectively converts this qualifier into the other.
+ }
+ * {
+ foreach pos [lindex $lastpos 1] {
+ eval lappend var($pos) [lindex $firstpos 1]
+ set var($pos) [makeSet $var($pos)]
+ }
+ }
+ }
+
+}
+
+# sgml::TraverseDepth1st --
+#
+# Perform depth-first traversal of a tree.
+# A new tree is constructed, with each node computed by f.
+#
+# Arguments:
+# state state array variable
+# t The tree to traverse, a Tcl list
+# leaf Evaluated at a leaf node
+# nonTerm Evaluated at a nonterminal node
+#
+# Results:
+# A new tree is returned.
+
+proc sgml::TraverseDepth1st {state t leaf nonTerm} {
+ upvar #0 $state var
+
+ set nullable {}
+ set firstpos {}
+ set lastpos {}
+
+ switch -- [lindex [lindex $t 1] 0] {
+ :seq -
+ :choice {
+ set rep [lindex $t 0]
+ set cs [lindex [lindex $t 1] 0]
+
+ foreach child [lrange [lindex $t 1] 1 end] {
+ foreach {childNullable childFirstpos childLastpos} \
+ [TraverseDepth1st $state $child $leaf $nonTerm] break
+ lappend nullable $childNullable
+ lappend firstpos $childFirstpos
+ lappend lastpos $childLastpos
+ }
+
+ eval $nonTerm
+ }
+ default {
+ incr var(number)
+ set rep [lindex [lindex $t 0] 0]
+ set name [lindex [lindex $t 1] 0]
+ eval $leaf
+ }
+ }
+
+ return [list $nullable $firstpos $lastpos]
+}
+
+# sgml::firstpos --
+#
+# Computes the firstpos function for a nonterminal node.
+#
+# Arguments:
+# cs node type, choice or sequence
+# firstpos firstpos functions for the subtree
+# nullable nullable functions for the subtree
+#
+# Results:
+# firstpos function for this node is returned.
+
+proc sgml::firstpos {cs firstpos nullable} {
+ switch -- $cs {
+ :seq {
+ set result [lindex [lindex $firstpos 0] 1]
+ for {set i 0} {$i < [llength $nullable]} {incr i} {
+ if {[lindex [lindex $nullable $i] 1]} {
+ eval lappend result [lindex [lindex $firstpos [expr $i + 1]] 1]
+ } else {
+ break
+ }
+ }
+ }
+ :choice {
+ foreach child $firstpos {
+ eval lappend result $child
+ }
+ }
+ }
+
+ return [list $firstpos [makeSet $result]]
+}
+
+# sgml::lastpos --
+#
+# Computes the lastpos function for a nonterminal node.
+# Same as firstpos, only logic is reversed
+#
+# Arguments:
+# cs node type, choice or sequence
+# lastpos lastpos functions for the subtree
+# nullable nullable functions forthe subtree
+#
+# Results:
+# lastpos function for this node is returned.
+
+proc sgml::lastpos {cs lastpos nullable} {
+ switch -- $cs {
+ :seq {
+ set result [lindex [lindex $lastpos end] 1]
+ for {set i [expr [llength $nullable] - 1]} {$i >= 0} {incr i -1} {
+ if {[lindex [lindex $nullable $i] 1]} {
+ eval lappend result [lindex [lindex $lastpos $i] 1]
+ } else {
+ break
+ }
+ }
+ }
+ :choice {
+ foreach child $lastpos {
+ eval lappend result $child
+ }
+ }
+ }
+
+ return [list $lastpos [makeSet $result]]
+}
+
+# sgml::makeSet --
+#
+# Turn a list into a set, ie. remove duplicates.
+#
+# Arguments:
+# s a list
+#
+# Results:
+# A set is returned, which is a list with duplicates removed.
+
+proc sgml::makeSet s {
+ foreach r $s {
+ if {[llength $r]} {
+ set unique($r) {}
+ }
+ }
+ return [array names unique]
+}
+
+# sgml::nullable --
+#
+# Compute the nullable function for a node.
+#
+# Arguments:
+# nodeType leaf or nonterminal
+# rep repetition applying to this node
+# name leaf node: symbol for this node, nonterm node: choice or seq node
+# subtree nonterm node: nullable functions for the subtree
+#
+# Results:
+# Returns nullable function for this branch of the tree.
+
+proc sgml::nullable {nodeType rep name {subtree {}}} {
+ switch -glob -- $rep:$nodeType {
+ :leaf -
+ +:leaf {
+ return [list {} 0]
+ }
+ \\*:leaf -
+ \\?:leaf {
+ return [list {} 1]
+ }
+ \\*:nonterm -
+ \\?:nonterm {
+ return [list $subtree 1]
+ }
+ :nonterm -
+ +:nonterm {
+ switch -- $name {
+ :choice {
+ set result 0
+ foreach child $subtree {
+ set result [expr $result || [lindex $child 1]]
+ }
+ }
+ :seq {
+ set result 1
+ foreach child $subtree {
+ set result [expr $result && [lindex $child 1]]
+ }
+ }
+ }
+ return [list $subtree $result]
+ }
+ }
+}
+
+# sgml::DTD:ATTLIST --
+#
+# <!ATTLIST ...> defines an attribute list.
+#
+# Arguments:
+# opts configuration opions
+# name Element GI
+# attspec unparsed attribute definitions
+#
+# Results:
+# Attribute list variables are modified.
+
+proc sgml::DTD:ATTLIST {opts name attspec} {
+ variable attlist_exp
+ variable attlist_enum_exp
+ variable attlist_fixed_exp
+
+ array set options $opts
+
+ # Parse the attribute list. If it were regular, could just use foreach,
+ # but some attributes may have values.
+ regsub -all {([][$\\])} $attspec {\\\1} attspec
+ regsub -all $attlist_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {} \{" attspec
+ regsub -all $attlist_enum_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {} {\\4} \{" attspec
+ regsub -all $attlist_fixed_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {\\4} \{" attspec
+
+ eval "noop \{$attspec\}"
+
+ return {}
+}
+
+# sgml::DTDAttribute --
+#
+# Parse definition of a single attribute.
+#
+# Arguments:
+# callback attribute defn callback
+# name element name
+# var array variable
+# att attribute name
+# type type of this attribute
+# default default value of the attribute
+# value other information
+# text other text (should be empty)
+#
+# Results:
+# Attribute defn added to array, unless it already exists
+
+proc sgml::DTDAttribute args {
+ # BUG: Some problems with parameter passing - deal with it later
+ foreach {callback name var att type default value text} $args break
+
+ upvar #0 $var atts
+
+ if {[string length [string trim $text]]} {
+ return -code error "unexpected text \"$text\" in attribute definition"
+ }
+
+ # What about overridden attribute defns?
+ # A non-validating app may want to know about them
+ # (eg. an editor)
+ if {![info exists atts($name/$att)]} {
+ set atts($name/$att) [list $type $default $value]
+ uplevel #0 $callback [list $name $att $type $default $value]
+ }
+
+ return {}
+}
+
+# sgml::DTD:ENTITY --
+#
+# <!ENTITY ...> declaration.
+#
+# Callbacks:
+# -entitydeclcommand for general entity declaration
+# -unparsedentitydeclcommand for unparsed external entity declaration
+# -parameterentitydeclcommand for parameter entity declaration
+#
+# Arguments:
+# opts configuration options
+# name name of entity being defined
+# param whether a parameter entity is being defined
+# value unparsed replacement text
+#
+# Results:
+# Modifies the caller's entities array variable
+
+proc sgml::DTD:ENTITY {opts name param value} {
+
+ array set options $opts
+
+ if {[string compare % $param]} {
+ # Entity declaration - general or external
+ upvar #0 $options(entities) ents
+ upvar #0 $options(extentities) externals
+
+ if {[info exists ents($name)] || [info exists externals($name)]} {
+ eval $options(-warningcommand) entity [list "entity \"$name\" already declared"]
+ } else {
+ if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
+ return -code error "unable to parse entity declaration due to \"$value\""
+ }
+ switch -glob [lindex $value 0],[lindex $value 3] {
+ internal, {
+ set ents($name) [EntitySubst [array get options] [lindex $value 1]]
+ uplevel #0 $options(-entitydeclcommand) [list $name $ents($name)]
+ }
+ internal,* {
+ return -code error "unexpected NDATA declaration"
+ }
+ external, {
+ set externals($name) [lrange $value 1 2]
+ uplevel #0 $options(-entitydeclcommand) [eval list $name [lrange $value 1 2]]
+ }
+ external,* {
+ set externals($name) [lrange $value 1 3]
+ uplevel #0 $options(-unparsedentitydeclcommand) [eval list $name [lrange $value 1 3]]
+ }
+ default {
+ return -code error "internal error: unexpected parser state"
+ }
+ }
+ }
+ } else {
+ # Parameter entity declaration
+ upvar #0 $options(parameterentities) PEnts
+ upvar #0 $options(externalparameterentities) ExtPEnts
+
+ if {[info exists PEnts($name)] || [info exists ExtPEnts($name)]} {
+ eval $options(-warningcommand) parameterentity [list "parameter entity \"$name\" already declared"]
+ } else {
+ if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
+ return -code error "unable to parse parameter entity declaration due to \"$value\""
+ }
+ if {[string length [lindex $value 3]]} {
+ return -code error "NDATA illegal in parameter entity declaration"
+ }
+ switch [lindex $value 0] {
+ internal {
+ # Substitute character references and PEs (XML: 4.5)
+ set value [EntitySubst [array get options] [lindex $value 1]]
+
+ set PEnts($name) $value
+ uplevel #0 $options(-parameterentitydeclcommand) [list $name $value]
+ }
+ external -
+ default {
+ # Get the replacement text now.
+ # Could wait until the first reference, but easier
+ # to just do it now.
+
+ set token [uri::geturl [uri::resolve $options(-baseuri) [lindex $value 1]]]
+
+ set ExtPEnts($name) [lindex [array get $token data] 1]
+ uplevel #0 $options(-parameterentitydeclcommand) [eval list $name [lrange $value 1 2]]
+ }
+ }
+ }
+ }
+}
+
+# sgml::EntitySubst --
+#
+# Perform entity substitution on an entity replacement text.
+# This differs slightly from other substitution procedures,
+# because only parameter and character entity substitution
+# is performed, not general entities.
+# See XML Rec. section 4.5.
+#
+# Arguments:
+# opts configuration options
+# value Literal entity value
+#
+# Results:
+# Expanded replacement text
+
+proc sgml::EntitySubst {opts value} {
+ array set options $opts
+
+ # Protect Tcl special characters
+ regsub -all {([{}\\])} $value {\\\1} value
+
+ # Find entity references
+ regsub -all (&#\[0-9\]+|&#x\[0-9a-fA-F\]+|%${::sgml::Name})\; $value "\[EntitySubstValue [list $options(parameterentities)] {\\1}\]" value
+
+ set result [subst $value]
+
+ return $result
+}
+
+# sgml::EntitySubstValue --
+#
+# Handle a single character or parameter entity substitution
+#
+# Arguments:
+# PEvar array variable containing PE declarations
+# ref character or parameter entity reference
+#
+# Results:
+# Replacement text
+
+proc sgml::EntitySubstValue {PEvar ref} {
+ switch -glob -- $ref {
+ &#x* {
+ scan [string range $ref 3 end] %x hex
+ return [format %c $hex]
+ }
+ &#* {
+ return [format %c [string range $ref 2 end]]
+ }
+ %* {
+ upvar #0 $PEvar PEs
+ set ref [string range $ref 1 end]
+ if {[info exists PEs($ref)]} {
+ return $PEs($ref)
+ } else {
+ return -code error "parameter entity \"$ref\" not declared"
+ }
+ }
+ default {
+ return -code error "internal error - unexpected entity reference"
+ }
+ }
+ return {}
+}
+
+# sgml::DTD:NOTATION --
+#
+# Process notation declaration
+#
+# Arguments:
+# opts configuration options
+# name notation name
+# value unparsed notation spec
+
+proc sgml::DTD:NOTATION {opts name value} {
+ return {}
+
+ variable notation_exp
+ upvar opts state
+
+ if {[regexp $notation_exp $value x scheme data] == 2} {
+ } else {
+ eval $state(-errorcommand) [list notationvalue "notation value \"$value\" incorrectly specified"]
+ }
+}
+\f
+# sgml::ResolveEntity --
+#
+# Default entity resolution routine
+#
+# Arguments:
+# cmd command of parent parser
+# base base URL for relative URLs
+# sysId system identifier
+# pubId public identifier
+
+proc sgml::ResolveEntity {cmd base sysId pubId} {
+ variable ParseEventNum
+
+ if {[catch {uri::resolve $base $sysId} url]} {
+ return -code error "unable to resolve system identifier \"$sysId\""
+ }
+ if {[catch {uri::geturl $url} token]} {
+ return -code error "unable to retrieve external entity \"$url\" for system identifier \"$sysId\""
+ }
+
+ upvar #0 $token data
+
+ set parser [uplevel #0 $cmd entityparser]
+
+ set body {}
+ catch {set body $data(body)}
+ catch {set body $data(data)}
+ if {[string length $body]} {
+ uplevel #0 $parser parse [list $body] -dtdsubset external
+ }
+ $parser free
+
+ return {}
+}
--- /dev/null
+# tclparser-8.1.tcl --
+#
+# This file provides a Tcl implementation of a XML parser.
+# This file supports Tcl 8.1.
+#
+# See xml-8.[01].tcl for definitions of character sets and
+# regular expressions.
+#
+# Copyright (c) 1998-2003 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: tclparser-8.1.tcl,v 1.26 2004/08/14 07:41:11 balls Exp $
+
+package require Tcl 8.1
+
+package provide xml::tclparser 3.1
+
+package require xmldefs 3.1
+
+package require sgmlparser 1.0
+
+namespace eval xml::tclparser {
+
+ namespace export create createexternal externalentity parse configure get delete
+
+ # Tokenising expressions
+
+ variable tokExpr $::xml::tokExpr
+ variable substExpr $::xml::substExpr
+
+ # Register this parser class
+
+ ::xml::parserclass create tcl \
+ -createcommand [namespace code create] \
+ -createentityparsercommand [namespace code createentityparser] \
+ -parsecommand [namespace code parse] \
+ -configurecommand [namespace code configure] \
+ -deletecommand [namespace code delete] \
+ -resetcommand [namespace code reset]
+}
+\f
+# xml::tclparser::create --
+#
+# Creates XML parser object.
+#
+# Arguments:
+# name unique identifier for this instance
+#
+# Results:
+# The state variable is initialised.
+
+proc xml::tclparser::create name {
+
+ # Initialise state variable
+ upvar \#0 [namespace current]::$name parser
+ array set parser [list -name $name \
+ -cmd [uplevel 3 namespace current]::$name \
+ -final 1 \
+ -validate 0 \
+ -statevariable [namespace current]::$name \
+ -baseuri {} \
+ internaldtd {} \
+ entities [namespace current]::Entities$name \
+ extentities [namespace current]::ExtEntities$name \
+ parameterentities [namespace current]::PEntities$name \
+ externalparameterentities [namespace current]::ExtPEntities$name \
+ elementdecls [namespace current]::ElDecls$name \
+ attlistdecls [namespace current]::AttlistDecls$name \
+ notationdecls [namespace current]::NotDecls$name \
+ depth 0 \
+ leftover {} \
+ ]
+
+ # Initialise entities with predefined set
+ array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]
+
+ return $parser(-cmd)
+}
+\f
+# xml::tclparser::createentityparser --
+#
+# Creates XML parser object for an entity.
+#
+# Arguments:
+# name name for the new parser
+# parent name of parent parser
+#
+# Results:
+# The state variable is initialised.
+
+proc xml::tclparser::createentityparser {parent name} {
+ upvar #0 [namespace current]::$parent p
+
+ # Initialise state variable
+ upvar \#0 [namespace current]::$name external
+ array set external [array get p]
+
+ regsub $parent $p(-cmd) {} parentns
+
+ array set external [list -name $name \
+ -cmd $parentns$name \
+ -statevariable [namespace current]::$name \
+ internaldtd {} \
+ line 0 \
+ ]
+ incr external(depth)
+
+ return $external(-cmd)
+}
+\f
+# xml::tclparser::configure --
+#
+# Configures a XML parser object.
+#
+# Arguments:
+# name unique identifier for this instance
+# args option name/value pairs
+#
+# Results:
+# May change values of config options
+
+proc xml::tclparser::configure {name args} {
+ upvar \#0 [namespace current]::$name parser
+
+ # BUG: very crude, no checks for illegal args
+ # Mats: Should be synced with sgmlparser.tcl
+ set options {-elementstartcommand -elementendcommand \
+ -characterdatacommand -processinginstructioncommand \
+ -externalentitycommand -xmldeclcommand \
+ -doctypecommand -commentcommand \
+ -entitydeclcommand -unparsedentitydeclcommand \
+ -parameterentitydeclcommand -notationdeclcommand \
+ -elementdeclcommand -attlistdeclcommand \
+ -paramentityparsing -defaultexpandinternalentities \
+ -startdoctypedeclcommand -enddoctypedeclcommand \
+ -entityreferencecommand -warningcommand \
+ -defaultcommand -unknownencodingcommand -notstandalonecommand \
+ -startcdatasectioncommand -endcdatasectioncommand \
+ -errorcommand -final \
+ -validate -baseuri -baseurl \
+ -name -cmd -emptyelement \
+ -parseattributelistcommand -parseentitydeclcommand \
+ -normalize -internaldtd -dtdsubset \
+ -reportempty -ignorewhitespace \
+ -reportempty \
+ }
+ set usage [join $options ", "]
+ regsub -all -- - $options {} options
+ set pat ^-([join $options |])$
+ foreach {flag value} $args {
+ if {[regexp $pat $flag]} {
+ # Validate numbers
+ if {[info exists parser($flag)] && \
+ [string is integer -strict $parser($flag)] && \
+ ![string is integer -strict $value]} {
+ return -code error "Bad value for $flag ($value), must be integer"
+ }
+ set parser($flag) $value
+ } else {
+ return -code error "Unknown option $flag, can be: $usage"
+ }
+ }
+
+ # Backward-compatibility: -baseuri is a synonym for -baseurl
+ catch {set parser(-baseuri) $parser(-baseurl)}
+
+ return {}
+}
+\f
+# xml::tclparser::parse --
+#
+# Parses document instance data
+#
+# Arguments:
+# name parser object
+# xml data
+# args configuration options
+#
+# Results:
+# Callbacks are invoked
+
+proc xml::tclparser::parse {name xml args} {
+
+ array set options $args
+ upvar \#0 [namespace current]::$name parser
+ variable tokExpr
+ variable substExpr
+
+ # Mats:
+ if {[llength $args]} {
+ eval {configure $name} $args
+ }
+
+ set parseOptions [list \
+ -emptyelement [namespace code ParseEmpty] \
+ -parseattributelistcommand [namespace code ParseAttrs] \
+ -parseentitydeclcommand [namespace code ParseEntity] \
+ -normalize 0]
+ eval lappend parseOptions \
+ [array get parser -*command] \
+ [array get parser -reportempty] \
+ [array get parser -ignorewhitespace] \
+ [array get parser -name] \
+ [array get parser -cmd] \
+ [array get parser -baseuri] \
+ [array get parser -validate] \
+ [array get parser -final] \
+ [array get parser -defaultexpandinternalentities] \
+ [array get parser entities] \
+ [array get parser extentities] \
+ [array get parser parameterentities] \
+ [array get parser externalparameterentities] \
+ [array get parser elementdecls] \
+ [array get parser attlistdecls] \
+ [array get parser notationdecls]
+
+ # Mats:
+ # If -final 0 we also need to maintain the state with a -statevariable !
+ if {!$parser(-final)} {
+ eval lappend parseOptions [array get parser -statevariable]
+ }
+
+ set dtdsubset no
+ catch {set dtdsubset $options(-dtdsubset)}
+ switch -- $dtdsubset {
+ internal {
+ # Bypass normal parsing
+ lappend parseOptions -statevariable $parser(-statevariable)
+ array set intOptions [array get ::sgml::StdOptions]
+ array set intOptions $parseOptions
+ ::sgml::ParseDTD:Internal [array get intOptions] $xml
+ return {}
+ }
+ external {
+ # Bypass normal parsing
+ lappend parseOptions -statevariable $parser(-statevariable)
+ array set intOptions [array get ::sgml::StdOptions]
+ array set intOptions $parseOptions
+ ::sgml::ParseDTD:External [array get intOptions] $xml
+ return {}
+ }
+ default {
+ # Pass through to normal processing
+ }
+ }
+
+ lappend tokenOptions \
+ -internaldtdvariable [namespace current]::${name}(internaldtd)
+
+ # Mats: If -final 0 we also need to maintain the state with a -statevariable !
+ if {!$parser(-final)} {
+ eval lappend tokenOptions [array get parser -statevariable] \
+ [array get parser -final]
+ }
+
+ # Mats:
+ # Why not the first four? Just padding? Lrange undos \n interp.
+ # It is necessary to have the first four as well if chopped off in
+ # middle of pcdata.
+ set tokenised [lrange \
+ [eval {::sgml::tokenise $xml $tokExpr $substExpr} $tokenOptions] \
+ 0 end]
+
+ lappend parseOptions -internaldtd [list $parser(internaldtd)]
+ eval ::sgml::parseEvent [list $tokenised] $parseOptions
+
+ return {}
+}
+\f
+# xml::tclparser::ParseEmpty -- Tcl 8.1+ version
+#
+# Used by parser to determine whether an element is empty.
+# This is usually dead easy in XML, but as always not quite.
+# Have to watch out for empty element syntax
+#
+# Arguments:
+# tag element name
+# attr attribute list (raw)
+# e End tag delimiter.
+#
+# Results:
+# Return value of e
+
+proc xml::tclparser::ParseEmpty {tag attr e} {
+ switch -glob [string length $e],[regexp "/[::xml::cl $::xml::Wsp]*$" $attr] {
+ 0,0 {
+ return {}
+ }
+ 0,* {
+ return /
+ }
+ default {
+ return $e
+ }
+ }
+}
+
+# xml::tclparser::ParseAttrs -- Tcl 8.1+ version
+#
+# Parse element attributes.
+#
+# There are two forms for name-value pairs:
+#
+# name="value"
+# name='value'
+#
+# Arguments:
+# opts parser options
+# attrs attribute string given in a tag
+#
+# Results:
+# Returns a Tcl list representing the name-value pairs in the
+# attribute string
+#
+# A ">" occurring in the attribute list causes problems when parsing
+# the XML. This manifests itself by an unterminated attribute value
+# and a ">" appearing the element text.
+# In this case return a three element list;
+# the message "unterminated attribute value", the attribute list it
+# did manage to parse and the remainder of the attribute list.
+
+proc xml::tclparser::ParseAttrs {opts attrs} {
+
+ set result {}
+
+ while {[string length [string trim $attrs]]} {
+ if {[regexp [::sgml::cl $::xml::Wsp]*($::xml::Name)[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')([::sgml::cl ^<]*?)\\2(.*) $attrs discard attrName delimiter value attrs]} {
+ lappend result $attrName [NormalizeAttValue $opts $value]
+ } elseif {[regexp [::sgml::cl $::xml::Wsp]*$::xml::Name[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')[::sgml::cl ^<]*\$ $attrs]} {
+ return -code error [list {unterminated attribute value} $result $attrs]
+ } else {
+ return -code error "invalid attribute list"
+ }
+ }
+
+ return $result
+}
+
+# xml::tclparser::NormalizeAttValue --
+#
+# Perform attribute value normalisation. This involves:
+# . character references are appended to the value
+# . entity references are recursively processed and replacement value appended
+# . whitespace characters cause a space to be appended
+# . other characters appended as-is
+#
+# Arguments:
+# opts parser options
+# value unparsed attribute value
+#
+# Results:
+# Normalised value returned.
+
+proc xml::tclparser::NormalizeAttValue {opts value} {
+
+ # sgmlparser already has backslashes protected
+ # Protect Tcl specials
+ regsub -all {([][$])} $value {\\\1} value
+
+ # Deal with white space
+ regsub -all "\[$::xml::Wsp\]" $value { } value
+
+ # Find entity refs
+ regsub -all {&([^;]+);} $value {[NormalizeAttValue:DeRef $opts {\1}]} value
+
+ return [subst $value]
+}
+
+# xml::tclparser::NormalizeAttValue:DeRef --
+#
+# Handler to normalize attribute values
+#
+# Arguments:
+# opts parser options
+# ref entity reference
+#
+# Results:
+# Returns character
+
+proc xml::tclparser::NormalizeAttValue:DeRef {opts ref} {
+
+ switch -glob -- $ref {
+ #x* {
+ scan [string range $ref 2 end] %x value
+ set char [format %c $value]
+ # Check that the char is legal for XML
+ if {[regexp [format {^[%s]$} $::xml::Char] $char]} {
+ return $char
+ } else {
+ return -code error "illegal character"
+ }
+ }
+ #* {
+ scan [string range $ref 1 end] %d value
+ set char [format %c $value]
+ # Check that the char is legal for XML
+ if {[regexp [format {^[%s]$} $::xml::Char] $char]} {
+ return $char
+ } else {
+ return -code error "illegal character"
+ }
+ }
+ lt -
+ gt -
+ amp -
+ quot -
+ apos {
+ array set map {lt < gt > amp & quot \" apos '}
+ return $map($ref)
+ }
+ default {
+ # A general entity. Must resolve to a text value - no element structure.
+
+ array set options $opts
+ upvar #0 $options(entities) map
+
+ if {[info exists map($ref)]} {
+
+ if {[regexp < $map($ref)]} {
+ return -code error "illegal character \"<\" in attribute value"
+ }
+
+ if {![regexp & $map($ref)]} {
+ # Simple text replacement
+ return $map($ref)
+ }
+
+ # There are entity references in the replacement text.
+ # Can't use child entity parser since must catch element structures
+
+ return [NormalizeAttValue $opts $map($ref)]
+
+ } elseif {[string compare $options(-entityreferencecommand) "::sgml::noop"]} {
+
+ set result [uplevel #0 $options(-entityreferencecommand) [list $ref]]
+
+ return $result
+
+ } else {
+ return -code error "unable to resolve entity reference \"$ref\""
+ }
+ }
+ }
+}
+\f
+# xml::tclparser::ParseEntity --
+#
+# Parse general entity declaration
+#
+# Arguments:
+# data text to parse
+#
+# Results:
+# Tcl list containing entity declaration
+
+proc xml::tclparser::ParseEntity data {
+ set data [string trim $data]
+ if {[regexp $::sgml::ExternalEntityExpr $data discard type delimiter1 id1 discard delimiter2 id2 optNDATA ndata]} {
+ switch $type {
+ PUBLIC {
+ return [list external $id2 $id1 $ndata]
+ }
+ SYSTEM {
+ return [list external $id1 {} $ndata]
+ }
+ }
+ } elseif {[regexp {^("|')(.*?)\1$} $data discard delimiter value]} {
+ return [list internal $value]
+ } else {
+ return -code error "badly formed entity declaration"
+ }
+}
+\f
+# xml::tclparser::delete --
+#
+# Destroy parser data
+#
+# Arguments:
+# name parser object
+#
+# Results:
+# Parser data structure destroyed
+
+proc xml::tclparser::delete name {
+ upvar \#0 [namespace current]::$name parser
+ catch {::sgml::ParserDelete $parser(-statevariable)}
+ catch {unset parser}
+ return {}
+}
+\f
+# xml::tclparser::get --
+#
+# Retrieve additional information from the parser
+#
+# Arguments:
+# name parser object
+# method info to retrieve
+# args additional arguments for method
+#
+# Results:
+# Depends on method
+
+proc xml::tclparser::get {name method args} {
+ upvar #0 [namespace current]::$name parser
+
+ switch -- $method {
+
+ elementdecl {
+ switch [llength $args] {
+
+ 0 {
+ # Return all element declarations
+ upvar #0 $parser(elementdecls) elements
+ return [array get elements]
+ }
+
+ 1 {
+ # Return specific element declaration
+ upvar #0 $parser(elementdecls) elements
+ if {[info exists elements([lindex $args 0])]} {
+ return [array get elements [lindex $args 0]]
+ } else {
+ return -code error "element \"[lindex $args 0]\" not declared"
+ }
+ }
+
+ default {
+ return -code error "wrong number of arguments: should be \"elementdecl ?element?\""
+ }
+ }
+ }
+
+ attlist {
+ if {[llength $args] != 1} {
+ return -code error "wrong number of arguments: should be \"get attlist element\""
+ }
+
+ upvar #0 $parser(attlistdecls)
+
+ return {}
+ }
+
+ entitydecl {
+ }
+
+ parameterentitydecl {
+ }
+
+ notationdecl {
+ }
+
+ default {
+ return -code error "unknown method \"$method\""
+ }
+ }
+
+ return {}
+}
+\f
+# xml::tclparser::ExternalEntity --
+#
+# Resolve and parse external entity
+#
+# Arguments:
+# name parser object
+# base base URL
+# sys system identifier
+# pub public identifier
+#
+# Results:
+# External entity is fetched and parsed
+
+proc xml::tclparser::ExternalEntity {name base sys pub} {
+}
+\f
+# xml::tclparser:: --
+#
+# Reset a parser instance, ready to parse another document
+#
+# Arguments:
+# name parser object
+#
+# Results:
+# Variables unset
+
+proc xml::tclparser::reset {name} {
+ upvar \#0 [namespace current]::$name parser
+
+ # Has this parser object been properly initialised?
+ if {![info exists parser] || \
+ ![info exists parser(-name)]} {
+ return [create $name]
+ }
+
+ array set parser {
+ -final 1
+ depth 0
+ leftover {}
+ }
+
+ foreach var {Entities ExtEntities PEntities ExtPEntities ElDecls AttlistDecls NotDecls} {
+ catch {unset [namespace current]::${var}$name}
+ }
+
+ # Initialise entities with predefined set
+ array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]
+
+ return {}
+}
--- /dev/null
+# xml.tcl --
+#
+# This file provides generic XML services for all implementations.
+# This file supports Tcl 8.1 regular expressions.
+#
+# See tclparser.tcl for the Tcl implementation of a XML parser.
+#
+# Copyright (c) 1998-2004 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: xml-8.1.tcl,v 1.16 2004/08/14 07:41:11 balls Exp $
+
+package require Tcl 8.1
+
+package provide xmldefs 3.1
+
+package require sgml 1.8
+
+namespace eval xml {
+
+ namespace export qnamesplit
+
+ # Convenience routine
+ proc cl x {
+ return "\[$x\]"
+ }
+
+ # Define various regular expressions
+
+ # Characters
+ variable Char $::sgml::Char
+
+ # white space
+ variable Wsp " \t\r\n"
+ variable allWsp [cl $Wsp]*
+ variable noWsp [cl ^$Wsp]
+
+ # Various XML names and tokens
+
+ variable NameChar $::sgml::NameChar
+ variable Name $::sgml::Name
+ variable Names $::sgml::Names
+ variable Nmtoken $::sgml::Nmtoken
+ variable Nmtokens $::sgml::Nmtokens
+
+ # XML Namespaces names
+
+ # NCName ::= Name - ':'
+ variable NCName $::sgml::Name
+ regsub -all : $NCName {} NCName
+ variable QName (${NCName}:)?$NCName ;# (Prefix ':')? LocalPart
+
+ # The definition of the Namespace URI for XML Namespaces themselves.
+ # The prefix 'xml' is automatically bound to this URI.
+ variable xmlnsNS http://www.w3.org/XML/1998/namespace
+
+ # table of predefined entities
+
+ variable EntityPredef
+ array set EntityPredef {
+ lt < gt > amp & quot \" apos '
+ }
+
+ # Expressions for pulling things apart
+ variable tokExpr <(/?)([::xml::cl ^$::xml::Wsp>/]+)([::xml::cl $::xml::Wsp]*[::xml::cl ^>]*)>
+ variable substExpr "\}\n{\\2} {\\1} {\\3} \{"
+
+}
+
+###
+### Exported procedures
+###
+
+# xml::qnamesplit --
+#
+# Split a QName into its constituent parts:
+# the XML Namespace prefix and the Local-name
+#
+# Arguments:
+# qname XML Qualified Name (see XML Namespaces [6])
+#
+# Results:
+# Returns prefix and local-name as a Tcl list.
+# Error condition returned if the prefix or local-name
+# are not valid NCNames (XML Name)
+
+proc xml::qnamesplit qname {
+ variable NCName
+ variable Name
+
+ set prefix {}
+ set localname $qname
+ if {[regexp : $qname]} {
+ if {![regexp ^($NCName)?:($NCName)\$ $qname discard prefix localname]} {
+ return -code error "name \"$qname\" is not a valid QName"
+ }
+ } elseif {![regexp ^$Name\$ $qname]} {
+ return -code error "name \"$qname\" is not a valid Name"
+ }
+
+ return [list $prefix $localname]
+}
+
+###
+### General utility procedures
+###
+
+# xml::noop --
+#
+# A do-nothing proc
+
+proc xml::noop args {}
+
+### Following procedures are based on html_library
+
+# xml::zapWhite --
+#
+# Convert multiple white space into a single space.
+#
+# Arguments:
+# data plain text
+#
+# Results:
+# As above
+
+proc xml::zapWhite data {
+ regsub -all "\[ \t\r\n\]+" $data { } data
+ return $data
+}
+
--- /dev/null
+# xml__tcl.tcl --
+#
+# This file provides a Tcl implementation of the parser
+# class support found in ../tclxml.c. It is only used
+# when the C implementation is not installed (for some reason).
+#
+# Copyright (c) 2000-2004 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: xml__tcl.tcl,v 1.15 2004/08/14 07:41:11 balls Exp $
+
+package provide xml::tcl 3.1
+
+namespace eval xml {
+ namespace export configure parser parserclass
+
+ # Parser implementation classes
+ variable classes
+ array set classes {}
+
+ # Default parser class
+ variable default {}
+
+ # Counter for generating unique names
+ variable counter 0
+}
+\f
+# xml::configure --
+#
+# Configure the xml package
+#
+# Arguments:
+# None
+#
+# Results:
+# None (not yet implemented)
+
+proc xml::configure args {}
+\f
+# xml::parserclass --
+#
+# Implements the xml::parserclass command for managing
+# parser implementations.
+#
+# Arguments:
+# method subcommand
+# args method arguments
+#
+# Results:
+# Depends on method
+
+proc xml::parserclass {method args} {
+ variable classes
+ variable default
+
+ switch -- $method {
+
+ create {
+ if {[llength $args] < 1} {
+ return -code error "wrong number of arguments, should be xml::parserclass create name ?args?"
+ }
+
+ set name [lindex $args 0]
+ if {[llength [lrange $args 1 end]] % 2} {
+ return -code error "missing value for option \"[lindex $args end]\""
+ }
+ array set classes [list $name [list \
+ -createcommand [namespace current]::noop \
+ -createentityparsercommand [namespace current]::noop \
+ -parsecommand [namespace current]::noop \
+ -configurecommand [namespace current]::noop \
+ -getcommand [namespace current]::noop \
+ -deletecommand [namespace current]::noop \
+ ]]
+ # BUG: we're not checking that the arguments are kosher
+ set classes($name) [lrange $args 1 end]
+ set default $name
+ }
+
+ destroy {
+ if {[llength $args] < 1} {
+ return -code error "wrong number of arguments, should be xml::parserclass destroy name"
+ }
+
+ if {[info exists classes([lindex $args 0])]} {
+ unset classes([lindex $args 0])
+ } else {
+ return -code error "no such parser class \"[lindex $args 0]\""
+ }
+ }
+
+ info {
+ if {[llength $args] < 1} {
+ return -code error "wrong number of arguments, should be xml::parserclass info method"
+ }
+
+ switch -- [lindex $args 0] {
+ names {
+ return [array names classes]
+ }
+ default {
+ return $default
+ }
+ }
+ }
+
+ default {
+ return -code error "unknown method \"$method\""
+ }
+ }
+
+ return {}
+}
+\f
+# xml::parser --
+#
+# Create a parser object instance
+#
+# Arguments:
+# args optional name, configuration options
+#
+# Results:
+# Returns object name. Parser instance created.
+
+proc xml::parser args {
+ variable classes
+ variable default
+
+ if {[llength $args] < 1} {
+ # Create unique name, no options
+ set parserName [FindUniqueName]
+ } else {
+ if {[string index [lindex $args 0] 0] == "-"} {
+ # Create unique name, have options
+ set parserName [FindUniqueName]
+ } else {
+ # Given name, optional options
+ set parserName [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ }
+
+ array set options [list \
+ -parser $default
+ ]
+ array set options $args
+
+ if {![info exists classes($options(-parser))]} {
+ return -code error "no such parser class \"$options(-parser)\""
+ }
+
+ # Now create the parser instance command and data structure
+ # The command must be created in the caller's namespace
+ uplevel 1 [list proc $parserName {method args} "eval [namespace current]::ParserCmd [list $parserName] \[list \$method\] \$args"]
+ upvar #0 [namespace current]::$parserName data
+ array set data [list class $options(-parser)]
+
+ array set classinfo $classes($options(-parser))
+ if {[string compare $classinfo(-createcommand) ""]} {
+ eval $classinfo(-createcommand) [list $parserName]
+ }
+ if {[string compare $classinfo(-configurecommand) ""] && \
+ [llength $args]} {
+ eval $classinfo(-configurecommand) [list $parserName] $args
+ }
+
+ return $parserName
+}
+\f
+# xml::FindUniqueName --
+#
+# Generate unique object name
+#
+# Arguments:
+# None
+#
+# Results:
+# Returns string.
+
+proc xml::FindUniqueName {} {
+ variable counter
+ return xmlparser[incr counter]
+}
+\f
+# xml::ParserCmd --
+#
+# Implements parser object command
+#
+# Arguments:
+# name object reference
+# method subcommand
+# args method arguments
+#
+# Results:
+# Depends on method
+
+proc xml::ParserCmd {name method args} {
+ variable classes
+ upvar #0 [namespace current]::$name data
+
+ array set classinfo $classes($data(class))
+
+ switch -- $method {
+
+ configure {
+ # BUG: We're not checking for legal options
+ array set data $args
+ eval $classinfo(-configurecommand) [list $name] $args
+ return {}
+ }
+
+ cget {
+ return $data([lindex $args 0])
+ }
+
+ entityparser {
+ set new [FindUniqueName]
+
+ upvar #0 [namespace current]::$name parent
+ upvar #0 [namespace current]::$new data
+ array set data [array get parent]
+
+ uplevel 1 [list proc $new {method args} "eval [namespace current]::ParserCmd [list $new] \[list \$method\] \$args"]
+
+ return [eval $classinfo(-createentityparsercommand) [list $name $new] $args]
+ }
+
+ free {
+ eval $classinfo(-deletecommand) [list $name]
+ unset data
+ uplevel 1 [list rename $name {}]
+ }
+
+ get {
+ eval $classinfo(-getcommand) [list $name] $args
+ }
+
+ parse {
+ if {[llength $args] < 1} {
+ return -code error "wrong number of arguments, should be $name parse xml ?options?"
+ }
+ eval $classinfo(-parsecommand) [list $name] $args
+ }
+
+ reset {
+ eval $classinfo(-resetcommand) [list $name]
+ }
+
+ default {
+ return -code error "unknown method"
+ }
+ }
+
+ return {}
+}
+\f
+# xml::noop --
+#
+# Do nothing utility proc
+#
+# Arguments:
+# args whatever
+#
+# Results:
+# Nothing happens
+
+proc xml::noop args {}
--- /dev/null
+# xmldep.tcl --
+#
+# Find the dependencies in an XML document.
+# Supports external entities and XSL include/import.
+#
+# TODO:
+# XInclude
+#
+# Copyright (c) 2001-2003 Zveno Pty Ltd
+# http://www.zveno.com/
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: xmldep.tcl,v 1.3 2003/12/09 04:43:15 balls Exp $
+
+package require xml
+
+package provide xml::dep 1.0
+
+namespace eval xml::dep {
+ namespace export depend
+
+ variable extEntities
+ array set extEntities {}
+
+ variable XSLTNS http://www.w3.org/1999/XSL/Transform
+}
+
+# xml::dep::depend --
+#
+# Find the resources which an XML document
+# depends on. The document is parsed
+# sequentially, rather than using DOM, for efficiency.
+#
+# TODO:
+# Asynchronous parsing.
+#
+# Arguments:
+# xml XML document entity
+# args configuration options
+#
+# Results:
+# Returns list of resource (system) identifiers
+
+proc xml::dep::depend {xml args} {
+ variable resources
+ variable entities
+
+ set resources {}
+ catch {unset entities}
+ array set entities {}
+
+ set p [xml::parser \
+ -elementstartcommand [namespace code ElStart] \
+ -doctypecommand [namespace code DocTypeDecl] \
+ -entitydeclcommand [namespace code EntityDecl] \
+ -entityreferencecommand [namespace code EntityReference] \
+ -validate 1 \
+ ]
+ if {[llength $args]} {
+ eval [list $p] configure $args
+ }
+ $p parse $xml
+
+ return $resources
+}
+
+# xml::dep::ElStart --
+#
+# Process start element
+#
+# Arguments:
+# name tag name
+# atlist attribute list
+# args options
+#
+# Results:
+# May add to resources list
+
+proc xml::dep::ElStart {name atlist args} {
+ variable XSLTNS
+ variable resources
+
+ array set opts {
+ -namespace {}
+ }
+ array set opts $args
+
+ switch -- $opts(-namespace) \
+ $XSLTNS {
+ switch $name {
+ import -
+ include {
+ array set attr {
+ href {}
+ }
+ array set attr $atlist
+
+ if {[string length $attr(href)]} {
+ if {[lsearch $resources $attr(href)] < 0} {
+ lappend resources $attr(href)
+ }
+ }
+
+ }
+ }
+ }
+}
+
+# xml::dep::DocTypeDecl --
+#
+# Process Document Type Declaration
+#
+# Arguments:
+# name Document element
+# pubid Public identifier
+# sysid System identifier
+# dtd Internal DTD Subset
+#
+# Results:
+# Resource added to list
+
+proc xml::dep::DocTypeDecl {name pubid sysid dtd} {
+ variable resources
+
+ puts stderr [list DocTypeDecl $name $pubid $sysid dtd]
+
+ if {[string length $sysid] && \
+ [lsearch $resources $sysid] < 0} {
+ lappend resources $sysid
+ }
+
+ return {}
+}
+
+# xml::dep::EntityDecl --
+#
+# Process entity declaration, looking for external entity
+#
+# Arguments:
+# name entity name
+# sysid system identifier
+# pubid public identifier or repl. text
+#
+# Results:
+# Store external entity info for later reference
+
+proc xml::dep::EntityDecl {name sysid pubid} {
+ variable extEntities
+
+ puts stderr [list EntityDecl $name $sysid $pubid]
+
+ set extEntities($name) $sysid
+}
+
+# xml::dep::EntityReference --
+#
+# Process entity reference
+#
+# Arguments:
+# name entity name
+#
+# Results:
+# May add to resources list
+
+proc xml::dep::EntityReference name {
+ variable extEntities
+ variable resources
+
+ puts stderr [list EntityReference $name]
+
+ if {[info exists extEntities($name)] && \
+ [lsearch $resources $extEntities($name)] < 0} {
+ lappend resources $extEntities($name)
+ }
+
+}
+
--- /dev/null
+# xpath.tcl --
+#
+# Provides an XPath parser for Tcl,
+# plus various support procedures
+#
+# Copyright (c) 2000-2003 Zveno Pty Ltd
+#
+# See the file "LICENSE" in this distribution for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: xpath.tcl,v 1.8 2003/12/09 04:43:15 balls Exp $
+
+package provide xpath 1.0
+
+# We need the XML package for definition of Names
+package require xml
+
+namespace eval xpath {
+ namespace export split join createnode
+
+ variable axes {
+ ancestor
+ ancestor-or-self
+ attribute
+ child
+ descendant
+ descendant-or-self
+ following
+ following-sibling
+ namespace
+ parent
+ preceding
+ preceding-sibling
+ self
+ }
+
+ variable nodeTypes {
+ comment
+ text
+ processing-instruction
+ node
+ }
+
+ # NB. QName has parens for prefix
+
+ variable nodetestExpr ^(${::xml::QName})${::xml::allWsp}(\\(${::xml::allWsp}(("|')(.*?)\\5)?${::xml::allWsp}\\))?${::xml::allWsp}(.*)
+
+ variable nodetestExpr2 ((($::xml::QName)${::xml::allWsp}(\\(${::xml::allWsp}(("|')(.*?)\\7)?${::xml::allWsp}\\))?)|${::xml::allWsp}(\\*))${::xml::allWsp}(.*)
+}
+
+# xpath::split --
+#
+# Parse an XPath location path
+#
+# Arguments:
+# locpath location path
+#
+# Results:
+# A Tcl list representing the location path.
+# The list has the form: {{axis node-test {predicate predicate ...}} ...}
+# Where each list item is a location step.
+
+proc xpath::split locpath {
+ set leftover {}
+
+ set result [InnerSplit $locpath leftover]
+
+ if {[string length [string trim $leftover]]} {
+ return -code error "unexpected text \"$leftover\""
+ }
+
+ return $result
+}
+
+proc xpath::InnerSplit {locpath leftoverVar} {
+ upvar $leftoverVar leftover
+
+ variable axes
+ variable nodetestExpr
+ variable nodetestExpr2
+
+ # First determine whether we have an absolute location path
+ if {[regexp {^/(.*)} $locpath discard locpath]} {
+ set path {{}}
+ } else {
+ set path {}
+ }
+
+ while {[string length [string trimleft $locpath]]} {
+ if {[regexp {^\.\.(.*)} $locpath discard locpath]} {
+ # .. abbreviation
+ set axis parent
+ set nodetest *
+ } elseif {[regexp {^/(.*)} $locpath discard locpath]} {
+ # // abbreviation
+ set axis descendant-or-self
+ if {[regexp ^$nodetestExpr2 [string trimleft $locpath] discard discard discard nodetest discard typetest discard discard literal wildcard locpath]} {
+ set nodetest [ResolveWildcard $nodetest $typetest $wildcard $literal]
+ } else {
+ set leftover $locpath
+ return $path
+ }
+ } elseif {[regexp ^\\.${::xml::allWsp}(.*) $locpath discard locpath]} {
+ # . abbreviation
+ set axis self
+ set nodetest *
+ } elseif {[regexp ^@($::xml::QName)${::xml::allWsp}=${::xml::allWsp}"(\[^"\])"(.*) $locpath discard attrName discard attrValue locpath]} {
+ # @ abbreviation
+ set axis attribute
+ set nodetest $attrName
+ } elseif {[regexp ^@($::xml::QName)${::xml::allWsp}=${::xml::allWsp}'(\[^'\])'(.*) $locpath discard attrName discard attrValue locpath]} {
+ # @ abbreviation
+ set axis attribute
+ set nodetest $attrName
+ } elseif {[regexp ^@($::xml::QName)(.*) $locpath discard attrName discard2 locpath]} {
+ # @ abbreviation
+ set axis attribute
+ set nodetest $attrName
+ } elseif {[regexp ^((${::xml::QName})${::xml::allWsp}::${::xml::allWsp})?\\*(.*) $locpath discard discard axis discard locpath]} {
+ # wildcard specified
+ set nodetest *
+ if {![string length $axis]} {
+ set axis child
+ }
+ } elseif {[regexp ^((${::xml::QName})${::xml::allWsp}::${::xml::allWsp})?$nodetestExpr2 $locpath discard discard axis discard discard discard nodetest discard typetest discard discard literal wildcard locpath]} {
+ # nodetest, with or without axis
+ if {![string length $axis]} {
+ set axis child
+ }
+ set nodetest [ResolveWildcard $nodetest $typetest $wildcard $literal]
+ } else {
+ set leftover $locpath
+ return $path
+ }
+
+ # ParsePredicates
+ set predicates {}
+ set locpath [string trimleft $locpath]
+ while {[regexp {^\[(.*)} $locpath discard locpath]} {
+ if {[regexp {^([0-9]+)(\].*)} [string trim $locpath] discard posn locpath]} {
+ set predicate [list = {function position {}} [list number $posn]]
+ } else {
+ set leftover2 {}
+ set predicate [ParseExpr $locpath leftover2]
+ set locpath $leftover2
+ unset leftover2
+ }
+
+ if {[regexp {^\](.*)} [string trimleft $locpath] discard locpath]} {
+ lappend predicates $predicate
+ } else {
+ return -code error "unexpected text in predicate \"$locpath\""
+ }
+ }
+
+ set axis [string trim $axis]
+ set nodetest [string trim $nodetest]
+
+ # This step completed
+ if {[lsearch $axes $axis] < 0} {
+ return -code error "invalid axis \"$axis\""
+ }
+ lappend path [list $axis $nodetest $predicates]
+
+ # Move to next step
+
+ if {[string length $locpath] && ![regexp ^/(.*) $locpath discard locpath]} {
+ set leftover $locpath
+ return $path
+ }
+
+ }
+
+ return $path
+}
+
+# xpath::ParseExpr --
+#
+# Parse one expression in a predicate
+#
+# Arguments:
+# locpath location path to parse
+# leftoverVar Name of variable in which to store remaining path
+#
+# Results:
+# Returns parsed expression as a Tcl list
+
+proc xpath::ParseExpr {locpath leftoverVar} {
+ upvar $leftoverVar leftover
+ variable nodeTypes
+
+ set expr {}
+ set mode expr
+ set stack {}
+
+ while {[string index [string trimleft $locpath] 0] != "\]"} {
+ set locpath [string trimleft $locpath]
+ switch $mode {
+ expr {
+ # We're looking for a term
+ if {[regexp ^-(.*) $locpath discard locpath]} {
+ # UnaryExpr
+ lappend stack "-"
+ } elseif {[regexp ^\\\$({$::xml::QName})(.*) $locpath discard varname discard locpath]} {
+ # VariableReference
+ lappend stack [list varRef $varname]
+ set mode term
+ } elseif {[regexp {^\((.*)} $locpath discard locpath]} {
+ # Start grouping
+ set leftover2 {}
+ lappend stack [list group [ParseExpr $locpath leftover2]]
+ set locpath $leftover2
+ unset leftover2
+
+ if {[regexp {^\)(.*)} [string trimleft $locpath] discard locpath]} {
+ set mode term
+ } else {
+ return -code error "unexpected text \"$locpath\", expected \")\""
+ }
+
+ } elseif {[regexp {^"([^"]*)"(.*)} $locpath discard literal locpath]} {
+ # Literal (" delimited)
+ lappend stack [list literal $literal]
+ set mode term
+ } elseif {[regexp {^'([^']*)'(.*)} $locpath discard literal locpath]} {
+ # Literal (' delimited)
+ lappend stack [list literal $literal]
+ set mode term
+ } elseif {[regexp {^([0-9]+(\.[0-9]+)?)(.*)} $locpath discard number discard locpath]} {
+ # Number
+ lappend stack [list number $number]
+ set mode term
+ } elseif {[regexp {^(\.[0-9]+)(.*)} $locpath discard number locpath]} {
+ # Number
+ lappend stack [list number $number]
+ set mode term
+ } elseif {[regexp ^(${::xml::QName})\\(${::xml::allWsp}(.*) $locpath discard functionName discard locpath]} {
+ # Function call start or abbreviated node-type test
+
+ if {[lsearch $nodeTypes $functionName] >= 0} {
+ # Looking like a node-type test
+ if {[regexp ^\\)${::xml::allWsp}(.*) $locpath discard locpath]} {
+ lappend stack [list path [list child [list $functionName ()] {}]]
+ set mode term
+ } else {
+ return -code error "invalid node-type test \"$functionName\""
+ }
+ } else {
+ if {[regexp ^\\)${::xml::allWsp}(.*) $locpath discard locpath]} {
+ set parameters {}
+ } else {
+ set leftover2 {}
+ set parameters [ParseExpr $locpath leftover2]
+ set locpath $leftover2
+ unset leftover2
+ while {[regexp {^,(.*)} $locpath discard locpath]} {
+ set leftover2 {}
+ lappend parameters [ParseExpr $locpath leftover2]
+ set locpath $leftover2
+ unset leftover2
+ }
+
+ if {![regexp ^\\)${::xml::allWsp}(.*) [string trimleft $locpath] discard locpath]} {
+ return -code error "unexpected text \"locpath\" - expected \")\""
+ }
+ }
+
+ lappend stack [list function $functionName $parameters]
+ set mode term
+ }
+
+ } else {
+ # LocationPath
+ set leftover2 {}
+ lappend stack [list path [InnerSplit $locpath leftover2]]
+ set locpath $leftover2
+ unset leftover2
+ set mode term
+ }
+ }
+ term {
+ # We're looking for an expression operator
+ if {[regexp ^-(.*) $locpath discard locpath]} {
+ # UnaryExpr
+ set stack [linsert $stack 0 expr "-"]
+ set mode expr
+ } elseif {[regexp ^(and|or|\\=|!\\=|<|>|<\\=|>\\=|\\||\\+|\\-|\\*|div|mod)(.*) $locpath discard exprtype locpath]} {
+ # AndExpr, OrExpr, EqualityExpr, RelationalExpr or UnionExpr
+ set stack [linsert $stack 0 $exprtype]
+ set mode expr
+ } else {
+ return -code error "unexpected text \"$locpath\", expecting operator"
+ }
+ }
+ default {
+ # Should never be here!
+ return -code error "internal error"
+ }
+ }
+ }
+
+ set leftover $locpath
+ return $stack
+}
+
+# xpath::ResolveWildcard --
+
+proc xpath::ResolveWildcard {nodetest typetest wildcard literal} {
+ variable nodeTypes
+
+ switch -glob -- [string length $nodetest],[string length $typetest],[string length $wildcard],[string length $literal] {
+ 0,0,0,* {
+ return -code error "bad location step (nothing parsed)"
+ }
+ 0,0,* {
+ # Name wildcard specified
+ return *
+ }
+ *,0,0,* {
+ # Element type test - nothing to do
+ return $nodetest
+ }
+ *,0,*,* {
+ # Internal error?
+ return -code error "bad location step (found both nodetest and wildcard)"
+ }
+ *,*,0,0 {
+ # Node type test
+ if {[lsearch $nodeTypes $nodetest] < 0} {
+ return -code error "unknown node type \"$typetest\""
+ }
+ return [list $nodetest $typetest]
+ }
+ *,*,0,* {
+ # Node type test
+ if {[lsearch $nodeTypes $nodetest] < 0} {
+ return -code error "unknown node type \"$typetest\""
+ }
+ return [list $nodetest $literal]
+ }
+ default {
+ # Internal error?
+ return -code error "bad location step"
+ }
+ }
+}
+
+# xpath::join --
+#
+# Reconstitute an XPath location path from a
+# Tcl list representation.
+#
+# Arguments:
+# spath split path
+#
+# Results:
+# Returns an Xpath location path
+
+proc xpath::join spath {
+ return -code error "not yet implemented"
+}
+
--- /dev/null
+# Only relevant on Windows-x86
+if {[string compare $::tcl_platform(platform) "windows"]} { return }
+if {[string compare $::tcl_platform(machine) "intel"]} { return }
+package ifneeded tdom 0.8.3 \
+ "load [list [file join $dir win32-ix86 tdom083.dll]];\
+ source [list [file join $dir tdom.tcl]]"
--- /dev/null
+#----------------------------------------------------------------------------
+# Copyright (c) 1999 Jochen Loewer (loewerj@hotmail.com)
+#----------------------------------------------------------------------------
+#
+# $Id: tdom.tcl,v 1.19 2005/01/11 15:57:19 rolf Exp $
+#
+#
+# The higher level functions of tDOM written in plain Tcl.
+#
+#
+# The contents of this file are subject to the Mozilla Public License
+# Version 1.1 (the "License"); you may not use this file except in
+# compliance with the License. You may obtain a copy of the License at
+# http://www.mozilla.org/MPL/
+#
+# Software distributed under the License is distributed on an "AS IS"
+# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
+# License for the specific language governing rights and limitations
+# under the License.
+#
+# The Original Code is tDOM.
+#
+# The Initial Developer of the Original Code is Jochen Loewer
+# Portions created by Jochen Loewer are Copyright (C) 1998, 1999
+# Jochen Loewer. All Rights Reserved.
+#
+# Contributor(s):
+# Rolf Ade (rolf@pointsman.de): 'fake' nodelists/live childNodes
+#
+# written by Jochen Loewer
+# April, 1999
+#
+#----------------------------------------------------------------------------
+
+package require tdom
+
+#----------------------------------------------------------------------------
+# setup namespaces for additional Tcl level methods, etc.
+#
+#----------------------------------------------------------------------------
+namespace eval ::dom {
+ namespace eval domDoc {
+ }
+ namespace eval domNode {
+ }
+ namespace eval DOMImplementation {
+ }
+ namespace eval xpathFunc {
+ }
+ namespace eval xpathFuncHelper {
+ }
+}
+
+namespace eval ::tDOM {
+ variable extRefHandlerDebug 0
+ variable useForeignDTD ""
+
+ namespace export xmlOpenFile xmlReadFile extRefHandler baseURL
+}
+
+#----------------------------------------------------------------------------
+# hasFeature (DOMImplementation method)
+#
+#
+# @in url the URL, where to get the XML document
+#
+# @return document object
+# @exception XML parse errors, ...
+#
+#----------------------------------------------------------------------------
+proc ::dom::DOMImplementation::hasFeature { dom feature {version ""} } {
+
+ switch $feature {
+ xml -
+ XML {
+ if {($version == "") || ($version == "1.0")} {
+ return 1
+ }
+ }
+ }
+ return 0
+
+}
+
+#----------------------------------------------------------------------------
+# load (DOMImplementation method)
+#
+# requests a XML document via http using the given URL and
+# builds up a DOM tree in memory returning the document object
+#
+#
+# @in url the URL, where to get the XML document
+#
+# @return document object
+# @exception XML parse errors, ...
+#
+#----------------------------------------------------------------------------
+proc ::dom::DOMImplementation::load { dom url } {
+
+ error "Sorry, load method not implemented yet!"
+
+}
+
+#----------------------------------------------------------------------------
+# isa (docDoc method, for [incr tcl] compatibility)
+#
+#
+# @in className
+#
+# @return 1 iff inherits from the given class
+#
+#----------------------------------------------------------------------------
+proc ::dom::domDoc::isa { doc className } {
+
+ if {$className == "domDoc"} {
+ return 1
+ }
+ return 0
+}
+
+#----------------------------------------------------------------------------
+# info (domDoc method, for [incr tcl] compatibility)
+#
+#
+# @in subcommand
+# @in args
+#
+#----------------------------------------------------------------------------
+proc ::dom::domDoc::info { doc subcommand args } {
+
+ switch $subcommand {
+ class {
+ return "domDoc"
+ }
+ inherit {
+ return ""
+ }
+ heritage {
+ return "domDoc {}"
+ }
+ default {
+ error "domDoc::info subcommand $subcommand not yet implemented!"
+ }
+ }
+}
+
+#----------------------------------------------------------------------------
+# importNode (domDoc method)
+#
+# Document Object Model (Core) Level 2 method
+#
+#
+# @in subcommand
+# @in args
+#
+#----------------------------------------------------------------------------
+proc ::dom::domDoc::importNode { doc importedNode deep } {
+
+ if {$deep || ($deep == "-deep")} {
+ set node [$importedNode cloneNode -deep]
+ } else {
+ set node [$importedNode cloneNode]
+ }
+ return $node
+}
+
+#----------------------------------------------------------------------------
+# isa (domNode method, for [incr tcl] compatibility)
+#
+#
+# @in className
+#
+# @return 1 iff inherits from the given class
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::isa { doc className } {
+
+ if {$className == "domNode"} {
+ return 1
+ }
+ return 0
+}
+
+#----------------------------------------------------------------------------
+# info (domNode method, for [incr tcl] compatibility)
+#
+#
+# @in subcommand
+# @in args
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::info { doc subcommand args } {
+
+ switch $subcommand {
+ class {
+ return "domNode"
+ }
+ inherit {
+ return ""
+ }
+ heritage {
+ return "domNode {}"
+ }
+ default {
+ error "domNode::info subcommand $subcommand not yet implemented!"
+ }
+ }
+}
+
+#----------------------------------------------------------------------------
+# isWithin (domNode method)
+#
+# tests, whether a node object is nested below another tag
+#
+#
+# @in tagName the nodeName of an elment node
+#
+# @return 1 iff node is nested below a element with nodeName tagName
+# 0 otherwise
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::isWithin { node tagName } {
+
+ while {[$node parentNode] != ""} {
+ set node [$node parentNode]
+ if {[$node nodeName] == $tagName} {
+ return 1
+ }
+ }
+ return 0
+}
+
+#----------------------------------------------------------------------------
+# tagName (domNode method)
+#
+# same a nodeName for element interface
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::tagName { node } {
+
+ if {[$node nodeType] == "ELEMENT_NODE"} {
+ return [$node nodeName]
+ }
+ return -code error "NOT_SUPPORTED_ERR not an element!"
+}
+
+#----------------------------------------------------------------------------
+# simpleTranslate (domNode method)
+#
+# applies simple translation rules similar to Cost's simple
+# translations to a node
+#
+#
+# @in output_var
+# @in trans_specs
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::simpleTranslate { node output_var trans_specs } {
+
+ upvar $output_var output
+
+ if {[$node nodeType] == "TEXT_NODE"} {
+ append output [cgiQuote [$node nodeValue]]
+ return
+ }
+ set found 0
+
+ foreach {match action} $trans_specs {
+
+ if {[catch {
+ if {!$found && ([$node selectNode self::$match] != "") } {
+ set found 1
+ }
+ } err]} {
+ if {![string match "NodeSet expected for parent axis!" $err]} {
+ error $err
+ }
+ }
+ if {$found && ($action != "-")} {
+ set stop 0
+ foreach {type value} $action {
+ switch $type {
+ prefix { append output [subst $value] }
+ tag { append output <$value> }
+ start { append output [eval $value] }
+ stop { set stop 1 }
+ }
+ }
+ if {!$stop} {
+ foreach child [$node childNodes] {
+ simpleTranslate $child output $trans_specs
+ }
+ }
+ foreach {type value} $action {
+ switch $type {
+ suffix { append output [subst $value] }
+ end { append output [eval $value] }
+ tag { append output </$value> }
+ }
+ }
+ return
+ }
+ }
+ foreach child [$node childNodes] {
+ simpleTranslate $child output $trans_specs
+ }
+}
+
+#----------------------------------------------------------------------------
+# a DOM conformant 'live' childNodes
+#
+# @return a 'nodelist' object (it is just the normal node)
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::childNodesLive { node } {
+
+ return $node
+}
+
+#----------------------------------------------------------------------------
+# item method on a 'nodelist' object
+#
+# @return a 'nodelist' object (it is just a normal
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::item { nodeListNode index } {
+
+ return [lindex [$nodeListNode childNodes] $index]
+}
+
+#----------------------------------------------------------------------------
+# length method on a 'nodelist' object
+#
+# @return a 'nodelist' object (it is just a normal
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::length { nodeListNode } {
+
+ return [llength [$nodeListNode childNodes]]
+}
+
+#----------------------------------------------------------------------------
+# appendData on a 'CharacterData' object
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::appendData { node arg } {
+
+ set type [$node nodeType]
+ if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
+ ($type != "COMMENT_NODE")
+ } {
+ return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
+ }
+ set oldValue [$node nodeValue]
+ $node nodeValue [append oldValue $arg]
+}
+
+#----------------------------------------------------------------------------
+# deleteData on a 'CharacterData' object
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::deleteData { node offset count } {
+
+ set type [$node nodeType]
+ if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
+ ($type != "COMMENT_NODE")
+ } {
+ return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
+ }
+ incr offset -1
+ set before [string range [$node nodeValue] 0 $offset]
+ incr offset
+ incr offset $count
+ set after [string range [$node nodeValue] $offset end]
+ $node nodeValue [append before $after]
+}
+
+#----------------------------------------------------------------------------
+# insertData on a 'CharacterData' object
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::insertData { node offset arg } {
+
+ set type [$node nodeType]
+ if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
+ ($type != "COMMENT_NODE")
+ } {
+ return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
+ }
+ incr offset -1
+ set before [string range [$node nodeValue] 0 $offset]
+ incr offset
+ set after [string range [$node nodeValue] $offset end]
+ $node nodeValue [append before $arg $after]
+}
+
+#----------------------------------------------------------------------------
+# replaceData on a 'CharacterData' object
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::replaceData { node offset count arg } {
+
+ set type [$node nodeType]
+ if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
+ ($type != "COMMENT_NODE")
+ } {
+ return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
+ }
+ incr offset -1
+ set before [string range [$node nodeValue] 0 $offset]
+ incr offset
+ incr offset $count
+ set after [string range [$node nodeValue] $offset end]
+ $node nodeValue [append before $arg $after]
+}
+
+#----------------------------------------------------------------------------
+# substringData on a 'CharacterData' object
+#
+# @return part of the node value (text)
+#
+#----------------------------------------------------------------------------
+proc ::dom::domNode::substringData { node offset count } {
+
+ set type [$node nodeType]
+ if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
+ ($type != "COMMENT_NODE")
+ } {
+ return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
+ }
+ set endOffset [expr $offset + $count - 1]
+ return [string range [$node nodeValue] $offset $endOffset]
+}
+
+#----------------------------------------------------------------------------
+# coerce2number
+#
+#----------------------------------------------------------------------------
+proc ::dom::xpathFuncHelper::coerce2number { type value } {
+ switch $type {
+ empty { return 0 }
+ number -
+ string { return $value }
+ attrvalues { return [lindex $value 0] }
+ nodes { return [[lindex $value 0] selectNodes number()] }
+ attrnodes { return [lindex $value 1] }
+ }
+}
+
+#----------------------------------------------------------------------------
+# coerce2string
+#
+#----------------------------------------------------------------------------
+proc ::dom::xpathFuncHelper::coerce2string { type value } {
+ switch $type {
+ empty { return "" }
+ number -
+ string { return $value }
+ attrvalues { return [lindex $value 0] }
+ nodes { return [[lindex $value 0] selectNodes string()] }
+ attrnodes { return [lindex $value 1] }
+ }
+}
+
+#----------------------------------------------------------------------------
+# function-available
+#
+#----------------------------------------------------------------------------
+proc ::dom::xpathFunc::function-available { ctxNode pos
+ nodeListType nodeList args} {
+
+ if {[llength $args] != 2} {
+ error "function-available(): wrong # of args!"
+ }
+ foreach { arg1Typ arg1Value } $args break
+ set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
+ switch $str {
+ boolean -
+ ceiling -
+ concat -
+ contains -
+ count -
+ current -
+ document -
+ element-available -
+ false -
+ floor -
+ format-number -
+ generate-id -
+ id -
+ key -
+ last -
+ lang -
+ local-name -
+ name -
+ namespace-uri -
+ normalize-space -
+ not -
+ number -
+ position -
+ round -
+ starts-with -
+ string -
+ string-length -
+ substring -
+ substring-after -
+ substring-before -
+ sum -
+ translate -
+ true -
+ unparsed-entity-uri {
+ return [list bool true]
+ }
+ default {
+ set TclXpathFuncs [info procs ::dom::xpathFunc::*]
+ if {[lsearch -exact $TclXpathFuncs $str] != -1} {
+ return [list bool true]
+ } else {
+ return [list bool false]
+ }
+ }
+ }
+}
+
+#----------------------------------------------------------------------------
+# element-available
+#
+# This is not strictly correct. The XSLT namespace may be bound
+# to another prefix (and the prefix 'xsl' may be bound to another
+# namespace). Since the expression context isn't available at the
+# moment at tcl coded XPath functions, this couldn't be done better
+# than this "works in the 'normal' cases" version.
+#----------------------------------------------------------------------------
+proc ::dom::xpathFunc::element-available { ctxNode pos
+ nodeListType nodeList args} {
+
+ if {[llength $args] != 2} {
+ error "element-available(): wrong # of args!"
+ }
+ foreach { arg1Typ arg1Value } $args break
+ set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
+ switch $str {
+ xsl:stylesheet -
+ xsl:transform -
+ xsl:include -
+ xsl:import -
+ xsl:strip-space -
+ xsl:preserve-space -
+ xsl:template -
+ xsl:apply-templates -
+ xsl:apply-imports -
+ xsl:call-template -
+ xsl:element -
+ xsl:attribute -
+ xsl:attribute-set -
+ xsl:text -
+ xsl:processing-instruction -
+ xsl:comment -
+ xsl:copy -
+ xsl:value-of -
+ xsl:number -
+ xsl:for-each -
+ xsl:if -
+ xsl:choose -
+ xsl:when -
+ xsl:otherwise -
+ xsl:sort -
+ xsl:variable -
+ xsl:param -
+ xsl:copy-of -
+ xsl:with-param -
+ xsl:key -
+ xsl:message -
+ xsl:decimal-format -
+ xsl:namespace-alias -
+ xsl:output -
+ xsl:fallback {
+ return [list bool true]
+ }
+ default {
+ return [list bool false]
+ }
+ }
+}
+
+#----------------------------------------------------------------------------
+# system-property
+#
+# This is not strictly correct. The XSLT namespace may be bound
+# to another prefix (and the prefix 'xsl' may be bound to another
+# namespace). Since the expression context isn't available at the
+# moment at tcl coded XPath functions, this couldn't be done better
+# than this "works in the 'normal' cases" version.
+#----------------------------------------------------------------------------
+proc ::dom::xpathFunc::system-property { ctxNode pos
+ nodeListType nodeList args } {
+
+ if {[llength $args] != 2} {
+ error "system-property(): wrong # of args!"
+ }
+ foreach { arg1Typ arg1Value } $args break
+ set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
+ switch $str {
+ xsl:version {
+ return [list number 1.0]
+ }
+ xsl:vendor {
+ return [list string "Jochen Loewer (loewerj@hotmail.com), Rolf Ade (rolf@pointsman.de) et. al."]
+ }
+ xsl:vendor-url {
+ return [list string "http://www.tdom.org"]
+ }
+ default {
+ return [list string ""]
+ }
+ }
+}
+
+#----------------------------------------------------------------------------
+# IANAEncoding2TclEncoding
+#
+#----------------------------------------------------------------------------
+
+# As of version 8.3.4 tcl supports
+# cp860 cp861 cp862 cp863 tis-620 cp864 cp865 cp866 gb12345 cp949
+# cp950 cp869 dingbats ksc5601 macCentEuro cp874 macUkraine jis0201
+# gb2312 euc-cn euc-jp iso8859-10 macThai jis0208 iso2022-jp
+# macIceland iso2022 iso8859-13 iso8859-14 jis0212 iso8859-15 cp737
+# iso8859-16 big5 euc-kr macRomania macTurkish gb1988 iso2022-kr
+# macGreek ascii cp437 macRoman iso8859-1 iso8859-2 iso8859-3 ebcdic
+# macCroatian koi8-r iso8859-4 iso8859-5 cp1250 macCyrillic iso8859-6
+# cp1251 koi8-u macDingbats iso8859-7 cp1252 iso8859-8 cp1253
+# iso8859-9 cp1254 cp1255 cp850 cp1256 cp932 identity cp1257 cp852
+# macJapan cp1258 shiftjis utf-8 cp855 cp936 symbol cp775 unicode
+# cp857
+#
+# Just add more mappings (and mail them to the tDOM mailing list, please).
+
+proc tDOM::IANAEncoding2TclEncoding {IANAName} {
+
+ # First the most widespread encodings with there
+ # preferred MIME name, to speed lookup in this
+ # usual cases. Later the official names and the
+ # aliases.
+ #
+ # For "official names for character sets that may be
+ # used in the Internet" see
+ # http://www.iana.org/assignments/character-sets
+ # (that's the source for the encoding names below)
+ #
+ # Matching is case-insensitive
+
+ switch [string tolower $IANAName] {
+ "us-ascii" {return ascii}
+ "utf-8" {return utf-8}
+ "utf-16" {return unicode; # not sure about this}
+ "iso-8859-1" {return iso8859-1}
+ "iso-8859-2" {return iso8859-2}
+ "iso-8859-3" {return iso8859-3}
+ "iso-8859-4" {return iso8859-4}
+ "iso-8859-5" {return iso8859-5}
+ "iso-8859-6" {return iso8859-6}
+ "iso-8859-7" {return iso8859-7}
+ "iso-8859-8" {return iso8859-8}
+ "iso-8859-9" {return iso8859-9}
+ "iso-8859-10" {return iso8859-10}
+ "iso-8859-13" {return iso8859-13}
+ "iso-8859-14" {return iso8859-14}
+ "iso-8859-15" {return iso8859-15}
+ "iso-8859-16" {return iso8859-16}
+ "iso-2022-kr" {return iso2022-kr}
+ "euc-kr" {return euc-kr}
+ "iso-2022-jp" {return iso2022-jp}
+ "koi8-r" {return koi8-r}
+ "shift_jis" {return shiftjis}
+ "euc-jp" {return euc-jp}
+ "gb2312" {return gb2312}
+ "big5" {return big5}
+ "cp866" {return cp866}
+ "cp1250" {return cp1250}
+ "cp1253" {return cp1253}
+ "cp1254" {return cp1254}
+ "cp1255" {return cp1255}
+ "cp1256" {return cp1256}
+ "cp1257" {return cp1257}
+
+ "windows-1251" -
+ "cp1251" {return cp1251}
+
+ "windows-1252" -
+ "cp1252" {return cp1252}
+
+ "iso_8859-1:1987" -
+ "iso-ir-100" -
+ "iso_8859-1" -
+ "latin1" -
+ "l1" -
+ "ibm819" -
+ "cp819" -
+ "csisolatin1" {return iso8859-1}
+
+ "iso_8859-2:1987" -
+ "iso-ir-101" -
+ "iso_8859-2" -
+ "iso-8859-2" -
+ "latin2" -
+ "l2" -
+ "csisolatin2" {return iso8859-2}
+
+ "iso_8859-5:1988" -
+ "iso-ir-144" -
+ "iso_8859-5" -
+ "iso-8859-5" -
+ "cyrillic" -
+ "csisolatincyrillic" {return iso8859-5}
+
+ "ms_kanji" -
+ "csshiftjis" {return shiftjis}
+
+ "csiso2022kr" {return iso2022-kr}
+
+ "ibm866" -
+ "csibm866" {return cp866}
+
+ default {
+ # There are much more encoding names out there
+ # It's only laziness, that let me stop here.
+ error "Unrecognized encoding name '$IANAName'"
+ }
+ }
+}
+
+#----------------------------------------------------------------------------
+# xmlOpenFile
+#
+#----------------------------------------------------------------------------
+proc tDOM::xmlOpenFile {filename {encodingString {}}} {
+
+ set fd [open $filename]
+
+ if {$encodingString != {}} {
+ upvar $encodingString encString
+ }
+
+ # The autodetection of the encoding follows
+ # XML Recomendation, Appendix F
+
+ fconfigure $fd -encoding binary
+ if {![binary scan [read $fd 4] "H8" firstBytes]} {
+ # very short (< 4 Bytes) file
+ seek $fd 0 start
+ set encString UTF-8
+ return $fd
+ }
+
+ # First check for BOM
+ switch [string range $firstBytes 0 3] {
+ "feff" -
+ "fffe" {
+ # feff: UTF-16, big-endian BOM
+ # ffef: UTF-16, little-endian BOM
+ seek $fd 0 start
+ set encString UTF-16
+ fconfigure $fd -encoding identity
+ return $fd
+ }
+ }
+
+ # If the entity has a XML Declaration, the first four characters
+ # must be "<?xm".
+ switch $firstBytes {
+ "3c3f786d" {
+ # UTF-8, ISO 646, ASCII, some part of ISO 8859, Shift-JIS,
+ # EUC, or any other 7-bit, 8-bit, or mixed-width encoding which
+ # ensures that the characters of ASCII have their normal positions,
+ # width and values; the actual encoding declaration must be read to
+ # detect which of these applies, but since all of these encodings
+ # use the same bit patterns for the ASCII characters, the encoding
+ # declaration itself be read reliably.
+
+ # First 300 bytes should be enough for a XML Declaration
+ # This is of course not 100 percent bullet-proof.
+ set head [read $fd 296]
+
+ # Try to find the end of the XML Declaration
+ set closeIndex [string first ">" $head]
+ if {$closeIndex == -1} {
+ error "Weird XML data or not XML data at all"
+ }
+
+ seek $fd 0 start
+ set xmlDeclaration [read $fd [expr {$closeIndex + 5}]]
+ # extract the encoding information
+ set pattern {^[^>]+encoding=[\x20\x9\xd\xa]*["']([^ "']+)['"]}
+ # emacs: "
+ if {![regexp $pattern $head - encStr]} {
+ # Probably something like <?xml version="1.0"?>.
+ # Without encoding declaration this must be UTF-8
+ set encoding utf-8
+ set encString UTF-8
+ } else {
+ set encoding [IANAEncoding2TclEncoding $encStr]
+ set encString $encStr
+ }
+ }
+ "0000003c" -
+ "0000003c" -
+ "3c000000" -
+ "00003c00" {
+ # UCS-4
+ error "UCS-4 not supported"
+ }
+ "003c003f" -
+ "3c003f00" {
+ # UTF-16, big-endian, no BOM
+ # UTF-16, little-endian, no BOM
+ seek $fd 0 start
+ set encoding identity
+ set encString UTF-16
+ }
+ "4c6fa794" {
+ # EBCDIC in some flavor
+ error "EBCDIC not supported"
+ }
+ default {
+ # UTF-8 without an encoding declaration
+ seek $fd 0 start
+ set encoding identity
+ set encString "UTF-8"
+ }
+ }
+ fconfigure $fd -encoding $encoding
+ return $fd
+}
+
+#----------------------------------------------------------------------------
+# xmlReadFile
+#
+#----------------------------------------------------------------------------
+proc tDOM::xmlReadFile {filename {encodingString {}}} {
+
+ if {$encodingString != {}} {
+ upvar $encodingString encString
+ }
+
+ set fd [xmlOpenFile $filename encString]
+ set data [read $fd [file size $filename]]
+ close $fd
+ return $data
+}
+
+#----------------------------------------------------------------------------
+# extRefHandler
+#
+# A very simple external entity resolver, included for convenience.
+# Depends on the tcllib package uri and resolves only file URLs.
+#
+#----------------------------------------------------------------------------
+
+if {![catch {package require uri}]} {
+ proc tDOM::extRefHandler {base systemId publicId} {
+ variable extRefHandlerDebug
+ variable useForeignDTD
+
+ if {$extRefHandlerDebug} {
+ puts stderr "tDOM::extRefHandler called with:"
+ puts stderr "\tbase: '$base'"
+ puts stderr "\tsystemId: '$systemId'"
+ puts stderr "\tpublicId: '$publicId'"
+ }
+ if {$systemId == ""} {
+ if {$useForeignDTD != ""} {
+ set systemId $useForeignDTD
+ } else {
+ error "::tDOM::useForeignDTD does\
+ not point to the foreign DTD"
+ }
+ }
+ set absolutURI [uri::resolve $base $systemId]
+ array set uriData [uri::split $absolutURI]
+ switch $uriData(scheme) {
+ file {
+ return [list string $absolutURI [xmlReadFile $uriData(path)]]
+ }
+ default {
+ error "can only handle file URI's"
+ }
+ }
+ }
+}
+
+#----------------------------------------------------------------------------
+# baseURL
+#
+# A simple convenience proc which returns an absolute URL for a given
+# filename.
+#
+#----------------------------------------------------------------------------
+
+proc tDOM::baseURL {path} {
+ switch [file pathtype $path] {
+ "relative" {
+ return "file://[pwd]/$path"
+ }
+ default {
+ return "file://$path"
+ }
+ }
+}
+
+# EOF
--- /dev/null
+# We only have a win32-intel binary at the moment
+if {[string compare $::tcl_platform(platform) "windows"]} { return }
+if {[string compare $::tcl_platform(machine) "intel"]} { return }
+if {![package vsatisfies [package provide Tcl] 8.3]} { return }
+package ifneeded tls 1.6 "source \[file join [list $dir] tls.tcl\];\
+ tls::initlib \[file join [list $dir] win32-ix86\] tls16.dll"
--- /dev/null
+#
+# Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
+#
+# $Header: /cvsroot/tls/tls/tls.tcl,v 1.10 2008/03/19 02:34:21 patthoyts Exp $
+#
+namespace eval tls {
+ variable logcmd tclLog
+ variable debug 0
+
+ # Default flags passed to tls::import
+ variable defaults {}
+
+ # Maps UID to Server Socket
+ variable srvmap
+ variable srvuid 0
+
+ # Over-ride this if you are using a different socket command
+ variable socketCmd
+ if {![info exists socketCmd]} {
+ set socketCmd [info command ::socket]
+ }
+}
+
+proc tls::initlib {dir dll} {
+ # Package index cd's into the package directory for loading.
+ # Irrelevant to unixoids, but for Windows this enables the OS to find
+ # the dependent DLL's in the CWD, where they may be.
+ set cwd [pwd]
+ catch {cd $dir}
+ set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err]
+ catch {cd $cwd}
+ if {$res} {
+ namespace eval [namespace parent] {namespace delete tls}
+ return -code $res $err
+ }
+ rename tls::initlib {}
+}
+
+#
+# Backwards compatibility, also used to set the default
+# context options
+#
+proc tls::init {args} {
+ variable defaults
+
+ set defaults $args
+}
+#
+# Helper function - behaves exactly as the native socket command.
+#
+proc tls::socket {args} {
+ variable socketCmd
+ variable defaults
+ set idx [lsearch $args -server]
+ if {$idx != -1} {
+ set server 1
+ set callback [lindex $args [expr {$idx+1}]]
+ set args [lreplace $args $idx [expr {$idx+1}]]
+
+ set usage "wrong # args: should be \"tls::socket -server command ?options? port\""
+ set options "-cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -password, -request, -require, -ssl2, -ssl3, or -tls1"
+ } else {
+ set server 0
+
+ set usage "wrong # args: should be \"tls::socket ?options? host port\""
+ set options "-async, -cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -myport, -password, -request, -require, -ssl2, -ssl3, or -tls1"
+ }
+ set argc [llength $args]
+ set sopts {}
+ set iopts [concat [list -server $server] $defaults] ;# Import options
+
+ for {set idx 0} {$idx < $argc} {incr idx} {
+ set arg [lindex $args $idx]
+ switch -glob -- $server,$arg {
+ 0,-async {lappend sopts $arg}
+ 0,-myport -
+ *,-myaddr {lappend sopts $arg [lindex $args [incr idx]]}
+ *,-cadir -
+ *,-cafile -
+ *,-certfile -
+ *,-cipher -
+ *,-command -
+ *,-keyfile -
+ *,-password -
+ *,-request -
+ *,-require -
+ *,-ssl2 -
+ *,-ssl3 -
+ *,-tls1 {lappend iopts $arg [lindex $args [incr idx]]}
+ -* {return -code error "bad option \"$arg\": must be one of $options"}
+ default {break}
+ }
+ }
+ if {$server} {
+ if {($idx + 1) != $argc} {
+ return -code error $usage
+ }
+ set uid [incr ::tls::srvuid]
+
+ set port [lindex $args [expr {$argc-1}]]
+ lappend sopts $port
+ #set sopts [linsert $sopts 0 -server $callback]
+ set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
+ #set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
+ } else {
+ if {($idx + 2) != $argc} {
+ return -code error $usage
+ }
+ set host [lindex $args [expr {$argc-2}]]
+ set port [lindex $args [expr {$argc-1}]]
+ lappend sopts $host $port
+ }
+ #
+ # Create TCP/IP socket
+ #
+ set chan [eval $socketCmd $sopts]
+ if {!$server && [catch {
+ #
+ # Push SSL layer onto socket
+ #
+ eval [list tls::import] $chan $iopts
+ } err]} {
+ set info ${::errorInfo}
+ catch {close $chan}
+ return -code error -errorinfo $info $err
+ }
+ return $chan
+}
+
+# tls::_accept --
+#
+# This is the actual accept that TLS sockets use, which then calls
+# the callback registered by tls::socket.
+#
+# Arguments:
+# iopts tls::import opts
+# callback server callback to invoke
+# chan socket channel to accept/deny
+# ipaddr calling IP address
+# port calling port
+#
+# Results:
+# Returns an error if the callback throws one.
+#
+proc tls::_accept { iopts callback chan ipaddr port } {
+ log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port]
+
+ set chan [eval [list tls::import $chan] $iopts]
+
+ lappend callback $chan $ipaddr $port
+ if {[catch {
+ uplevel #0 $callback
+ } err]} {
+ log 1 "tls::_accept error: ${::errorInfo}"
+ close $chan
+ error $err $::errorInfo $::errorCode
+ } else {
+ log 2 "tls::_accept - called \"$callback\" succeeded"
+ }
+}
+#
+# Sample callback for hooking: -
+#
+# error
+# verify
+# info
+#
+proc tls::callback {option args} {
+ variable debug
+
+ #log 2 [concat $option $args]
+
+ switch -- $option {
+ "error" {
+ foreach {chan msg} $args break
+
+ log 0 "TLS/$chan: error: $msg"
+ }
+ "verify" {
+ # poor man's lassign
+ foreach {chan depth cert rc err} $args break
+
+ array set c $cert
+
+ if {$rc != "1"} {
+ log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
+ } else {
+ log 2 "TLS/$chan: verify/$depth: $c(subject)"
+ }
+ if {$debug > 0} {
+ return 1; # FORCE OK
+ } else {
+ return $rc
+ }
+ }
+ "info" {
+ # poor man's lassign
+ foreach {chan major minor state msg} $args break
+
+ if {$msg != ""} {
+ append state ": $msg"
+ }
+ # For tracing
+ upvar #0 tls::$chan cb
+ set cb($major) $minor
+
+ log 2 "TLS/$chan: $major/$minor: $state"
+ }
+ default {
+ return -code error "bad option \"$option\":\
+ must be one of error, info, or verify"
+ }
+ }
+}
+
+proc tls::xhandshake {chan} {
+ upvar #0 tls::$chan cb
+
+ if {[info exists cb(handshake)] && \
+ $cb(handshake) == "done"} {
+ return 1
+ }
+ while {1} {
+ vwait tls::${chan}(handshake)
+ if {![info exists cb(handshake)]} {
+ return 0
+ }
+ if {$cb(handshake) == "done"} {
+ return 1
+ }
+ }
+}
+
+proc tls::password {} {
+ log 0 "TLS/Password: did you forget to set your passwd!"
+ # Return the worlds best kept secret password.
+ return "secret"
+}
+
+proc tls::log {level msg} {
+ variable debug
+ variable logcmd
+
+ if {$level > $debug || $logcmd == ""} {
+ return
+ }
+ set cmd $logcmd
+ lappend cmd $msg
+ uplevel #0 $cmd
+}
--- /dev/null
+# -*- tcl -*-
+
+package ifneeded tooltip 1.4.1 [list source [file join $dir tooltip.tcl]]
+package ifneeded tipstack 1.0 [list source [file join $dir tipstack.tcl]]
--- /dev/null
+# tipstack.tcl --
+#
+# Based on 'tooltip', provides a dynamic stack of tip texts per
+# widget. This allows dynamic transient changes to the tips, for
+# example to temporarily replace a standard epxlanation with an
+# error message.
+#
+# Copyright (c) 2003 ActiveState Corporation.
+#
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: tipstack.tcl,v 1.3 2006/04/04 23:56:36 andreas_kupries Exp $
+#
+
+# ### ######### ###########################
+# Requisites
+
+package require tooltip
+namespace eval ::tipstack {}
+
+# ### ######### ###########################
+# Public API
+#
+## Basic syntax for all commands having a widget reference:
+#
+## tipstack::command .w ...
+## tipstack::command .m -index foo ...
+
+# ### ######### ###########################
+## Push new text for a widget (or menu)
+
+proc ::tipstack::push {args} {
+ if {([llength $args] != 2) && (([llength $args] != 4))} {
+ return -code error "wrong#args: expected w ?-index index? text"
+ }
+
+ # Extract valueable parts.
+
+ set text [lindex $args end]
+ set wref [lrange $args 0 end-1]
+
+ # Remember new data (setup/extend db)
+
+ variable db
+ if {![info exists db($wref)]} {
+ set db($wref) [list $text]
+ } else {
+ lappend db($wref) $text
+ }
+
+ # Forward to standard tooltip package.
+
+ eval [linsert [linsert $wref end $text] 0 tooltip::tooltip]
+ return
+}
+
+# ### ######### ###########################
+## Pop text from stack of tip for widget.
+## ! Keeps the bottom-most entry.
+
+proc ::tipstack::pop {args} {
+ if {([llength $args] != 1) && (([llength $args] != 3))} {
+ return -code error "wrong#args: expected w ?-index index?"
+ }
+ # args == wref (see 'push').
+ set wref $args
+
+ # Pop top information form the database. Except if the
+ # text is the last in the stack. Then we will keep it, it
+ # is the baseline for the widget.
+
+ variable db
+ if {![info exists db($wref)]} {
+ set text ""
+ } else {
+ set data $db($wref)
+
+ if {[llength $data] == 1} {
+ set text [lindex $data 0]
+ } else {
+ set data [lrange $data 0 end-1]
+ set text [lindex $data end]
+
+ set db($wref) $data
+ }
+ }
+
+ # Forward to standard tooltip package.
+
+ eval [linsert [linsert $wref end $text] 0 tooltip::tooltip]
+ return
+}
+
+# ### ######### ###########################
+## Clears out all data about a widget (or menu).
+
+proc ::tipstack::clear {args} {
+
+ if {([llength $args] != 1) && (([llength $args] != 3))} {
+ return -code error "wrong#args: expected w ?-index index?"
+ }
+ # args == wref (see 'push').
+ set wref $args
+
+ # Remove data about widget.
+
+ variable db
+ catch {unset db($wref)}
+
+ eval [linsert [linsert $wref end ""] 0 tooltip::tooltip]
+ return
+}
+
+# ### ######### ###########################
+## Convenient definition of tooltips for multiple
+## independent widgets. No menus possible
+
+proc ::tipstack::def {defs} {
+ foreach {path text} $defs {
+ push $path $text
+ }
+ return
+}
+
+# ### ######### ###########################
+## Convenient definition of tooltips for multiple
+## widgets in a containing widget. No menus possible.
+## This is for megawidgets.
+
+proc ::tipstack::defsub {base defs} {
+ foreach {subpath text} $defs {
+ push $base$subpath $text
+ }
+ return
+}
+
+# ### ######### ###########################
+## Convenient clearage of tooltips for multiple
+## widgets in a containing widget. No menus possible.
+## This is for megawidgets.
+
+proc ::tipstack::clearsub {base} {
+ variable db
+
+ foreach k [array names db ${base}*] {
+ # Danger. Will fail if 'base' matches a menu reference.
+ clear $k
+ }
+ return
+}
+
+# ### ######### ###########################
+# Internal commands -- None
+
+# ### ######### ###########################
+## Data structures
+
+namespace eval ::tipstack {
+ # Map from widget references to stack of tooltips.
+
+ variable db
+ array set db {}
+}
+
+# ### ######### ###########################
+# Ready
+
+package provide tipstack 1.0
--- /dev/null
+# tooltip.tcl --
+#
+# Balloon help
+#
+# Copyright (c) 1996-2007 Jeffrey Hobbs
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: tooltip.tcl,v 1.12 2008/03/12 20:41:05 hobbs Exp $
+#
+# Initiated: 28 October 1996
+
+
+package require Tk 8.4
+package provide tooltip 1.4.1
+package require msgcat
+
+#------------------------------------------------------------------------
+# PROCEDURE
+# tooltip::tooltip
+#
+# DESCRIPTION
+# Implements a tooltip (balloon help) system
+#
+# ARGUMENTS
+# tooltip <option> ?arg?
+#
+# clear ?pattern?
+# Stops the specified widgets (defaults to all) from showing tooltips
+#
+# delay ?millisecs?
+# Query or set the delay. The delay is in milliseconds and must
+# be at least 50. Returns the delay.
+#
+# disable OR off
+# Disables all tooltips.
+#
+# enable OR on
+# Enables tooltips for defined widgets.
+#
+# <widget> ?-index index? ?-item id? ?message?
+# If -index is specified, then <widget> is assumed to be a menu
+# and the index represents what index into the menu (either the
+# numerical index or the label) to associate the tooltip message with.
+# Tooltips do not appear for disabled menu items.
+# If message is {}, then the tooltip for that widget is removed.
+# The widget must exist prior to calling tooltip. The current
+# tooltip message for <widget> is returned, if any.
+#
+# RETURNS: varies (see methods above)
+#
+# NAMESPACE & STATE
+# The namespace tooltip is used.
+# Control toplevel name via ::tooltip::wname.
+#
+# EXAMPLE USAGE:
+# tooltip .button "A Button"
+# tooltip .menu -index "Load" "Loads a file"
+#
+#------------------------------------------------------------------------
+
+namespace eval ::tooltip {
+ namespace export -clear tooltip
+ variable tooltip
+ variable G
+
+ array set G {
+ enabled 1
+ fade 1
+ FADESTEP 0.2
+ FADEID {}
+ DELAY 500
+ AFTERID {}
+ LAST -1
+ TOPLEVEL .__tooltip__
+ }
+ if {[tk windowingsystem] eq "x11"} {
+ set G(fade) 0 ; # don't fade by default on X11
+ }
+ # The extra ::hide call in <Enter> is necessary to catch moving to
+ # child widgets where the <Leave> event won't be generated
+ bind Tooltip <Enter> [namespace code {
+ #tooltip::hide
+ variable tooltip
+ variable G
+ set G(LAST) -1
+ if {$G(enabled) && [info exists tooltip(%W)]} {
+ set G(AFTERID) \
+ [after $G(DELAY) [namespace code [list show %W $tooltip(%W) cursor]]]
+ }
+ }]
+
+ bind Menu <<MenuSelect>> [namespace code { menuMotion %W }]
+ bind Tooltip <Leave> [namespace code [list hide 1]] ; # fade ok
+ bind Tooltip <Any-KeyPress> [namespace code hide]
+ bind Tooltip <Any-Button> [namespace code hide]
+}
+
+proc ::tooltip::tooltip {w args} {
+ variable tooltip
+ variable G
+ switch -- $w {
+ clear {
+ if {[llength $args]==0} { set args .* }
+ clear $args
+ }
+ delay {
+ if {[llength $args]} {
+ if {![string is integer -strict $args] || $args<50} {
+ return -code error "tooltip delay must be an\
+ integer greater than 50 (delay is in millisecs)"
+ }
+ return [set G(DELAY) $args]
+ } else {
+ return $G(DELAY)
+ }
+ }
+ fade {
+ if {[llength $args]} {
+ set G(fade) [string is true -strict [lindex $args 0]]
+ }
+ return $G(fade)
+ }
+ off - disable {
+ set G(enabled) 0
+ hide
+ }
+ on - enable {
+ set G(enabled) 1
+ }
+ default {
+ set i $w
+ if {[llength $args]} {
+ set i [uplevel 1 [namespace code "register [list $w] $args"]]
+ }
+ set b $G(TOPLEVEL)
+ if {![winfo exists $b]} {
+ toplevel $b -class Tooltip
+ if {[tk windowingsystem] eq "aqua"} {
+ ::tk::unsupported::MacWindowStyle style $b help none
+ } else {
+ wm overrideredirect $b 1
+ }
+ catch {wm attributes $b -topmost 1}
+ # avoid the blink issue with 1 to <1 alpha on Windows
+ catch {wm attributes $b -alpha 0.99}
+ wm positionfrom $b program
+ wm withdraw $b
+ label $b.label -highlightthickness 0 -relief solid -bd 1 \
+ -background lightyellow -fg black
+ pack $b.label -ipadx 1
+ }
+ if {[info exists tooltip($i)]} { return $tooltip($i) }
+ }
+ }
+}
+
+proc ::tooltip::register {w args} {
+ variable tooltip
+ set key [lindex $args 0]
+ while {[string match -* $key]} {
+ switch -- $key {
+ -index {
+ if {[catch {$w entrycget 1 -label}]} {
+ return -code error "widget \"$w\" does not seem to be a\
+ menu, which is required for the -index switch"
+ }
+ set index [lindex $args 1]
+ set args [lreplace $args 0 1]
+ }
+ -item {
+ set namedItem [lindex $args 1]
+ if {[catch {$w find withtag $namedItem} item]} {
+ return -code error "widget \"$w\" is not a canvas, or item\
+ \"$namedItem\" does not exist in the canvas"
+ }
+ if {[llength $item] > 1} {
+ return -code error "item \"$namedItem\" specifies more\
+ than one item on the canvas"
+ }
+ set args [lreplace $args 0 1]
+ }
+ -tag {
+ set tag [lindex $args 1]
+ set r [catch {lsearch -exact [$w tag names] $tag} ndx]
+ if {$r || $ndx == -1} {
+ return -code error "widget \"$w\" is not a text widget or\
+ \"$tag\" is not a text tag"
+ }
+ set args [lreplace $args 0 1]
+ }
+ default {
+ return -code error "unknown option \"$key\":\
+ should be -index or -item"
+ }
+ }
+ set key [lindex $args 0]
+ }
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"tooltip widget\
+ ?-index index? ?-item item? ?-tag tag? message\""
+ }
+ if {$key eq ""} {
+ clear $w
+ } else {
+ if {![winfo exists $w]} {
+ return -code error "bad window path name \"$w\""
+ }
+ if {[info exists index]} {
+ set tooltip($w,$index) $key
+ return $w,$index
+ } elseif {[info exists item]} {
+ set tooltip($w,$item) $key
+ enableCanvas $w $item
+ return $w,$item
+ } elseif {[info exists tag]} {
+ set tooltip($w,t_$tag) $key
+ enableTag $w $tag
+ return $w,$tag
+ } else {
+ set tooltip($w) $key
+ bindtags $w [linsert [bindtags $w] end "Tooltip"]
+ return $w
+ }
+ }
+}
+
+proc ::tooltip::clear {{pattern .*}} {
+ variable tooltip
+ # cache the current widget at pointer
+ set ptrw [winfo containing [winfo pointerx .] [winfo pointery .]]
+ foreach w [array names tooltip $pattern] {
+ unset tooltip($w)
+ if {[winfo exists $w]} {
+ set tags [bindtags $w]
+ if {[set i [lsearch -exact $tags "Tooltip"]] != -1} {
+ bindtags $w [lreplace $tags $i $i]
+ }
+ ## We don't remove TooltipMenu because there
+ ## might be other indices that use it
+
+ # Withdraw the tooltip if we clear the current contained item
+ if {$ptrw eq $w} { hide }
+ }
+ }
+}
+
+proc ::tooltip::show {w msg {i {}}} {
+ if {![winfo exists $w]} { return }
+
+ # Use string match to allow that the help will be shown when
+ # the pointer is in any child of the desired widget
+ if {([winfo class $w] ne "Menu")
+ && ![string match $w* [eval [list winfo containing] \
+ [winfo pointerxy $w]]]} {
+ return
+ }
+
+ variable G
+
+ after cancel $G(FADEID)
+ set b $G(TOPLEVEL)
+ # Use late-binding msgcat (lazy translation) to support programs
+ # that allow on-the-fly l10n changes
+ $b.label configure -text [::msgcat::mc $msg] -justify left
+ update idletasks
+ set screenw [winfo screenwidth $w]
+ set screenh [winfo screenheight $w]
+ set reqw [winfo reqwidth $b]
+ set reqh [winfo reqheight $b]
+ # When adjusting for being on the screen boundary, check that we are
+ # near the "edge" already, as Tk handles multiple monitors oddly
+ if {$i eq "cursor"} {
+ set y [expr {[winfo pointery $w]+20}]
+ if {($y < $screenh) && ($y+$reqh) > $screenh} {
+ set y [expr {[winfo pointery $w]-$reqh-5}]
+ }
+ } elseif {$i ne ""} {
+ set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[$w yposition $i]+25}]
+ if {($y < $screenh) && ($y+$reqh) > $screenh} {
+ # show above if we would be offscreen
+ set y [expr {[winfo rooty $w]+[$w yposition $i]-$reqh-5}]
+ }
+ } else {
+ set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[winfo height $w]+5}]
+ if {($y < $screenh) && ($y+$reqh) > $screenh} {
+ # show above if we would be offscreen
+ set y [expr {[winfo rooty $w]-$reqh-5}]
+ }
+ }
+ if {$i eq "cursor"} {
+ set x [winfo pointerx $w]
+ } else {
+ set x [expr {[winfo rootx $w]+[winfo vrootx $w]+
+ ([winfo width $w]-$reqw)/2}]
+ }
+ # only readjust when we would appear right on the screen edge
+ if {$x<0 && ($x+$reqw)>0} {
+ set x 0
+ } elseif {($x < $screenw) && ($x+$reqw) > $screenw} {
+ set x [expr {$screenw-$reqw}]
+ }
+ if {[tk windowingsystem] eq "aqua"} {
+ set focus [focus]
+ }
+ # avoid the blink issue with 1 to <1 alpha on Windows, watch half-fading
+ catch {wm attributes $b -alpha 0.99}
+ wm geometry $b +$x+$y
+ wm deiconify $b
+ raise $b
+ if {[tk windowingsystem] eq "aqua" && $focus ne ""} {
+ # Aqua's help window steals focus on display
+ after idle [list focus -force $focus]
+ }
+}
+
+proc ::tooltip::menuMotion {w} {
+ variable G
+
+ if {$G(enabled)} {
+ variable tooltip
+
+ # Menu events come from a funny path, map to the real path.
+ set m [string map {"#" "."} [winfo name $w]]
+ set cur [$w index active]
+
+ # The next two lines (all uses of LAST) are necessary until the
+ # <<MenuSelect>> event is properly coded for Unix/(Windows)?
+ if {$cur == $G(LAST)} return
+ set G(LAST) $cur
+ # a little inlining - this is :hide
+ after cancel $G(AFTERID)
+ catch {wm withdraw $G(TOPLEVEL)}
+ if {[info exists tooltip($m,$cur)] || \
+ (![catch {$w entrycget $cur -label} cur] && \
+ [info exists tooltip($m,$cur)])} {
+ set G(AFTERID) [after $G(DELAY) \
+ [namespace code [list show $w $tooltip($m,$cur) cursor]]]
+ }
+ }
+}
+
+proc ::tooltip::hide {{fadeOk 0}} {
+ variable G
+
+ after cancel $G(AFTERID)
+ after cancel $G(FADEID)
+ if {$fadeOk && $G(fade)} {
+ fade $G(TOPLEVEL) $G(FADESTEP)
+ } else {
+ catch {wm withdraw $G(TOPLEVEL)}
+ }
+}
+
+proc ::tooltip::fade {w step} {
+ if {[catch {wm attributes $w -alpha} alpha] || $alpha <= 0.0} {
+ catch { wm withdraw $w }
+ catch { wm attributes $w -alpha 0.99 }
+ } else {
+ variable G
+ wm attributes $w -alpha [expr {$alpha-$step}]
+ set G(FADEID) [after 50 [namespace code [list fade $w $step]]]
+ }
+}
+
+proc ::tooltip::wname {{w {}}} {
+ variable G
+ if {[llength [info level 0]] > 1} {
+ # $w specified
+ if {$w ne $G(TOPLEVEL)} {
+ hide
+ destroy $G(TOPLEVEL)
+ set G(TOPLEVEL) $w
+ }
+ }
+ return $G(TOPLEVEL)
+}
+
+proc ::tooltip::itemTip {w args} {
+ variable tooltip
+ variable G
+
+ set G(LAST) -1
+ set item [$w find withtag current]
+ if {$G(enabled) && [info exists tooltip($w,$item)]} {
+ set G(AFTERID) [after $G(DELAY) \
+ [namespace code [list show $w $tooltip($w,$item) cursor]]]
+ }
+}
+
+proc ::tooltip::enableCanvas {w args} {
+ $w bind all <Enter> +[namespace code [list itemTip $w]]
+ $w bind all <Leave> +[namespace code [list hide 1]] ; # fade ok
+ $w bind all <Any-KeyPress> +[namespace code hide]
+ $w bind all <Any-Button> +[namespace code hide]
+}
+
+proc ::tooltip::tagTip {w tag} {
+ variable tooltip
+ variable G
+ set G(LAST) -1
+ if {$G(enabled) && [info exists tooltip($w,t_$tag)]} {
+ set G(AFTERID) [after $G(DELAY) \
+ [namespace code [list show $w $tooltip($w,t_$tag) cursor]]]
+ }
+}
+
+proc ::tooltip::enableTag {w tag} {
+ $w tag bind $tag <Enter> +[namespace code [list tagTip $w $tag]]
+ $w tag bind $tag <Leave> +[namespace code [list hide 1]] ; # fade ok
+ $w tag bind $tag <Any-KeyPress> +[namespace code hide]
+ $w tag bind $tag <Any-Button> +[namespace code hide]
+}
--- /dev/null
+# We only have a win32-intel binary at the moment
+if {[string compare $::tcl_platform(platform) "windows"]} { return }
+if {[string compare $::tcl_platform(machine) "intel"]} { return }
+package ifneeded udp 1.0.9 [list load [file join $dir win32-ix86 udp109.dll]]
--- /dev/null
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ # FRINK: nocheck
+ return
+}
+package ifneeded uri 1.2.1 [list source [file join $dir uri.tcl]]
+package ifneeded uri::urn 1.0.2 [list source [file join $dir urn-scheme.tcl]]
--- /dev/null
+# uri.tcl --
+#
+# URI parsing and fetch
+#
+# Copyright (c) 2000 Zveno Pty Ltd
+# Copyright (c) 2006 Pierre DAVID <Pierre.David@crc.u-strasbg.fr>
+# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Steve Ball, http://www.zveno.com/
+# Derived from urls.tcl by Andreas Kupries
+#
+# TODO:
+# Handle www-url-encoding details
+#
+# CVS: $Id: uri.tcl,v 1.35 2007/01/11 19:35:23 andreas_kupries Exp $
+
+package require Tcl 8.2
+
+namespace eval ::uri {
+
+ namespace export split join
+ namespace export resolve isrelative
+ namespace export geturl
+ namespace export canonicalize
+ namespace export register
+
+ variable file:counter 0
+
+ # extend these variable in the coming namespaces
+ variable schemes {}
+ variable schemePattern ""
+ variable url ""
+ variable url2part
+ array set url2part {}
+
+ # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ # basic regular expressions used in URL syntax.
+
+ namespace eval basic {
+ variable loAlpha {[a-z]}
+ variable hiAlpha {[A-Z]}
+ variable digit {[0-9]}
+ variable alpha {[a-zA-Z]}
+ variable safe {[$_.+-]}
+ variable extra {[!*'(,)]}
+ # danger in next pattern, order important for []
+ variable national {[][|\}\{\^~`]}
+ variable punctuation {[<>#%"]} ;#" fake emacs hilit
+ variable reserved {[;/?:@&=]}
+ variable hex {[0-9A-Fa-f]}
+ variable alphaDigit {[A-Za-z0-9]}
+ variable alphaDigitMinus {[A-Za-z0-9-]}
+
+ # next is <national | punctuation>
+ variable unsafe {[][<>"#%\{\}|\\^~`]} ;#" emacs hilit
+ variable escape "%${hex}${hex}"
+
+ # unreserved = alpha | digit | safe | extra
+ # xchar = unreserved | reserved | escape
+
+ variable unreserved {[a-zA-Z0-9$_.+!*'(,)-]}
+ variable uChar "(${unreserved}|${escape})"
+ variable xCharN {[a-zA-Z0-9$_.+!*'(,);/?:@&=-]}
+ variable xChar "(${xCharN}|${escape})"
+ variable digits "${digit}+"
+
+ variable toplabel \
+ "(${alpha}${alphaDigitMinus}*${alphaDigit}|${alpha})"
+ variable domainlabel \
+ "(${alphaDigit}${alphaDigitMinus}*${alphaDigit}|${alphaDigit})"
+
+ variable hostname \
+ "((${domainlabel}\\.)*${toplabel})"
+ variable hostnumber \
+ "(${digits}\\.${digits}\\.${digits}\\.${digits})"
+
+ variable host "(${hostname}|${hostnumber})"
+
+ variable port $digits
+ variable hostOrPort "${host}(:${port})?"
+
+ variable usrCharN {[a-zA-Z0-9$_.+!*'(,);?&=-]}
+ variable usrChar "(${usrCharN}|${escape})"
+ variable user "${usrChar}*"
+ variable password $user
+ variable login "(${user}(:${password})?@)?${hostOrPort}"
+ } ;# basic {}
+}
+\f
+
+# ::uri::register --
+#
+# Register a scheme (and aliases) in the package. The command
+# creates a namespace below "::uri" with the same name as the
+# scheme and executes the script declaring the pattern variables
+# for this scheme in the new namespace. At last it updates the
+# uri variables keeping track of overall scheme information.
+#
+# The script has to declare at least the variable "schemepart",
+# the pattern for an url of the registered scheme after the
+# scheme declaration. Not declaring this variable is an error.
+#
+# Arguments:
+# schemeList Name of the scheme to register, plus aliases
+# script Script declaring the scheme patterns
+#
+# Results:
+# None.
+
+proc ::uri::register {schemeList script} {
+ variable schemes
+ variable schemePattern
+ variable url
+ variable url2part
+
+ # Check scheme and its aliases for existence.
+ foreach scheme $schemeList {
+ if {[lsearch -exact $schemes $scheme] >= 0} {
+ return -code error \
+ "trying to register scheme (\"$scheme\") which is already known"
+ }
+ }
+
+ # Get the main scheme
+ set scheme [lindex $schemeList 0]
+
+ if {[catch {namespace eval $scheme $script} msg]} {
+ catch {namespace delete $scheme}
+ return -code error \
+ "error while evaluating scheme script: $msg"
+ }
+
+ if {![info exists ${scheme}::schemepart]} {
+ namespace delete $scheme
+ return -code error \
+ "Variable \"schemepart\" is missing."
+ }
+
+ # Now we can extend the variables which keep track of the registered schemes.
+
+ eval [linsert $schemeList 0 lappend schemes]
+ set schemePattern "([::join $schemes |]):"
+
+ foreach s $schemeList {
+ # FRINK: nocheck
+ set url2part($s) "${s}:[set ${scheme}::schemepart]"
+ # FRINK: nocheck
+ append url "(${s}:[set ${scheme}::schemepart])|"
+ }
+ set url [string trimright $url |]
+ return
+}
+
+# ::uri::split --
+#
+# Splits the given <a url> into its constituents.
+#
+# Arguments:
+# url the URL to split
+#
+# Results:
+# Tcl list containing constituents, suitable for 'array set'.
+
+proc ::uri::split {url {defaultscheme http}} {
+
+ set url [string trim $url]
+ set scheme {}
+
+ # RFC 1738: scheme = 1*[ lowalpha | digit | "+" | "-" | "." ]
+ regexp -- {^([a-z0-9+.-][a-z0-9+.-]*):} $url dummy scheme
+
+ if {$scheme == {}} {
+ set scheme $defaultscheme
+ }
+
+ # ease maintenance: dynamic dispatch, able to handle all schemes
+ # added in future!
+
+ if {[::info procs Split[string totitle $scheme]] == {}} {
+ error "unknown scheme '$scheme' in '$url'"
+ }
+
+ regsub -- "^${scheme}:" $url {} url
+
+ set parts(scheme) $scheme
+ array set parts [Split[string totitle $scheme] $url]
+
+ # should decode all encoded characters!
+
+ return [array get parts]
+}
+\f
+proc ::uri::SplitFtp {url} {
+ # @c Splits the given ftp-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ # general syntax:
+ # //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
+ #
+ # additional rules:
+ #
+ # <user>:<password> are optional, detectable by presence of @.
+ # <password> is optional too.
+ #
+ # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
+ # <cwd1> "/" ..."/" <cwdN> "/" <name> [";type=" <typecode>]
+
+ upvar \#0 [namespace current]::ftp::typepart ftptype
+
+ array set parts {user {} pwd {} host {} port {} path {} type {}}
+
+ # slash off possible type specification
+
+ if {[regexp -indices -- "${ftptype}$" $url dummy ftype]} {
+
+ set from [lindex $ftype 0]
+ set to [lindex $ftype 1]
+
+ set parts(type) [string range $url $from $to]
+
+ set from [lindex $dummy 0]
+ set url [string replace $url $from end]
+ }
+
+ # Handle user, password, host and port
+
+ if {[string match "//*" $url]} {
+ set url [string range $url 2 end]
+
+ array set parts [GetUPHP url]
+ }
+
+ set parts(path) [string trimleft $url /]
+
+ return [array get parts]
+}
+\f
+proc ::uri::JoinFtp args {
+ array set components {
+ user {} pwd {} host {} port {}
+ path {} type {}
+ }
+ array set components $args
+
+ set userPwd {}
+ if {[string length $components(user)] || [string length $components(pwd)]} {
+ set userPwd $components(user)[expr {[string length $components(pwd)] ? ":$components(pwd)" : {}}]@
+ }
+
+ set port {}
+ if {[string length $components(port)]} {
+ set port :$components(port)
+ }
+
+ set type {}
+ if {[string length $components(type)]} {
+ set type \;type=$components(type)
+ }
+
+ return ftp://${userPwd}$components(host)${port}/[string trimleft $components(path) /]$type
+}
+\f
+proc ::uri::SplitHttps {url} {
+ return [SplitHttp $url]
+}
+
+proc ::uri::SplitHttp {url} {
+ # @c Splits the given http-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ # general syntax:
+ # //<host>:<port>/<path>?<searchpart>
+ #
+ # where <host> and <port> are as described in Section 3.1. If :<port>
+ # is omitted, the port defaults to 80. No user name or password is
+ # allowed. <path> is an HTTP selector, and <searchpart> is a query
+ # string. The <path> is optional, as is the <searchpart> and its
+ # preceding "?". If neither <path> nor <searchpart> is present, the "/"
+ # may also be omitted.
+ #
+ # Within the <path> and <searchpart> components, "/", ";", "?" are
+ # reserved. The "/" character may be used within HTTP to designate a
+ # hierarchical structure.
+ #
+ # path == <cwd1> "/" ..."/" <cwdN> "/" <name> ["#" <fragment>]
+
+ upvar #0 [namespace current]::http::search search
+ upvar #0 [namespace current]::http::segment segment
+
+ array set parts {host {} port {} path {} query {}}
+
+ set searchPattern "\\?(${search})\$"
+ set fragmentPattern "#(${segment})\$"
+
+ # slash off possible query. the 'search' regexp, while official,
+ # is not good enough. We have apparently lots of urls in the wild
+ # which contain unquoted urls with queries in a query. The RE
+ # finds the embedded query, not the actual one. Using string first
+ # now instead of a RE
+
+ if {[set pos [string first ? $url]] >= 0} {
+ incr pos
+ set parts(query) [string range $url $pos end]
+ incr pos -1
+ set url [string replace $url $pos end]
+ }
+
+ # slash off possible fragment
+
+ if {[regexp -indices -- $fragmentPattern $url match fragment]} {
+ set from [lindex $fragment 0]
+ set to [lindex $fragment 1]
+
+ set parts(fragment) [string range $url $from $to]
+
+ set url [string replace $url [lindex $match 0] end]
+ }
+
+ if {[string match "//*" $url]} {
+ set url [string range $url 2 end]
+
+ array set parts [GetUPHP url]
+ }
+
+ set parts(path) [string trimleft $url /]
+
+ return [array get parts]
+}
+\f
+proc ::uri::JoinHttp {args} {
+ return [eval [linsert $args 0 ::uri::JoinHttpInner http 80]]
+}
+
+proc ::uri::JoinHttps {args} {
+ return [eval [linsert $args 0 ::uri::JoinHttpInner https 443]]
+}
+
+proc ::uri::JoinHttpInner {scheme defport args} {
+ array set components {host {} path {} query {}}
+ set components(port) $defport
+ array set components $args
+
+ set port {}
+ if {[string length $components(port)] && $components(port) != $defport} {
+ set port :$components(port)
+ }
+
+ set query {}
+ if {[string length $components(query)]} {
+ set query ?$components(query)
+ }
+
+ regsub -- {^/} $components(path) {} components(path)
+
+ if { [info exists components(fragment)] && $components(fragment) != "" } {
+ set components(fragment) "#$components(fragment)"
+ } else {
+ set components(fragment) ""
+ }
+
+ return $scheme://$components(host)$port/$components(path)$components(fragment)$query
+}
+\f
+proc ::uri::SplitFile {url} {
+ # @c Splits the given file-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ upvar #0 [namespace current]::basic::hostname hostname
+ upvar #0 [namespace current]::basic::hostnumber hostnumber
+
+ if {[string match "//*" $url]} {
+ set url [string range $url 2 end]
+
+ set hostPattern "^($hostname|$hostnumber)"
+ switch -exact -- $::tcl_platform(platform) {
+ windows {
+ # Catch drive letter
+ append hostPattern :?
+ }
+ default {
+ # Proceed as usual
+ }
+ }
+
+ if {[regexp -indices -- $hostPattern $url match host]} {
+ set fh [lindex $host 0]
+ set th [lindex $host 1]
+
+ set parts(host) [string range $url $fh $th]
+
+ set matchEnd [lindex $match 1]
+ incr matchEnd
+
+ set url [string range $url $matchEnd end]
+ }
+ }
+
+ set parts(path) $url
+
+ return [array get parts]
+}
+\f
+proc ::uri::JoinFile args {
+ array set components {
+ host {} port {} path {}
+ }
+ array set components $args
+
+ switch -exact -- $::tcl_platform(platform) {
+ windows {
+ if {[string length $components(host)]} {
+ return file://$components(host):$components(path)
+ } else {
+ return file://$components(path)
+ }
+ }
+ default {
+ return file://$components(host)$components(path)
+ }
+ }
+}
+\f
+proc ::uri::SplitMailto {url} {
+ # @c Splits the given mailto-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ if {[string match "*@*" $url]} {
+ set url [::split $url @]
+ return [list user [lindex $url 0] host [lindex $url 1]]
+ } else {
+ return [list user $url]
+ }
+}
+\f
+proc ::uri::JoinMailto args {
+ array set components {
+ user {} host {}
+ }
+ array set components $args
+
+ return mailto:$components(user)@$components(host)
+}
+\f
+proc ::uri::SplitNews {url} {
+ if { [string first @ $url] >= 0 } {
+ return [list message-id $url]
+ } else {
+ return [list newsgroup-name $url]
+ }
+}
+\f
+proc ::uri::JoinNews args {
+ array set components {
+ message-id {} newsgroup-name {}
+ }
+ array set components $args
+ return news:$components(message-id)$components(newsgroup-name)
+}
+\f
+proc ::uri::SplitLdaps {url} {
+ ::uri::SplitLdap $url
+}
+
+proc ::uri::SplitLdap {url} {
+ # @c Splits the given Ldap-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ # general syntax:
+ # //<host>:<port>/<dn>?<attrs>?<scope>?<filter>?<extensions>
+ #
+ # where <host> and <port> are as described in Section 5 of RFC 1738.
+ # No user name or password is allowed.
+ # If omitted, the port defaults to 389 for ldap, 636 for ldaps
+ # <dn> is the base DN for the search
+ # <attrs> is a comma separated list of attributes description
+ # <scope> is either "base", "one" or "sub".
+ # <filter> is a RFC 2254 filter specification
+ # <extensions> are documented in RFC 2255
+ #
+
+ array set parts {host {} port {} dn {} attrs {} scope {} filter {} extensions {}}
+
+ # host port dn attrs scope filter extns
+ set re {//([^:?/]+)(?::([0-9]+))?(?:/([^?]+)(?:\?([^?]*)(?:\?(base|one|sub)?(?:\?([^?]*)(?:\?(.*))?)?)?)?)?}
+
+ if {! [regexp $re $url match parts(host) parts(port) \
+ parts(dn) parts(attrs) parts(scope) parts(filter) \
+ parts(extensions)]} then {
+ return -code error "unable to match URL \"$url\""
+ }
+
+ set parts(attrs) [::split $parts(attrs) ","]
+
+ return [array get parts]
+}
+\f
+proc ::uri::JoinLdap {args} {
+ return [eval [linsert $args 0 ::uri::JoinLdapInner ldap 389]]
+}
+
+proc ::uri::JoinLdaps {args} {
+ return [eval [linsert $args 0 ::uri::JoinLdapInner ldaps 636]]
+}
+
+proc ::uri::JoinLdapInner {scheme defport args} {
+ array set components {host {} port {} dn {} attrs {} scope {} filter {} extensions {}}
+ set components(port) $defport
+ array set components $args
+
+ set port {}
+ if {[string length $components(port)] && $components(port) != $defport} {
+ set port :$components(port)
+ }
+
+ set url "$scheme://$components(host)$port"
+
+ set components(attrs) [::join $components(attrs) ","]
+
+ set s ""
+ foreach c {dn attrs scope filter extensions} {
+ if {[string equal $c "dn"]} then {
+ append s "/"
+ } else {
+ append s "?"
+ }
+ if {! [string equal $components($c) ""]} then {
+ append url "${s}$components($c)"
+ set s ""
+ }
+ }
+
+ return $url
+}
+\f
+proc ::uri::GetUPHP {urlvar} {
+ # @c Parse user, password host and port out of the url stored in
+ # @c variable <a urlvar>.
+ # @d Side effect: The extracted information is removed from the given url.
+ # @r List containing the extracted information in a format suitable for
+ # @r 'array set'.
+ # @a urlvar: Name of the variable containing the url to parse.
+
+ upvar \#0 [namespace current]::basic::user user
+ upvar \#0 [namespace current]::basic::password password
+ upvar \#0 [namespace current]::basic::hostname hostname
+ upvar \#0 [namespace current]::basic::hostnumber hostnumber
+ upvar \#0 [namespace current]::basic::port port
+
+ upvar $urlvar url
+
+ array set parts {user {} pwd {} host {} port {}}
+
+ # syntax
+ # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
+ # "//" already cut off by caller
+
+ set upPattern "^(${user})(:(${password}))?@"
+
+ if {[regexp -indices -- $upPattern $url match theUser c d thePassword]} {
+ set fu [lindex $theUser 0]
+ set tu [lindex $theUser 1]
+
+ set fp [lindex $thePassword 0]
+ set tp [lindex $thePassword 1]
+
+ set parts(user) [string range $url $fu $tu]
+ set parts(pwd) [string range $url $fp $tp]
+
+ set matchEnd [lindex $match 1]
+ incr matchEnd
+
+ set url [string range $url $matchEnd end]
+ }
+
+ set hpPattern "^($hostname|$hostnumber)(:($port))?"
+
+ if {[regexp -indices -- $hpPattern $url match theHost c d e f g h thePort]} {
+ set fh [lindex $theHost 0]
+ set th [lindex $theHost 1]
+
+ set fp [lindex $thePort 0]
+ set tp [lindex $thePort 1]
+
+ set parts(host) [string range $url $fh $th]
+ set parts(port) [string range $url $fp $tp]
+
+ set matchEnd [lindex $match 1]
+ incr matchEnd
+
+ set url [string range $url $matchEnd end]
+ }
+
+ return [array get parts]
+}
+\f
+proc ::uri::GetHostPort {urlvar} {
+ # @c Parse host and port out of the url stored in variable <a urlvar>.
+ # @d Side effect: The extracted information is removed from the given url.
+ # @r List containing the extracted information in a format suitable for
+ # @r 'array set'.
+ # @a urlvar: Name of the variable containing the url to parse.
+
+ upvar #0 [namespace current]::basic::hostname hostname
+ upvar #0 [namespace current]::basic::hostnumber hostnumber
+ upvar #0 [namespace current]::basic::port port
+
+ upvar $urlvar url
+
+ set pattern "^(${hostname}|${hostnumber})(:(${port}))?"
+
+ if {[regexp -indices -- $pattern $url match host c d e f g h thePort]} {
+ set fromHost [lindex $host 0]
+ set toHost [lindex $host 1]
+
+ set fromPort [lindex $thePort 0]
+ set toPort [lindex $thePort 1]
+
+ set parts(host) [string range $url $fromHost $toHost]
+ set parts(port) [string range $url $fromPort $toPort]
+
+ set matchEnd [lindex $match 1]
+ incr matchEnd
+
+ set url [string range $url $matchEnd end]
+ }
+
+ return [array get parts]
+}
+\f
+# ::uri::resolve --
+#
+# Resolve an arbitrary URL, given a base URL
+#
+# Arguments:
+# base base URL (absolute)
+# url arbitrary URL
+#
+# Results:
+# Returns a URL
+
+proc ::uri::resolve {base url} {
+ if {[string length $url]} {
+ if {[isrelative $url]} {
+
+ array set baseparts [split $base]
+
+ switch -- $baseparts(scheme) {
+ http -
+ https -
+ ftp -
+ file {
+ array set relparts [split $url]
+ if { [string match /* $url] } {
+ catch { set baseparts(path) $relparts(path) }
+ } elseif { [string match */ $baseparts(path)] } {
+ set baseparts(path) "$baseparts(path)$relparts(path)"
+ } else {
+ if { [string length $relparts(path)] > 0 } {
+ set path [lreplace [::split $baseparts(path) /] end end]
+ set baseparts(path) "[::join $path /]/$relparts(path)"
+ }
+ }
+ catch { set baseparts(query) $relparts(query) }
+ catch { set baseparts(fragment) $relparts(fragment) }
+ return [eval [linsert [array get baseparts] 0 join]]
+ }
+ default {
+ return -code error "unable to resolve relative URL \"$url\""
+ }
+ }
+
+ } else {
+ return $url
+ }
+ } else {
+ return $base
+ }
+}
+\f
+# ::uri::isrelative --
+#
+# Determines whether a URL is absolute or relative
+#
+# Arguments:
+# url URL to check
+#
+# Results:
+# Returns 1 if the URL is relative, 0 otherwise
+
+proc ::uri::isrelative url {
+ return [expr {![regexp -- {^[a-z0-9+-.][a-z0-9+-.]*:} $url]}]
+}
+\f
+# ::uri::geturl --
+#
+# Fetch the data from an arbitrary URL.
+#
+# This package provides a handler for the file:
+# scheme, since this conflicts with the file command.
+#
+# Arguments:
+# url address of data resource
+# args configuration options
+#
+# Results:
+# Depends on scheme
+
+proc ::uri::geturl {url args} {
+ array set urlparts [split $url]
+
+ switch -- $urlparts(scheme) {
+ file {
+ return [eval [linsert $args 0 file_geturl $url]]
+ }
+ default {
+ # Load a geturl package for the scheme first and only if
+ # that fails the scheme package itself. This prevents
+ # cyclic dependencies between packages.
+ if {[catch {package require $urlparts(scheme)::geturl}]} {
+ package require $urlparts(scheme)
+ }
+ return [eval [linsert $args 0 $urlparts(scheme)::geturl $url]]
+ }
+ }
+}
+\f
+# ::uri::file_geturl --
+#
+# geturl implementation for file: scheme
+#
+# TODO:
+# This is an initial, basic implementation.
+# Eventually want to support all options for geturl.
+#
+# Arguments:
+# url URL to fetch
+# args configuration options
+#
+# Results:
+# Returns data from file
+
+proc ::uri::file_geturl {url args} {
+ variable file:counter
+
+ set var [namespace current]::file[incr file:counter]
+ upvar #0 $var state
+ array set state {data {}}
+
+ array set parts [split $url]
+
+ set ch [open $parts(path)]
+ # Could determine text/binary from file extension,
+ # except on Macintosh
+ # fconfigure $ch -translation binary
+ set state(data) [read $ch]
+ close $ch
+
+ return $var
+}
+\f
+# ::uri::join --
+#
+# Format a URL
+#
+# Arguments:
+# args components, key-value format
+#
+# Results:
+# A URL
+
+proc ::uri::join args {
+ array set components $args
+
+ return [eval [linsert $args 0 Join[string totitle $components(scheme)]]]
+}
+\f
+# ::uri::canonicalize --
+#
+# Canonicalize a URL
+#
+# Acknowledgements:
+# Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# Arguments:
+# uri URI (which contains a path component)
+#
+# Results:
+# The canonical form of the URI
+
+proc ::uri::canonicalize uri {
+
+ # Make uri canonical with respect to dots (path changing commands)
+ #
+ # Remove single dots (.) => pwd not changing
+ # Remove double dots (..) => gobble previous segment of path
+ #
+ # Fixes for this command:
+ #
+ # * Ignore any url which cannot be split into components by this
+ # module. Just assume that such urls do not have a path to
+ # canonicalize.
+ #
+ # * Ignore any url which could be split into components, but does
+ # not have a path component.
+ #
+ # In the text above 'ignore' means
+ # 'return the url unchanged to the caller'.
+
+ if {[catch {array set u [::uri::split $uri]}]} {
+ return $uri
+ }
+ if {![info exists u(path)]} {
+ return $uri
+ }
+
+ set uri $u(path)
+
+ # Remove leading "./" "../" "/.." (and "/../")
+ regsub -all -- {^(\./)+} $uri {} uri
+ regsub -all -- {^/(\.\./)+} $uri {/} uri
+ regsub -all -- {^(\.\./)+} $uri {} uri
+
+ # Remove inner /./ and /../
+ while {[regsub -all -- {/\./} $uri {/} uri]} {}
+ while {[regsub -all -- {/[^/]+/\.\./} $uri {/} uri]} {}
+ while {[regsub -all -- {^[^/]+/\.\./} $uri {} uri]} {}
+ # Munge trailing /..
+ while {[regsub -all -- {/[^/]+/\.\.} $uri {/} uri]} {}
+ if { $uri == ".." } { set uri "/" }
+
+ set u(path) $uri
+ set uri [eval [linsert [array get u] 0 ::uri::join]]
+
+ return $uri
+}
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+# regular expressions covering various url schemes
+
+# Currently known URL schemes:
+#
+# (RFC 1738)
+# ------------------------------------------------
+# scheme basic syntax of scheme specific part
+# ------------------------------------------------
+# ftp //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
+#
+# http //<host>:<port>/<path>?<searchpart>
+#
+# gopher //<host>:<port>/<gophertype><selector>
+# <gophertype><selector>%09<search>
+# <gophertype><selector>%09<search>%09<gopher+_string>
+#
+# mailto <rfc822-addr-spec>
+# news <newsgroup-name>
+# <message-id>
+# nntp //<host>:<port>/<newsgroup-name>/<article-number>
+# telnet //<user>:<password>@<host>:<port>/
+# wais //<host>:<port>/<database>
+# //<host>:<port>/<database>?<search>
+# //<host>:<port>/<database>/<wtype>/<wpath>
+# file //<host>/<path>
+# prospero //<host>:<port>/<hsoname>;<field>=<value>
+# ------------------------------------------------
+#
+# (RFC 2111)
+# ------------------------------------------------
+# scheme basic syntax of scheme specific part
+# ------------------------------------------------
+# mid message-id
+# message-id/content-id
+# cid content-id
+# ------------------------------------------------
+#
+# (RFC 2255)
+# ------------------------------------------------
+# scheme basic syntax of scheme specific part
+# ------------------------------------------------
+# ldap //<host>:<port>/<dn>?<attrs>?<scope>?<filter>?<extensions>
+# ------------------------------------------------
+
+# FTP
+uri::register ftp {
+ variable escape [set [namespace parent [namespace current]]::basic::escape]
+ variable login [set [namespace parent [namespace current]]::basic::login]
+
+ variable charN {[a-zA-Z0-9$_.+!*'(,)?:@&=-]}
+ variable char "(${charN}|${escape})"
+ variable segment "${char}*"
+ variable path "${segment}(/${segment})*"
+
+ variable type {[AaDdIi]}
+ variable typepart ";type=(${type})"
+ variable schemepart \
+ "//${login}(/${path}(${typepart})?)?"
+
+ variable url "ftp:${schemepart}"
+}
+
+# FILE
+uri::register file {
+ variable host [set [namespace parent [namespace current]]::basic::host]
+ variable path [set [namespace parent [namespace current]]::ftp::path]
+
+ variable schemepart "//(${host}|localhost)?/${path}"
+ variable url "file:${schemepart}"
+}
+
+# HTTP
+uri::register http {
+ variable escape \
+ [set [namespace parent [namespace current]]::basic::escape]
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+
+ variable charN {[a-zA-Z0-9$_.+!*'(,);:@&=-]}
+ variable char "($charN|${escape})"
+ variable segment "${char}*"
+
+ variable path "${segment}(/${segment})*"
+ variable search $segment
+ variable schemepart \
+ "//${hostOrPort}(/${path}(\\?${search})?)?"
+
+ variable url "http:${schemepart}"
+}
+
+# GOPHER
+uri::register gopher {
+ variable xChar \
+ [set [namespace parent [namespace current]]::basic::xChar]
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+ variable search \
+ [set [namespace parent [namespace current]]::http::search]
+
+ variable type $xChar
+ variable selector "$xChar*"
+ variable string $selector
+ variable schemepart \
+ "//${hostOrPort}(/(${type}(${selector}(%09${search}(%09${string})?)?)?)?)?"
+ variable url "gopher:${schemepart}"
+}
+
+# MAILTO
+uri::register mailto {
+ variable xChar [set [namespace parent [namespace current]]::basic::xChar]
+ variable host [set [namespace parent [namespace current]]::basic::host]
+
+ variable schemepart "$xChar+(@${host})?"
+ variable url "mailto:${schemepart}"
+}
+
+# NEWS
+uri::register news {
+ variable escape [set [namespace parent [namespace current]]::basic::escape]
+ variable alpha [set [namespace parent [namespace current]]::basic::alpha]
+ variable host [set [namespace parent [namespace current]]::basic::host]
+
+ variable aCharN {[a-zA-Z0-9$_.+!*'(,);/?:&=-]}
+ variable aChar "($aCharN|${escape})"
+ variable gChar {[a-zA-Z0-9$_.+-]}
+ variable newsgroup-name "${alpha}${gChar}*"
+ variable message-id "${aChar}+@${host}"
+ variable schemepart "\\*|${newsgroup-name}|${message-id}"
+ variable url "news:${schemepart}"
+}
+
+# WAIS
+uri::register wais {
+ variable uChar \
+ [set [namespace parent [namespace current]]::basic::xChar]
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+ variable search \
+ [set [namespace parent [namespace current]]::http::search]
+
+ variable db "${uChar}*"
+ variable type "${uChar}*"
+ variable path "${uChar}*"
+
+ variable database "//${hostOrPort}/${db}"
+ variable index "//${hostOrPort}/${db}\\?${search}"
+ variable doc "//${hostOrPort}/${db}/${type}/${path}"
+
+ #variable schemepart "${doc}|${index}|${database}"
+
+ variable schemepart \
+ "//${hostOrPort}/${db}((\\?${search})|(/${type}/${path}))?"
+
+ variable url "wais:${schemepart}"
+}
+
+# PROSPERO
+uri::register prospero {
+ variable escape \
+ [set [namespace parent [namespace current]]::basic::escape]
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+ variable path \
+ [set [namespace parent [namespace current]]::ftp::path]
+
+ variable charN {[a-zA-Z0-9$_.+!*'(,)?:@&-]}
+ variable char "(${charN}|$escape)"
+
+ variable fieldname "${char}*"
+ variable fieldvalue "${char}*"
+ variable fieldspec ";${fieldname}=${fieldvalue}"
+
+ variable schemepart "//${hostOrPort}/${path}(${fieldspec})*"
+ variable url "prospero:$schemepart"
+}
+
+# LDAP
+uri::register ldap {
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+
+ # very crude parsing
+ variable dn {[^?]*}
+ variable attrs {[^?]*}
+ variable scope "base|one|sub"
+ variable filter {[^?]*}
+ # extensions are not handled yet
+
+ variable schemepart "//${hostOrPort}(/${dn}(\?${attrs}(\?(${scope})(\?${filter})?)?)?)?"
+ variable url "ldap:$schemepart"
+}
+
+package provide uri 1.2.1
--- /dev/null
+# urn-scheme.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sf.net>
+#
+# extend the uri package to deal with URN (RFC 2141)
+# see http://www.normos.org/ietf/rfc/rfc2141.txt
+#
+# Released under the tcllib license.
+#
+# $Id: urn-scheme.tcl,v 1.11 2005/09/28 04:51:24 andreas_kupries Exp $
+# -------------------------------------------------------------------------
+
+package require uri 1.1.2
+
+namespace eval ::uri {}
+namespace eval ::uri::urn {
+ variable version 1.0.2
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Called by uri::split with a url to split into its parts.
+#
+proc ::uri::SplitUrn {uri} {
+ #@c Split the given uri into then URN component parts
+ #@a uri: the URI to split without it's scheme part.
+ #@r List of the component parts suitable for 'array set'
+
+ upvar \#0 [namespace current]::urn::URNpart pattern
+ array set parts {nid {} nss {}}
+ if {[regexp -- ^$pattern $uri -> parts(nid) parts(nss)]} {
+ return [array get parts]
+ } else {
+ error "invalid urn syntax: \"$uri\" could not be parsed"
+ }
+}
+
+
+# -------------------------------------------------------------------------
+
+proc ::uri::JoinUrn args {
+ #@c Join the parts of a URN scheme URI
+ #@a list of nid value nss value
+ #@r a valid string representation for your URI
+ variable urn::NIDpart
+
+ array set parts [list nid {} nss {}]
+ array set parts $args
+ if {! [regexp -- ^$NIDpart$ $parts(nid)]} {
+ error "invalid urn: nid is invalid"
+ }
+ set url "urn:$parts(nid):[urn::quote $parts(nss)]"
+ return $url
+}
+
+# -------------------------------------------------------------------------
+
+# Quote the disallowed characters according to the RFC for URN scheme.
+# ref: RFC2141 sec2.2
+proc ::uri::urn::quote {url} {
+ variable trans
+
+ set ndx 0
+ set result ""
+ while {[regexp -indices -- "\[^$trans\]" $url r]} {
+ set ndx [lindex $r 0]
+ scan [string index $url $ndx] %c chr
+ set rep %[format %.2X $chr]
+ if {[string match $rep %00]} {
+ error "invalid character: character $chr is not allowed"
+ }
+
+ incr ndx -1
+ append result [string range $url 0 $ndx] $rep
+ incr ndx 2
+ set url [string range $url $ndx end]
+ }
+ append result $url
+ return $result
+}
+
+# -------------------------------------------------------------------------
+# Perform the reverse of urn::quote.
+
+if { [package vcompare [package provide Tcl] 8.3] < 0 } {
+ # Before Tcl 8.3 we do not have 'regexp -start'. We simulate it by
+ # using 'string range' and adjusting the match results.
+
+ proc ::uri::urn::unquote {url} {
+ set result ""
+ set start 0
+ while {[regexp -indices {%[0-9a-fA-F]{2}} [string range $url $start end] match]} {
+ foreach {first last} $match break
+ incr first $start ; # Make the indices relative to the true string.
+ incr last $start ; # I.e. undo the effect of the 'string range' on match results.
+ append result [string range $url $start [expr {$first - 1}]]
+ append result [format %c 0x[string range $url [incr first] $last]]
+ set start [incr last]
+ }
+ append result [string range $url $start end]
+ return $result
+ }
+} else {
+ proc ::uri::urn::unquote {url} {
+ set result ""
+ set start 0
+ while {[regexp -start $start -indices {%[0-9a-fA-F]{2}} $url match]} {
+ foreach {first last} $match break
+ append result [string range $url $start [expr {$first - 1}]]
+ append result [format %c 0x[string range $url [incr first] $last]]
+ set start [incr last]
+ }
+ append result [string range $url $start end]
+ return $result
+ }
+}
+
+# -------------------------------------------------------------------------
+
+::uri::register {urn URN} {
+ variable NIDpart {[a-zA-Z0-9][a-zA-Z0-9-]{0,31}}
+ variable esc {%[0-9a-fA-F]{2}}
+ variable trans {a-zA-Z0-9$_.+!*'(,):=@;-}
+ variable NSSpart "($esc|\[$trans\])+"
+ variable URNpart "($NIDpart):($NSSpart)"
+ variable schemepart $URNpart
+ variable url "urn:$NIDpart:$NSSpart"
+}
+
+# -------------------------------------------------------------------------
+
+package provide uri::urn $::uri::urn::version
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+# pkgIndex.tcl -
+#
+# uuid package index file
+#
+# $Id: pkgIndex.tcl,v 1.2 2005/09/30 05:36:39 andreas_kupries Exp $
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded uuid 1.0.1 [list source [file join $dir uuid.tcl]]
--- /dev/null
+# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# UUIDs are 128 bit values that attempt to be unique in time and space.
+#
+# Reference:
+# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt
+#
+# uuid: scheme:
+# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html
+#
+# Usage: uuid::uuid generate
+# uuid::uuid equal $idA $idB
+
+namespace eval uuid {
+ variable version 1.0.1
+ variable accel
+ array set accel {critcl 0}
+
+ namespace export uuid
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 1
+ }
+
+ if {[package vcompare [package provide Tcl] 8.4] < 0} {
+ package require struct::list
+ interp alias {} ::uuid::lset {} ::struct::list::lset
+ }
+
+ proc K {a b} {set a}
+}
+
+# Generates a binary UUID as per the draft spec. We generate a pseudo-random
+# type uuid (type 4). See section 3.4
+#
+proc ::uuid::generate_tcl {} {
+ package require md5 2
+ variable uid
+
+ set tok [md5::MD5Init]
+ md5::MD5Update $tok [clock seconds]; # timestamp
+ md5::MD5Update $tok [clock clicks]; # system incrementing counter
+ md5::MD5Update $tok [incr uid]; # package incrementing counter
+ md5::MD5Update $tok [info hostname]; # spatial unique id (poor)
+ md5::MD5Update $tok [pid]; # additional entropy
+ md5::MD5Update $tok [array get ::tcl_platform]
+
+ # More spatial information -- better than hostname.
+ # bug 1150714: opening a server socket may raise a warning messagebox
+ # with WinXP firewall, using ipconfig will return all IP addresses
+ # including ipv6 ones if available. ipconfig is OK on win98+
+ if {[string equal $::tcl_platform(platform) "windows"]} {
+ catch {exec ipconfig} config
+ md5::MD5Update $tok $config
+ } else {
+ catch {
+ set s [socket -server void -myaddr [info hostname] 0]
+ K [fconfigure $s -sockname] [close $s]
+ } r
+ md5::MD5Update $tok $r
+ }
+
+ if {[package provide Tk] != {}} {
+ md5::MD5Update $tok [winfo pointerxy .]
+ md5::MD5Update $tok [winfo id .]
+ }
+
+ set r [md5::MD5Final $tok]
+ binary scan $r c* r
+
+ # 3.4: set uuid versioning fields
+ lset r 8 [expr {([lindex $r 8] & 0x7F) | 0x40}]
+ lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}]
+
+ return [binary format c* $r]
+}
+
+if {[string equal $tcl_platform(platform) "windows"]
+ && [package provide critcl] != {}} {
+ namespace eval uuid {
+ critcl::ccode {
+ #define WIN32_LEAN_AND_MEAN
+ #define STRICT
+ #include <windows.h>
+ #include <ole2.h>
+ typedef long (__stdcall *LPFNUUIDCREATE)(UUID *);
+ typedef const unsigned char cu_char;
+ }
+ critcl::cproc generate_c {Tcl_Interp* interp} ok {
+ HRESULT hr = S_OK;
+ int r = TCL_OK;
+ UUID uuid = {0};
+ HMODULE hLib;
+ LPFNUUIDCREATE lpfnUuidCreate = NULL;
+
+ hLib = LoadLibrary(_T("rpcrt4.dll"));
+ if (hLib)
+ lpfnUuidCreate = (LPFNUUIDCREATE)
+ GetProcAddress(hLib, "UuidCreate");
+ if (lpfnUuidCreate) {
+ Tcl_Obj *obj;
+ lpfnUuidCreate(&uuid);
+ obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid));
+ Tcl_SetObjResult(interp, obj);
+ } else {
+ Tcl_SetResult(interp, "error: failed to create a guid",
+ TCL_STATIC);
+ r = TCL_ERROR;
+ }
+ return r;
+ }
+ }
+}
+
+# Convert a binary uuid into its string representation.
+#
+proc ::uuid::tostring {uuid} {
+ binary scan $uuid H* s
+ foreach {a b} {0 7 8 11 12 15 16 19 20 end} {
+ append r [string range $s $a $b] -
+ }
+ return [string tolower [string trimright $r -]]
+}
+
+# Convert a string representation of a uuid into its binary format.
+#
+proc ::uuid::fromstring {uuid} {
+ return [binary format H* [string map {- {}} $uuid]]
+}
+
+# Compare two uuids for equality.
+#
+proc ::uuid::equal {left right} {
+ set l [fromstring $left]
+ set r [fromstring $right]
+ return [string equal $l $r]
+}
+
+# Call our generate uuid implementation
+proc ::uuid::generate {} {
+ variable accel
+ if {$accel(critcl)} {
+ return [generate_c]
+ } else {
+ return [generate_tcl]
+ }
+}
+
+# uuid generate -> string rep of a new uuid
+# uuid equal uuid1 uuid2
+#
+proc uuid::uuid {cmd args} {
+ switch -exact -- $cmd {
+ generate {
+ if {[llength $args] != 0} {
+ return -code error "wrong # args:\
+ should be \"uuid generate\""
+ }
+ return [tostring [generate]]
+ }
+ equal {
+ if {[llength $args] != 2} {
+ return -code error "wrong \# args:\
+ should be \"uuid equal uuid1 uuid2\""
+ }
+ return [eval [linsert $args 0 equal]]
+ }
+ default {
+ return -code error "bad option \"$cmd\":\
+ must be generate or equal"
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# LoadAccelerator --
+#
+# This package can make use of a number of compiled extensions to
+# accelerate the digest computation. This procedure manages the
+# use of these extensions within the package. During normal usage
+# this should not be called, but the test package manipulates the
+# list of enabled accelerators.
+#
+proc ::uuid::LoadAccelerator {name} {
+ variable accel
+ set r 0
+ switch -exact -- $name {
+ critcl {
+ if {![catch {package require tcllibc}]} {
+ set r [expr {[info command ::uuid::generate_c] != {}}]
+ }
+ }
+ default {
+ return -code error "invalid accelerator package:\
+ must be one of [join [array names accel] {, }]"
+ }
+ }
+ set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::uuid {
+ foreach e {critcl} { if {[LoadAccelerator $e]} { break } }
+}
+
+package provide uuid $::uuid::version
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+# Starkit setup.
+#
+package require Tcl 8.4
+package require starkit
+if {[starkit::startup] ne "sourced"} {
+ set f [file join $starkit::topdir bin [lindex $argv 0].tcl]
+ if {[file exists $f]} {
+ set argv [lrange $argv 1 end]
+ source $f
+ } else {
+ source [file join $starkit::topdir bin bullfrog.tcl]
+ }
+}
--- /dev/null
+set auto_path [concat [file join [file dirname [info script]] lib] $auto_path]
+if {[lindex $argv 0] eq "irc"} {
+ set argv [lrange $argv 1 end]
+ source [file join [file dirname [info script]] bin irc.tcl]
+} else {
+ source [file join [file dirname [info script]] bin demo.tcl]
+}
--- /dev/null
+CompanyName "Pat Thoyts"
+LegalCopyright "Copyright (c) 2007-2008 Pat Thoyts"
+FileDescription "Bullfrog multi-user chat"
+ProductName "Bullfrog"
+ProductVersion "0.0.2.0"
projects / Bullfrog / commitdiff
