| # xmpp.tcl -- |
| # xmpp.tcl -- |
| # |
| # |
| # This file is part of the XMPP library. It implements the main library |
| # This file is part of the XMPP library. It implements the main library |
| # routines. |
| # routines. |
| # |
| # |
| # Copyright (c) 2008-2010 Sergei Golovan <sgolovan@nes.ru> |
| # Copyright (c) 2008-2010 Sergei Golovan <sgolovan@nes.ru> |
| # |
| # |
| # See the file "license.terms" for information on usage and redistribution |
| # See the file "license.terms" for information on usage and redistribution |
| # of this file, and for a DISCLAMER OF ALL WARRANTIES. |
| # of this file, and for a DISCLAMER OF ALL WARRANTIES. |
| # |
| # |
| # $Id: xmpp.tcl 142 2010-01-29 15:14:25Z sgolovan $ |
| # $Id: xmpp.tcl 142 2010-01-29 15:14:25Z sgolovan $ |
| |
| |
| #
|
| |
| # KG 13-Aug-2010: Added hooks for XML stanza trace callback -xmltracecommand
|
| |
| # KG 20-Sep-2010: Added missing proc ::xmpp::status
|
| |
| #
|
| |
| package require msgcat |
| package require msgcat |
| package require xmpp::jid |
| package require xmpp::jid |
| package require xmpp::xml |
| package require xmpp::xml |
| package require xmpp::transport::tcp |
| package require xmpp::transport::tcp |
| package require xmpp::streamerror |
| package require xmpp::streamerror |
| package require xmpp::stanzaerror |
| package require xmpp::stanzaerror |
| package require xmpp::iq |
| package require xmpp::iq |
| package require xmpp::presence |
| package require xmpp::presence |
| |
| |
| package provide xmpp 0.1 |
| package provide xmpp 0.1 |
| |
| |
| namespace eval ::xmpp { |
| namespace eval ::xmpp { |
| |
| |
| # Default debug level (0: no debug, 1: light debug, 2: heavy debug). |
| # Default debug level (0: no debug, 1: light debug, 2: heavy debug). |
| |
| |
| variable debug 0 |
| variable debug 0 |
| } |
| } |
| |
| |
| # ::xmpp::new -- |
| # ::xmpp::new -- |
| # |
| # |
| # Create a new XMPP token and assigns client callbacks for XMPP events. |
| # Create a new XMPP token and assigns client callbacks for XMPP events. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # token (optional, if missing then token is created |
| # token (optional, if missing then token is created |
| # automatically, if present then it must be a |
| # automatically, if present then it must be a |
| # fully namespaced nonexistent variable) XMPP |
| # fully namespaced nonexistent variable) XMPP |
| # token to create. |
| # token to create. |
| # -packetcommand cmd (optional) Command to call on every incoming |
| # -packetcommand cmd (optional) Command to call on every incoming |
| # XMPP packet except stream errors. |
| # XMPP packet except stream errors. |
| # -messagecommand cmd (optional) Command to call on every XMPP |
| # -messagecommand cmd (optional) Command to call on every XMPP |
| # message packet (overrides -packetCommand). |
| # message packet (overrides -packetCommand). |
| # -presencecommand cmd (optional) Command to call on every XMPP |
| # -presencecommand cmd (optional) Command to call on every XMPP |
| # presence packet (overrides -packetCommand). |
| # presence packet (overrides -packetCommand). |
| # -disconnectcommand cmd (optional) Command to call on forced disconnect |
| # -disconnectcommand cmd (optional) Command to call on forced disconnect |
| # from XMPP server. |
| # from XMPP server. |
| # -statuscommand cmd (optional) Command to call when XMPP connection |
| # -statuscommand cmd (optional) Command to call when XMPP connection |
| # status is changed (e.g. after successful |
| # status is changed (e.g. after successful |
| # authentication). |
| # authentication). |
| # -errorcommand cmd (optional) Command to call on XMPP stream error |
| # -errorcommand cmd (optional) Command to call on XMPP stream error |
| # packet. |
| # packet. |
| # -xmltracecommand cmd (optional) Command to call for each Tx or Rx XML stanza
|
| |
| # |
| # |
| # Result: |
| # Result: |
| # XMPP token name or error if the supplied variable exists or illegal |
| # XMPP token name or error if the supplied variable exists or illegal |
| # option is listed. |
| # option is listed. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # A new variable is created. |
| # A new variable is created. |
| |
| |
| proc ::xmpp::new {args} { |
| proc ::xmpp::new {args} { |
| variable id |
| variable id |
| |
| |
| if {![info exists id]} { |
| if {![info exists id]} { |
| set id 0 |
| set id 0 |
| } |
| } |
| |
| |
| if {[llength $args] > 0 && ![string match -* [lindex $args 0]]} { |
| if {[llength $args] > 0 && ![string match -* [lindex $args 0]]} { |
| set xlib [lindex $args 0] |
| set xlib [lindex $args 0] |
| set args [lrange $args 1 end] |
| set args [lrange $args 1 end] |
| |
| |
| if {[info exists $xlib]} { |
| if {[info exists $xlib]} { |
| return -code error \ |
| return -code error \ |
| [::msgcat::mc "An existing variable \"%s\" cannot be used\ |
| [::msgcat::mc "An existing variable \"%s\" cannot be used\ |
| as an XMPP token" $xlib] |
| as an XMPP token" $xlib] |
| } |
| } |
| } else { |
| } else { |
| set xlib [namespace current]::[incr id] |
| set xlib [namespace current]::[incr id] |
| |
| |
| # Variable id always grows but user may occupy some values |
| # Variable id always grows but user may occupy some values |
| |
| |
| while {[info exists $xlib]} { |
| while {[info exists $xlib]} { |
| set xlib [namespace current]::[incr id] |
| set xlib [namespace current]::[incr id] |
| } |
| } |
| } |
| } |
| |
| |
| foreach {key val} $args { |
| foreach {key val} $args { |
| switch -- $key { |
| switch -- $key { |
| -packetcommand - |
| -packetcommand - |
| -messagecommand - |
| -messagecommand - |
| -presencecommand - |
| -presencecommand - |
| -iqcommand - |
| -iqcommand - |
| -disconnectcommand - |
| -disconnectcommand - |
| -statuscommand - |
| -statuscommand - |
| -errorcommand - |
| -errorcommand - |
| -logcommand - |
| -logcommand { |
| -xmltracecommand {
|
| |
| set attrs($key) $val |
| set attrs($key) $val |
| } |
| } |
| default { |
| default { |
| return -code error [::msgcat::mc "Illegal option \"%s\"" $key] |
| return -code error [::msgcat::mc "Illegal option \"%s\"" $key] |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| array unset state |
| array unset state |
| set state(status) disconnected |
| set state(status) disconnected |
| |
| |
| # A sequence of IQ ids |
| # A sequence of IQ ids |
| set state(id) 0 |
| set state(id) 0 |
| |
| |
| array set state [array get attrs] |
| array set state [array get attrs] |
| |
| |
| if {[info exists state(-messagecommand)]} { |
| if {[info exists state(-messagecommand)]} { |
| RegisterElement $xlib message * \ |
| RegisterElement $xlib message * \ |
| [namespace code [list ParseMessage $xlib]] |
| [namespace code [list ParseMessage $xlib]] |
| } |
| } |
| if {[info exists state(-presencecommand)]} { |
| if {[info exists state(-presencecommand)]} { |
| RegisterElement $xlib presence * \ |
| RegisterElement $xlib presence * \ |
| [namespace code [list ParsePresence $xlib]] |
| [namespace code [list ParsePresence $xlib]] |
| } |
| } |
| if {![info exists state(-packetcommand)] || \ |
| if {![info exists state(-packetcommand)] || \ |
| [info exists state(-iqcommand)]} { |
| [info exists state(-iqcommand)]} { |
| RegisterElement $xlib iq * \ |
| RegisterElement $xlib iq * \ |
| [namespace code [list ParseIQ $xlib]] |
| [namespace code [list ParseIQ $xlib]] |
| } |
| } |
| |
| |
| RegisterElement $xlib error http://etherx.jabber.org/streams \ |
| RegisterElement $xlib error http://etherx.jabber.org/streams \ |
| [namespace code [list ParseStreamError $xlib]] |
| [namespace code [list ParseStreamError $xlib]] |
| RegisterElement $xlib features http://etherx.jabber.org/streams \ |
| RegisterElement $xlib features http://etherx.jabber.org/streams \ |
| [namespace code [list ParseStreamFeatures $xlib]] |
| [namespace code [list ParseStreamFeatures $xlib]] |
| |
| |
| Debug $xlib 2 "" |
| Debug $xlib 2 "" |
| |
| |
| return $xlib |
| return $xlib |
| } |
| } |
| |
| |
| # ::xmpp::free -- |
| # ::xmpp::free -- |
| # |
| # |
| # Destroy an existing XMPP token. |
| # Destroy an existing XMPP token. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token to destroy. |
| # xlib XMPP token to destroy. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string or error if the token is still connected. |
| # Empty string or error if the token is still connected. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # The variable which contains token state is destroyed. |
| # The variable which contains token state is destroyed. |
| |
| |
| proc ::xmpp::free {xlib} { |
| proc ::xmpp::free {xlib} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "" |
| Debug $xlib 2 "" |
| |
| |
| if {![status $xlib disconnected]} { |
| if {![status $xlib disconnected]} { |
| return -code error [::msgcat::mc "Free without disconnect"] |
| return -code error [::msgcat::mc "Free without disconnect"] |
| } |
| } |
| |
| |
| if {[info exists state(-messagecommand)]} { |
| if {[info exists state(-messagecommand)]} { |
| UnregisterElement $xlib message * |
| UnregisterElement $xlib message * |
| } |
| } |
| if {[info exists state(-presencecommand)]} { |
| if {[info exists state(-presencecommand)]} { |
| UnregisterElement $xlib presence * |
| UnregisterElement $xlib presence * |
| } |
| } |
| if {![info exists state(-packetcommand)]} { |
| if {![info exists state(-packetcommand)]} { |
| UnregisterElement $xlib iq * |
| UnregisterElement $xlib iq * |
| } |
| } |
| |
| |
| UnregisterElement $xlib error http://etherx.jabber.org/streams |
| UnregisterElement $xlib error http://etherx.jabber.org/streams |
| UnregisterElement $xlib features http://etherx.jabber.org/streams |
| UnregisterElement $xlib features http://etherx.jabber.org/streams |
| |
| |
| unset state |
| unset state |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::connect -- |
| # ::xmpp::connect -- |
| # |
| # |
| # Connect to XMPP server. |
| # Connect to XMPP server. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # host (optional, defaults to "localhost") Server name |
| # host (optional, defaults to "localhost") Server name |
| # to connect. It isn't used when transport is |
| # to connect. It isn't used when transport is |
| # "poll". |
| # "poll". |
| # port (optional, defaults to 5222) Port to connect. |
| # port (optional, defaults to 5222) Port to connect. |
| # It isn't used for "poll" transport. |
| # It isn't used for "poll" transport. |
| # -transport transport (optional, defaults to "tcp") Transport to use |
| # -transport transport (optional, defaults to "tcp") Transport to use |
| # when connecting to an XMPP server. May be one |
| # when connecting to an XMPP server. May be one |
| # of "tcp", "tls", "poll", "zlib" (though none of |
| # of "tcp", "tls", "poll", "zlib" (though none of |
| # the servers support zlib compressed sockets |
| # the servers support zlib compressed sockets |
| # without prior negotiating). |
| # without prior negotiating). |
| # -command cmd (optional) If present then the connection |
| # -command cmd (optional) If present then the connection |
| # becomes asynchronous and the command is called |
| # becomes asynchronous and the command is called |
| # upon connection success or failure. Otherwise |
| # upon connection success or failure. Otherwise |
| # the connection is in synchronous mode. |
| # the connection is in synchronous mode. |
| # Other arguments are passed unchanged to corresponding transport open |
| # Other arguments are passed unchanged to corresponding transport open |
| # routine. |
| # routine. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string on success or error on failure in synchronous mode. |
| # Empty string on success or error on failure in synchronous mode. |
| # Connection token to make it possible to abort connection in |
| # Connection token to make it possible to abort connection in |
| # asynchronous mode. |
| # asynchronous mode. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # A new connection to an XMPP server is started (or is opened). In |
| # A new connection to an XMPP server is started (or is opened). In |
| # synchronous mode connection status is set to "connected". In |
| # synchronous mode connection status is set to "connected". In |
| # asynchronous mode an abort command is stored to be called if a user |
| # asynchronous mode an abort command is stored to be called if a user |
| # will decide to abort connection procedure. |
| # will decide to abort connection procedure. |
| |
| |
| proc ::xmpp::connect {xlib args} { |
| proc ::xmpp::connect {xlib args} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| if {![string equal $state(status) disconnected]} { |
| if {![string equal $state(status) disconnected]} { |
| # TODO: Should we use ForcedDisconnect or call back? |
| # TODO: Should we use ForcedDisconnect or call back? |
| disconnect $xlib |
| disconnect $xlib |
| } |
| } |
| |
| |
| set transport tcp |
| set transport tcp |
| set host localhost |
| set host localhost |
| set port 5222 |
| set port 5222 |
| set argList {} |
| set argList {} |
| |
| |
| if {![string match -* [lindex $args 0]]} { |
| if {![string match -* [lindex $args 0]]} { |
| set host [lindex $args 0] |
| set host [lindex $args 0] |
| set args [lrange $args 1 end] |
| set args [lrange $args 1 end] |
| } |
| } |
| |
| |
| if {![string match -* [lindex $args 0]]} { |
| if {![string match -* [lindex $args 0]]} { |
| set port [lindex $args 0] |
| set port [lindex $args 0] |
| set args [lrange $args 1 end] |
| set args [lrange $args 1 end] |
| } |
| } |
| |
| |
| foreach {key val} $args { |
| foreach {key val} $args { |
| switch -- $key { |
| switch -- $key { |
| -transport {set transport $val} |
| -transport {set transport $val} |
| -command {set cmd $val} |
| -command {set cmd $val} |
| default {lappend argList $key $val} |
| default {lappend argList $key $val} |
| } |
| } |
| } |
| } |
| |
| |
| Debug $xlib 2 "$host $port $transport" |
| Debug $xlib 2 "$host $port $transport" |
| |
| |
| if {![info exists cmd]} { |
| if {![info exists cmd]} { |
| # TODO: Allow abortions in synchronous mode too. |
| # TODO: Allow abortions in synchronous mode too. |
| |
| |
| # Propagate error (if any) up. |
| # Propagate error (if any) up. |
| set state(transport) \ |
| set state(transport) \ |
| [eval [list transport::open $transport $host $port \ |
| [eval [list transport::open $transport $host $port \ |
| -streamheadercommand \ |
| -streamheadercommand \ |
| [namespace code [list GotStream $xlib ok]] \ |
| [namespace code [list GotStream $xlib ok]] \ |
| -streamtrailercommand \ |
| -streamtrailercommand \ |
| [namespace code [list EndOfParse $xlib]] \ |
| [namespace code [list EndOfParse $xlib]] \ |
| -stanzacommand \ |
| -stanzacommand \ |
| [namespace code [list Parse $xlib]] \ |
| [namespace code [list Parse $xlib]] \ |
| -eofcommand \ |
| -eofcommand \ |
| [namespace code [list EndOfFile $xlib]]] \ |
| [namespace code [list EndOfFile $xlib]]] \ |
| $argList] |
| $argList] |
| |
| |
| set state(status) connected |
| set state(status) connected |
| return |
| return |
| } else { |
| } else { |
| set token \ |
| set token \ |
| [eval [list transport::open $transport $host $port \ |
| [eval [list transport::open $transport $host $port \ |
| -streamheadercommand \ |
| -streamheadercommand \ |
| [namespace code [list GotStream $xlib ok]] \ |
| [namespace code [list GotStream $xlib ok]] \ |
| -streamtrailercommand \ |
| -streamtrailercommand \ |
| [namespace code [list EndOfParse $xlib]] \ |
| [namespace code [list EndOfParse $xlib]] \ |
| -stanzacommand \ |
| -stanzacommand \ |
| [namespace code [list Parse $xlib]] \ |
| [namespace code [list Parse $xlib]] \ |
| -eofcommand \ |
| -eofcommand \ |
| [namespace code [list EndOfFile $xlib]] \ |
| [namespace code [list EndOfFile $xlib]] \ |
| -command \ |
| -command \ |
| [namespace code [list ConnectAux $xlib $cmd]]] \ |
| [namespace code [list ConnectAux $xlib $cmd]]] \ |
| $argList] |
| $argList] |
| |
| |
| set state(abortCommand) \ |
| set state(abortCommand) \ |
| [namespace code [list transport::use $token abort]] |
| [namespace code [list transport::use $token abort]] |
| return $token |
| return $token |
| } |
| } |
| } |
| } |
| |
| |
| # ::xmpp::ConnectAux -- |
| # ::xmpp::ConnectAux -- |
| # |
| # |
| # A helper procedure which calls back with connection to XMPP server |
| # A helper procedure which calls back with connection to XMPP server |
| # result. |
| # result. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # cmd Callback to call. |
| # cmd Callback to call. |
| # status "ok", "error", "abort", or "timeout". |
| # status "ok", "error", "abort", or "timeout". |
| # msg Transport token in case of success or error message in |
| # msg Transport token in case of success or error message in |
| # case of failure. |
| # case of failure. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # A callback is called and a stored abort command is emptied (it is no |
| # A callback is called and a stored abort command is emptied (it is no |
| # longer needed as the connect procedure is finished). |
| # longer needed as the connect procedure is finished). |
| |
| |
| proc ::xmpp::ConnectAux {xlib cmd status msg} { |
| proc ::xmpp::ConnectAux {xlib cmd status msg} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| catch {unset state(abortCommand)} |
| catch {unset state(abortCommand)} |
| |
| |
| if {[string equal $status ok]} { |
| if {[string equal $status ok]} { |
| set state(transport) $msg |
| set state(transport) $msg |
| set state(status) connected |
| set state(status) connected |
| uplevel #0 $cmd [list ok ""] |
| uplevel #0 $cmd [list ok ""] |
| } else { |
| } else { |
| uplevel #0 $cmd [list $status $msg] |
| uplevel #0 $cmd [list $status $msg] |
| } |
| } |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::openStream -- |
| # ::xmpp::openStream -- |
| # |
| # |
| # Open XMPP stream over the already opened connection. |
| # Open XMPP stream over the already opened connection. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # server XMPP server to which the stream is opened. |
| # server XMPP server to which the stream is opened. |
| # -xmlns:stream ns (optional, defaults to |
| # -xmlns:stream ns (optional, defaults to |
| # http://etherx.jabber.org/streams, if present must be |
| # http://etherx.jabber.org/streams, if present must be |
| # http://etherx.jabber.org/streams). XMLNS for stream |
| # http://etherx.jabber.org/streams). XMLNS for stream |
| # prefix. |
| # prefix. |
| # -xmlns xmlns (optional, defaults to jabber:client) Stream default |
| # -xmlns xmlns (optional, defaults to jabber:client) Stream default |
| # XMLNS. |
| # XMLNS. |
| # -xml:lang lang (optional, defaults to language from msgcat |
| # -xml:lang lang (optional, defaults to language from msgcat |
| # preferences) Stream default xml:lang attribute. |
| # preferences) Stream default xml:lang attribute. |
| # -version ver (optional) Stream XMPP version. Must be "1.0" if any |
| # -version ver (optional) Stream XMPP version. Must be "1.0" if any |
| # XMPP feature is used (SASL, STARTTLS, stream |
| # XMPP feature is used (SASL, STARTTLS, stream |
| # compression). |
| # compression). |
| # -timeout num (optional, defaults to 0 which means infinity) Timeout |
| # -timeout num (optional, defaults to 0 which means infinity) Timeout |
| # after which the operation is finished with failure. |
| # after which the operation is finished with failure. |
| # -command cmd (optional) If present then the stream opens in |
| # -command cmd (optional) If present then the stream opens in |
| # asynchronous mode and the command "cmd" is called upon |
| # asynchronous mode and the command "cmd" is called upon |
| # success or failure. Otherwise the mode is synchronous. |
| # success or failure. Otherwise the mode is synchronous. |
| # |
| # |
| # Result: |
| # Result: |
| # The same as in [OpenStreamAux]. |
| # The same as in [OpenStreamAux]. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # The same as in [OpenStreamAux]. Also, server state variable is set. |
| # The same as in [OpenStreamAux]. Also, server state variable is set. |
| |
| |
| proc ::xmpp::openStream {xlib server args} { |
| proc ::xmpp::openStream {xlib server args} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$server $args" |
| Debug $xlib 2 "$server $args" |
| |
| |
| set state(server) $server |
| set state(server) $server |
| |
| |
| eval [list OpenStreamAux $xlib] $args |
| eval [list OpenStreamAux $xlib] $args |
| } |
| } |
| |
| |
| # ::xmpp::ReopenStream -- |
| # ::xmpp::ReopenStream -- |
| # |
| # |
| # Reset underlying XML parser and reopen XMPP stream. This procedure |
| # Reset underlying XML parser and reopen XMPP stream. This procedure |
| # is useful when changing transport (from tcp to tls or zlib) and |
| # is useful when changing transport (from tcp to tls or zlib) and |
| # when resetting stream after SASL authentication. It's never called |
| # when resetting stream after SASL authentication. It's never called |
| # by user directly. |
| # by user directly. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # args Additional arguments to pass to OpenStreamAux. They are |
| # args Additional arguments to pass to OpenStreamAux. They are |
| # the same as for [openStream]. But usually the only |
| # the same as for [openStream]. But usually the only |
| # useful options are -command and -timeout. |
| # useful options are -command and -timeout. |
| # |
| # |
| # Result: |
| # Result: |
| # The same as in [OpenStreamAux]. |
| # The same as in [OpenStreamAux]. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # In addition to [OpenStreamAux] side effects, an XML parser in transport |
| # In addition to [OpenStreamAux] side effects, an XML parser in transport |
| # is reset. |
| # is reset. |
| |
| |
| proc ::xmpp::ReopenStream {xlib args} { |
| proc ::xmpp::ReopenStream {xlib args} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$args" |
| Debug $xlib 2 "$args" |
| |
| |
| transport::use $state(transport) reset |
| transport::use $state(transport) reset |
| |
| |
| # Unset features variable to remove possible trace. |
| # Unset features variable to remove possible trace. |
| array unset state features |
| array unset state features |
| |
| |
| if {[info exists state(-version)]} { |
| if {[info exists state(-version)]} { |
| set vargs [list -version $state(-version)] |
| set vargs [list -version $state(-version)] |
| } else { |
| } else { |
| set vargs {} |
| set vargs {} |
| } |
| } |
| |
| |
| eval [list OpenStreamAux $xlib \ |
| eval [list OpenStreamAux $xlib \ |
| -xmlns:stream $state(-xmlns:stream) \ |
| -xmlns:stream $state(-xmlns:stream) \ |
| -xmlns $state(-xmlns) \ |
| -xmlns $state(-xmlns) \ |
| -xml:lang $state(-xml:lang)] $vargs $args |
| -xml:lang $state(-xml:lang)] $vargs $args |
| } |
| } |
| |
| |
| # ::xmpp::OpenStreamAux -- |
| # ::xmpp::OpenStreamAux -- |
| # |
| # |
| # A helper procedure which contains common code for opening and |
| # A helper procedure which contains common code for opening and |
| # reopening XMPP streams. |
| # reopening XMPP streams. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # The same as for openStream (except server which is taken from state |
| # The same as for openStream (except server which is taken from state |
| # variable). |
| # variable). |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string in asynchronous mode, session id or error in synchronous |
| # Empty string in asynchronous mode, session id or error in synchronous |
| # mode. |
| # mode. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # Stream header is sent to an open channel. An abort command is stored |
| # Stream header is sent to an open channel. An abort command is stored |
| # to be called if a user will decide to abort stream opening procedure. |
| # to be called if a user will decide to abort stream opening procedure. |
| # |
| # |
| # Bugs: |
| # Bugs: |
| # Only stream XMLNS http://etherx.jabber.org/streams is supported. |
| # Only stream XMLNS http://etherx.jabber.org/streams is supported. |
| # On the other hand there's no other defined stream XMLNS currently. |
| # On the other hand there's no other defined stream XMLNS currently. |
| |
| |
| proc ::xmpp::OpenStreamAux {xlib args} { |
| proc ::xmpp::OpenStreamAux {xlib args} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| array set params [list -xmlns:stream http://etherx.jabber.org/streams \ |
| array set params [list -xmlns:stream http://etherx.jabber.org/streams \ |
| -xmlns jabber:client \ |
| -xmlns jabber:client \ |
| -xml:lang [xml::lang]] |
| -xml:lang [xml::lang]] |
| |
| |
| array set state [array get params] |
| array set state [array get params] |
| |
| |
| set timeout 0 |
| set timeout 0 |
| foreach {key val} $args { |
| foreach {key val} $args { |
| switch -- $key { |
| switch -- $key { |
| -xmlns:stream { |
| -xmlns:stream { |
| if {![string equal $val http://etherx.jabber.org/streams]} { |
| if {![string equal $val http://etherx.jabber.org/streams]} { |
| return -code error \ |
| return -code error \ |
| [::msgcat::mc "Unsupported stream XMLNS \"%s\"" \ |
| [::msgcat::mc "Unsupported stream XMLNS \"%s\"" \ |
| $val] |
| $val] |
| } |
| } |
| } |
| } |
| -xmlns - |
| -xmlns - |
| -xml:lang - |
| -xml:lang - |
| -version { |
| -version { |
| set state($key) $val |
| set state($key) $val |
| set params($key) $val |
| set params($key) $val |
| } |
| } |
| -timeout { |
| -timeout { |
| set timeout $val |
| set timeout $val |
| } |
| } |
| -command { |
| -command { |
| set state(openStreamCommand) $val |
| set state(openStreamCommand) $val |
| } |
| } |
| default { |
| default { |
| return -code error [::msgcat::mc "Illegal option \"%s\"" $key] |
| return -code error [::msgcat::mc "Illegal option \"%s\"" $key] |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| |
| if {$timeout > 0} { |
| if {$timeout > 0} { |
| set state(streamAfterId) \ |
| set state(streamAfterId) \ |
| [after $timeout [namespace code [list GotStream $xlib timeout {}]]] |
| [after $timeout [namespace code [list GotStream $xlib timeout {}]]] |
| } |
| } |
| |
| |
| # Stream may be reopened inside STARTTLS, or compression, or SASL |
| # Stream may be reopened inside STARTTLS, or compression, or SASL |
| # procedure, so set abort command only if it isn't defined already. |
| # procedure, so set abort command only if it isn't defined already. |
| |
| |
| if {![info exists state(abortCommand)]} { |
| if {![info exists state(abortCommand)]} { |
| set state(abortCommand) \ |
| set state(abortCommand) \ |
| [namespace code [list GotStream $xlib abort {}]] |
| [namespace code [list GotStream $xlib abort {}]] |
| } |
| } |
| |
| |
| eval [list transport::use $state(transport) openStream $state(server)] \ |
| eval [list transport::use $state(transport) openStream $state(server)] \ |
| [array get params] |
| [array get params] |
| |
| |
| if {[info exists state(openStreamCommand)]} { |
| if {[info exists state(openStreamCommand)]} { |
| # Asynchronous mode |
| # Asynchronous mode |
| return "" |
| return "" |
| } else { |
| } else { |
| # Synchronous mode |
| # Synchronous mode |
| vwait $xlib\(openStatus) |
| vwait $xlib\(openStatus) |
| |
| |
| if {![string equal $state(openStatus) timeout]} { |
| if {![string equal $state(openStatus) timeout]} { |
| return $state(sessionID) |
| return $state(sessionID) |
| } else { |
| } else { |
| return -code error $state(sessionID) |
| return -code error $state(sessionID) |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| |
| # ::xmpp::GotStream -- |
| # ::xmpp::GotStream -- |
| # |
| # |
| # A helper procedure which is invoked when an incoming XMPP stream |
| # A helper procedure which is invoked when an incoming XMPP stream |
| # header is parsed by a transport. It finishes headers exchange. |
| # header is parsed by a transport. It finishes headers exchange. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # status "ok", "abort", or "timeout". |
| # status "ok", "abort", or "timeout". |
| # attrs List of XMPP stream attributes. |
| # attrs List of XMPP stream attributes. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # A callback is called in asynchronous mode or [vwait] is triggered |
| # A callback is called in asynchronous mode or [vwait] is triggered |
| # in synchronous mode. Also, a stored abort command is emptied (it is no |
| # in synchronous mode. Also, a stored abort command is emptied (it is no |
| # longer needed as the connect procedure is finished). |
| # longer needed as the connect procedure is finished). |
| |
| |
| proc ::xmpp::GotStream {xlib status attrs} { |
| proc ::xmpp::GotStream {xlib status attrs} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| if {![info exists state(abortCommand)]} { |
| if {![info exists state(abortCommand)]} { |
| # state(abortCommand) must exist, otherwise it's a stale stream |
| # state(abortCommand) must exist, otherwise it's a stale stream |
| Debug $xlib 2 "Stale stream: $status $attrs" |
| Debug $xlib 2 "Stale stream: $status $attrs" |
| return |
| return |
| } |
| } |
| |
| |
| Debug $xlib 2 "$status $attrs" |
| Debug $xlib 2 "$status $attrs" |
| if {[string equal $status ok]} { |
| if {[string equal $status ok]} { |
| set msg "<stream:stream " |
| set msg "<stream:stream " |
| foreach {attr val} $attrs { |
| foreach {attr val} $attrs { |
| append msg " $attr='[xml::Escape $val]'" |
| append msg " $attr='[xml::Escape $val]'" |
| } |
| } |
| append msg ">" |
| append msg ">" |
| CallBack $xlib log input text $msg |
| CallBack $xlib log input text $msg |
| } |
| } |
| |
| |
| if {[info exists state(openStreamCommand)]} { |
| if {[info exists state(openStreamCommand)]} { |
| set cmd $state(openStreamCommand) |
| set cmd $state(openStreamCommand) |
| unset state(openStreamCommand) |
| unset state(openStreamCommand) |
| } |
| } |
| |
| |
| if {[info exists state(streamAfterId)]} { |
| if {[info exists state(streamAfterId)]} { |
| after cancel $state(streamAfterId) |
| after cancel $state(streamAfterId) |
| unset state(streamAfterId) |
| unset state(streamAfterId) |
| } |
| } |
| |
| |
| # Stream may be reopened inside STARTTLS, or compression, or SASL |
| # Stream may be reopened inside STARTTLS, or compression, or SASL |
| # procedure, so unset abort command only if it was set in [openStream] |
| # procedure, so unset abort command only if it was set in [openStream] |
| |
| |
| if {[string equal $state(abortCommand) \ |
| if {[string equal $state(abortCommand) \ |
| [namespace code [list GotStream $xlib abort {}]]]} { |
| [namespace code [list GotStream $xlib abort {}]]]} { |
| catch {unset state(abortCommand)} |
| catch {unset state(abortCommand)} |
| } |
| } |
| |
| |
| switch -- $status { |
| switch -- $status { |
| timeout { |
| timeout { |
| set state(sessionID) [::msgcat::mc "Opening stream timed out"] |
| set state(sessionID) [::msgcat::mc "Opening stream timed out"] |
| |
| |
| # Trigger vwait in [openStream] in synchronous mode |
| # Trigger vwait in [openStream] in synchronous mode |
| set state(openStatus) $status |
| set state(openStatus) $status |
| |
| |
| if {[info exists cmd]} { |
| if {[info exists cmd]} { |
| # Invoke callback in asynchronous mode |
| # Invoke callback in asynchronous mode |
| uplevel #0 $cmd [list $status $state(sessionID)] |
| uplevel #0 $cmd [list $status $state(sessionID)] |
| } |
| } |
| return |
| return |
| } |
| } |
| abort { |
| abort { |
| set state(sessionID) [::msgcat::mc "Opening stream aborted"] |
| set state(sessionID) [::msgcat::mc "Opening stream aborted"] |
| |
| |
| # Trigger vwait in [openStream] in synchronous mode |
| # Trigger vwait in [openStream] in synchronous mode |
| set state(openStatus) $status |
| set state(openStatus) $status |
| |
| |
| if {[info exists cmd]} { |
| if {[info exists cmd]} { |
| # Invoke callback in asynchronous mode |
| # Invoke callback in asynchronous mode |
| uplevel #0 $cmd [list $status $state(sessionID)] |
| uplevel #0 $cmd [list $status $state(sessionID)] |
| } |
| } |
| return |
| return |
| } |
| } |
| } |
| } |
| |
| |
| if {[xml::isAttr $attrs from]} { |
| if {[xml::isAttr $attrs from]} { |
| # Sometimes server (ejabberd is known to) returns 'from' |
| # Sometimes server (ejabberd is known to) returns 'from' |
| # attribute which differs from 'to' attribute sent to the server. |
| # attribute which differs from 'to' attribute sent to the server. |
| # If XMLNS is 'jabber:component:accept' then the address in 'from' |
| # If XMLNS is 'jabber:component:accept' then the address in 'from' |
| # attribute is ignored. |
| # attribute is ignored. |
| |
| |
| if {![string equal $state(-xmlns) jabber:component:accept]} { |
| if {![string equal $state(-xmlns) jabber:component:accept]} { |
| set state(server) [xml::getAttr $attrs from] |
| set state(server) [xml::getAttr $attrs from] |
| } |
| } |
| } |
| } |
| |
| |
| set version [xml::getAttr $attrs version] |
| set version [xml::getAttr $attrs version] |
| if {![string is double -strict $version]} { |
| if {![string is double -strict $version]} { |
| set version 0.0 |
| set version 0.0 |
| } |
| } |
| |
| |
| set sessionID [xml::getAttr $attrs id] |
| set sessionID [xml::getAttr $attrs id] |
| |
| |
| Debug $xlib 2 "server = $state(server), sessionID = $sessionID,\ |
| Debug $xlib 2 "server = $state(server), sessionID = $sessionID,\ |
| version = $version" |
| version = $version" |
| |
| |
| if {$version < 1.0} { |
| if {$version < 1.0} { |
| # Register iq-auth and iq-register namespaces to allow |
| # Register iq-auth and iq-register namespaces to allow |
| # authenticate and register in-band on pre-XMPP server |
| # authenticate and register in-band on pre-XMPP server |
| ParseStreamFeatures $xlib \ |
| ParseStreamFeatures $xlib \ |
| [xml::create features \ |
| [xml::create features \ |
| -xmlns http://etherx.jabber.org/streams \ |
| -xmlns http://etherx.jabber.org/streams \ |
| -subelement \ |
| -subelement \ |
| [xml::create auth \ |
| [xml::create auth \ |
| -xmlns http://jabber.org/features/iq-auth] \ |
| -xmlns http://jabber.org/features/iq-auth] \ |
| -subelement \ |
| -subelement \ |
| [xml::create register \ |
| [xml::create register \ |
| -xmlns http://jabber.org/features/iq-register]] |
| -xmlns http://jabber.org/features/iq-register]] |
| } |
| } |
| |
| |
| set state(status) streamOpened |
| set state(status) streamOpened |
| |
| |
| set state(sessionID) $sessionID |
| set state(sessionID) $sessionID |
| # Trigger vwait in [openStream] in synchronous mode |
| # Trigger vwait in [openStream] in synchronous mode |
| set state(openStatus) $status |
| set state(openStatus) $status |
| |
| |
| if {[info exists cmd]} { |
| if {[info exists cmd]} { |
| # Invoke callback in asynchronous mode |
| # Invoke callback in asynchronous mode |
| uplevel #0 $cmd [list $status $sessionID] |
| uplevel #0 $cmd [list $status $sessionID] |
| } |
| } |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::ParseStreamFeatures -- |
| # ::xmpp::ParseStreamFeatures -- |
| # |
| # |
| # A helper procedure which is called when stream features are received. |
| # A helper procedure which is called when stream features are received. |
| # It stores features list (as a list of XML elements, because it may be |
| # It stores features list (as a list of XML elements, because it may be |
| # a deep list) in a variable. This procedure is registered as a handler |
| # a deep list) in a variable. This procedure is registered as a handler |
| # for features element in http://etherx.jabber.org/streams XMLNS in |
| # for features element in http://etherx.jabber.org/streams XMLNS in |
| # [new]. |
| # [new]. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # xmlElement Features XML element to store. |
| # xmlElement Features XML element to store. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # Features list is stored in a state variable. |
| # Features list is stored in a state variable. |
| |
| |
| proc ::xmpp::ParseStreamFeatures {xlib xmlElement} { |
| proc ::xmpp::ParseStreamFeatures {xlib xmlElement} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$xmlElement" |
| Debug $xlib 2 "$xmlElement" |
| |
| |
| xml::split $xmlElement tag xmlns attrs cdata subels |
| xml::split $xmlElement tag xmlns attrs cdata subels |
| |
| |
| set state(features) $subels |
| set state(features) $subels |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::TraceStreamFeatures -- |
| # ::xmpp::TraceStreamFeatures -- |
| # |
| # |
| # Call the specified command back if stream features are already |
| # Call the specified command back if stream features are already |
| # received, or set a trace to call the command upon receiving them. |
| # received, or set a trace to call the command upon receiving them. |
| # Trace syntax is old-style to make it work in Tcl 8.3. |
| # Trace syntax is old-style to make it work in Tcl 8.3. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # cmd Command to call. |
| # cmd Command to call. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # If stream features aren't received yet then a trace is added for |
| # If stream features aren't received yet then a trace is added for |
| # variable state(features). |
| # variable state(features). |
| |
| |
| proc ::xmpp::TraceStreamFeatures {xlib cmd} { |
| proc ::xmpp::TraceStreamFeatures {xlib cmd} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| if {[info exists state(features)]} { |
| if {[info exists state(features)]} { |
| after idle $cmd [list $state(features)] |
| after idle $cmd [list $state(features)] |
| } else { |
| } else { |
| # Variable state(features) must not be set outside ParseStreamFeatures, |
| # Variable state(features) must not be set outside ParseStreamFeatures, |
| # to prevent spurious trace callback triggering. |
| # to prevent spurious trace callback triggering. |
| trace variable $xlib\(features) w \ |
| trace variable $xlib\(features) w \ |
| [namespace code [list TraceStreamFeaturesAux $xlib $cmd]] |
| [namespace code [list TraceStreamFeaturesAux $xlib $cmd]] |
| } |
| } |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::TraceStreamFeaturesAux -- |
| # ::xmpp::TraceStreamFeaturesAux -- |
| # |
| # |
| # A helper procedure which is called by a trace of state(features) |
| # A helper procedure which is called by a trace of state(features) |
| # variable. It in turn removes trace and calls a specified command back. |
| # variable. It in turn removes trace and calls a specified command back. |
| # Trace syntax is old-style to make it work in Tcl 8.3. |
| # Trace syntax is old-style to make it work in Tcl 8.3. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # cmd Command to call. |
| # cmd Command to call. |
| # args Arguments, added by trace. |
| # args Arguments, added by trace. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # Trace of state(features) variable is removed. |
| # Trace of state(features) variable is removed. |
| |
| |
| proc ::xmpp::TraceStreamFeaturesAux {xlib cmd args} { |
| proc ::xmpp::TraceStreamFeaturesAux {xlib cmd args} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| RemoveTraceStreamFeatures $xlib $cmd |
| RemoveTraceStreamFeatures $xlib $cmd |
| |
| |
| uplevel #0 $cmd [list $state(features)] |
| uplevel #0 $cmd [list $state(features)] |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::RemoveTraceStreamFeatures -- |
| # ::xmpp::RemoveTraceStreamFeatures -- |
| # |
| # |
| # Remove trace of state(features) variable if it's set. This procedure |
| # Remove trace of state(features) variable if it's set. This procedure |
| # may be called in case if it's needed to abort connection process, or |
| # may be called in case if it's needed to abort connection process, or |
| # in case when stream features are received (see |
| # in case when stream features are received (see |
| # [TraceStreamFeaturesAux]). |
| # [TraceStreamFeaturesAux]). |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # cmd Command that was to be called. |
| # cmd Command that was to be called. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # Trace of state(features) is removed if it was set. |
| # Trace of state(features) is removed if it was set. |
| |
| |
| proc ::xmpp::RemoveTraceStreamFeatures {xlib cmd} { |
| proc ::xmpp::RemoveTraceStreamFeatures {xlib cmd} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| trace vdelete $xlib\(features) w \ |
| trace vdelete $xlib\(features) w \ |
| [namespace code [list TraceStreamFeaturesAux $xlib $cmd]] |
| [namespace code [list TraceStreamFeaturesAux $xlib $cmd]] |
| |
| |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::ParseStreamError -- |
| # ::xmpp::ParseStreamError -- |
| # |
| # |
| # A helper procedure which is called when stream error is received. |
| # A helper procedure which is called when stream error is received. |
| # It calls back error command (-errorcommand option in [new]) with |
| # It calls back error command (-errorcommand option in [new]) with |
| # appended error message. This procedure is registered as a handler |
| # appended error message. This procedure is registered as a handler |
| # for error element in http://etherx.jabber.org/streams XMLNS in [new]. |
| # for error element in http://etherx.jabber.org/streams XMLNS in [new]. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # xmlElement Stream error XML element. |
| # xmlElement Stream error XML element. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # A client error callback is invoked. |
| # A client error callback is invoked. |
| |
| |
| proc ::xmpp::ParseStreamError {xlib xmlElement} { |
| proc ::xmpp::ParseStreamError {xlib xmlElement} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$xmlElement" |
| Debug $xlib 2 "$xmlElement" |
| |
| |
| CallBack $xlib error [streamerror::condition $xmlElement] \ |
| CallBack $xlib error [streamerror::condition $xmlElement] \ |
| [streamerror::message $xmlElement] |
| [streamerror::message $xmlElement] |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::SwitchTransport -- |
| # ::xmpp::SwitchTransport -- |
| # |
| # |
| # Switch XMPP transport. This procedure is helpful if STARTTLS or |
| # Switch XMPP transport. This procedure is helpful if STARTTLS or |
| # stream compression over TCP is used. |
| # stream compression over TCP is used. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # transport Transport name to switch to. |
| # transport Transport name to switch to. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string or error. |
| # Empty string or error. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # Transport is changed if it's possible. |
| # Transport is changed if it's possible. |
| |
| |
| proc ::xmpp::SwitchTransport {xlib transport args} { |
| proc ::xmpp::SwitchTransport {xlib transport args} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$transport" |
| Debug $xlib 2 "$transport" |
| |
| |
| set state(transport) \ |
| set state(transport) \ |
| [eval [list transport::switch $state(transport) $transport] $args] |
| [eval [list transport::switch $state(transport) $transport] $args] |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::outXML -- |
| # ::xmpp::outXML -- |
| # |
| # |
| # Output XML element to an XMPP channel. |
| # Output XML element to an XMPP channel. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # xmlElement XML element to send. |
| # xmlElement XML element to send. |
| # |
| # |
| # Result: |
| # Result: |
| # Length of the sent textual XML representation. |
| # Length of the sent textual XML representation. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # XML element is sent to the server. |
| # XML element is sent to the server. |
| |
| |
| proc ::xmpp::outXML {xlib xmlElement} { |
| proc ::xmpp::outXML {xlib xmlElement} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| set xmlString "[xml::toTabbedText $xmlElement]" |
| Debug $xlib 2 "[xml::toText $xmlElement]" |
| Debug $xlib 2 $xmlString
|
| |
| CallBack $xlib xmltrace TX $xmlString
|
| |
| CallBack $xlib log output xml $xmlElement |
| CallBack $xlib log output xml $xmlElement |
| |
| |
| transport::use $state(transport) outXML $xmlElement |
| transport::use $state(transport) outXML $xmlElement |
| } |
| } |
| |
| |
| # ::xmpp::outText -- |
| # ::xmpp::outText -- |
| # |
| # |
| # Output text string to an XMPP channel. If the text doesn't represent |
| # Output text string to an XMPP channel. If the text doesn't represent |
| # valid XML then server will likely disconnect the XMPP session. |
| # valid XML then server will likely disconnect the XMPP session. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # text Text to send. |
| # text Text to send. |
| # |
| # |
| # Result: |
| # Result: |
| # Length of the sent XML textual representation. |
| # Length of the sent XML textual representation. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # XML element is sent to the server. |
| # XML element is sent to the server. |
| |
| |
| proc ::xmpp::outText {xlib text} { |
| proc ::xmpp::outText {xlib text} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$text" |
| Debug $xlib 2 "$text" |
| CallBack $xlib log output text $text |
| CallBack $xlib log output text $text |
| |
| |
| transport::use $state(transport) outText $text |
| transport::use $state(transport) outText $text |
| } |
| } |
| |
| |
| # ::xmpp::closeStream -- |
| # ::xmpp::closeStream -- |
| # |
| # |
| # Close XMPP stream (usually by sending </stream:stream>). |
| # Close XMPP stream (usually by sending </stream:stream>). |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # |
| # |
| # Result: |
| # Result: |
| # Length of the sent stream trailer. |
| # Length of the sent stream trailer. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # XMPP stream trailer is sent to the server. |
| # XMPP stream trailer is sent to the server. |
| |
| |
| proc ::xmpp::closeStream {xlib} { |
| proc ::xmpp::closeStream {xlib} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| set msg [xml::streamTrailer] |
| set msg [xml::streamTrailer] |
| Debug $xlib 2 "$msg" |
| Debug $xlib 2 "$msg" |
| CallBack $xlib log output text $msg |
| CallBack $xlib log output text $msg |
| |
| |
| transport::use $state(transport) closeStream |
| transport::use $state(transport) closeStream |
| } |
| } |
| |
| |
| # ::xmpp::EndOfParse -- |
| # ::xmpp::EndOfParse -- |
| # |
| # |
| # A callback procedure which is called if end of stream is received from |
| # A callback procedure which is called if end of stream is received from |
| # an XMPP server. If it's intentional (XMPP token is in disconnecting |
| # an XMPP server. If it's intentional (XMPP token is in disconnecting |
| # state) then do nothing, otherwise disconnect. |
| # state) then do nothing, otherwise disconnect. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # In disconnected or disconnecting state none, otherwise ForcedDisconnect |
| # In disconnected or disconnecting state none, otherwise ForcedDisconnect |
| # procedure is called. |
| # procedure is called. |
| |
| |
| proc ::xmpp::EndOfParse {xlib} { |
| proc ::xmpp::EndOfParse {xlib} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "" |
| Debug $xlib 2 "" |
| CallBack $xlib log input text "</stream:stream>" |
| CallBack $xlib log input text "</stream:stream>" |
| |
| |
| switch -- $state(status) { |
| switch -- $state(status) { |
| disconnecting - |
| disconnecting - |
| disconnected {} |
| disconnected {} |
| default { |
| default { |
| ForcedDisconnect $xlib |
| ForcedDisconnect $xlib |
| } |
| } |
| } |
| } |
| |
| |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::EndOfFile -- |
| # ::xmpp::EndOfFile -- |
| # |
| # |
| # A callback procedure which is called if an XMPP server has closed |
| # A callback procedure which is called if an XMPP server has closed |
| # connection. If it's intentional (XMPP token is in disconnecting |
| # connection. If it's intentional (XMPP token is in disconnecting |
| # state) then do nothing, otherwise disconnect. |
| # state) then do nothing, otherwise disconnect. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # In disconnected or disconnecting state none, otherwise ForcedDisconnect |
| # In disconnected or disconnecting state none, otherwise ForcedDisconnect |
| # procedure is called. |
| # procedure is called. |
| |
| |
| proc ::xmpp::EndOfFile {xlib} { |
| proc ::xmpp::EndOfFile {xlib} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "" |
| Debug $xlib 2 "" |
| |
| |
| switch -- $state(status) { |
| switch -- $state(status) { |
| disconnecting - |
| disconnecting - |
| disconnected {} |
| disconnected {} |
| default { |
| default { |
| ForcedDisconnect $xlib |
| ForcedDisconnect $xlib |
| } |
| } |
| } |
| } |
| |
| |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::ForcedDisconnect -- |
| # ::xmpp::ForcedDisconnect -- |
| # |
| # |
| # Disconnect from an XMPP server if this disconnect id forced by the |
| # Disconnect from an XMPP server if this disconnect id forced by the |
| # server itself. |
| # server itself. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # In disconnected or disconnecting state none, otherwise this procedure |
| # In disconnected or disconnecting state none, otherwise this procedure |
| # aborts any pending operation, closes the XMPP channel, calls back |
| # aborts any pending operation, closes the XMPP channel, calls back |
| # "disconnect" client function and clears the token state. |
| # "disconnect" client function and clears the token state. |
| |
| |
| proc ::xmpp::ForcedDisconnect {xlib} { |
| proc ::xmpp::ForcedDisconnect {xlib} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "" |
| Debug $xlib 2 "" |
| |
| |
| switch -- $state(status) { |
| switch -- $state(status) { |
| disconnecting - |
| disconnecting - |
| disconnected {} |
| disconnected {} |
| default { |
| default { |
| set state(status) disconnecting |
| set state(status) disconnecting |
| |
| |
| if {[info exists state(abortCommand)]} { |
| if {[info exists state(abortCommand)]} { |
| uplevel #0 $state(abortCommand) |
| uplevel #0 $state(abortCommand) |
| catch {unset state(abortCommand)} |
| catch {unset state(abortCommand)} |
| } |
| } |
| |
| |
| if {[catch {transport::use $state(transport) close} msg]} { |
| if {[catch {transport::use $state(transport) close} msg]} { |
| Debug $xlib 1 "Closing connection failed: $msg" |
| Debug $xlib 1 "Closing connection failed: $msg" |
| } |
| } |
| catch {unset state(transport)} |
| catch {unset state(transport)} |
| |
| |
| CallBack $xlib disconnect |
| CallBack $xlib disconnect |
| |
| |
| ClearState $xlib |
| ClearState $xlib |
| } |
| } |
| } |
| } |
| |
| |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::disconnect -- |
| # ::xmpp::disconnect -- |
| # |
| # |
| # Disconnect from an XMPP server. |
| # Disconnect from an XMPP server. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # In disconnected or disconnecting state none, otherwise this procedure |
| # In disconnected or disconnecting state none, otherwise this procedure |
| # aborts any pending operation, closes the XMPP stream and channel, and |
| # aborts any pending operation, closes the XMPP stream and channel, and |
| # clears the token state. |
| # clears the token state. |
| |
| |
| proc ::xmpp::disconnect {xlib} { |
| proc ::xmpp::disconnect {xlib} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "" |
| Debug $xlib 2 "" |
| |
| |
| switch -- $state(status) { |
| switch -- $state(status) { |
| disconnecting - |
| disconnecting - |
| disconnected {} |
| disconnected {} |
| default { |
| default { |
| set state(status) disconnecting |
| set state(status) disconnecting |
| |
| |
| if {[info exists state(abortCommand)]} { |
| if {[info exists state(abortCommand)]} { |
| uplevel #0 $state(abortCommand) |
| uplevel #0 $state(abortCommand) |
| catch {unset state(abortCommand)} |
| catch {unset state(abortCommand)} |
| } |
| } |
| |
| |
| if {[catch {closeStream $xlib} msg]} { |
| if {[catch {closeStream $xlib} msg]} { |
| Debug $xlib 1 "Closing stream failed: $msg" |
| Debug $xlib 1 "Closing stream failed: $msg" |
| } |
| } |
| if {[catch {transport::use $state(transport) close} msg]} { |
| if {[catch {transport::use $state(transport) close} msg]} { |
| Debug $xlib 1 "Closing connection failed: $msg" |
| Debug $xlib 1 "Closing connection failed: $msg" |
| } |
| } |
| catch {unset state(transport)} |
| catch {unset state(transport)} |
| |
| |
| ClearState $xlib |
| ClearState $xlib |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| |
| # ::xmpp::ClearState -- |
| # ::xmpp::ClearState -- |
| # |
| # |
| # Clean XMPP token state. |
| # Clean XMPP token state. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # All pending IQ callbacks are called and state array is cleaned up. |
| # All pending IQ callbacks are called and state array is cleaned up. |
| |
| |
| proc ::xmpp::ClearState {xlib} { |
| proc ::xmpp::ClearState {xlib} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "" |
| Debug $xlib 2 "" |
| |
| |
| foreach idx [array names state iq,*] { |
| foreach idx [array names state iq,*] { |
| set cmd $state($idx) |
| set cmd $state($idx) |
| unset state($idx) |
| unset state($idx) |
| |
| |
| uplevel #0 $cmd [list abort \ |
| uplevel #0 $cmd [list abort \ |
| [xml::create error \ |
| [xml::create error \ |
| -cdata [::msgcat::mc "Disconnected"]]] |
| -cdata [::msgcat::mc "Disconnected"]]] |
| } |
| } |
| |
| |
| # Don't reset ID counter because the higher level application may |
| # Don't reset ID counter because the higher level application may |
| # still use the old values. |
| # still use the old values. |
| #set state(id) 0 |
| #set state(id) 0 |
| set state(status) disconnected |
| set state(status) disconnected |
| |
| |
| # connect |
| # connect |
| # This variable is unset in [disconnect] or [ForcedDisconnect] |
| # This variable is unset in [disconnect] or [ForcedDisconnect] |
| #array unset state transport |
| #array unset state transport |
| |
| |
| # openStream |
| # openStream |
| array unset state server |
| array unset state server |
| array unset state -xmlns:stream |
| array unset state -xmlns:stream |
| array unset state -xmlns |
| array unset state -xmlns |
| array unset state -xml:lang |
| array unset state -xml:lang |
| array unset state -version |
| array unset state -version |
| array unset state openStreamCommand |
| array unset state openStreamCommand |
| array unset state streamAfterId |
| array unset state streamAfterId |
| array unset state openStatus |
| array unset state openStatus |
| array unset state sessionID |
| array unset state sessionID |
| |
| |
| # TraceStreamFeatures |
| # TraceStreamFeatures |
| array unset state features |
| array unset state features |
| |
| |
| # various |
| # various |
| array unset state abortCommand |
| array unset state abortCommand |
| |
| |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::RegisterElement -- |
| # ::xmpp::RegisterElement -- |
| # |
| # |
| # Register callback for XMPP top-level stanza in a stream. |
| # Register callback for XMPP top-level stanza in a stream. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # tag XML element tag pattern. |
| # tag XML element tag pattern. |
| # xmlns XMLNS pattern. |
| # xmlns XMLNS pattern. |
| # cmd Command to call when the top-level stanza in XMPP |
| # cmd Command to call when the top-level stanza in XMPP |
| # stream matches tag ans XMLNS patterns. |
| # stream matches tag ans XMLNS patterns. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # Command is pushed to a stack of registered commands for given tag and |
| # Command is pushed to a stack of registered commands for given tag and |
| # XMLNS patterns. |
| # XMLNS patterns. |
| |
| |
| proc ::xmpp::RegisterElement {xlib tag xmlns cmd} { |
| proc ::xmpp::RegisterElement {xlib tag xmlns cmd} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$tag $xmlns $cmd" |
| Debug $xlib 2 "$tag $xmlns $cmd" |
| |
| |
| lappend state(registered,$tag,$xmlns) $cmd |
| lappend state(registered,$tag,$xmlns) $cmd |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::UnregisterElement -- |
| # ::xmpp::UnregisterElement -- |
| # |
| # |
| # Unregister the last callback for XMPP top-level stanza in a stream. |
| # Unregister the last callback for XMPP top-level stanza in a stream. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # tag XML element tag pattern. |
| # tag XML element tag pattern. |
| # xmlns XMLNS pattern. |
| # xmlns XMLNS pattern. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. Error is raised if there wasn't a registered command for |
| # Empty string. Error is raised if there wasn't a registered command for |
| # specified tag ans XMLNS patterns. |
| # specified tag ans XMLNS patterns. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # The last registered command is popped from a stack of registered |
| # The last registered command is popped from a stack of registered |
| # commands for given tag and XMLNS patterns. |
| # commands for given tag and XMLNS patterns. |
| |
| |
| proc ::xmpp::UnregisterElement {xlib tag xmlns} { |
| proc ::xmpp::UnregisterElement {xlib tag xmlns} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$tag $xmlns" |
| Debug $xlib 2 "$tag $xmlns" |
| |
| |
| set state(registered,$tag,$xmlns) \ |
| set state(registered,$tag,$xmlns) \ |
| [lreplace $state(registered,$tag,$xmlns) end end] |
| [lreplace $state(registered,$tag,$xmlns) end end] |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::ElementCommand -- |
| # ::xmpp::ElementCommand -- |
| # |
| # |
| # Return the last registerd command for XMPP top-level stanza. |
| # Return the last registerd command for XMPP top-level stanza. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # tag XML element tag. |
| # tag XML element tag. |
| # xmlns XMLNS. |
| # xmlns XMLNS. |
| # |
| # |
| # Result: |
| # Result: |
| # Command which was registered for specified tag and XMLNS if any. |
| # Command which was registered for specified tag and XMLNS if any. |
| # Otherwise a command which was registered for patterns which match tag |
| # Otherwise a command which was registered for patterns which match tag |
| # and XMLNS if any. Otherwise an empty string. |
| # and XMLNS if any. Otherwise an empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # None. |
| # None. |
| |
| |
| proc ::xmpp::ElementCommand {xlib tag xmlns} { |
| proc ::xmpp::ElementCommand {xlib tag xmlns} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| # If there's an exact match, return it |
| # If there's an exact match, return it |
| if {[info exists state(registered,$tag,$xmlns)]} { |
| if {[info exists state(registered,$tag,$xmlns)]} { |
| return [lindex $state(registered,$tag,$xmlns) end] |
| return [lindex $state(registered,$tag,$xmlns) end] |
| } |
| } |
| |
| |
| # Otherwise find matching indices |
| # Otherwise find matching indices |
| foreach idx [lsort [array names state registered,*]] { |
| foreach idx [lsort [array names state registered,*]] { |
| set fields [split $idx ,] |
| set fields [split $idx ,] |
| set ptag [lindex $fields 1] |
| set ptag [lindex $fields 1] |
| set pxmlns [join [lrange $fields 2 end] ,] |
| set pxmlns [join [lrange $fields 2 end] ,] |
| |
| |
| if {[string match $ptag $tag] && [string match $pxmlns $xmlns]} { |
| if {[string match $ptag $tag] && [string match $pxmlns $xmlns]} { |
| return [lindex $state($idx) end] |
| return [lindex $state($idx) end] |
| } |
| } |
| } |
| } |
| |
| |
| # There's no matches |
| # There's no matches |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::Parse -- |
| # ::xmpp::Parse -- |
| # |
| # |
| # A callback procedure which is called when a top-level XMPP stanza is |
| # A callback procedure which is called when a top-level XMPP stanza is |
| # received. It in turn calls a procedure which parses and processes the |
| # received. It in turn calls a procedure which parses and processes the |
| # stanza. |
| # stanza. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token |
| # xlib XMPP token |
| # xmlElement Top-level XML stanza. |
| # xmlElement Top-level XML stanza. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # A registered command for the xmlElement tag and XMLNS is called if any, |
| # A registered command for the xmlElement tag and XMLNS is called if any, |
| # or general "packet" callback is invoked. |
| # or general "packet" callback is invoked. |
| |
| |
| proc ::xmpp::Parse {xlib xmlElement} { |
| proc ::xmpp::Parse {xlib xmlElement} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$xmlElement" |
| Debug $xlib 2 "$xmlElement" |
| CallBack $xlib xmltrace RX "[xml::toTabbedText $xmlElement]"
|
| |
| CallBack $xlib log input xml $xmlElement |
| CallBack $xlib log input xml $xmlElement |
| |
| |
| if {![info exists state(transport)]} { |
| if {![info exists state(transport)]} { |
| Debug $xlib 1 "Connection doesn't exist" |
| Debug $xlib 1 "Connection doesn't exist" |
| return -1 |
| return -1 |
| } |
| } |
| |
| |
| xml::split $xmlElement tag xmlns attrs cdata subels |
| xml::split $xmlElement tag xmlns attrs cdata subels |
| |
| |
| set cmd [ElementCommand $xlib $tag $xmlns] |
| set cmd [ElementCommand $xlib $tag $xmlns] |
| if {![string equal $cmd ""]} { |
| if {![string equal $cmd ""]} { |
| uplevel #0 $cmd [list $xmlElement] |
| uplevel #0 $cmd [list $xmlElement] |
| return |
| return |
| } |
| } |
| |
| |
| CallBack $xlib packet $xmlElement |
| CallBack $xlib packet $xmlElement |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::ParseMessage -- |
| # ::xmpp::ParseMessage -- |
| # |
| # |
| # Parse XMPP message and invoke "message" client callback. The callback |
| # Parse XMPP message and invoke "message" client callback. The callback |
| # must take the following arguments: |
| # must take the following arguments: |
| # (Mandatory) |
| # (Mandatory) |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # from From JID. |
| # from From JID. |
| # type Message type ("", "error", "normal", "chat", |
| # type Message type ("", "error", "normal", "chat", |
| # "groupchat", "headline"). |
| # "groupchat", "headline"). |
| # x Extra subelements (attachments). |
| # x Extra subelements (attachments). |
| # (Optional) |
| # (Optional) |
| # -x keypairs Key-valus pairs of extra attributes. |
| # -x keypairs Key-valus pairs of extra attributes. |
| # -lang lang xml:lang |
| # -lang lang xml:lang |
| # -to to To JID (usually own JID). |
| # -to to To JID (usually own JID). |
| # -id id Stanza ID (string). |
| # -id id Stanza ID (string). |
| # -subject subject Message subject (string). |
| # -subject subject Message subject (string). |
| # -thread thread Message thread (string). |
| # -thread thread Message thread (string). |
| # -body body Message body (string). |
| # -body body Message body (string). |
| # -error error Error stanza (XML element). |
| # -error error Error stanza (XML element). |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token |
| # xlib XMPP token |
| # xmlElement XMPP <message/> stanza. |
| # xmlElement XMPP <message/> stanza. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # A message callback is called if defined. |
| # A message callback is called if defined. |
| |
| |
| proc ::xmpp::ParseMessage {xlib xmlElement} { |
| proc ::xmpp::ParseMessage {xlib xmlElement} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| xml::split $xmlElement tag xmlns attrs cdata subels |
| xml::split $xmlElement tag xmlns attrs cdata subels |
| |
| |
| set from "" |
| set from "" |
| set type "" |
| set type "" |
| set x {} |
| set x {} |
| set params {} |
| set params {} |
| set xparam {} |
| set xparam {} |
| |
| |
| foreach {key val} $attrs { |
| foreach {key val} $attrs { |
| switch -- $key { |
| switch -- $key { |
| from {set from $val} |
| from {set from $val} |
| type { |
| type { |
| switch -- $val { |
| switch -- $val { |
| chat - |
| chat - |
| error - |
| error - |
| groupchat - |
| groupchat - |
| headline - |
| headline - |
| normal { |
| normal { |
| set type $val |
| set type $val |
| } |
| } |
| default { |
| default { |
| Debug $xlib 1 \ |
| Debug $xlib 1 \ |
| [::msgcat::mc "Unknown message type %s" $val] |
| [::msgcat::mc "Unknown message type %s" $val] |
| } |
| } |
| } |
| } |
| } |
| } |
| xml:lang {lappend params -lang $val} |
| xml:lang {lappend params -lang $val} |
| to {lappend params -to $val} |
| to {lappend params -to $val} |
| id {lappend params -id $val} |
| id {lappend params -id $val} |
| default {lappend xparam $key $val} |
| default {lappend xparam $key $val} |
| } |
| } |
| } |
| } |
| |
| |
| foreach subel $subels { |
| foreach subel $subels { |
| xml::split $subel stag sxmlns sattrs scdata ssubels |
| xml::split $subel stag sxmlns sattrs scdata ssubels |
| |
| |
| switch -- $stag { |
| switch -- $stag { |
| subject {lappend params -subject $scdata} |
| subject {lappend params -subject $scdata} |
| thread {lappend params -thread $scdata} |
| thread {lappend params -thread $scdata} |
| body {lappend params -body $scdata} |
| body {lappend params -body $scdata} |
| error {lappend params -error $subel} |
| error {lappend params -error $subel} |
| default {lappend x $subel} |
| default {lappend x $subel} |
| } |
| } |
| } |
| } |
| |
| |
| eval [list CallBack $xlib message $from $type $x -x $xparam] $params |
| eval [list CallBack $xlib message $from $type $x -x $xparam] $params |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::ParsePresence -- |
| # ::xmpp::ParsePresence -- |
| # |
| # |
| # Parse XMPP presence and invoke "presence" client callback. The callback |
| # Parse XMPP presence and invoke "presence" client callback. The callback |
| # must take the following arguments: |
| # must take the following arguments: |
| # (Mandatory) |
| # (Mandatory) |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # from From JID. |
| # from From JID. |
| # type Presence type ("", "error", "unavailable", |
| # type Presence type ("", "error", "unavailable", |
| # "probe", "subscribe", "subscribed", |
| # "probe", "subscribe", "subscribed", |
| # "unsubscribe", "unsubscribed"). |
| # "unsubscribe", "unsubscribed"). |
| # x Extra subelements (attachments). |
| # x Extra subelements (attachments). |
| # (Optional) |
| # (Optional) |
| # -x keypairs Key-valus pairs of extra attributes. |
| # -x keypairs Key-valus pairs of extra attributes. |
| # -lang lang xml:lang |
| # -lang lang xml:lang |
| # -to to To JID (usually own JID). |
| # -to to To JID (usually own JID). |
| # -id id Stanza ID (string). |
| # -id id Stanza ID (string). |
| # -priority priority Presence priority (number). |
| # -priority priority Presence priority (number). |
| # -show show Presence status (missing, "away", "chat", |
| # -show show Presence status (missing, "away", "chat", |
| # "dnd", "xa"). |
| # "dnd", "xa"). |
| # -status status Presence extended status (string). |
| # -status status Presence extended status (string). |
| # -error error Error stanza (XML element). |
| # -error error Error stanza (XML element). |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token |
| # xlib XMPP token |
| # xmlElement XMPP <presence/> stanza. |
| # xmlElement XMPP <presence/> stanza. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # A presence callback is called if defined. |
| # A presence callback is called if defined. |
| |
| |
| proc ::xmpp::ParsePresence {xlib xmlElement} { |
| proc ::xmpp::ParsePresence {xlib xmlElement} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| xml::split $xmlElement tag xmlns attrs cdata subels |
| xml::split $xmlElement tag xmlns attrs cdata subels |
| |
| |
| set from "" |
| set from "" |
| set type "" |
| set type "" |
| set x {} |
| set x {} |
| set params {} |
| set params {} |
| set xparam {} |
| set xparam {} |
| |
| |
| foreach {key val} $attrs { |
| foreach {key val} $attrs { |
| switch -- $key { |
| switch -- $key { |
| from {set from $val} |
| from {set from $val} |
| type {set type $val} |
| type {set type $val} |
| xml:lang {lappend params -lang $val} |
| xml:lang {lappend params -lang $val} |
| to {lappend params -to $val} |
| to {lappend params -to $val} |
| id {lappend params -id $val} |
| id {lappend params -id $val} |
| default {lappend xparam $key $val} |
| default {lappend xparam $key $val} |
| } |
| } |
| } |
| } |
| |
| |
| foreach subel $subels { |
| foreach subel $subels { |
| xml::split $subel stag sxmlns sattrs scdata ssubels |
| xml::split $subel stag sxmlns sattrs scdata ssubels |
| |
| |
| switch $stag { |
| switch $stag { |
| priority { |
| priority { |
| if {[string is integer -strict $scdata]} { |
| if {[string is integer -strict $scdata]} { |
| lappend params -priority $scdata |
| lappend params -priority $scdata |
| } |
| } |
| } |
| } |
| show { |
| show { |
| switch -- $scdata { |
| switch -- $scdata { |
| away - |
| away - |
| chat - |
| chat - |
| dnd - |
| dnd - |
| xa { |
| xa { |
| lappend params -show $scdata |
| lappend params -show $scdata |
| } |
| } |
| } |
| } |
| } |
| } |
| status {lappend params -status $scdata} |
| status {lappend params -status $scdata} |
| error {lappend params -error $subel} |
| error {lappend params -error $subel} |
| default {lappend x $subel} |
| default {lappend x $subel} |
| } |
| } |
| } |
| } |
| |
| |
| # Evaluate client callback |
| # Evaluate client callback |
| eval [list CallBack $xlib presence $from $type $x -x $xparam] $params |
| eval [list CallBack $xlib presence $from $type $x -x $xparam] $params |
| |
| |
| # Evaluate internal (or otherwise registered) callbacks |
| # Evaluate internal (or otherwise registered) callbacks |
| eval [list presence::process $xlib $from $type $x -x $xparam] $params |
| eval [list presence::process $xlib $from $type $x -x $xparam] $params |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::ParseIQ -- |
| # ::xmpp::ParseIQ -- |
| # |
| # |
| # Parse XMPP IQ. For get or set IQ type invoke [iq::process] command |
| # Parse XMPP IQ. For get or set IQ type invoke [iq::process] command |
| # which will find and invoke the corresponding handler. For result or |
| # which will find and invoke the corresponding handler. For result or |
| # error IQ type find and call the callback stored in [sendIQ]. |
| # error IQ type find and call the callback stored in [sendIQ]. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token |
| # xlib XMPP token |
| # xmlElement XMPP <iq/> stanza. |
| # xmlElement XMPP <iq/> stanza. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # An IQ handler or the callback specified when IQ was sent is called if |
| # An IQ handler or the callback specified when IQ was sent is called if |
| # defined. |
| # defined. |
| |
| |
| proc ::xmpp::ParseIQ {xlib xmlElement} { |
| proc ::xmpp::ParseIQ {xlib xmlElement} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 $xmlElement |
| Debug $xlib 2 $xmlElement |
| |
| |
| xml::split $xmlElement tag xmlns attrs cdata subels |
| xml::split $xmlElement tag xmlns attrs cdata subels |
| |
| |
| set to "" |
| set to "" |
| set from "" |
| set from "" |
| set type "" |
| set type "" |
| set id "" |
| set id "" |
| set x {} |
| set x {} |
| set params {} |
| set params {} |
| set xparam {} |
| set xparam {} |
| |
| |
| foreach {key val} $attrs { |
| foreach {key val} $attrs { |
| switch -- $key { |
| switch -- $key { |
| from {set from $val} |
| from {set from $val} |
| type {set type $val} |
| type {set type $val} |
| xml:lang {lappend params -lang $val} |
| xml:lang {lappend params -lang $val} |
| to { |
| to { |
| set to $val |
| set to $val |
| lappend params -to $val |
| lappend params -to $val |
| } |
| } |
| id { |
| id { |
| set id $val |
| set id $val |
| lappend params -id $val |
| lappend params -id $val |
| } |
| } |
| default {lappend xparam $key $val} |
| default {lappend xparam $key $val} |
| } |
| } |
| } |
| } |
| |
| |
| # Any IQ. |
| # Any IQ. |
| eval [list CallBack $xlib iq $from $type $subels -x $xparam] $params |
| eval [list CallBack $xlib iq $from $type $subels -x $xparam] $params |
| |
| |
| switch -- $type { |
| switch -- $type { |
| get - |
| get - |
| set { |
| set { |
| # Registered IQ. |
| # Registered IQ. |
| eval [list iq::process $xlib $from $type \ |
| eval [list iq::process $xlib $from $type \ |
| [lindex $subels 0]] $params |
| [lindex $subels 0]] $params |
| return |
| return |
| } |
| } |
| result { |
| result { |
| if {[info exists state(iq,$id)]} { |
| if {[info exists state(iq,$id)]} { |
| set cmd $state(iq,$id) |
| set cmd $state(iq,$id) |
| unset state(iq,$id) |
| unset state(iq,$id) |
| |
| |
| uplevel #0 $cmd [list ok [lindex $subels 0]] |
| uplevel #0 $cmd [list ok [lindex $subels 0]] |
| } else { |
| } else { |
| Debug $xlib 1 \ |
| Debug $xlib 1 \ |
| [::msgcat::mc "IQ id %s doesn't exist in memory" $id] |
| [::msgcat::mc "IQ id %s doesn't exist in memory" $id] |
| } |
| } |
| return |
| return |
| } |
| } |
| error { |
| error { |
| if {[info exists state(iq,$id)]} { |
| if {[info exists state(iq,$id)]} { |
| set cmd $state(iq,$id) |
| set cmd $state(iq,$id) |
| unset state(iq,$id) |
| unset state(iq,$id) |
| |
| |
| set error {} |
| set error {} |
| foreach subel $subels { |
| foreach subel $subels { |
| xml::split $subel stag sxmlns sattrs scdata ssubels |
| xml::split $subel stag sxmlns sattrs scdata ssubels |
| if {[string equal $stag error]} { |
| if {[string equal $stag error]} { |
| set error $subel |
| set error $subel |
| break |
| break |
| } |
| } |
| } |
| } |
| |
| |
| uplevel #0 $cmd [list error $error] |
| uplevel #0 $cmd [list error $error] |
| } else { |
| } else { |
| Debug $xlib 1 \ |
| Debug $xlib 1 \ |
| [::msgcat::mc "IQ id %s doesn't exist in memory" $id] |
| [::msgcat::mc "IQ id %s doesn't exist in memory" $id] |
| } |
| } |
| return |
| return |
| } |
| } |
| default { |
| default { |
| Debug $xlib 1 [::msgcat::mc "Unknown IQ type \"%s\"" $type] |
| Debug $xlib 1 [::msgcat::mc "Unknown IQ type \"%s\"" $type] |
| return |
| return |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| |
| # ::xmpp::sendMessage -- |
| # ::xmpp::sendMessage -- |
| # |
| # |
| # Send XMPP message. |
| # Send XMPP message. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # to JID to send message to. |
| # to JID to send message to. |
| # -from from From attribute (it's usually overwritten by server) |
| # -from from From attribute (it's usually overwritten by server) |
| # -type type Message type ("", "normal", "chat", "groupchat", |
| # -type type Message type ("", "normal", "chat", "groupchat", |
| # "headline", "error"). |
| # "headline", "error"). |
| # -id id Stanza ID. |
| # -id id Stanza ID. |
| # -subject subj Message subject. |
| # -subject subj Message subject. |
| # -thread thread Message thread. |
| # -thread thread Message thread. |
| # -body body Message body. |
| # -body body Message body. |
| # -error error Error stanza. |
| # -error error Error stanza. |
| # -xlist elements List of attachments. |
| # -xlist elements List of attachments. |
| # |
| # |
| # Result: |
| # Result: |
| # Length of sent textual representation of message stanza. If negative |
| # Length of sent textual representation of message stanza. If negative |
| # then the operation is failed. |
| # then the operation is failed. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # Presence stanza is set to a server. |
| # Presence stanza is set to a server. |
| |
| |
| proc ::xmpp::sendMessage {xlib to args} { |
| proc ::xmpp::sendMessage {xlib to args} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$to $args" |
| Debug $xlib 2 "$to $args" |
| |
| |
| if {![info exists state(transport)]} { |
| if {![info exists state(transport)]} { |
| Debug $xlib 1 "Connection doesn't exist" |
| Debug $xlib 1 "Connection doesn't exist" |
| return -1 |
| return -1 |
| } |
| } |
| |
| |
| set attrs(to) $to |
| set attrs(to) $to |
| set attrs(xml:lang) [xml::lang] |
| set attrs(xml:lang) [xml::lang] |
| set subelements {} |
| set subelements {} |
| |
| |
| foreach {key val} $args { |
| foreach {key val} $args { |
| switch -- $key { |
| switch -- $key { |
| -from {set attrs(from) $val} |
| -from {set attrs(from) $val} |
| -type {set attrs(type) $val} |
| -type {set attrs(type) $val} |
| -id {set attrs(id) $val} |
| -id {set attrs(id) $val} |
| -subject {lappend subelements [xml::create subject -cdata $val]} |
| -subject {lappend subelements [xml::create subject -cdata $val]} |
| -thread {lappend subelements [xml::create thread -cdata $val]} |
| -thread {lappend subelements [xml::create thread -cdata $val]} |
| -body {lappend subelements [xml::create body -cdata $val]} |
| -body {lappend subelements [xml::create body -cdata $val]} |
| -error {lappend subelements $val} |
| -error {lappend subelements $val} |
| -xlist { |
| -xlist { |
| foreach x $val { |
| foreach x $val { |
| lappend subelements $x |
| lappend subelements $x |
| } |
| } |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| |
| set data [xml::create message -attrs [array get attrs] \ |
| set data [xml::create message -attrs [array get attrs] \ |
| -subelements $subelements] |
| -subelements $subelements] |
| return [outXML $xlib $data] |
| return [outXML $xlib $data] |
| } |
| } |
| |
| |
| # ::xmpp::sendPresence -- |
| # ::xmpp::sendPresence -- |
| # |
| # |
| # Send XMPP presence. |
| # Send XMPP presence. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # -from from From attribute (it's usually overwritten by server) |
| # -from from From attribute (it's usually overwritten by server) |
| # -to to JID to send message to. |
| # -to to JID to send message to. |
| # -type type Presence type (missing, "unavailable", "probe", |
| # -type type Presence type (missing, "unavailable", "probe", |
| # "subscribe", "subscribed", "unsubscribe", |
| # "subscribe", "subscribed", "unsubscribe", |
| # "unsubscribed", "error"). |
| # "unsubscribed", "error"). |
| # -id id Stanza ID. |
| # -id id Stanza ID. |
| # -show show Presence status (missing, "chat", "away", "xa", "dnd"). |
| # -show show Presence status (missing, "chat", "away", "xa", "dnd"). |
| # -status status Presence extended status. |
| # -status status Presence extended status. |
| # -priority prio Presence priority (-128 <= prio <= 127). |
| # -priority prio Presence priority (-128 <= prio <= 127). |
| # -error error Error stanza. |
| # -error error Error stanza. |
| # -xlist elements List of attachments. |
| # -xlist elements List of attachments. |
| # |
| # |
| # Result: |
| # Result: |
| # Length of sent textual representation of presence stanza. If negative |
| # Length of sent textual representation of presence stanza. If negative |
| # then the operation is failed. |
| # then the operation is failed. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # Presence stanza is set to a server. |
| # Presence stanza is set to a server. |
| |
| |
| proc ::xmpp::sendPresence {xlib args} { |
| proc ::xmpp::sendPresence {xlib args} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$args" |
| Debug $xlib 2 "$args" |
| |
| |
| if {![info exists state(transport)]} { |
| if {![info exists state(transport)]} { |
| Debug $xlib 1 "Connection doesn't exist" |
| Debug $xlib 1 "Connection doesn't exist" |
| return -1 |
| return -1 |
| } |
| } |
| |
| |
| set attrs(xml:lang) [xml::lang] |
| set attrs(xml:lang) [xml::lang] |
| set subelements {} |
| set subelements {} |
| |
| |
| foreach {key val} $args { |
| foreach {key val} $args { |
| switch -- $key { |
| switch -- $key { |
| -from {set attrs(from) $val} |
| -from {set attrs(from) $val} |
| -to {set attrs(to) $val} |
| -to {set attrs(to) $val} |
| -type {set attrs(type) $val} |
| -type {set attrs(type) $val} |
| -id {set attrs(id) $val} |
| -id {set attrs(id) $val} |
| -show {lappend subelements [xml::create show -cdata $val]} |
| -show {lappend subelements [xml::create show -cdata $val]} |
| -status {lappend subelements [xml::create status -cdata $val]} |
| -status {lappend subelements [xml::create status -cdata $val]} |
| -priority {lappend subelements [xml::create priority -cdata $val]} |
| -priority {lappend subelements [xml::create priority -cdata $val]} |
| -error {lappend subelements $val} |
| -error {lappend subelements $val} |
| -xlist { |
| -xlist { |
| foreach x $val { |
| foreach x $val { |
| lappend subelements $x |
| lappend subelements $x |
| } |
| } |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| |
| set data [xml::create presence -attrs [array get attrs] \ |
| set data [xml::create presence -attrs [array get attrs] \ |
| -subelements $subelements] |
| -subelements $subelements] |
| return [outXML $xlib $data] |
| return [outXML $xlib $data] |
| } |
| } |
| |
| |
| # ::xmpp::sendIQ -- |
| # ::xmpp::sendIQ -- |
| # |
| # |
| # Send XMPP IQ. |
| # Send XMPP IQ. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # type IQ type ("get", "set", "result", "error"). |
| # type IQ type ("get", "set", "result", "error"). |
| # -from from From attribute (it's usually overwritten by server) |
| # -from from From attribute (it's usually overwritten by server) |
| # -to to JID to send message to. |
| # -to to JID to send message to. |
| # -id id Stanza ID. |
| # -id id Stanza ID. |
| # -command Command to call when the result IQ will be received. |
| # -command Command to call when the result IQ will be received. |
| # This option is allowed for "get" and "set" types only. |
| # This option is allowed for "get" and "set" types only. |
| # -timeout num Timeout for waiting an answer (in milliseconds). |
| # -timeout num Timeout for waiting an answer (in milliseconds). |
| # -query query Query stanza. |
| # -query query Query stanza. |
| # -error error Error stanza. |
| # -error error Error stanza. |
| # |
| # |
| # Result: |
| # Result: |
| # Id of the sent stanza. |
| # Id of the sent stanza. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # IQ stanza is set to a server. If it's a "get" or "set" stanza then |
| # IQ stanza is set to a server. If it's a "get" or "set" stanza then |
| # depending on -command and -timeout options the command is stored for |
| # depending on -command and -timeout options the command is stored for |
| # calling it back later, and the IQ abortion is scheduled. |
| # calling it back later, and the IQ abortion is scheduled. |
| |
| |
| |
| |
| proc ::xmpp::sendIQ {xlib type args} { |
| proc ::xmpp::sendIQ {xlib type args} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$type $args" |
| Debug $xlib 2 "$type $args" |
| |
| |
| switch -- $type { |
| switch -- $type { |
| get - |
| get - |
| set { |
| set { |
| set attrs(type) $type |
| set attrs(type) $type |
| set getset 1 |
| set getset 1 |
| } |
| } |
| result - |
| result - |
| error { |
| error { |
| set attrs(type) $type |
| set attrs(type) $type |
| set getset 0 |
| set getset 0 |
| } |
| } |
| default { |
| default { |
| set attrs(type) get |
| set attrs(type) get |
| set getset 1 |
| set getset 1 |
| } |
| } |
| } |
| } |
| |
| |
| set attrs(xml:lang) [xml::lang] |
| set attrs(xml:lang) [xml::lang] |
| set subelements {} |
| set subelements {} |
| |
| |
| set timeout 0 |
| set timeout 0 |
| |
| |
| foreach {key val} $args { |
| foreach {key val} $args { |
| switch -- $key { |
| switch -- $key { |
| -from {set attrs(from) $val} |
| -from {set attrs(from) $val} |
| -to { |
| -to { |
| if {![string equal $val ""]} { |
| if {![string equal $val ""]} { |
| set attrs(to) $val |
| set attrs(to) $val |
| } |
| } |
| } |
| } |
| -id { |
| -id { |
| # Option -command takes precedence over -id |
| # Option -command takes precedence over -id |
| if {![info exists attrs(id)] || ![info exists cmd]} { |
| if {![info exists attrs(id)] || ![info exists cmd]} { |
| set attrs(id) $val |
| set attrs(id) $val |
| } |
| } |
| } |
| } |
| -command { |
| -command { |
| # Option -command makes sense for get or set IQs only |
| # Option -command makes sense for get or set IQs only |
| if {!$getset} { |
| if {!$getset} { |
| return -code error \ |
| return -code error \ |
| [::msgcat::mc "Option \"-command\" is illegal for\ |
| [::msgcat::mc "Option \"-command\" is illegal for\ |
| IQ type \"%s\"" $attrs(type)] |
| IQ type \"%s\"" $attrs(type)] |
| } |
| } |
| |
| |
| # Only the last -command takes effect |
| # Only the last -command takes effect |
| if {![info exists attrs(id)] || ![info exists cmd]} { |
| if {![info exists attrs(id)] || ![info exists cmd]} { |
| set attrs(id) [packetID $xlib] |
| set attrs(id) [packetID $xlib] |
| } |
| } |
| set cmd $val |
| set cmd $val |
| } |
| } |
| -timeout { |
| -timeout { |
| if {$val > 0} { |
| if {$val > 0} { |
| set timeout $val |
| set timeout $val |
| } |
| } |
| } |
| } |
| -query - |
| -query - |
| -error {lappend subelements $val} |
| -error {lappend subelements $val} |
| } |
| } |
| } |
| } |
| |
| |
| if {![info exists state(transport)]} { |
| if {![info exists state(transport)]} { |
| Debug $xlib 1 "Connection doesn't exist" |
| Debug $xlib 1 "Connection doesn't exist" |
| if {[info exists cmd]} { |
| if {[info exists cmd]} { |
| uplevel #0 $cmd [list abort \ |
| uplevel #0 $cmd [list abort \ |
| [xml::create error \ |
| [xml::create error \ |
| -cdata [::msgcat::mc "Disconnected"]]] |
| -cdata [::msgcat::mc "Disconnected"]]] |
| } |
| } |
| return |
| return |
| } |
| } |
| |
| |
| if {[info exists cmd]} { |
| if {[info exists cmd]} { |
| set state(iq,$attrs(id)) $cmd |
| set state(iq,$attrs(id)) $cmd |
| if {$timeout > 0} { |
| if {$timeout > 0} { |
| after $timeout \ |
| after $timeout \ |
| [namespace code [list abortIQ $xlib $attrs(id) timeout \ |
| [namespace code [list abortIQ $xlib $attrs(id) timeout \ |
| [xml::create error \ |
| [xml::create error \ |
| -cdata [::msgcat::mc "IQ %s timed out" \ |
| -cdata [::msgcat::mc "IQ %s timed out" \ |
| $attrs(id)]]]] |
| $attrs(id)]]]] |
| } |
| } |
| } |
| } |
| |
| |
| set data [xml::create iq -attrs [array get attrs] \ |
| set data [xml::create iq -attrs [array get attrs] \ |
| -subelements $subelements] |
| -subelements $subelements] |
| |
| |
| set res [outXML $xlib $data] |
| set res [outXML $xlib $data] |
| |
| |
| if {[info exists cmd] && $res < 0} { |
| if {[info exists cmd] && $res < 0} { |
| after idle \ |
| after idle \ |
| [namespace code [list abortIQ $xlib $attrs(id) abort \ |
| [namespace code [list abortIQ $xlib $attrs(id) abort \ |
| [xml::create error \ |
| [xml::create error \ |
| -cdata [::msgcat::mc \ |
| -cdata [::msgcat::mc \ |
| "Disconnected"]]]] |
| "Disconnected"]]]] |
| } |
| } |
| |
| |
| if {$getset && [info exists attrs(id)]} { |
| if {$getset && [info exists attrs(id)]} { |
| return $attrs(id) |
| return $attrs(id) |
| } else { |
| } else { |
| return |
| return |
| } |
| } |
| } |
| } |
| |
| |
| # ::xmpp::abortIQ -- |
| # ::xmpp::abortIQ -- |
| # |
| # |
| # Abort a pending IQ request and call its pending command with a |
| # Abort a pending IQ request and call its pending command with a |
| # specified status. |
| # specified status. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # id IQ identity attribute. |
| # id IQ identity attribute. |
| # status "ok", "abort", "timeout", or "error". |
| # status "ok", "abort", "timeout", or "error". |
| # error Error XML stanza. (If status is "ok" then error must be |
| # error Error XML stanza. (If status is "ok" then error must be |
| # a result stanza). |
| # a result stanza). |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # Side effects from the called command. |
| # Side effects from the called command. |
| |
| |
| proc ::xmpp::abortIQ {xlib id status error} { |
| proc ::xmpp::abortIQ {xlib id status error} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$id" |
| Debug $xlib 2 "$id" |
| |
| |
| if {[info exists state(iq,$id)]} { |
| if {[info exists state(iq,$id)]} { |
| set cmd $state(iq,$id) |
| set cmd $state(iq,$id) |
| unset state(iq,$id) |
| unset state(iq,$id) |
| |
| |
| uplevel #0 $cmd [list $status $error] |
| uplevel #0 $cmd [list $status $error] |
| } else { |
| } else { |
| Debug $xlib 1 [::msgcat::mc "IQ id %s doesn't exist in memory" $id] |
| Debug $xlib 1 [::msgcat::mc "IQ id %s doesn't exist in memory" $id] |
| } |
| } |
| |
| |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::packetID -- |
| # ::xmpp::packetID -- |
| # |
| # |
| # Return the next free packet ID. |
| # Return the next free packet ID. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # |
| # |
| # Result: |
| # Result: |
| # Packet ID. |
| # Packet ID. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # The next ID value is increased by one. |
| # The next ID value is increased by one. |
| |
| |
| proc ::xmpp::packetID {xlib} { |
| proc ::xmpp::packetID {xlib} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| return [incr state(id)]:[expr {round(rand()*1000000)}] |
| return [incr state(id)]:[expr {round(rand()*1000000)}] |
| } |
| } |
| |
| |
| # ::xmpp::CallBack -- |
| # ::xmpp::CallBack -- |
| # |
| # |
| # Call a client callback procedure if it was defined in [new]. |
| # Call a client callback procedure if it was defined in [new]. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # command Callback type. |
| # command Callback type. |
| # args Arguments for callback. |
| # args Arguments for callback. |
| # |
| # |
| # Result: |
| # Result: |
| # Callback return code and value: |
| # Callback return code and value: |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # Side effects from the callback. |
| # Side effects from the callback. |
| |
| |
| proc ::xmpp::CallBack {xlib command args} { |
| proc ::xmpp::CallBack {xlib command args} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "$command" |
| Debug $xlib 2 "$command" |
| |
| |
| set cmd -${command}command |
| set cmd -${command}command |
| |
| |
| if {[info exists state($cmd)]} { |
| if {[info exists state($cmd)]} { |
| set code [catch {uplevel #0 $state($cmd) [list $xlib] $args} msg] |
| set code [catch {uplevel #0 $state($cmd) [list $xlib] $args} msg] |
| return -code $code -errorinfo $::errorInfo $msg |
| return -code $code -errorinfo $::errorInfo $msg |
| } else { |
| } else { |
| return |
| return |
| } |
| } |
| } |
| } |
| |
| |
| # ::xmpp::Set -- |
| # ::xmpp::Set -- |
| # |
| # |
| # Set the specified XMPP token property or get it value. |
| # Set the specified XMPP token property or get it value. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # property Property to set or get. |
| # property Property to set or get. |
| # value (optional) If present then state variable is set. |
| # value (optional) If present then state variable is set. |
| # If missing then its value is returned. |
| # If missing then its value is returned. |
| # |
| # |
| # Result: |
| # Result: |
| # Value of a corresponding state variable. |
| # Value of a corresponding state variable. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # If value is present then variable state($property) is set. |
| # If value is present then variable state($property) is set. |
| |
| |
| proc ::xmpp::Set {xlib property args} { |
| proc ::xmpp::Set {xlib property args} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| switch -- [llength $args] { |
| switch -- [llength $args] { |
| 0 { |
| 0 { |
| return $state($property) |
| return $state($property) |
| } |
| } |
| 1 { |
| 1 { |
| return [set state($property) [lindex $args 0]] |
| return [set state($property) [lindex $args 0]] |
| } |
| } |
| default { |
| default { |
| return -code error \ |
| return -code error \ |
| [::msgcat::mc "Usage: ::xmpp::Set xlib property ?value?"] |
| [::msgcat::mc "Usage: ::xmpp::Set xlib property ?value?"] |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| |
| # ::xmpp::Unset -- |
| # ::xmpp::Unset -- |
| # |
| # |
| # Unset the specified XMPP token property. |
| # Unset the specified XMPP token property. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # property Property to unset. |
| # property Property to unset. |
| # |
| # |
| # Result: |
| # Result: |
| # Empty string. |
| # Empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # Variable state($property) is unset. |
| # Variable state($property) is unset. |
| |
| |
| |
| |
| proc ::xmpp::Unset {xlib property} { |
| proc ::xmpp::Unset {xlib property} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| catch {unset state($property)} |
| catch {unset state($property)} |
| return |
| return |
| } |
| } |
| |
| |
| # ::xmpp::ip -- |
| # ::xmpp::ip -- |
| # |
| # |
| # Return IP of low level TCP socket. |
| # Return IP of low level TCP socket. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # |
| # |
| # Result: |
| # Result: |
| # Socket IP or empty string. |
| # Socket IP or empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # None. |
| # None. |
| |
| |
| proc ::xmpp::ip {xlib} { |
| proc ::xmpp::ip {xlib} { |
| variable $xlib |
| variable $xlib |
| upvar 0 $xlib state |
| upvar 0 $xlib state |
| |
| |
| Debug $xlib 2 "" |
| Debug $xlib 2 "" |
| |
| |
| return [transport::use $state(transport) ip] |
| return [transport::use $state(transport) ip] |
| } |
| } |
| |
| |
| # ::xmpp::Debug -- |
| # ::xmpp::Debug -- |
| # |
| # |
| # Prints debug information. |
| # Prints debug information. |
| # |
| # |
| # Arguments: |
| # Arguments: |
| # xlib XMPP token. |
| # xlib XMPP token. |
| # level A debug level. |
| # level A debug level. |
| # str A debug message. |
| # str A debug message. |
| # |
| # |
| # Result: |
| # Result: |
| # An empty string. |
| # An empty string. |
| # |
| # |
| # Side effects: |
| # Side effects: |
| # A debug message is printed to the console if the value of |
| # A debug message is printed to the console if the value of |
| # ::xmpp::debug variable is not less than num. |
| # ::xmpp::debug variable is not less than num. |
| |
| |
| proc ::xmpp::Debug {xlib level str} { |
| proc ::xmpp::Debug {xlib level str} { |
| variable debug |
| variable debug |
| |
| |
| if {$debug >= $level} { |
| if {$debug >= $level} { |
| puts "[clock format [clock seconds] -format %T]\ |
| puts "[clock format [clock seconds] -format %T]\ |
| [lindex [info level -1] 0] $xlib $str" |
| [lindex [info level -1] 0] $xlib $str" |
| } |
| } |
| |
| |
| return |
| return |
| }
|
| |
|
|
| |
| # ::xmpp::status --
|
| |
| #
|
| |
| # Checks if the status is as expected.
|
| |
| #
|
| |
| # Arguments:
|
| |
| # xlib XMPP token.
|
| |
| # expectedState One of: connected, disconnected
|
| |
| #
|
| |
| # Result:
|
| |
| # 1 if the status matches the expected value, 0 if not
|
| |
| #
|
| |
| # Side effects:
|
| |
| # none
|
| |
| #
|
| |
| proc ::xmpp::status {xlib expectedState} {
|
| |
| upvar 0 $xlib state
|
| |
|
|
| |
| return [string equal -nocase "$state(status)" "$expectedState"]
|
| |
| } |
| } |
| |
| |
| # vim:ts=8:sw=4:sts=4:et |
| # vim:ts=8:sw=4:sts=4:et |
| |
| |