1# jabberlib.tcl --
2#
3#       This is the main part of the jabber lib, a Tcl library for interacting
4#       with jabber servers. The core parts are known under the name XMPP.
5#
6# Copyright (c) 2001-2007  Mats Bengtsson
7#
8# This file is distributed under BSD style license.
9#
10# $Id: jabberlib.tcl,v 1.199 2008-06-09 14:24:46 matben Exp $
11#
12# Error checking is minimal, and we assume that all clients are to be trusted.
13#
14# News: the transport mechanism shall be completely configurable, but where
15#       the standard mechanism (put directly to socket) is included here.
16#
17# Variables used in JabberLib:
18#
19# lib:
20#	lib(wrap)                  : Wrap ID
21#       lib(clientcmd)             : Callback proc up to the client
22#	lib(sock)                  : socket name
23#	lib(streamcmd)             : Callback command to run when the <stream>
24#	                             tag is received from the server.
25#
26# iqcmd:
27#	iqcmd(uid)                 : Next iq id-number. Sent in
28#                                    "id" attributes of <iq> packets.
29#	iqcmd($id)                 : Callback command to run when iq result
30#	                             packet of $id is received.
31#
32# locals:
33#       locals(server)             : The servers logical name (streams 'from')
34#       locals(username)
35#       locals(myjid)
36#       locals(myjid2)
37#
38############################# SCHEMA ###########################################
39#
40#   TclXML <---> wrapper <---> jabberlib <---> client
41#                                 |
42#                             jlib::roster
43#                             jlib::disco
44#                             jlib::muc
45#                               ...
46#
47#   Most jlib-packages are self-registered and are invoked using ensamble (sub)
48#   commands.
49#
50############################# USAGE ############################################
51#
52#   NAME
53#      jabberlib - an interface between Jabber clients and the wrapper
54#
55#   SYNOPSIS
56#      jlib::new clientCmd ?-opt value ...?
57#      jlib::havesasl
58#      jlib::havetls
59#
60#   OPTIONS
61#	-iqcommand            callback for <iq> elements not handled explicitly
62#	-messagecommand       callback for <message> elements
63#	-presencecommand      callback for <presence> elements
64#	-streamnamespace      initialization namespace (D = "jabber:client")
65#	-keepalivesecs        send a newline character with this interval
66#	-autoawaymins         if > 0 send away message after this many minutes
67#	-xautoawaymins        if > 0 send xaway message after this many minutes
68#	-awaymsg              the away message
69#	-xawaymsg             the xaway message
70#	-autodiscocaps        0|1 should presence caps elements be auto discoed
71#
72#   INSTANCE COMMANDS
73#      jlibName config ?args?
74#      jlibName openstream server ?args?
75#      jlibName closestream
76#      jlibName element_deregister xmlns func
77#      jlibName element_register xmlns func ?seq?
78#      jlibName getstreamattr name
79#      jlibName get_feature name
80#      jlibName get_last to cmd
81#      jlibName get_time to cmd
82#      jlibName getserver
83#      jlibName get_version to cmd
84#      jlibName getrecipientjid jid
85#      jlibName get_registered_presence_stanzas ?tag? ?xmlns?
86#      jlibName iq_get xmlns ?-to, -command, -sublists?
87#      jlibName iq_set xmlns ?-to, -command, -sublists?
88#      jlibName iq_register type xmlns cmd
89#      jlibName message_register xmlns cmd
90#      jlibName myjid
91#      jlibName myjid2
92#      jlibName myjidmap
93#      jlibName myjid2map
94#      jlibName mypresence
95#      jlibName oob_set to cmd url ?args?
96#      jlibName presence_register type cmd
97#      jlibName registertransport name initProc sendProc resetProc ipProc
98#      jlibName register_set username password cmd ?args?
99#      jlibName register_get cmd ?args?
100#      jlibName register_presence_stanza elem
101#      jlibName register_remove to cmd ?args?
102#      jlibName resetstream
103#      jlibName schedule_auto_away
104#      jlibName search_get to cmd
105#      jlibName search_set to cmd ?args?
106#      jlibName send_iq type xmldata ?args?
107#      jlibName send_message to ?args?
108#      jlibName send_presence ?args?
109#      jlibName send_auth username resource ?args?
110#      jlibName send xmllist
111#      jlibName setsockettransport socket
112#      jlibName state
113#      jlibName transport
114#      jlibName deregister_presence_stanza tag xmlns
115#
116#
117#   The callbacks given for any of the '-iqcommand', '-messagecommand',
118#   or '-presencecommand' must have the following form:
119#
120#      tclProc {jlibname xmldata}
121#
122#   where 'type' is the type attribute valid for each specific element, and
123#   'args' is a list of '-key value' pairs. The '-iqcommand' returns a boolean
124#   telling if any 'get' is handled or not. If not, then a "Not Implemented" is
125#   returned automatically.
126#
127#   The clientCmd procedure must have the following form:
128#
129#      clientCmd {jlibName what args}
130#
131#   where 'what' can be any of: connect, disconnect, xmlerror,
132#   version, networkerror, ....
133#   'args' is a list of '-key value' pairs.
134#
135#   @@@ TODO:
136#
137#      1) Rewrite from scratch and deliver complete iq, message, and presence
138#      elements to callbacks. Callbacks then get attributes like 'from' etc
139#      using accessor functions.
140#
141#      2) Cleanup all the presence code.
142#
143#-------------------------------------------------------------------------------
144
145# @@@ TODO: change package names to jlib::*
146
147package require wrapper
148package require service
149package require stanzaerror
150package require streamerror
151package require groupchat
152package require jlib::util
153
154package provide jlib 2.0
155
156
157namespace eval jlib {
158
159    # Globals same for all instances of this jlib.
160    #    > 1 prints raw xml I/O
161    #    > 2 prints a lot more
162    variable debug 0
163    if {[info exists ::debugLevel] && ($::debugLevel > 1) && ($debug == 0)} {
164	set debug 2
165    }
166
167    variable statics
168    set statics(inited) 0
169    set statics(presenceTypeExp)  \
170      {(available|unavailable|subscribe|unsubscribe|subscribed|unsubscribed|invisible|probe)}
171    set statics(instanceCmds) [list]
172
173    variable version 1.0
174
175    # Running number.
176    variable uid 0
177
178    # Let jlib components register themselves for subcommands, ensamble,
179    # so that they can be invoked by: jlibname subcommand ...
180    variable ensamble
181
182    # Some common xmpp xml namespaces.
183    variable xmppxmlns
184    array set xmppxmlns {
185	stream      "http://etherx.jabber.org/streams"
186	streams     "urn:ietf:params:xml:ns:xmpp-streams"
187	tls         "urn:ietf:params:xml:ns:xmpp-tls"
188	sasl        "urn:ietf:params:xml:ns:xmpp-sasl"
189	bind        "urn:ietf:params:xml:ns:xmpp-bind"
190	stanzas     "urn:ietf:params:xml:ns:xmpp-stanzas"
191	session     "urn:ietf:params:xml:ns:xmpp-session"
192    }
193
194    variable jxmlns
195    array set jxmlns {
196	amp             "http://jabber.org/protocol/amp"
197	caps            "http://jabber.org/protocol/caps"
198	compress        "http://jabber.org/features/compress"
199	disco           "http://jabber.org/protocol/disco"
200	disco,items     "http://jabber.org/protocol/disco#items"
201	disco,info      "http://jabber.org/protocol/disco#info"
202	ibb             "http://jabber.org/protocol/ibb"
203	muc             "http://jabber.org/protocol/muc"
204	muc,user        "http://jabber.org/protocol/muc#user"
205	muc,admin       "http://jabber.org/protocol/muc#admin"
206	muc,owner       "http://jabber.org/protocol/muc#owner"
207	pubsub          "http://jabber.org/protocol/pubsub"
208    }
209
210    set jxmlns(entitytime) "urn:xmpp:time"
211    set jxmlns(time) "jabber:iq:time"
212    set jxmlns(last) "jabber:iq:last"
213
214    # Auto away and extended away are only set when the
215    # current status has a lower priority than away or xa respectively.
216    # After an idea by Zbigniew Baniewski.
217    variable statusPriority
218    array set statusPriority {
219	chat            1
220	available       2
221	away            3
222	xa              4
223	dnd             5
224	invisible       6
225	unavailable     7
226    }
227}
228
229proc jlib::getxmlns {name} {
230    variable xmppxmlns
231    variable jxmlns
232
233    if {[info exists xmppxmlns($name)]} {
234	return $xmppxmlns($name)
235    } elseif {[info exists xmppxmlns($name)]} {
236	return $jxmlns($name)
237    } else {
238	return -code error "unknown xmlns for $name"
239    }
240}
241
242# jlib::register_instance --
243#
244#       Packages can register here to get notified when a new jlib instance is
245#       created.
246
247proc jlib::register_instance {cmd} {
248    variable statics
249
250    lappend statics(instanceCmds) $cmd
251}
252
253# jlib::new --
254#
255#       This creates a new instance jlib interpreter.
256#
257# Arguments:
258#       clientcmd:  callback procedure for the client
259#       args:
260#	-iqcommand
261#	-messagecommand
262#	-presencecommand
263#	-streamnamespace
264#	-keepalivesecs
265#	-autoawaymins
266#	-xautoawaymins
267#	-awaymsg
268#	-xawaymsg
269#	-autodiscocaps
270#
271# Results:
272#       jlibname which is the namespaced instance command
273
274proc jlib::new {clientcmd args} {
275
276    variable jxmlns
277    variable statics
278    variable objectmap
279    variable uid
280    variable ensamble
281
282    # Generate unique command token for this jlib instance.
283    # Fully qualified!
284    set jlibname [namespace current]::jlib[incr uid]
285
286    # Instance specific namespace.
287    namespace eval $jlibname {
288	variable lib
289	variable locals
290	variable iqcmd
291	variable iqhook
292	variable msghook
293	variable preshook
294	variable genhook
295	variable opts
296	variable pres
297	variable features
298    }
299
300    # Set simpler variable names.
301    upvar ${jlibname}::lib      lib
302    upvar ${jlibname}::iqcmd    iqcmd
303    upvar ${jlibname}::prescmd  prescmd
304    upvar ${jlibname}::msgcmd   msgcmd
305    upvar ${jlibname}::opts     opts
306    upvar ${jlibname}::locals   locals
307    upvar ${jlibname}::features features
308
309    array set opts {
310	-iqcommand            ""
311	-messagecommand       ""
312	-presencecommand      ""
313	-streamnamespace      "jabber:client"
314	-keepalivesecs        60
315	-autoawaymins         0
316	-xautoawaymins        0
317	-awaymsg              ""
318	-xawaymsg             ""
319	-autodiscocaps        0
320    }
321
322    # Verify options.
323    eval verify_options $jlibname $args
324
325    if {!$statics(inited)} {
326	init
327    }
328
329    set wrapper [wrapper::new [list [namespace current]::got_stream $jlibname] \
330      [list [namespace current]::end_of_parse $jlibname]  \
331      [list [namespace current]::dispatcher $jlibname]    \
332      [list [namespace current]::xmlerror $jlibname]]
333
334    set iqcmd(uid)   1001
335    set prescmd(uid) 1001
336    set msgcmd(uid)  1001
337    set lib(clientcmd)      $clientcmd
338    set lib(async_handler)  ""
339    set lib(wrap)           $wrapper
340    set lib(resetCmds)      [list]
341
342    set lib(isinstream) 0
343    set lib(state)      ""
344    set lib(transport,name) ""
345
346    set lib(socketfilter,out) [list]
347    set lib(socketfilter,in)  [list]
348
349    set lib(tee,send) [list]
350    set lib(tee,recv) [list]
351
352    init_inst $jlibname
353
354    # Init groupchat state.
355    groupchat::init $jlibname
356
357    # Register some standard iq handlers that are handled internally.
358    iq_register $jlibname get $jxmlns(last)    \
359      [namespace current]::handle_get_last
360    iq_register $jlibname get $jxmlns(time)    \
361      [namespace current]::handle_get_time
362    # This overrides any client handler which is bad.
363    #iq_register $jlibname get jabber:iq:version \
364    #  [namespace current]::handle_get_version
365
366    iq_register $jlibname get $jxmlns(entitytime) \
367      [namespace current]::handle_entity_time
368
369    # Create the actual jlib instance procedure.
370    proc $jlibname {cmd args}   \
371      "eval jlib::cmdproc {$jlibname} \$cmd \$args"
372
373    # Init the service layer for this jlib instance.
374    service::init $jlibname
375
376    # Init ensamble commands.
377    foreach {- name} [array get ensamble *,name] {
378	uplevel #0 $ensamble($name,init) $jlibname
379    }
380
381    return $jlibname
382}
383
384# jlib::init --
385#
386#       Static initializations.
387
388proc jlib::init {} {
389    variable statics
390
391    if {[catch {package require jlibsasl}]} {
392	set statics(sasl) 0
393    } else {
394	set statics(sasl) 1
395	sasl_init
396    }
397    if {[catch {package require jlibtls}]} {
398	set statics(tls) 0
399    } else {
400	set statics(tls) 1
401    }
402
403    set statics(inited) 1
404}
405
406# jlib::init_inst --
407#
408#       Instance specific initializations.
409
410proc jlib::init_inst {jlibname} {
411
412    upvar ${jlibname}::locals   locals
413    upvar ${jlibname}::features features
414
415    # Any of {available chat away xa dnd invisible unavailable}
416    set locals(status)        "unavailable"
417    set locals(pres,type)     "unavailable"
418    set locals(myjid)         ""
419    set locals(myjid2)        ""
420    set locals(myjidmap)      ""
421    set locals(myjid2map)     ""
422    set locals(trigAutoAway)  1
423    set locals(server)        ""
424    set locals(servermap)     ""
425
426    set features(trace) [list]
427}
428
429# jlib::havesasl --
430#
431#       Cache this info for effectiveness. It is needed at application level.
432
433proc jlib::havesasl {} {
434    variable statics
435
436    if {![info exists statics(sasl)]} {
437	if {[catch {package require jlibsasl}]} {
438	    set statics(sasl) 0
439	} else {
440	    set statics(sasl) 1
441	}
442    }
443    return $statics(sasl)
444}
445
446# jlib::havetls --
447#
448#       Cache this info for effectiveness. It is needed at application level.
449
450proc jlib::havetls {} {
451    variable statics
452
453    if {![info exists statics(tls)]} {
454	if {[catch {package require jlibtls}]} {
455	    set statics(tls) 0
456	} else {
457	    set statics(tls) 1
458	}
459    }
460    return $statics(tls)
461}
462
463proc jlib::havecompress {} {
464    variable statics
465
466    if {![info exists statics(compress)]} {
467	if {[catch {package require jlib::compress}]} {
468	    set statics(compress) 0
469	} else {
470	    set statics(compress) 1
471	}
472    }
473    return $statics(compress)
474}
475
476# jlib::register_package --
477#
478#       This is supposed to be a method for jlib::* packages to register
479#       themself just so we know they are there. So far only for the 'roster'.
480
481proc jlib::register_package {name} {
482    variable statics
483
484    set statics($name) 1
485}
486
487# jlib::ensamble_register --
488#
489#       Register a sub command.
490#       This is then used as: 'jlibName subCmd ...'
491
492proc jlib::ensamble_register {name initProc cmdProc} {
493    variable statics
494    variable ensamble
495
496    set ensamble($name,name) $name
497    set ensamble($name,init) $initProc
498    set ensamble($name,cmd)  $cmdProc
499
500    # Must call the initProc for already existing jlib instances.
501    if {$statics(inited)} {
502	foreach jlibname [namespace children ::jlib jlib*] {
503	    uplevel #0 $initProc $jlibname
504	}
505    }
506}
507
508proc jlib::ensamble_deregister {name} {
509    variable ensamble
510
511    array unset ensamble ${name},*
512}
513
514# jlib::cmdproc --
515#
516#       Just dispatches the command to the right procedure.
517#
518# Arguments:
519#       jlibname:   the instance of this jlib.
520#       cmd:        openstream - closestream - send_iq - send_message ... etc.
521#       args:       all args to the cmd procedure.
522#
523# Results:
524#       none.
525
526proc jlib::cmdproc {jlibname cmd args} {
527    variable ensamble
528
529    # Which command? Just dispatch the command to the right procedure.
530    if {[info exists ensamble($cmd,cmd)]} {
531	return [uplevel #0 $ensamble($cmd,cmd) $jlibname $args]
532    } else {
533	return [eval {$cmd $jlibname} $args]
534    }
535}
536
537# jlib::config --
538#
539#	See documentaion for details.
540#
541# Arguments:
542#	args		Options parsed by the procedure.
543#
544# Results:
545#       depending on args.
546
547proc jlib::config {jlibname args} {
548    variable ensamble
549    upvar ${jlibname}::opts opts
550
551    set options [lsort [array names opts -*]]
552    set usage [join $options ", "]
553    if {[llength $args] == 0} {
554	set result [list]
555	foreach name $options {
556	    lappend result $name $opts($name)
557	}
558	return $result
559    }
560    regsub -all -- - $options {} options
561    set pat ^-([join $options |])$
562    if {[llength $args] == 1} {
563	set flag [lindex $args 0]
564	if {[regexp -- $pat $flag]} {
565	    return $opts($flag)
566	} else {
567	    return -code error "Unknown option $flag, must be: $usage"
568	}
569    } else {
570	array set argsA $args
571
572	# Reschedule auto away only if changed. Before setting new opts!
573	# Better to use 'tk inactive' or 'tkinactive' and handle this on
574	# application level.
575	if {[info exists argsA(-autoawaymins)] &&  \
576	  ($argsA(-autoawaymins) != $opts(-autoawaymins))} {
577	    schedule_auto_away $jlibname
578	}
579	if {[info exists argsA(-xautoawaymins)] &&  \
580	  ($argsA(-xautoawaymins) != $opts(-xautoawaymins))} {
581	    schedule_auto_away $jlibname
582	}
583	foreach {flag value} $args {
584	    if {[regexp -- $pat $flag]} {
585		set opts($flag) $value
586	    } else {
587		return -code error "Unknown option $flag, must be: $usage"
588	    }
589	}
590    }
591
592    # Let components configure themselves.
593    # @@@ It is better to let components handle this???
594    foreach ename [array names ensamble] {
595	set ecmd ${ename}::configure
596	if {[llength [info commands $ecmd]]} {
597	    #uplevel #0 $ecmd $jlibname $args
598	}
599    }
600
601    return
602}
603
604# jlib::verify_options
605#
606#	Check if valid options and set them.
607#
608# Arguments
609#
610#	args    The argument list given on the call.
611#
612# Side Effects
613#	Sets error
614
615proc jlib::verify_options {jlibname args} {
616
617    upvar ${jlibname}::opts opts
618
619    set validopts [array names opts]
620    set usage [join $validopts ", "]
621    regsub -all -- - $validopts {} theopts
622    set pat ^-([join $theopts |])$
623    foreach {flag value} $args {
624	if {[regexp $pat $flag]} {
625
626	    # Validate numbers
627	    if {[info exists opts($flag)] && \
628	      [string is integer -strict $opts($flag)] && \
629	      ![string is integer -strict $value]} {
630		return -code error "Bad value for $flag ($value), must be integer"
631	    }
632	    set opts($flag) $value
633	} else {
634	    return -code error "Unknown option $flag, can be: $usage"
635	}
636    }
637}
638
639# jlib::state --
640#
641#       Accesor for the internal 'state'.
642
643proc jlib::state {jlibname} {
644
645    upvar ${jlibname}::lib lib
646
647    return $lib(state)
648}
649
650# jlib::register_reset --
651#
652#       Packages can register here to get notified when the jlib stream is reset.
653
654proc jlib::register_reset {jlibname cmd} {
655
656    upvar ${jlibname}::lib lib
657
658    lappend lib(resetCmds) $cmd
659}
660
661# jlib::registertransport --
662#
663#       We must have a transport mechanism for our xml. Socket is standard but
664#       http is also possible.
665
666proc jlib::registertransport {jlibname name initProc sendProc resetProc ipProc} {
667
668    upvar ${jlibname}::lib lib
669
670    set lib(transport,name)  $name
671    set lib(transport,init)  $initProc
672    set lib(transport,send)  $sendProc
673    set lib(transport,reset) $resetProc
674    set lib(transport,ip)    $ipProc
675}
676
677proc jlib::transport {jlibname} {
678
679    upvar ${jlibname}::lib lib
680
681    return $lib(transport,name)
682}
683
684# jlib::setsockettransport --
685#
686#       Sets the standard socket transport and the actual socket to use.
687
688proc jlib::setsockettransport {jlibname sock} {
689
690    upvar ${jlibname}::lib lib
691
692    # Settings for the raw socket transport layer.
693    set lib(sock) $sock
694    set lib(transport,name)  "socket"
695    set lib(transport,init)  [namespace current]::initsocket
696    set lib(transport,send)  [namespace current]::putssocket
697    set lib(transport,reset) [namespace current]::resetsocket
698    set lib(transport,ip)    [namespace current]::ipsocket
699}
700
701# The procedures for the standard socket transport layer -----------------------
702
703# jlib::initsocket
704#
705#	Default transport mechanism; init already opened socket.
706#
707# Arguments:
708#
709# Side Effects:
710#	none
711
712proc jlib::initsocket {jlibname} {
713
714    upvar ${jlibname}::lib lib
715    upvar ${jlibname}::opts opts
716
717    set sock $lib(sock)
718    if {[catch {
719	fconfigure $sock -blocking 0 -buffering none -encoding utf-8
720    } err]} {
721	return -code error "The connection failed or dropped later"
722    }
723
724    # Set up callback on incoming socket.
725    fileevent $sock readable [list [namespace current]::recvsocket $jlibname]
726
727    # Schedule keep-alives to keep socket open in case anyone want's to close it.
728    # Be sure to not send any keep-alives before the stream is inited.
729    if {$opts(-keepalivesecs)} {
730	after [expr {1000 * $opts(-keepalivesecs)}] \
731	  [list [namespace current]::schedule_keepalive $jlibname]
732    }
733}
734
735# jlib::putssocket
736#
737#	Default transport mechanism; put directly to socket.
738#
739# Arguments:
740#
741#	xml    The xml that is to be written.
742#
743# Side Effects:
744#	none
745
746proc jlib::putssocket {jlibname xml} {
747
748    upvar ${jlibname}::lib lib
749
750    Debug 2 "SEND: $xml"
751
752    if {$lib(socketfilter,out) ne {}} {
753	set xml [$lib(socketfilter,out) $jlibname $xml]
754    }
755    if {[catch {puts -nonewline $lib(sock) $xml} err]} {
756	# Error propagated to the caller that calls clientcmd.
757	return -code error $err
758    }
759}
760
761# jlib::resetsocket
762#
763#	Default transport mechanism; reset socket.
764#
765# Arguments:
766#
767# Side Effects:
768#	none
769
770proc jlib::resetsocket {jlibname} {
771
772    upvar ${jlibname}::lib lib
773    upvar ${jlibname}::locals locals
774
775    catch {close $lib(sock)}
776    catch {after cancel $locals(aliveid)}
777
778    set lib(socketfilter,out) [list]
779    set lib(socketfilter,in)  [list]
780}
781
782# jlib::recvsocket --
783#
784#	Default transport mechanism; fileevent on socket socket.
785#       Callback on incoming socket xml data. Feeds our wrapper and XML parser.
786#
787# Arguments:
788#       jlibname:   the instance of this jlib.
789#
790# Results:
791#       none.
792
793proc jlib::recvsocket {jlibname} {
794
795    upvar ${jlibname}::lib lib
796
797    if {[catch {eof $lib(sock)} iseof] || $iseof} {
798	kill $jlibname
799	invoke_async_error $jlibname networkerror
800	return
801    }
802
803    # Read what we've got.
804    if {[catch {read $lib(sock)} data]} {
805	kill $jlibname
806	invoke_async_error $jlibname networkerror
807	return
808    }
809    if {$lib(socketfilter,in) ne {}} {
810	set data [$lib(socketfilter,in) $jlibname $data]
811    }
812    Debug 2 "RECV: $data"
813
814    # Feed the XML parser. When the end of a command element tag is reached,
815    # we get a callback to 'jlib::dispatcher'.
816    wrapper::parse $lib(wrap) $data
817}
818
819proc jlib::set_socket_filter {jlibname outcmd incmd} {
820
821    upvar ${jlibname}::lib lib
822
823    set lib(socketfilter,out) $outcmd
824    set lib(socketfilter,in)  $incmd
825
826    fconfigure $lib(sock) -translation binary
827}
828
829# jlib::ipsocket --
830#
831#       Get our own ip address.
832
833proc jlib::ipsocket {jlibname} {
834
835    upvar ${jlibname}::lib lib
836
837    if {[string length $lib(sock)]} {
838	return [lindex [fconfigure $lib(sock) -sockname] 0]
839    } else {
840	return ""
841    }
842}
843
844# standard socket transport layer end ------------------------------------------
845
846proc jlib::tee_recv {jlibname cmd procName} {
847
848    upvar ${jlibname}::lib lib
849
850    if {$cmd eq "add"} {
851	lappend lib(tee,recv) $procName
852    } elseif {$cmd eq "remove"} {
853	set lib(tee,recv) [lsearch -all -inline -not $lib(tee,recv) $procName]
854    } else {
855	return -code error "unknown sub command \"$cmd\""
856    }
857}
858
859proc jlib::tee_send {jlibname cmd procName} {
860
861    upvar ${jlibname}::lib lib
862
863    if {$cmd eq "add"} {
864	lappend lib(tee,send) $procName
865    } elseif {$cmd eq "remove"} {
866	set lib(tee,send) [lsearch -all -inline -not $lib(tee,send) $procName]
867    } else {
868	return -code error "unknown sub command \"$cmd\""
869    }
870}
871
872# jlib::recv --
873#
874# 	Feed the XML parser. When the end of a command element tag is reached,
875# 	we get a callback to 'jlib::dispatcher'.
876
877proc jlib::recv {jlibname xml} {
878
879    upvar ${jlibname}::lib lib
880
881    wrapper::parse $lib(wrap) $xml
882}
883
884# jlib::openstream --
885#
886#       Initializes a stream to a jabber server. The socket must already
887#       be opened. Sets up fileevent on incoming xml stream.
888#
889# Arguments:
890#       jlibname:   the instance of this jlib.
891#       server:     the domain name or ip number of the server.
892#       args:
893#           -cmd    callback when we receive the <stream> tag from the server.
894#           -to     the receipients jabber id.
895#           -id
896#           -version
897#
898# Results:
899#       none.
900
901proc jlib::openstream {jlibname server args} {
902
903    upvar ${jlibname}::lib lib
904    upvar ${jlibname}::locals locals
905    upvar ${jlibname}::opts opts
906    variable xmppxmlns
907
908    array set argsA $args
909
910    # The server 'to' attribute is only temporary until we have either a
911    # confirmation or a redirection (alias) in received streams 'from' attribute.
912    set locals(server)    $server
913    set locals(servermap) [jidmap $server]
914    set locals(last) [clock seconds]
915
916    # Make sure we start with a clean state.
917    wrapper::reset $lib(wrap)
918
919    set optattr ""
920    foreach {key value} $args {
921
922	switch -- $key {
923	    -cmd {
924		if {$value ne ""} {
925		    # Register a <stream> callback proc.
926		    set lib(streamcmd) $value
927		}
928	    }
929	    -socket {
930		# empty
931	    }
932	    default {
933		set attr [string trimleft $key "-"]
934		append optattr " $attr='$value'"
935	    }
936	}
937    }
938    set lib(isinstream) 1
939    set lib(state) "instream"
940
941    if {[catch {
942
943	# This call to the transport layer shall set up fileevent callbacks etc.
944   	# to handle all incoming xml.
945	uplevel #0 $lib(transport,init) $jlibname
946
947    	# Network errors if failed to open connection properly are likely to show here.
948	set xml "<?xml version='1.0' encoding='UTF-8'?><stream:stream\
949	  xmlns='$opts(-streamnamespace)' xmlns:stream='$xmppxmlns(stream)'\
950	  xml:lang='[getlang]' to='$server'$optattr>"
951
952	sendraw $jlibname $xml
953    } err]} {
954
955	# The socket probably was never connected,
956	# or the connection dropped later.
957	#closestream $jlibname
958	kill $jlibname
959	return -code error "The connection failed or dropped later: $err"
960    }
961    return
962}
963
964# jlib::sendstream --
965#
966#       Utility for SASL, TLS etc. Sends only the actual stream:stream tag.
967#       May throw error!
968
969proc jlib::sendstream {jlibname args} {
970
971    upvar ${jlibname}::locals locals
972    upvar ${jlibname}::opts opts
973    variable xmppxmlns
974
975    set attr ""
976    foreach {key value} $args {
977	set name [string trimleft $key "-"]
978	append attr " $name='$value'"
979    }
980    set xml "<stream:stream\
981      xmlns='$opts(-streamnamespace)' xmlns:stream='$xmppxmlns(stream)'\
982      to='$locals(server)' xml:lang='[getlang]' $attr>"
983
984    sendraw $jlibname $xml
985}
986
987# jlib::closestream --
988#
989#       Closes the stream down, closes socket, and resets internal variables.
990#       It should handle the complete shutdown of our connection and state.
991#
992#       There is a potential problem if called from within a xml parser
993#       callback which makes the subsequent parsing to fail. (after idle?)
994#
995# Arguments:
996#       jlibname:   the instance of this jlib.
997#
998# Results:
999#       none.
1000
1001proc jlib::closestream {jlibname} {
1002
1003    upvar ${jlibname}::lib lib
1004
1005    Debug 4 "jlib::closestream"
1006
1007    if {$lib(isinstream)} {
1008	set xml "</stream:stream>"
1009	catch {sendraw $jlibname $xml}
1010	set lib(isinstream) 0
1011    }
1012    kill $jlibname
1013}
1014
1015# jlib::invoke_async_error --
1016#
1017#       Used for reporting async errors, typically network errors.
1018
1019proc jlib::invoke_async_error {jlibname err {msg ""}} {
1020
1021    upvar ${jlibname}::lib lib
1022    Debug 4 "jlib::invoke_async_error err=$err, msg=$msg"
1023
1024    if {$lib(async_handler) eq ""} {
1025	uplevel #0 $lib(clientcmd) [list $jlibname $err -errormsg $msg]
1026    } else {
1027	uplevel #0 $lib(async_handler) [list $jlibname $err $msg]
1028    }
1029}
1030
1031# jlib::set_async_error_handler --
1032#
1033#       This is a way to get all async events directly to a registered handler
1034#       without delivering them to clientcmd. Used in jlib::connect.
1035proc jlib::set_async_error_handler {jlibname {cmd ""}} {
1036
1037    upvar ${jlibname}::lib lib
1038
1039    set lib(async_handler) $cmd
1040}
1041
1042# jlib::reporterror --
1043#
1044#       Used for transports to report async, fatal and nonrecoverable errors.
1045
1046proc jlib::reporterror {jlibname err {msg ""}} {
1047
1048    Debug 4 "jlib::reporterror"
1049
1050    kill $jlibname
1051    invoke_async_error $jlibname $err $msg
1052}
1053
1054# jlib::kill --
1055#
1056#       Like closestream but without any network transactions.
1057
1058proc jlib::kill {jlibname} {
1059
1060    upvar ${jlibname}::lib lib
1061
1062    Debug 4 "jlib::kill"
1063
1064    # Close socket typically.
1065    catch {uplevel #0 $lib(transport,reset) $jlibname}
1066    reset $jlibname
1067
1068    # Be sure to reset the wrapper, which implicitly resets the XML parser.
1069    wrapper::reset $lib(wrap)
1070    return
1071}
1072
1073proc jlib::wrapper_reset {jlibname} {
1074    upvar ${jlibname}::lib lib
1075    wrapper::reset $lib(wrap)
1076}
1077
1078# jlib::getip --
1079#
1080#       Transport independent way of getting own ip address.
1081
1082proc jlib::getip {jlibname} {
1083    upvar ${jlibname}::lib lib
1084    return [$lib(transport,ip) $jlibname]
1085}
1086
1087# jlib::getserver --
1088#
1089#       Is the received streams 'from' attribute which is the logical host.
1090#       This is normally identical to the 'to' attribute but not always.
1091
1092proc jlib::getserver {jlibname} {
1093    upvar ${jlibname}::locals locals
1094    return $locals(server)
1095}
1096
1097proc jlib::getservermap {jlibname} {
1098    upvar ${jlibname}::locals locals
1099    return $locals(servermap)
1100}
1101
1102# jlib::isinstream --
1103#
1104#       Utility to help us closing down a stream.
1105
1106proc jlib::isinstream {jlibname} {
1107    upvar ${jlibname}::lib lib
1108    return $lib(isinstream)
1109}
1110
1111# jlib::dispatcher --
1112#
1113#       Just dispatches the xml to any of the iq, message, or presence handlers,
1114#       which in turn dispatches further and/or handles internally.
1115#
1116# Arguments:
1117#       jlibname:   the instance of this jlib.
1118#       xmldata:    the complete xml as a hierarchical list.
1119#
1120# Results:
1121#       none.
1122
1123proc jlib::dispatcher {jlibname xmldata} {
1124    upvar ${jlibname}::lib    lib
1125
1126    # Which method?
1127    set tag [wrapper::gettag $xmldata]
1128
1129    switch -- $tag {
1130	iq {
1131	    iq_handler $jlibname $xmldata
1132	}
1133	message {
1134	    message_handler $jlibname $xmldata
1135	}
1136	presence {
1137	    presence_handler $jlibname $xmldata
1138	}
1139	features {
1140	    features_handler $jlibname $xmldata
1141	}
1142	error {
1143	    error_handler $jlibname $xmldata
1144	}
1145	default {
1146	    element_run_hook $jlibname $xmldata
1147	}
1148    }
1149
1150    foreach cmd $lib(tee,recv) {
1151	uplevel #0 $cmd [list $jlibname $xmldata]
1152    }
1153
1154    # Will have to wait...
1155    #general_run_hook $jlibname $xmldata
1156}
1157
1158# jlib::iq_handler --
1159#
1160#       Callback for incoming <iq> elements.
1161#       The handling sequence is the following:
1162#       1) handle all preregistered callbacks via id attributes
1163#       2) handle callbacks specific for 'type' and 'xmlns' that have been
1164#          registered with 'iq_register'
1165#       3) if unhandled by 2, use any -iqcommand callback
1166#       4) if type='get' and still unhandled, return an error element
1167#
1168# Arguments:
1169#       jlibname:   the instance of this jlib.
1170#	xmldata     the xml element as a list structure.
1171#
1172# Results:
1173#       roster object set, callbacks invoked.
1174
1175proc jlib::iq_handler {jlibname xmldata} {
1176
1177    upvar ${jlibname}::lib    lib
1178    upvar ${jlibname}::iqcmd  iqcmd
1179    upvar ${jlibname}::opts   opts
1180    upvar ${jlibname}::locals locals
1181    variable xmppxmlns
1182
1183    Debug 4 "jlib::iq_handler: ------------"
1184
1185    # Extract the command level XML data items.
1186    set tag [wrapper::gettag $xmldata]
1187    array set attrArr [wrapper::getattrlist $xmldata]
1188
1189    # Make an argument list ('-key value' pairs) suitable for callbacks.
1190    # Make variables of the attributes.
1191    set arglist [list]
1192    foreach {key value} [array get attrArr] {
1193	set $key $value
1194	lappend arglist -$key $value
1195    }
1196
1197    # This helps callbacks to adapt to using full element as argument.
1198    lappend arglist -xmldata $xmldata
1199
1200    # The 'type' attribute must exist! Else we return silently.
1201    if {![info exists type]} {
1202	return
1203    }
1204    if {[info exists from]} {
1205	set afrom $from
1206    } else {
1207	set afrom $locals(servermap)
1208    }
1209
1210    # @@@ Section 9.2.3 of RFC 3920 states in part:
1211    # 6. An IQ stanza of type "result" MUST include zero or one child elements.
1212    # 7. An IQ stanza of type "error" SHOULD include the child element
1213    # contained in the associated "get" or "set" and MUST include an <error/>
1214    # child....
1215
1216    set childlist [wrapper::getchildren $xmldata]
1217    set subiq [lindex $childlist 0]
1218    set xmlns [wrapper::getattribute $subiq xmlns]
1219
1220    set ishandled 0
1221
1222    # (1) Handle all preregistered callbacks via id attributes.
1223    #     Must be type 'result' or 'error'.
1224    #     Some components use type='set' instead of 'result'.
1225    #     BUT this creates logical errors since we may also receive iq with
1226    #     identical id!
1227
1228    # @@@ It would be better NOT to have separate calls for errors.
1229
1230    switch -- $type {
1231	result {
1232
1233	    # Protect us from our own 'set' calls when we are awaiting
1234	    # 'result' or 'error'.
1235	    set setus 0
1236	    if {($type eq "set") && ($afrom eq $locals(myjidmap))} {
1237		set setus 1
1238	    }
1239
1240	    if {!$setus && [info exists id] && [info exists iqcmd($id)]} {
1241		uplevel #0 $iqcmd($id) [list result $subiq]
1242
1243		# @@@ TODO:
1244		#uplevel #0 $iqcmd($id) [list $jlibname xmldata]
1245
1246		# The callback my in turn call 'closestream' which unsets
1247		# all iq before returning.
1248		unset -nocomplain iqcmd($id)
1249		set ishandled 1
1250	    }
1251	}
1252	error {
1253	    set errspec [getstanzaerrorspec $xmldata]
1254	    if {[info exists id] && [info exists iqcmd($id)]} {
1255
1256		# @@@ Having a separate form of error callbacks is really BAD!!!
1257		uplevel #0 $iqcmd($id) [list error $errspec]
1258
1259		#uplevel #0 $iqcmd($id) [list $jlibname $xmldata]
1260
1261		unset -nocomplain iqcmd($id)
1262		set ishandled 1
1263	    }
1264	}
1265    }
1266
1267    # (2) Handle callbacks specific for 'type' and 'xmlns' that have been
1268    #     registered with 'iq_register'
1269
1270    if {[string equal $ishandled "0"]} {
1271	set ishandled [eval {
1272	    iq_run_hook $jlibname $type $xmlns $afrom $subiq} $arglist]
1273    }
1274
1275    # (3) If unhandled by 2, use any -iqcommand callback.
1276
1277    if {[string equal $ishandled "0"]} {
1278	if {[string length $opts(-iqcommand)]} {
1279	    set ishandled [uplevel #0 $opts(-iqcommand) [list $jlibname $xmldata]]
1280	}
1281
1282	# (4) If type='get' or 'set', and still unhandled, return an error element.
1283
1284	if {[string equal $ishandled "0"] && \
1285	  ([string equal $type "get"] || [string equal $type "set"])} {
1286
1287	    # Return a "Not Implemented" to the sender. Just switch to/from,
1288	    # type='result', and add an <error> element.
1289	    if {[info exists attrArr(from)]} {
1290		return_error $jlibname $xmldata 501 cancel "feature-not-implemented"
1291	    }
1292	}
1293    }
1294}
1295
1296# jlib::return_error --
1297#
1298#       Returns an iq-error response using complete iq-element.
1299
1300proc jlib::return_error {jlibname iqElem errcode errtype errtag} {
1301    variable xmppxmlns
1302
1303    array set attr [wrapper::getattrlist $iqElem]
1304    set childlist  [wrapper::getchildren $iqElem]
1305
1306    # Switch from -> to, type='error', retain any id.
1307    set attr(to)   $attr(from)
1308    set attr(type) "error"
1309    unset attr(from)
1310
1311    set iqElem [wrapper::setattrlist $iqElem [array get attr]]
1312    set stanzaElem [wrapper::createtag $errtag \
1313      -attrlist [list xmlns $xmppxmlns(stanzas)]]
1314    set errElem [wrapper::createtag "error" -subtags [list $stanzaElem] \
1315      -attrlist [list code $errcode type $errtype]]
1316
1317    lappend childlist $errElem
1318    set iqElem [wrapper::setchildlist $iqElem $childlist]
1319
1320    send $jlibname $iqElem
1321}
1322
1323# jlib::send_iq_error --
1324#
1325#       Sends an iq error element as a response to a iq element.
1326
1327proc jlib::send_iq_error {jlibname jid id errcode errtype stanza {extraElem {}}} {
1328    variable xmppxmlns
1329
1330    set stanzaElem [wrapper::createtag $stanza  \
1331      -attrlist [list xmlns $xmppxmlns(stanzas)]]
1332    set errChilds [list $stanzaElem]
1333    if {[llength $extraElem]} {
1334	lappend errChilds $extraElem
1335    }
1336    set errElem [wrapper::createtag "error"         \
1337      -attrlist [list code $errcode type $errtype]  \
1338      -subtags $errChilds]
1339    set iqElem [wrapper::createtag "iq"  \
1340      -attrlist [list type error to $jid id $id] -subtags [list $errElem]]
1341
1342    send $jlibname $iqElem
1343}
1344
1345# jlib::message_handler --
1346#
1347#       Callback for incoming <message> elements. See 'jlib::dispatcher'.
1348#
1349# Arguments:
1350#       jlibname:   the instance of this jlib.
1351#	xmldata     the xml element as a list structure.
1352#
1353# Results:
1354#       callbacks invoked.
1355
1356proc jlib::message_handler {jlibname xmldata} {
1357
1358    upvar ${jlibname}::opts opts
1359    upvar ${jlibname}::lib lib
1360    upvar ${jlibname}::msgcmd msgcmd
1361
1362    # Extract the command level XML data items.
1363    set attrlist  [wrapper::getattrlist $xmldata]
1364    set childlist [wrapper::getchildren $xmldata]
1365    set attrArr(type) "normal"
1366    array set attrArr $attrlist
1367    set type $attrArr(type)
1368
1369    # Make an argument list ('-key value' pairs) suitable for callbacks.
1370    # Make variables of the attributes.
1371    foreach {key value} [array get attrArr] {
1372	set vopts(-$key) $value
1373    }
1374
1375    # This helps callbacks to adapt to using full element as argument.
1376    set vopts(-xmldata) $xmldata
1377    set ishandled 0
1378
1379    switch -- $type {
1380	error {
1381	    set errspec [getstanzaerrorspec $xmldata]
1382	    set vopts(-error) $errspec
1383	}
1384    }
1385
1386    # Extract the message sub-elements.
1387    # @@@ really bad solution... Deliver full element instead
1388    set xmlnsList  [list]
1389    foreach child $childlist {
1390
1391	# Extract the message sub-elements XML data items.
1392	set ctag    [wrapper::gettag $child]
1393	set cchdata [wrapper::getcdata $child]
1394
1395	switch -- $ctag {
1396	    body - subject - thread {
1397		set vopts(-$ctag) $cchdata
1398	    }
1399	    error {
1400		# handled above
1401	    }
1402	    default {
1403		lappend elem(-$ctag) $child
1404		lappend xmlnsList [wrapper::getattribute $child xmlns]
1405	    }
1406	}
1407    }
1408    set xmlnsList [lsort -unique $xmlnsList]
1409    set arglist [array get vopts]
1410
1411    # Invoke any registered handler for this particular message.
1412    set iscallback 0
1413    if {[info exists attrArr(id)]} {
1414	set id $attrArr(id)
1415
1416	# Avoid the weird situation when we send to ourself.
1417	if {[info exists msgcmd($id)] && ![info exists msgcmd($id,self)]} {
1418	    uplevel #0 $msgcmd($id) [list $jlibname $type] $arglist
1419	    unset -nocomplain msgcmd($id)
1420	    set iscallback 1
1421	}
1422	unset -nocomplain msgcmd($id,self)
1423    }
1424
1425    # Invoke any registered message handlers for this type and xmlns.
1426    if {[array exists elem]} {
1427	set arglist [concat [array get vopts] [array get elem]]
1428	foreach xmlns $xmlnsList {
1429	    set ishandled [eval {
1430		message_run_hook $jlibname $type $xmlns $xmldata} $arglist]
1431	    if {$ishandled} {
1432		break
1433	    }
1434	}
1435    }
1436    if {!$iscallback && [string equal $ishandled "0"]} {
1437
1438	# Invoke callback to client.
1439	if {[string length $opts(-messagecommand)]} {
1440	    uplevel #0 $opts(-messagecommand) [list $jlibname $xmldata]
1441	}
1442    }
1443}
1444
1445# jlib::send_message_error --
1446#
1447#       Sends a message error element as a response to another message.
1448
1449proc jlib::send_message_error {jlibname jid id errcode errtype stanza {extraElem {}}} {
1450    variable xmppxmlns
1451
1452    set stanzaElem [wrapper::createtag $stanza  \
1453      -attrlist [list xmlns $xmppxmlns(stanzas)]]
1454    set errChilds [list $stanzaElem]
1455    if {[llength $extraElem]} {
1456	lappend errChilds $extraElem
1457    }
1458    set errElem [wrapper::createtag "error"         \
1459      -attrlist [list code $errcode type $errtype]  \
1460      -subtags $errChilds]
1461    set msgElem [wrapper::createtag "iq"  \
1462      -attrlist [list type error to $jid id $id]  \
1463      -subtags [list $errElem]]
1464
1465    send $jlibname $msgElem
1466}
1467
1468# jlib::presence_handler --
1469#
1470#       Callback for incoming <presence> elements. See 'jlib::dispatcher'.
1471#
1472# Arguments:
1473#       jlibname:   the instance of this jlib.
1474#	xmldata     the xml element as a list structure.
1475#
1476# Results:
1477#       roster object set, callbacks invoked.
1478
1479proc jlib::presence_handler {jlibname xmldata} {
1480    variable statics
1481    variable jxmlns
1482    upvar ${jlibname}::lib lib
1483    upvar ${jlibname}::prescmd prescmd
1484    upvar ${jlibname}::opts opts
1485    upvar ${jlibname}::locals locals
1486
1487    set id [wrapper::getattribute $xmldata id]
1488
1489    # Handle callbacks specific for 'type' that have been registered with
1490    # 'presence_register(_ex)'.
1491
1492    # We keep two sets of registered handlers, jlib internal which are
1493    # called first, and then externals which are used by the client.
1494
1495    # Internals:
1496    presence_run_hook $jlibname 1 $xmldata
1497    presence_ex_run_hook $jlibname 1 $xmldata
1498
1499    # Externals:
1500    presence_run_hook $jlibname 0 $xmldata
1501    presence_ex_run_hook $jlibname 0 $xmldata
1502
1503    # Invoke any callback before the rosters callback.
1504    # @@@ Right place ???
1505    if {[info exists prescmd($id)]} {
1506	uplevel #0 $prescmd($id) [list $jlibname $xmldata]
1507	unset -nocomplain prescmd($id)
1508    } else {
1509    	foreach child [wrapper::getchildren $xmldata] {
1510            wrapper::splitxml $child tag attr chdata children
1511            set xmlns [wrapper::getattribute $child xmlns]
1512            # if the xmlns is not set, continue searching
1513	    # the xmlns is only interesting for us, if it is a $jxmlns(muc,user)
1514            if {$xmlns eq ""} {
1515          	continue
1516            } elseif {[string equal $jxmlns(muc,user) $xmlns]} {
1517		# get a list of discovered conferences
1518		set services [::Jabber::Jlib disco getconferences]
1519		# get the domain from where the presence arrived, and check if
1520		# it is in the list of known conference services
1521        	set from [wrapper::getattribute $xmldata from]
1522		jlib::splitjidex $from node domain -
1523		if { [lsearch -exact $services $domain] } {
1524        	    set hasmuc [::Jabber::Jlib disco hasfeature $jxmlns(muc) $domain]
1525		    if {$hasmuc} {
1526			# in case the conference service is able to handle muc protocol
1527			uplevel #0 [list ::jlib::muc::parse_enter {::Enter::MUCCallback ::Enter::[incr uid]}] [list $jlibname $xmldata]
1528		    } else {
1529			# otherwise take the fallback to the old gc-1.0 protocol
1530			uplevel #0 [list ::jlib::muc::parse_enter {::Enter::GCCallback ::Enter::[incr uid]}] [list $jlibname $xmldata]
1531		    }
1532		}
1533            break
1534            }
1535        }
1536    }
1537    # This is the last station.
1538    if {[string length $opts(-presencecommand)]} {
1539	uplevel #0 $opts(-presencecommand) [list $jlibname $xmldata]
1540    }
1541}
1542
1543# jlib::features_handler --
1544#
1545#       Callback for the <stream:features> element.
1546
1547proc jlib::features_handler {jlibname xmllist} {
1548
1549    upvar ${jlibname}::features features
1550    variable xmppxmlns
1551    variable jxmlns
1552
1553    Debug 4 "jlib::features_handler"
1554
1555    set features(xmllist) $xmllist
1556
1557    foreach child [wrapper::getchildren $xmllist] {
1558	wrapper::splitxml $child tag attr chdata children
1559	set xmlns [wrapper::getattribute $child xmlns]
1560
1561	# All feature elements must be namespaced.
1562	if {$xmlns eq ""} {
1563	    continue
1564	}
1565	set features(elem,$xmlns) $child
1566
1567	switch -- $tag {
1568	    starttls {
1569
1570		# TLS
1571		if {$xmlns eq $xmppxmlns(tls)} {
1572		    set features(starttls) 1
1573		    set childs [wrapper::getchildswithtag $child required]
1574		    if {$childs ne ""} {
1575			set features(starttls,required) 1
1576		    }
1577		}
1578	    }
1579	    compression {
1580
1581		# Compress
1582		if {$xmlns eq $jxmlns(compress)} {
1583		    set features(compression) 1
1584		    foreach c [wrapper::getchildswithtag $child method] {
1585			set method [wrapper::getcdata $c]
1586			set features(compression,$method) 1
1587		    }
1588		}
1589	    }
1590	    mechanisms {
1591
1592		# SASL
1593		set mechanisms [list]
1594		if {$xmlns eq $xmppxmlns(sasl)} {
1595		    set features(sasl) 1
1596		    foreach mechelem $children {
1597			wrapper::splitxml $mechelem mtag mattr mchdata mchild
1598			if {$mtag eq "mechanism"} {
1599			    lappend mechanisms $mchdata
1600			}
1601			set features(mechanism,$mchdata) 1
1602		    }
1603		}
1604
1605		# Variable that may trigger a trace event.
1606		set features(mechanisms) $mechanisms
1607	    }
1608	    bind {
1609		if {$xmlns eq $xmppxmlns(bind)} {
1610		    set features(bind) 1
1611		}
1612	    }
1613	    session {
1614		if {$xmlns eq $xmppxmlns(session)} {
1615		    set features(session) 1
1616		}
1617	    }
1618	    default {
1619
1620		# Have no idea of what this could be.
1621		set features($xmlns) 1
1622	    }
1623	}
1624    }
1625
1626    if {$features(trace) ne {}} {
1627	uplevel #0 $features(trace) [list $jlibname]
1628    }
1629}
1630
1631# jlib::trace_stream_features --
1632#
1633#       Register a callback when getting stream features.
1634#       Only one component at a time.
1635#
1636#       args:     tclProc  set callback
1637#                 {}       unset callback
1638#                 empty    return callback
1639
1640proc jlib::trace_stream_features {jlibname args} {
1641
1642    upvar ${jlibname}::features features
1643
1644    switch -- [llength $args] {
1645	0 {
1646	    return $features(trace)
1647	}
1648	1 {
1649	    set features(trace) [lindex $args 0]
1650	}
1651	default {
1652	    return -code error "Usage: trace_stream_features ?tclProc?"
1653	}
1654    }
1655}
1656
1657# jlib::get_feature, have_feature --
1658#
1659#       Just to get access of the stream features.
1660
1661proc jlib::get_feature {jlibname name {name2 ""}} {
1662
1663    upvar ${jlibname}::features features
1664
1665    set ans ""
1666    if {$name2 ne ""} {
1667	if {[info exists features($name,$name2)]} {
1668	    set ans $features($name,$name2)
1669	}
1670    } else {
1671	if {[info exists features($name)]} {
1672	    set ans $features($name)
1673	}
1674    }
1675    return $ans
1676}
1677
1678proc jlib::have_feature {jlibname {name ""} {name2 ""}} {
1679
1680    upvar ${jlibname}::features features
1681
1682    set ans 0
1683    if {$name2 ne ""} {
1684	if {[info exists features($name,$name2)]} {
1685	    set ans 1
1686	}
1687    } elseif {$name ne ""} {
1688	if {[info exists features($name)]} {
1689	    set ans 1
1690	}
1691    } else {
1692	if {[info exists features(xmllist)]} {
1693	    set ans 1
1694	}
1695    }
1696    return $ans
1697}
1698
1699# jlib::got_stream --
1700#
1701#       Callback when we have parsed the initial root element.
1702#
1703# Arguments:
1704#       jlibname:   the instance of this jlib.
1705#       args:       attributes
1706#
1707# Results:
1708#       none.
1709
1710proc jlib::got_stream {jlibname args} {
1711
1712    upvar ${jlibname}::lib lib
1713    upvar ${jlibname}::locals locals
1714
1715    Debug 4 "jlib::got_stream jlibname=$jlibname, args='$args'"
1716
1717    # Cache stream attributes.
1718    foreach {name value} $args {
1719	set locals(streamattr,$name) $value
1720    }
1721
1722    # The streams 'from' attribute has the "last word" on the servers name.
1723    if {[info exists locals(streamattr,from)]} {
1724	set locals(server)    $locals(streamattr,from)
1725	set locals(servermap) [jidmap $locals(server)]
1726    }
1727    schedule_auto_away $jlibname
1728
1729    # If we use    we should have a callback command here.
1730    if {[info exists lib(streamcmd)] && [llength $lib(streamcmd)]} {
1731	uplevel #0 $lib(streamcmd) $jlibname $args
1732	unset lib(streamcmd)
1733    }
1734}
1735
1736# jlib::getthis --
1737#
1738#       Access function for: server, username, myjid, myjid2...
1739
1740proc jlib::getthis {jlibname name} {
1741
1742    upvar ${jlibname}::locals locals
1743
1744    if {[info exists locals($name)]} {
1745	return $locals($name)
1746    } else {
1747	return
1748    }
1749}
1750
1751# jlib::getstreamattr --
1752#
1753#       Returns the value of any stream attribute, typically 'id'.
1754
1755proc jlib::getstreamattr {jlibname name} {
1756
1757    upvar ${jlibname}::locals locals
1758
1759    if {[info exists locals(streamattr,$name)]} {
1760	return $locals(streamattr,$name)
1761    } else {
1762	return
1763    }
1764}
1765
1766# jlib::end_of_parse --
1767#
1768#       Callback when the ending root element is parsed.
1769#
1770# Arguments:
1771#       jlibname:   the instance of this jlib.
1772#
1773# Results:
1774#       none.
1775
1776proc jlib::end_of_parse {jlibname} {
1777
1778    upvar ${jlibname}::lib lib
1779
1780    Debug 4 "jlib::end_of_parse jlibname=$jlibname"
1781
1782    catch {eval $lib(transport,reset) $jlibname}
1783    invoke_async_error $jlibname disconnect
1784    reset $jlibname
1785}
1786
1787# jlib::error_handler --
1788#
1789#       Callback when receiving an stream:error element. According to xmpp-core
1790#       this is an unrecoverable error (4.7.1) and the stream MUST be closed
1791#       and the TCP connection also be closed.
1792#
1793#       jabberd 1.4.3: <stream:error>Disconnected</stream:error>
1794#       jabberd 1.4.4:
1795#       <stream:error>
1796#           <xml-not-well-formed xmlns='urn:ietf:params:xml:ns:xmpp-streams'/>
1797#       </stream:error>
1798#   </stream:stream>
1799
1800proc jlib::error_handler {jlibname xmllist} {
1801
1802    variable xmppxmlns
1803
1804    Debug 4 "jlib::error_handler"
1805
1806    # This should handle all internal stuff.
1807    closestream $jlibname
1808
1809    if {[llength [wrapper::getchildren $xmllist]]} {
1810	set errspec [getstreamerrorspec $xmllist]
1811	set errcode "xmpp-streams-error-[lindex $errspec 0]"
1812	set errmsg [lindex $errspec 1]
1813    } else {
1814	set errcode xmpp-streams-error
1815	set errmsg [wrapper::getcdata $xmllist]
1816    }
1817    invoke_async_error $jlibname $errcode $errmsg
1818}
1819
1820# jlib::xmlerror --
1821#
1822#       Callback when we receive an XML error from the wrapper (parser).
1823#
1824# Arguments:
1825#       jlibname:   the instance of this jlib.
1826#
1827# Results:
1828#       none.
1829
1830proc jlib::xmlerror {jlibname args} {
1831
1832    Debug 4 "jlib::xmlerror jlibname=$jlibname, args='$args'"
1833
1834    # This should handle all internal stuff.
1835    closestream $jlibname
1836    invoke_async_error $jlibname xmlerror $args
1837}
1838
1839# jlib::reset --
1840#
1841#       Unsets all iqcmd($id) callback procedures.
1842#
1843# Arguments:
1844#       jlibname:   the instance of this jlib.
1845#
1846# Results:
1847#       none.
1848
1849proc jlib::reset {jlibname} {
1850    upvar ${jlibname}::lib lib
1851    upvar ${jlibname}::iqcmd iqcmd
1852    upvar ${jlibname}::prescmd prescmd
1853    upvar ${jlibname}::locals locals
1854    upvar ${jlibname}::features features
1855
1856    Debug 4 "jlib::reset"
1857
1858    cancel_auto_away $jlibname
1859
1860    set num $iqcmd(uid)
1861    unset -nocomplain iqcmd
1862    set iqcmd(uid) $num
1863
1864    set num $prescmd(uid)
1865    unset -nocomplain prescmd
1866    set prescmd(uid) $num
1867
1868    unset -nocomplain locals
1869    unset -nocomplain features
1870
1871    init_inst $jlibname
1872
1873    set lib(isinstream) 0
1874    set lib(state) "reset"
1875
1876    stream_reset $jlibname
1877    if {[havesasl]} {
1878	sasl_reset $jlibname
1879    }
1880    if {[havetls]} {
1881	tls_reset $jlibname
1882    }
1883
1884    # Execute any register reset commands.
1885    foreach cmd $lib(resetCmds) {
1886	uplevel #0 $cmd $jlibname
1887    }
1888}
1889
1890# jlib::stream_reset --
1891#
1892#       Clears out all variables that are cached for this stream.
1893#       The xmpp specifies that any information obtained during tls,sasl
1894#       must be discarded before opening a new stream.
1895#       Call this before opening a new stream
1896
1897proc jlib::stream_reset {jlibname} {
1898
1899    upvar ${jlibname}::locals locals
1900    upvar ${jlibname}::features features
1901
1902    array unset locals streamattr,*
1903
1904    set cmd $features(trace)
1905    unset -nocomplain features
1906    set features(trace) $cmd
1907}
1908
1909# jlib::getstanzaerrorspec --
1910#
1911#       Extracts the error code and an error message from an type='error'
1912#       element. We must handle both the original Jabber protocol and the
1913#       XMPP protocol:
1914#
1915#   The syntax for stanza-related errors is as follows (XMPP):
1916#
1917#   <stanza-kind to='sender' type='error'>
1918#     [RECOMMENDED to include sender XML here]
1919#     <error type='error-type'>
1920#       <defined-condition xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
1921#       <text xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'>
1922#         OPTIONAL descriptive text
1923#       </text>
1924#       [OPTIONAL application-specific condition element]
1925#     </error>
1926#   </stanza-kind>
1927#
1928#   Jabber:
1929#
1930#   <iq type='error'>
1931#     <query ...>
1932#       <error code='..'> ... </error>
1933#     </query>
1934#   </iq>
1935#
1936#   or:
1937#   <iq type='error'>
1938#     <error code='401'/>
1939#     <query ...>...</query>
1940#   </iq>
1941#
1942#   or:
1943#   <message type='error' ...>
1944#       ...
1945#       <error code='403'>Forbidden</error>
1946#   </message>
1947
1948proc jlib::getstanzaerrorspec {stanza} {
1949
1950    variable xmppxmlns
1951
1952    set errcode ""
1953    set errmsg  ""
1954
1955    # First search children of stanza (<iq> element) for error element.
1956    foreach child [wrapper::getchildren $stanza] {
1957	set tag [wrapper::gettag $child]
1958	if {[string equal $tag "error"]} {
1959	    set errelem $child
1960	}
1961	if {[string equal $tag "query"]} {
1962	    set queryelem $child
1963	}
1964    }
1965    if {![info exists errelem] && [info exists queryelem]} {
1966
1967	# Search children if <query> element (Jabber).
1968	set errlist [wrapper::getchildswithtag $queryelem "error"]
1969	if {[llength $errlist]} {
1970	    set errelem [lindex $errlist 0]
1971	}
1972    }
1973
1974    # Found it! XMPP contains an error stanza and not pure text.
1975    if {[info exists errelem]} {
1976	foreach {errcode errmsg} [geterrspecfromerror $errelem stanzas] {break}
1977    }
1978    return [list $errcode $errmsg]
1979}
1980
1981# jlib::getstreamerrorspec --
1982#
1983#       Extracts the error code and an error message from a stream:error
1984#       element. We must handle both the original Jabber protocol and the
1985#       XMPP protocol:
1986#
1987#   The syntax for stream errors is as follows:
1988#
1989#   <stream:error>
1990#      <defined-condition xmlns='urn:ietf:params:xml:ns:xmpp-streams'/>
1991#      <text xmlns='urn:ietf:params:xml:ns:xmpp-streams'>
1992#        OPTIONAL descriptive text
1993#      </text>
1994#      [OPTIONAL application-specific condition element]
1995#   </stream:error>
1996#
1997#   Jabber:
1998#
1999
2000proc jlib::getstreamerrorspec {errelem} {
2001
2002    return [geterrspecfromerror $errelem streams]
2003}
2004
2005# jlib::geterrspecfromerror --
2006#
2007#       Get an error specification from an stanza error element.
2008#
2009# Arguments:
2010#       errelem:    the <error/> element
2011#       kind.       'stanzas' or 'streams'
2012#
2013# Results:
2014#       {errcode errmsg}
2015
2016proc jlib::geterrspecfromerror {errelem kind} {
2017
2018    variable xmppxmlns
2019    variable errCodeToText
2020
2021    array set msgproc {
2022	stanzas  stanzaerror::getmsg
2023	streams  streamerror::getmsg
2024    }
2025    set cchdata [wrapper::getcdata $errelem]
2026    set errcode [wrapper::getattribute $errelem code]
2027    set errmsg  "Unknown"
2028
2029    if {[string is integer -strict $errcode]} {
2030	if {$cchdata ne ""} {
2031	    set errmsg $cchdata
2032	} elseif {[info exists errCodeToText($errcode)]} {
2033	    set errmsg $errCodeToText($errcode)
2034	}
2035    } elseif {$cchdata ne ""} {
2036
2037	# Old jabber way.
2038	set errmsg $cchdata
2039    }
2040
2041    # xmpp way.
2042    foreach c [wrapper::getchildren $errelem] {
2043	set tag [wrapper::gettag $c]
2044
2045	switch -- $tag {
2046	    text {
2047		# Use only as a complement iff our language. ???
2048		set xmlns [wrapper::getattribute $c xmlns]
2049		set lang  [wrapper::getattribute $c xml:lang]
2050		# [string equal $lang [getlang]]
2051		if {[string equal $xmlns $xmppxmlns($kind)]} {
2052		    set errstr [wrapper::getcdata $c]
2053		}
2054	    }
2055	    default {
2056		set xmlns [wrapper::getattribute $c xmlns]
2057		if {[string equal $xmlns $xmppxmlns($kind)]} {
2058		    set errcode $tag
2059		    set errstr [$msgproc($kind) $tag]
2060		}
2061	    }
2062	}
2063    }
2064    if {[info exists errstr]} {
2065	set errmsg $errstr
2066    }
2067    if {$errmsg eq ""} {
2068	set errmsg "Unknown"
2069    }
2070    return [list $errcode $errmsg]
2071}
2072
2073# jlib::bind_resource --
2074#
2075#       xmpp requires us to bind a resource to the stream.
2076
2077proc jlib::bind_resource {jlibname resource cmd} {
2078
2079    variable xmppxmlns
2080
2081    # If resource is an empty string request the server to create it.
2082    set subtags [list]
2083    if {$resource ne ""} {
2084	set subtags [list [wrapper::createtag resource -chdata $resource]]
2085    }
2086    set xmllist [wrapper::createtag bind       \
2087      -attrlist [list xmlns $xmppxmlns(bind)] -subtags $subtags]
2088    send_iq $jlibname set [list $xmllist]  \
2089      -command [list [namespace current]::parse_bind_resource $jlibname $cmd]
2090}
2091
2092proc jlib::parse_bind_resource {jlibname cmd type subiq args} {
2093
2094    upvar ${jlibname}::locals locals
2095    variable xmppxmlns
2096
2097    # The server MAY change the 'resource' why we need to check this here.
2098    if {[string equal [wrapper::gettag $subiq] bind] &&  \
2099      [string equal [wrapper::getattribute $subiq xmlns] $xmppxmlns(bind)]} {
2100	set jidElem [wrapper::getfirstchildwithtag $subiq jid]
2101	if {[llength $jidElem]} {
2102
2103	    # Server replies with full JID.
2104	    set sjid [wrapper::getcdata $jidElem]
2105	    splitjid $sjid sjid2 sresource
2106	    if {![string equal [resourcemap $locals(resource)] $sresource]} {
2107		set locals(myjid)     $sjid
2108		set locals(myjid2)    $sjid2
2109		set locals(resource)  $sresource
2110		set locals(myjidmap)  [jidmap $sjid]
2111		set locals(myjid2map) [jidmap $sjid2]
2112	    }
2113	}
2114    }
2115    uplevel #0 $cmd [list $jlibname $type $subiq]
2116}
2117
2118# jlib::invoke_iq_callback --
2119#
2120#       Callback when we get server response on iq set/get.
2121#       This is a generic callback procedure.
2122#
2123# Arguments:
2124#       jlibname:   the instance of this jlib.
2125#       cmd:        the 'cmd' argument in the calling procedure.
2126#       type:       "error" or "ok".
2127#       subiq:      if type="error", this is a list {errcode errmsg},
2128#                   else it is the query element as a xml list structure.
2129#
2130# Results:
2131#       none.
2132
2133proc jlib::invoke_iq_callback {jlibname cmd type subiq} {
2134
2135    Debug 3 "jlib::invoke_iq_callback cmd=$cmd, type=$type, subiq=$subiq"
2136
2137    uplevel #0 $cmd [list $jlibname $type $subiq]
2138}
2139
2140# jlib::parse_search_set --
2141#
2142#       Callback for 'jabber:iq:search' 'result' and 'set' elements.
2143#
2144# Arguments:
2145#       jlibname:   the instance of this jlib.
2146#       cmd:        the callback to notify.
2147#       type:       "ok", "error", or "set"
2148#       subiq:
2149
2150proc jlib::parse_search_set {jlibname cmd type subiq} {
2151
2152    upvar ${jlibname}::lib lib
2153
2154    uplevel #0 $cmd [list $type $subiq]
2155}
2156
2157# jlib::iq_register --
2158#
2159#       Handler for registered iq callbacks.
2160#
2161#       @@@ We could think of a more general mechanism here!!!!
2162#       1) Using -type, -xmlns, -from etc.
2163
2164proc jlib::iq_register {jlibname type xmlns func {seq 50}} {
2165
2166    upvar ${jlibname}::iqhook iqhook
2167
2168    lappend iqhook($type,$xmlns) [list $func $seq]
2169    set iqhook($type,$xmlns) \
2170      [lsort -integer -index 1 [lsort -unique $iqhook($type,$xmlns)]]
2171}
2172
2173proc jlib::iq_run_hook {jlibname type xmlns from subiq args} {
2174
2175    upvar ${jlibname}::iqhook iqhook
2176
2177    set ishandled 0
2178
2179    foreach key [list $type,$xmlns *,$xmlns $type,*] {
2180	if {[info exists iqhook($key)]} {
2181	    foreach spec $iqhook($key) {
2182		set func [lindex $spec 0]
2183		set code [catch {
2184		    uplevel #0 $func [list $jlibname $from $subiq] $args
2185		} ans]
2186		if {$code} {
2187		    bgerror "iqhook $func failed: $code\n$::errorInfo"
2188		}
2189		if {[string equal $ans "1"]} {
2190		    set ishandled 1
2191		    break
2192		}
2193	    }
2194	}
2195	if {$ishandled} {
2196	    break
2197	}
2198    }
2199    return $ishandled
2200}
2201
2202# jlib::message_register --
2203#
2204#       Handler for registered message callbacks.
2205#
2206#       We could think of a more general mechanism here!!!!
2207
2208proc jlib::message_register {jlibname type xmlns func {seq 50}} {
2209
2210    upvar ${jlibname}::msghook msghook
2211
2212    lappend msghook($type,$xmlns) [list $func $seq]
2213    set msghook($type,$xmlns)  \
2214      [lsort -integer -index 1 [lsort -unique $msghook($type,$xmlns)]]
2215}
2216
2217proc jlib::message_run_hook {jlibname type xmlns xmldata args} {
2218
2219    upvar ${jlibname}::msghook msghook
2220
2221    set ishandled 0
2222
2223    foreach key [list $type,$xmlns *,$xmlns $type,*] {
2224	if {[info exists msghook($key)]} {
2225	    foreach spec $msghook($key) {
2226		set func [lindex $spec 0]
2227		set code [catch {
2228		    uplevel #0 $func [list $jlibname $xmlns $xmldata] $args
2229		} ans]
2230		if {$code} {
2231		    bgerror "msghook $func failed: $code\n$::errorInfo"
2232		}
2233		if {[string equal $ans "1"]} {
2234		    set ishandled 1
2235		    break
2236		}
2237	    }
2238	}
2239	if {$ishandled} {
2240	    break
2241	}
2242    }
2243    return $ishandled
2244}
2245
2246# @@@ We keep two versions, internal for jlib usage and external for apps.
2247#     Do this for all registered callbacks!
2248
2249# jlib::presence_register --
2250#
2251#       Handler for registered presence callbacks. Simple version.
2252
2253proc jlib::presence_register_int {jlibname type func {seq 50}} {
2254    pres_reg $jlibname 1 $type $func $seq
2255}
2256
2257proc jlib::presence_register {jlibname type func {seq 50}} {
2258    pres_reg $jlibname 0 $type $func $seq
2259}
2260
2261proc jlib::pres_reg {jlibname int type func {seq 50}} {
2262
2263    upvar ${jlibname}::preshook preshook
2264
2265    lappend preshook($int,$type) [list $func $seq]
2266    set preshook($int,$type)  \
2267      [lsort -integer -index 1 [lsort -unique $preshook($int,$type)]]
2268}
2269
2270proc jlib::presence_run_hook {jlibname int xmldata} {
2271
2272    upvar ${jlibname}::preshook preshook
2273    upvar ${jlibname}::locals locals
2274
2275    set type [wrapper::getattribute $xmldata type]
2276    set from [wrapper::getattribute $xmldata from]
2277    if {$type eq ""} {
2278	set type "available"
2279    }
2280    if {$from eq ""} {
2281	set from $locals(server)
2282    }
2283    set ishandled 0
2284
2285    if {[info exists preshook($int,$type)]} {
2286	foreach spec $preshook($int,$type) {
2287	    set func [lindex $spec 0]
2288	    set code [catch {
2289		uplevel #0 $func [list $jlibname $xmldata]
2290	    } ans]
2291	    if {$code} {
2292		bgerror "preshook $func failed: $code\n$::errorInfo"
2293	    }
2294	    if {[string equal $ans "1"]} {
2295		set ishandled 1
2296		break
2297	    }
2298	}
2299    }
2300    return $ishandled
2301}
2302
2303proc jlib::presence_deregister_int {jlibname type func} {
2304    pres_dereg $jlibname 1 $type $func
2305}
2306
2307proc jlib::presence_deregister {jlibname type func} {
2308    pres_dereg $jlibname 0 $type $func
2309}
2310
2311proc jlib::pres_dereg {jlibname int type func} {
2312
2313    upvar ${jlibname}::preshook preshook
2314
2315    if {[info exists preshook($int,$type)]} {
2316	set idx [lsearch -glob $preshook($int,$type) "$func *"]
2317	if {$idx >= 0} {
2318	    set preshook($int,$type) [lreplace $preshook($int,$type) $idx $idx]
2319	}
2320    }
2321}
2322
2323# jlib::presence_register_ex --
2324#
2325#       Set extended presence callbacks which can be triggered for
2326#       various attributes and elements.
2327#
2328#       The internal storage consists of two parts:
2329#       1) attributes; stored as array keys using wildcards (*)
2330#       2) elements  : stored as a -tag .. -xmlns .. list
2331#
2332#       expreshook($type,$from,$from2) {{{-key value ...} tclProc seq} {...} ...}
2333#
2334#       These are matched separately but not independently.
2335#
2336# Arguments:
2337#       jlibname:   the instance of this jlib.
2338#       func:       tclProc
2339#       args:       -type     type and from must match the presence element
2340#                   -from     attributes
2341#                   -from2    match the bare from jid
2342#                   -tag      tag and xmlns must coexist in the same element
2343#                   -xmlns    for a valid match
2344#                   -seq      priority 0-100 (D=50)
2345#
2346# Results:
2347#       none.
2348
2349proc jlib::presence_register_ex_int {jlibname func args} {
2350    eval {pres_reg_ex $jlibname 1 $func} $args
2351}
2352
2353proc jlib::presence_register_ex {jlibname func args} {
2354    eval {pres_reg_ex $jlibname 0 $func} $args
2355}
2356
2357proc jlib::pres_reg_ex {jlibname int func args} {
2358    upvar ${jlibname}::expreshook expreshook
2359
2360    set type  "*"
2361    set from  "*"
2362    set from2 "*"
2363    set seq   50
2364
2365    foreach {key value} $args {
2366	switch -- $key {
2367	    -from - -from2 {
2368		set name [string trimleft $key "-"]
2369		set $name [ESC $value]
2370	    }
2371	    -type {
2372		set type $value
2373	    }
2374	    -tag - -xmlns {
2375		set aopts($key) $value
2376	    }
2377	    -seq {
2378		set seq $value
2379	    }
2380	}
2381    }
2382    set pat "$type,$from,$from2"
2383
2384    # The 'opts' must be ordered.
2385    set opts [list]
2386    foreach key [array names aopts] {
2387	lappend opts $key $aopts($key)
2388    }
2389    lappend expreshook($int,$pat) [list $opts $func $seq]
2390    set expreshook($int,$pat)  \
2391      [lsort -integer -index 2 [lsort -unique $expreshook($int,$pat)]]
2392}
2393
2394proc jlib::presence_ex_run_hook {jlibname int xmldata} {
2395    upvar ${jlibname}::expreshook expreshook
2396    upvar ${jlibname}::locals locals
2397
2398    set type [wrapper::getattribute $xmldata type]
2399    set from [wrapper::getattribute $xmldata from]
2400    if {$type eq ""} {
2401	set type "available"
2402    }
2403    if {$from eq ""} {
2404	set from $locals(server)
2405    }
2406    set from2 [barejid $from]
2407    set pkey "$int,$type,$from,$from2"
2408    # Make matching in two steps, attributes and elements.
2409    # First the attributes.
2410    set matched [list]
2411    foreach {pat value} [array get expreshook $int,*] {
2412	if {[string match $pat $pkey]} {
2413
2414	    foreach spec $value {
2415
2416		# Match attributes only if opts empty.
2417		if {[lindex $spec 0] eq {}} {
2418		    set func [lindex $spec 1]
2419		    set code [catch {
2420			uplevel #0 $func [list $jlibname $xmldata]
2421		    } ans]
2422		    if {$code} {
2423			bgerror "preshook $func failed: $code\n$::errorInfo"
2424		    }
2425		} else {
2426
2427		    # Collect all callbacks that match the attributes and have
2428		    # a nonempty element spec.
2429		    lappend matched $spec
2430		}
2431	    }
2432	}
2433    }
2434
2435    # Now try match the elements with the ones that matched the attributes.
2436    if {[llength $matched]} {
2437
2438	# Start by collecting all tags and xmlns we have in 'xmldata'.
2439	set tagxmlns [list]
2440	foreach c [wrapper::getchildren $xmldata] {
2441	    set xmlns [wrapper::getattribute $c xmlns]
2442	    lappend tagxmlns [list [wrapper::gettag $c] $xmlns]
2443	}
2444
2445	foreach spec $matched {
2446	    array set opts {-tag * -xmlns *}
2447	    array set opts [lindex $spec 0]
2448
2449	    # The 'olist' must be ordered.
2450	    set olist [list $opts(-tag) $opts(-xmlns)]
2451	    set idx [lsearch -glob $tagxmlns $olist]
2452	    if {$idx >= 0} {
2453		set func [lindex $spec 1]
2454		set code [catch {
2455		    uplevel #0 $func [list $jlibname $xmldata]
2456		} ans]
2457		if {$code} {
2458		    bgerror "preshook $func failed: $code\n$::errorInfo"
2459		}
2460	    }
2461	}
2462    }
2463}
2464
2465proc jlib::presence_deregister_ex_int {jlibname func args} {
2466    eval {pres_dereg_ex $jlibname 1 $func} $args
2467}
2468
2469proc jlib::presence_deregister_ex {jlibname func args} {
2470    eval {pres_dereg_ex $jlibname 0 $func} $args
2471}
2472
2473proc jlib::pres_dereg_ex {jlibname int func args} {
2474
2475    upvar ${jlibname}::expreshook expreshook
2476
2477    set type  "*"
2478    set from  "*"
2479    set from2 "*"
2480    set seq   "*"
2481
2482    foreach {key value} $args {
2483	switch -- $key {
2484	    -from - -from2 {
2485		set name [string trimleft $key "-"]
2486		set $name [jlib::ESC $value]
2487	    }
2488	    -type {
2489		set type $value
2490	    }
2491	    -tag - -xmlns {
2492		set aopts($key) $value
2493	    }
2494	    -seq {
2495		set seq $value
2496	    }
2497	}
2498    }
2499    set pat "$type,$from,$from2"
2500    if {[info exists expreshook($int,$pat)]} {
2501
2502	# The 'opts' must be ordered.
2503	set opts [list]
2504	foreach key [array names aopts] {
2505	    lappend opts $key $aopts($key)
2506	}
2507	set idx [lsearch -glob $expreshook($int,$pat) [list $opts $func $seq]]
2508	if {$idx >= 0} {
2509	    set expreshook($int,$pat) [lreplace $expreshook($int,$pat) $idx $idx]
2510	    if {$expreshook($int,$pat) eq {}} {
2511		unset expreshook($int,$pat)
2512	    }
2513	}
2514    }
2515}
2516
2517# jlib::element_register --
2518#
2519#       Used to get callbacks from non stanza elements, like sasl etc.
2520
2521proc jlib::element_register {jlibname xmlns func {seq 50}} {
2522
2523    upvar ${jlibname}::elementhook elementhook
2524
2525    lappend elementhook($xmlns) [list $func $seq]
2526    set elementhook($xmlns)  \
2527      [lsort -integer -index 1 [lsort -unique $elementhook($xmlns)]]
2528}
2529
2530proc jlib::element_deregister {jlibname xmlns func} {
2531
2532    upvar ${jlibname}::elementhook elementhook
2533
2534    if {![info exists elementhook($xmlns)]} {
2535	return
2536    }
2537    set ind -1
2538    set found 0
2539    foreach spec $elementhook($xmlns) {
2540	incr ind
2541	if {[string equal $func [lindex $spec 0]]} {
2542	    set found 1
2543	    break
2544	}
2545    }
2546    if {$found} {
2547	set elementhook($xmlns) [lreplace $elementhook($xmlns) $ind $ind]
2548    }
2549}
2550
2551proc jlib::element_run_hook {jlibname xmldata} {
2552
2553    upvar ${jlibname}::elementhook elementhook
2554
2555    set ishandled 0
2556    set xmlns [wrapper::getattribute $xmldata xmlns]
2557
2558    if {[info exists elementhook($xmlns)]} {
2559	foreach spec $elementhook($xmlns) {
2560	    set func [lindex $spec 0]
2561	    set code [catch {
2562		uplevel #0 $func [list $jlibname $xmldata]
2563	    } ans]
2564	    if {$code} {
2565		bgerror "preshook $func failed: $code\n$::errorInfo"
2566	    }
2567	    if {[string equal $ans "1"]} {
2568		set ishandled 1
2569		break
2570	    }
2571	}
2572    }
2573    return $ishandled
2574}
2575
2576# This part is supposed to be a maximal flexible event register mechanism.
2577#
2578# Bind:  stanza  (presence, iq, message,...)
2579#        its attributes  (optional)
2580#        any child tag name  (optional)
2581#        its attributes  (optional)
2582#
2583# genhook(stanza) = {{attrspec childspec func seq} ...}
2584#
2585# with:  attrspec = {name1 value1 name2 value2 ...}
2586#        childspec = {tag attrspec}
2587
2588# jlib::general_register --
2589#
2590#       A mechanism to register for almost any kind of elements.
2591
2592proc jlib::general_register {jlibname tag attrspec childspec func {seq 50}} {
2593
2594    upvar ${jlibname}::genhook genhook
2595
2596    lappend genhook($tag) [list $attrspec $childspec $func $seq]
2597    set genhook($tag)  \
2598      [lsort -integer -index 3 [lsort -unique $genhook($tag)]]
2599}
2600
2601proc jlib::general_run_hook {jlibname xmldata} {
2602
2603    upvar ${jlibname}::genhook genhook
2604
2605    set ishandled 0
2606    set tag [wrapper::gettag $xmldata]
2607    if {[info exists genhook($tag)]} {
2608	foreach spec $genhook($tag) {
2609	    lassign $spec attrspec childspec func seq
2610	    lassign $childspec ctag cattrspec
2611	    if {![match_attr $attrspec [wrapper::getattrlist $xmldata]]} {
2612		continue
2613	    }
2614
2615	    # Search child elements for matches.
2616	    set match 0
2617	    foreach c [wrapper::getchildren $xmldata] {
2618		if {$ctag ne "" && $ctag ne [wrapper::gettag $c]} {
2619		    continue
2620		}
2621		if {![match_attr $cattrspec [wrapper::getattrlist $c]]} {
2622		    continue
2623		}
2624		set match 1
2625		break
2626	    }
2627	    if {!$match} {
2628		continue
2629	    }
2630
2631	    # If the spec survived here it matched.
2632	    set code [catch {
2633		uplevel #0 $func [list $jlibname $xmldata]
2634	    } ans]
2635	    if {$code} {
2636		bgerror "genhook $func failed: $code\n$::errorInfo"
2637	    }
2638	    if {[string equal $ans "1"]} {
2639		set ishandled 1
2640		break
2641	    }
2642	}
2643    }
2644    return $ishandled
2645}
2646
2647proc jlib::match_attr {attrspec attr} {
2648
2649    array set attrA $attr
2650    foreach {name value} $attrspec {
2651	if {![info exists attrA($name)]} {
2652	    return 0
2653	} elseif {$value ne $attrA($name)} {
2654	    return 0
2655	}
2656    }
2657    return 1
2658}
2659
2660proc jlib::general_deregister {jlibname tag attrspec childspec func} {
2661
2662    upvar ${jlibname}::genhook genhook
2663
2664    if {[info exists genhook($tag)]} {
2665	set idx [lsearch -glob $genhook($tag) [list $attrspec $childspec $func *]]
2666	if {$idx >= 0} {
2667	    set genhook($tag) [lreplace $genhook($tag) $idx $idx]
2668
2669	}
2670    }
2671}
2672
2673# Test code...
2674if {0} {
2675    proc cb {args} {puts "************** $args"}
2676    set childspec [list query [list xmlns "http://jabber.org/protocol/disco#items"]]
2677    ::jlib::jlib1 general_register iq {} $childspec cb
2678    ::jlib::jlib1 general_deregister iq {} $childspec cb
2679
2680
2681}
2682
2683# jlib::send_iq --
2684#
2685#       To send an iq (info/query) packet.
2686#
2687# Arguments:
2688#       jlibname:   the instance of this jlib.
2689#       type:       can be "get", "set", "result", or "error".
2690#                   "result" and "error" are used when replying an incoming iq.
2691#       xmldata:    list of elements as xmllists
2692#       args:
2693#                   -to $to       : Specify jid to send this packet to. If it
2694#		    isn't specified, this part is set to sender's user-id by
2695#		    the server.
2696#
2697#                   -id $id       : Specify an id to send with the <iq>.
2698#                   If $type is "get", or "set", then the id will be generated
2699#                   by jlib internally, and this switch will not work.
2700#                   If $type is "result" or "error", then you may use this
2701#                   switch.
2702#
2703#                   -command $cmd : Specify a callback to call when the
2704#                   reply-packet is got. This switch will not work if $type
2705#                   is "result" or "error".
2706#
2707# Results:
2708#       none.
2709
2710proc jlib::send_iq {jlibname type xmldata args} {
2711
2712    upvar ${jlibname}::lib lib
2713    upvar ${jlibname}::iqcmd iqcmd
2714
2715    Debug 3 "jlib::send_iq type='$type', xmldata='$xmldata', args='$args'"
2716
2717    array set argsA $args
2718    set attrlist [list "type" $type]
2719
2720    # Need to generate a unique identifier (id) for this packet.
2721    if {[string equal $type "get"] || [string equal $type "set"]} {
2722	lappend attrlist "id" $iqcmd(uid)
2723
2724	# Record any callback procedure.
2725	if {[info exists argsA(-command)] && ($argsA(-command) ne "")} {
2726	    set iqcmd($iqcmd(uid)) $argsA(-command)
2727	}
2728	incr iqcmd(uid)
2729    } elseif {[info exists argsA(-id)]} {
2730	lappend attrlist "id" $argsA(-id)
2731    }
2732    unset -nocomplain argsA(-id) argsA(-command)
2733    foreach {key value} [array get argsA] {
2734	set name [string trimleft $key -]
2735	lappend attrlist $name $value
2736    }
2737    set xmllist [wrapper::createtag "iq" -attrlist $attrlist -subtags $xmldata]
2738
2739    send $jlibname $xmllist
2740    return
2741}
2742
2743# jlib::iq_get, iq_set --
2744#
2745#       Wrapper for 'send_iq' for set/getting namespaced elements.
2746#
2747# Arguments:
2748#       jlibname:   the instance of this jlib.
2749#       xmlns:
2750#       args:     -to recepient jid
2751#                 -command procName
2752#                 -sublists
2753#                 else as attributes
2754#
2755# Results:
2756#       none.
2757
2758proc jlib::iq_get {jlibname xmlns args} {
2759
2760    set opts [list]
2761    set sublists [list]
2762    set attrlist [list xmlns $xmlns]
2763    foreach {key value} $args {
2764
2765	switch -- $key {
2766	    -command {
2767		lappend opts -command  \
2768		  [list [namespace current]::invoke_iq_callback $jlibname $value]
2769	    }
2770	    -to {
2771		lappend opts -to $value
2772	    }
2773	    -sublists {
2774		set sublists $value
2775	    }
2776	    default {
2777		lappend attrlist [string trimleft $key "-"] $value
2778	    }
2779	}
2780    }
2781    set xmllist [wrapper::createtag "query" -attrlist $attrlist \
2782      -subtags $sublists]
2783    eval {send_iq $jlibname "get" [list $xmllist]} $opts
2784    return
2785}
2786
2787proc jlib::iq_set {jlibname xmlns args} {
2788
2789    set opts [list]
2790    set sublists [list]
2791    foreach {key value} $args {
2792
2793	switch -- $key {
2794	    -command {
2795		lappend opts -command  \
2796		  [list [namespace current]::invoke_iq_callback $jlibname $value]
2797	    }
2798	    -to {
2799		lappend opts -to $value
2800	    }
2801	    -sublists {
2802		set sublists $value
2803	    }
2804	    default {
2805		#lappend subelements [wrapper::createtag  \
2806		#  [string trimleft $key -] -chdata $value]
2807	    }
2808	}
2809    }
2810    set xmllist [wrapper::createtag "query" -attrlist [list xmlns $xmlns] \
2811      -subtags $sublists]
2812    eval {send_iq $jlibname "set" [list $xmllist]} $opts
2813    return
2814}
2815
2816# jlib::send_auth --
2817#
2818#       Send simple client authentication.
2819#       It implements the 'jabber:iq:auth' set method.
2820#
2821# Arguments:
2822#       jlibname:   the instance of this jlib.
2823#       username:
2824#       resource:
2825#       cmd:        client command to be executed at the iq "result" element.
2826#       args:       Any of "-password" or "-digest" must be given.
2827#           -password
2828#           -digest
2829#           -to
2830#
2831# Results:
2832#       none.
2833
2834proc jlib::send_auth {jlibname username resource cmd args} {
2835
2836    upvar ${jlibname}::locals locals
2837
2838    set subelements [list  \
2839      [wrapper::createtag "username" -chdata $username]  \
2840      [wrapper::createtag "resource" -chdata $resource]]
2841    set toopt [list]
2842
2843    foreach {key value} $args {
2844	switch -- $key {
2845	    -password - -digest {
2846		lappend subelements [wrapper::createtag  \
2847		  [string trimleft $key -] -chdata $value]
2848	    }
2849	    -to {
2850		set toopt [list -to $value]
2851	    }
2852	}
2853    }
2854
2855    # Cache our login jid.
2856    set myjid  ${username}@$locals(server)/${resource}
2857    set myjid2 ${username}@$locals(server)
2858
2859    set locals(username)  $username
2860    set locals(resource)  $resource
2861    set locals(myjid)     $myjid
2862    set locals(myjid2)    $myjid2
2863    set locals(myjidmap)  [jidmap $myjid]
2864    set locals(myjid2map) [jidmap $myjid2]
2865
2866    set xmllist [wrapper::createtag "query" -attrlist {xmlns jabber:iq:auth} \
2867      -subtags $subelements]
2868    eval {send_iq $jlibname "set" [list $xmllist] -command  \
2869      [list [namespace current]::invoke_iq_callback $jlibname $cmd]} $toopt
2870
2871    return
2872}
2873
2874# jlib::register_get --
2875#
2876#       Sent with a blank query to retrieve registration information.
2877#       Retrieves a key for use on future registration pushes.
2878#       It implements the 'jabber:iq:register' get method.
2879#
2880# Arguments:
2881#       jlibname:   the instance of this jlib.
2882#       cmd:        client command to be executed at the iq "result" element.
2883#       args:       -to     : the jid for the service
2884#
2885# Results:
2886#       none.
2887
2888proc jlib::register_get {jlibname cmd args} {
2889
2890    array set argsA $args
2891    set xmllist [wrapper::createtag "query" -attrlist {xmlns jabber:iq:register}]
2892    if {[info exists argsA(-to)]} {
2893	set toopt [list -to $argsA(-to)]
2894    } else {
2895	set toopt ""
2896    }
2897    eval {send_iq $jlibname "get" [list $xmllist] -command  \
2898      [list [namespace current]::invoke_iq_callback $jlibname $cmd]} $toopt
2899    return
2900}
2901
2902# jlib::register_set --
2903#
2904#       Create a new account with the server, or to update user information.
2905#       It implements the 'jabber:iq:register' set method.
2906#
2907# Arguments:
2908#       jlibname:   the instance of this jlib.
2909#       username:
2910#       password:
2911#       cmd:        client command to be executed at the iq "result" element.
2912#       args:       -to       : the jid for the service
2913#                   -nick     :
2914#                   -name     :
2915#                   -first    :
2916#                   -last     :
2917#                   -email    :
2918#                   -address  :
2919#                   -city     :
2920#                   -state    :
2921#                   -zip      :
2922#                   -phone    :
2923#                   -url      :
2924#                   -date     :
2925#                   -misc     :
2926#                   -text     :
2927#                   -key      :
2928#
2929# Results:
2930#       none.
2931
2932proc jlib::register_set {jlibname username password cmd args} {
2933
2934    set subelements [list  \
2935      [wrapper::createtag "username" -chdata $username]  \
2936      [wrapper::createtag "password" -chdata $password]]
2937    array set argsA $args
2938    foreach argsswitch [array names argsA] {
2939	if {[string equal $argsswitch "-to"]} {
2940	    continue
2941	}
2942	set par [string trimleft $argsswitch {-}]
2943	lappend subelements [wrapper::createtag $par  \
2944	  -chdata $argsA($argsswitch)]
2945    }
2946    set xmllist [wrapper::createtag "query"  \
2947      -attrlist {xmlns jabber:iq:register}   \
2948      -subtags $subelements]
2949
2950    if {[info exists argsA(-to)]} {
2951	set toopt [list -to $argsA(-to)]
2952    } else {
2953	set toopt ""
2954    }
2955    eval {send_iq $jlibname "set" [list $xmllist] -command  \
2956      [list [namespace current]::invoke_iq_callback $jlibname $cmd]} $toopt
2957    return
2958}
2959
2960# jlib::register_remove --
2961#
2962#       It implements the 'jabber:iq:register' set method with a <remove/> tag.
2963#
2964# Arguments:
2965#       jlibname:   the instance of this jlib.
2966#       to:
2967#       cmd:        client command to be executed at the iq "result" element.
2968#       args    -key
2969#
2970# Results:
2971#       none.
2972
2973proc jlib::register_remove {jlibname to cmd args} {
2974
2975    set subelements [list [wrapper::createtag "remove"]]
2976    array set argsA $args
2977    if {[info exists argsA(-key)]} {
2978	lappend subelements [wrapper::createtag "key" -chdata $argsA(-key)]
2979    }
2980    set xmllist [wrapper::createtag "query"  \
2981      -attrlist {xmlns jabber:iq:register} -subtags $subelements]
2982
2983    eval {send_iq $jlibname "set" [list $xmllist] -command   \
2984      [list [namespace current]::invoke_iq_callback $jlibname $cmd]} -to $to
2985    return
2986}
2987
2988# jlib::search_get --
2989#
2990#       Sent with a blank query to retrieve search information.
2991#       Retrieves a key for use on future search pushes.
2992#       It implements the 'jabber:iq:search' get method.
2993#
2994# Arguments:
2995#       jlibname:   the instance of this jlib.
2996#       to:         this must be a searchable jud service, typically
2997#                   'jud.jabber.org'.
2998#       cmd:        client command to be executed at the iq "result" element.
2999#
3000# Results:
3001#       none.
3002
3003proc jlib::search_get {jlibname to cmd} {
3004
3005    set xmllist [wrapper::createtag "query" -attrlist {xmlns jabber:iq:search}]
3006    send_iq $jlibname "get" [list $xmllist] -to $to -command        \
3007      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
3008    return
3009}
3010
3011# jlib::search_set --
3012#
3013#       Makes an actual search in our roster at the server.
3014#       It implements the 'jabber:iq:search' set method.
3015#
3016# Arguments:
3017#       jlibname:   the instance of this jlib.
3018#       cmd:        client command to be executed at the iq "result" element.
3019#       to:         this must be a searchable jud service, typically
3020#                   'jud.jabber.org'.
3021#       args:    -subtags list
3022#
3023# Results:
3024#       none.
3025
3026proc jlib::search_set {jlibname to cmd args} {
3027
3028    set argsA(-subtags) [list]
3029    array set argsA $args
3030
3031    set xmllist [wrapper::createtag "query"  \
3032      -attrlist {xmlns jabber:iq:search}   \
3033      -subtags $argsA(-subtags)]
3034    send_iq $jlibname "set" [list $xmllist] -to $to -command  \
3035      [list [namespace current]::parse_search_set $jlibname $cmd]
3036
3037    return
3038}
3039
3040# jlib::send_message --
3041#
3042#       Sends a message element.
3043#
3044# Arguments:
3045#       jlibname:   the instance of this jlib.
3046#       to:         the jabber id of the receiver.
3047#       args:
3048#                   -subject $subject     : Set subject of the message to
3049#                   $subject.
3050#
3051#                   -thread $thread       : Set thread of the message to
3052#                   $thread.
3053#
3054#                   -priority $priority   : Set priority of the message to
3055#                   $priority.
3056#
3057#                   -body text            :
3058#
3059#                   -type $type           : normal, chat or groupchat
3060#
3061#                   -id token
3062#
3063#                   -from                 : only for internal use, never send
3064#
3065#                   -xlist $xlist         : A list containing *X* xml_data.
3066#                   Anything can be put inside an *X*. Please make sure you
3067#                   created it with "wrapper::createtag" procedure,
3068#                   and also, it has a "xmlns" attribute in its root tag.
3069#
3070#                   -command
3071#
3072# Results:
3073#       none.
3074
3075proc jlib::send_message {jlibname to args} {
3076
3077    upvar ${jlibname}::msgcmd msgcmd
3078    upvar ${jlibname}::locals locals
3079
3080    Debug 3 "jlib::send_message to=$to, args=$args"
3081
3082    array set argsA $args
3083    if {[info exists argsA(-command)]} {
3084	set uid $msgcmd(uid)
3085	set msgcmd($uid) $argsA(-command)
3086	incr msgcmd(uid)
3087	lappend args -id $uid
3088	unset argsA(-command)
3089
3090	# There exist a weird situation if we send to ourself.
3091	# Skip this registered command the 1st time we get this,
3092	# and let any handlers take over. Trigger this 2nd time.
3093	if {[string equal $to $locals(myjidmap)]} {
3094	    set msgcmd($uid,self) 1
3095	}
3096
3097    }
3098    set xmllist [eval {send_message_xmllist $to} [array get argsA]]
3099    send $jlibname $xmllist
3100    return
3101}
3102
3103# jlib::send_message_xmllist --
3104#
3105#       Create the xml list for send_message.
3106
3107proc jlib::send_message_xmllist {to args} {
3108
3109    array set argsA $args
3110    set attr [list to $to]
3111    set children [list]
3112
3113    foreach {name value} $args {
3114	set par [string trimleft $name "-"]
3115
3116	switch -- $name {
3117	    -xlist {
3118		foreach xchild $value {
3119		    lappend children $xchild
3120		}
3121	    }
3122	    -type {
3123		if {![string equal $value "normal"]} {
3124		    lappend attr "type" $value
3125		}
3126	    }
3127	    -id - -from {
3128		lappend attr $par $value
3129	    }
3130	    default {
3131		lappend children [wrapper::createtag $par -chdata $value]
3132	    }
3133	}
3134    }
3135    return [wrapper::createtag "message" -attrlist $attr -subtags $children]
3136}
3137
3138# jlib::send_presence --
3139#
3140#       To send your presence.
3141#
3142# Arguments:
3143#
3144#       jlibname:   the instance of this jlib.
3145#       args:
3146#           -keep   0|1 (D=0) we may keep the present 'status' and 'show'
3147#                   elements for undirected presence
3148#           -to     the JID of the recepient.
3149#           -from   should never be set by client!
3150#           -type   one of 'available', 'unavailable', 'subscribe',
3151#                   'unsubscribe', 'subscribed', 'unsubscribed', 'invisible'.
3152#           -status
3153#           -priority  persistant option if undirected presence
3154#           -show
3155#           -xlist
3156#           -extras
3157#           -command   Specify a callback to call if we may expect any reply
3158#                   package, as entering a room with 'gc-1.0'.
3159#
3160# Results:
3161#       none.
3162
3163proc jlib::send_presence {jlibname args} {
3164
3165    variable statics
3166    upvar ${jlibname}::locals locals
3167    upvar ${jlibname}::opts opts
3168    upvar ${jlibname}::prescmd prescmd
3169    upvar ${jlibname}::pres pres
3170
3171    Debug 3 "jlib::send_presence args='$args'"
3172
3173    set attrlist [list]
3174    set children [list]
3175    set directed 0
3176    set keep     0
3177    set type "available"
3178    array set argsA $args
3179
3180    foreach {key value} $args {
3181	set par [string trimleft $key -]
3182
3183	switch -- $key {
3184	    -command {
3185		lappend attrlist "id" $prescmd(uid)
3186		set prescmd($prescmd(uid)) $value
3187		incr prescmd(uid)
3188	    }
3189	    -extras - -xlist {
3190		foreach xchild $value {
3191		    lappend children $xchild
3192		}
3193	    }
3194	    -from {
3195		# Should never happen!
3196		lappend attrlist $par $value
3197	    }
3198	    -keep {
3199		set keep $value
3200	    }
3201	    -priority - -show {
3202		lappend children [wrapper::createtag $par -chdata $value]
3203	    }
3204	    -status {
3205		if {$value ne ""} {
3206		    lappend children [wrapper::createtag $par -chdata $value]
3207		}
3208	    }
3209	    -to {
3210		# Presence to server (undirected) shall not contain a to.
3211		if {$value ne $locals(servermap)} {
3212		    lappend attrlist $par $value
3213		    set directed 1
3214		}
3215	    }
3216	    -type {
3217		set type $value
3218		if {[regexp $statics(presenceTypeExp) $type]} {
3219		    lappend attrlist $par $type
3220		} else {
3221		    return -code error "Is not valid presence type: \"$type\""
3222		}
3223	    }
3224	    default {
3225		return -code error "unrecognized option \"$value\""
3226	    }
3227	}
3228    }
3229
3230    # Must be destined to login server (by default).
3231    if {!$directed} {
3232
3233	# Each and every presence stanza MUST contain the complete presence
3234	# state of the client. As a convinience we cache previous states and
3235	# may use them if not set explicitly:
3236	#    1.  <show/>
3237	#    2.  <status/>
3238	#    3.  <priority/>  Always reused if cached
3239
3240	foreach name {show status} {
3241	    if {[info exists argsA(-$name)]} {
3242		set locals(pres,$name) $argsA(-$name)
3243	    } elseif {[info exists locals(pres,$name)]} {
3244		if {$keep} {
3245		    lappend children [wrapper::createtag $name  \
3246		      -chdata $locals(pres,$name)]
3247		} else {
3248		    unset -nocomplain locals(pres,$name)
3249		}
3250	    }
3251	}
3252	if {[info exists argsA(-priority)]} {
3253	    set locals(pres,priority) $argsA(-priority)
3254	} elseif {[info exists locals(pres,priority)]} {
3255	    lappend children [wrapper::createtag "priority"  \
3256	      -chdata $locals(pres,priority)]
3257	}
3258
3259	set locals(pres,type) $type
3260
3261	set locals(status) $type
3262	if {[info exists argsA(-show)]} {
3263	    set locals(status) $argsA(-show)
3264	    set locals(pres,show) $argsA(-show)
3265	}
3266    }
3267
3268    # Assemble our registered presence stanzas. Only for undirected?
3269    foreach {key elem} [array get pres "stanza,*,"] {
3270	lappend children $elem
3271    }
3272    foreach {key elem} [array get pres "stanza,*,$type"] {
3273	lappend children $elem
3274    }
3275
3276    set xmllist [wrapper::createtag "presence" -attrlist $attrlist \
3277      -subtags $children]
3278    send $jlibname $xmllist
3279
3280    return
3281}
3282
3283# jlib::register_presence_stanza, ... --
3284#
3285#       Each presence element we send to the server (undirected) must contain
3286#       the complete state. This is a way to add custom presence stanzas
3287#       to our internal presence state to send each time we set our presence
3288#       with the server (undirected presence).
3289#       They are stored by tag, xmlns, and an optional type attribute.
3290#       Any existing presence stanza with identical tag/xmlns/type will
3291#       be replaced.
3292#
3293# Arguments:
3294#       jlibname:   the instance of this jlib
3295#       elem:       xml element
3296#       args        -type  available | unavailable | ...
3297
3298proc jlib::register_presence_stanza {jlibname elem args} {
3299
3300    upvar ${jlibname}::pres pres
3301
3302    set argsA(-type) ""
3303    array set argsA $args
3304    set type $argsA(-type)
3305
3306    set tag   [wrapper::gettag $elem]
3307    set xmlns [wrapper::getattribute $elem xmlns]
3308    set pres(stanza,$tag,$xmlns,$type) $elem
3309}
3310
3311proc jlib::deregister_presence_stanza {jlibname tag xmlns} {
3312
3313    upvar ${jlibname}::pres pres
3314
3315    array unset pres "stanza,$tag,$xmlns,*"
3316}
3317
3318proc jlib::get_registered_presence_stanzas {jlibname {tag *} {xmlns *}} {
3319
3320    upvar ${jlibname}::pres pres
3321
3322    set stanzas [list]
3323    foreach key [array names pres -glob stanza,$tag,$xmlns,*] {
3324	lassign [split $key ,] - t x type
3325	set spec [list $t $x $pres($key)]
3326	if {$type ne ""} {
3327	    lappend spec -type $type
3328	}
3329	lappend stanzas $spec
3330    }
3331    return $stanzas
3332}
3333
3334# jlib::send --
3335#
3336#       Sends general xml using a xmllist.
3337#       Never throws error. Network errors reported via callback.
3338
3339proc jlib::send {jlibname xmllist} {
3340
3341    upvar ${jlibname}::lib lib
3342    upvar ${jlibname}::locals locals
3343
3344    # For the auto away function.
3345    if {$locals(trigAutoAway)} {
3346	schedule_auto_away $jlibname
3347    }
3348    set locals(last) [clock seconds]
3349    set xml [wrapper::createxml $xmllist]
3350    foreach cmd $lib(tee,send) {
3351	uplevel #0 $cmd [list $jlibname $xmllist]
3352    }
3353
3354    # We fail only if already in stream.
3355    # The first failure reports the network error, closes the stream,
3356    # which stops multiple errors to be reported to the client.
3357    if {$lib(isinstream)} {
3358	if {[catch {
3359	    uplevel #0 $lib(transport,send) [list $jlibname $xml]
3360	} err]} {
3361	    kill $jlibname
3362	    invoke_async_error $jlibname networkerror
3363	}
3364    }
3365    return
3366}
3367
3368# jlib::sendraw --
3369#
3370#       Send raw xml. The caller is responsible for catching errors.
3371
3372proc jlib::sendraw {jlibname xml} {
3373
3374    upvar ${jlibname}::lib lib
3375
3376    uplevel #0 $lib(transport,send) [list $jlibname $xml]
3377}
3378
3379# jlib::mypresence --
3380#
3381#       Returns any of {available away xa chat dnd invisible unavailable}
3382#       for our status with the login server.
3383
3384proc jlib::mypresence {jlibname} {
3385
3386    upvar ${jlibname}::locals locals
3387
3388    if {[info exists locals(pres,show)]} {
3389	return $locals(pres,show)
3390    } else {
3391	return $locals(pres,type)
3392    }
3393}
3394
3395proc jlib::mypresencestatus {jlibname} {
3396
3397    upvar ${jlibname}::locals locals
3398
3399    if {[info exists locals(pres,status)]} {
3400	return $locals(pres,status)
3401    } else {
3402	return ""
3403    }
3404}
3405
3406# jlib::myjid --
3407#
3408#       Returns our 3-tier jid as authorized with the login server.
3409
3410proc jlib::myjid {jlibname} {
3411    upvar ${jlibname}::locals locals
3412    return $locals(myjid)
3413}
3414
3415proc jlib::myjid2 {jlibname} {
3416    upvar ${jlibname}::locals locals
3417    return $locals(myjid2)
3418}
3419
3420proc jlib::myjidmap {jlibname} {
3421    upvar ${jlibname}::locals locals
3422    return $locals(myjidmap)
3423}
3424
3425proc jlib::myjid2map {jlibname} {
3426    upvar ${jlibname}::locals locals
3427    return $locals(myjid2map)
3428}
3429
3430# jlib::oob_set --
3431#
3432#       It implements the 'jabber:iq:oob' set method.
3433#
3434# Arguments:
3435#       jlibname:   the instance of this jlib.
3436#       to:
3437#       cmd:        client command to be executed at the iq "result" element.
3438#       url:
3439#       args:
3440#                   -desc
3441#
3442# Results:
3443#       none.
3444
3445proc jlib::oob_set {jlibname to cmd url args} {
3446
3447    set attrlist {xmlns jabber:iq:oob}
3448    set children [list [wrapper::createtag "url" -chdata $url]]
3449    array set argsA $args
3450    if {[info exists argsA(-desc)] && [string length $argsA(-desc)]} {
3451	lappend children [wrapper::createtag "desc" -chdata $argsA(-desc)]
3452    }
3453    set xmllist [wrapper::createtag query -attrlist $attrlist  \
3454      -subtags $children]
3455    send_iq $jlibname set [list $xmllist] -to $to -command  \
3456      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
3457    return
3458}
3459
3460# jlib::get_last --
3461#
3462#       Query the 'last' of 'to' using 'jabber:iq:last' get.
3463
3464proc jlib::get_last {jlibname to cmd} {
3465    variable jxmlns
3466
3467    set xmllist [wrapper::createtag "query"  \
3468      -attrlist {xmlns $jxmlns(last)}]
3469    send_iq $jlibname "get" [list $xmllist] -to $to -command   \
3470      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
3471    return
3472}
3473
3474# jlib::handle_get_last --
3475#
3476#       Seconds since last activity. Response to 'jabber:iq:last' get.
3477
3478proc jlib::handle_get_last {jlibname from subiq args} {
3479    variable jxmlns
3480    upvar ${jlibname}::locals locals
3481
3482    array set argsA $args
3483
3484    set secs [expr {[clock seconds] - $locals(last)}]
3485    set xmllist [wrapper::createtag "query"  \
3486      -attrlist [list xmlns $jxmlns(last) seconds $secs]]
3487
3488    set opts [list]
3489    if {[info exists argsA(-from)]} {
3490	lappend opts -to $argsA(-from)
3491    }
3492    if {[info exists argsA(-id)]} {
3493	lappend opts -id $argsA(-id)
3494    }
3495    eval {send_iq $jlibname "result" [list $xmllist]} $opts
3496
3497    # Tell jlib's iq-handler that we handled the event.
3498    return 1
3499}
3500
3501# jlib::get_time --
3502#
3503#       Query the 'time' of 'to' using 'jabber:iq:time' get.
3504
3505proc jlib::get_time {jlibname to cmd} {
3506    variable jxmlns
3507
3508    set xmllist [wrapper::createtag "query"  \
3509      -attrlist {xmlns $jxmlns(time)}]
3510    send_iq $jlibname "get" [list $xmllist] -to $to -command        \
3511      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
3512    return
3513}
3514
3515# jlib::handle_get_time --
3516#
3517#       Send our time. Response to 'jabber:iq:time' get.
3518
3519proc jlib::handle_get_time {jlibname from subiq args} {
3520    variable jxmlns
3521    array set argsA $args
3522
3523    # Applications using 'jabber:iq:time' SHOULD use the old format,
3524    # not the format defined in XEP-0082.
3525    set secs [clock seconds]
3526    set utc [clock format $secs -format "%Y%m%dT%H:%M:%S" -timezone :UTC]
3527    set tz "GMT"
3528    set display [clock format $secs]
3529    set subtags [list  \
3530      [wrapper::createtag "utc" -chdata $utc]  \
3531      [wrapper::createtag "tz" -chdata $tz]  \
3532      [wrapper::createtag "display" -chdata $display] ]
3533    set xmllist [wrapper::createtag "query" -subtags $subtags  \
3534      -attrlist {xmlns $jxmlns(time)}]
3535
3536    set opts [list]
3537    if {[info exists argsA(-from)]} {
3538	lappend opts -to $argsA(-from)
3539    }
3540    if {[info exists argsA(-id)]} {
3541	lappend opts -id $argsA(-id)
3542    }
3543    eval {send_iq $jlibname "result" [list $xmllist]} $opts
3544
3545    # Tell jlib's iq-handler that we handled the event.
3546    return 1
3547}
3548
3549# Support for XEP-0202 Entity Time.
3550
3551proc jlib::get_entity_time {jlibname to cmd} {
3552    variable jxmlns
3553
3554    set xmllist [wrapper::createtag "time"  \
3555      -attrlist [list xmlns $jxmlns(entitytime)]]
3556    send_iq $jlibname "get" [list $xmllist] -to $to -command        \
3557      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
3558    return
3559}
3560
3561proc jlib::handle_entity_time {jlibname from subiq args} {
3562    variable jxmlns
3563
3564    array set argsA $args
3565
3566    # Figure out our time zone in terms of HH:MM.
3567    # Compare with the GMT time and take the diff. Avoid year wrap around.
3568    set secs [clock seconds]
3569    set day [clock format $secs -format "%j"]
3570    if {$day eq "001"} {
3571	incr secs [expr {24*60*60}]
3572    } elseif {($day eq "365") || ($day eq "366")} {
3573	incr secs [expr {-2*24*60*60}]
3574    }
3575    set format "%S + 60*(%M + 60*(%H + 24*%j))"
3576    set local [clock format $secs -format $format]
3577    set gmt   [clock format $secs -format $format -timezone :UTC]
3578
3579    # Remove leading zeros since they will be interpreted as octals.
3580    regsub -all {0+([1-9]+)} $local {\1} local
3581    regsub -all {0+([1-9]+)} $gmt   {\1} gmt
3582    set local [expr {$local}]
3583    set gmt [expr {$gmt}]
3584    set mindiff [expr {($local - $gmt)/60}]
3585    set sign [expr {$mindiff >= 0 ? "" : "-"}]
3586    set zhour [expr {abs($mindiff)/60}]
3587    set zmin [expr {$mindiff % 60}]
3588    set tzo [format "$sign%.2d:%.2d" $zhour $zmin]
3589
3590    # Time format according to XEP-0082 (XMPP Date and Time Profiles).
3591    # <utc>2006-12-19T17:58:35Z</utc>
3592    set utc [clock format $secs -format "%Y-%m-%dT%H:%M:%SZ" -timezone :UTC]
3593
3594    set subtags [list  \
3595      [wrapper::createtag "tzo" -chdata $tzo] \
3596      [wrapper::createtag "utc" -chdata $utc] ]
3597    set xmllist [wrapper::createtag "time" -subtags $subtags  \
3598      -attrlist [list xmlns $jxmlns(entitytime)]]
3599
3600    set opts [list]
3601    if {[info exists argsA(-from)]} {
3602	lappend opts -to $argsA(-from)
3603    }
3604    if {[info exists argsA(-id)]} {
3605	lappend opts -id $argsA(-id)
3606    }
3607    eval {send_iq $jlibname "result" [list $xmllist]} $opts
3608    return 1
3609}
3610
3611# jlib::get_version --
3612#
3613#       Query the 'version' of 'to' using 'jabber:iq:version' get.
3614
3615proc jlib::get_version {jlibname to cmd} {
3616
3617    set xmllist [wrapper::createtag "query"  \
3618      -attrlist {xmlns jabber:iq:version}]
3619    send_iq $jlibname "get" [list $xmllist] -to $to -command   \
3620      [list [namespace current]::invoke_iq_callback $jlibname $cmd]
3621    return
3622}
3623
3624# jlib::handle_get_version --
3625#
3626#       Send our version. Response to 'jabber:iq:version' get.
3627
3628proc jlib::handle_get_version {jlibname from subiq args} {
3629    global  prefs tcl_platform
3630    variable version
3631
3632    array set argsA $args
3633
3634    # Return any id!
3635    set opts [list]
3636    if {[info exists argsA(-id)]} {
3637	set opts [list -id $argsA(-id)]
3638    }
3639    set os $tcl_platform(os)
3640    if {[info exists tcl_platform(osVersion)]} {
3641	append os " " $tcl_platform(osVersion)
3642    }
3643    lappend opts -to $from
3644    set subtags [list  \
3645      [wrapper::createtag name    -chdata "JabberLib"]  \
3646      [wrapper::createtag version -chdata $version]  \
3647      [wrapper::createtag os      -chdata $os] ]
3648    set xmllist [wrapper::createtag query -subtags $subtags  \
3649      -attrlist {xmlns jabber:iq:version}]
3650    eval {send_iq $jlibname "result" [list $xmllist]} $opts
3651
3652    # Tell jlib's iq-handler that we handled the event.
3653    return 1
3654}
3655
3656# jlib::schedule_keepalive --
3657#
3658#       Supposed to detect network failures but seems not to work like that.
3659
3660proc jlib::schedule_keepalive {jlibname} {
3661
3662    upvar ${jlibname}::locals locals
3663    upvar ${jlibname}::opts opts
3664    upvar ${jlibname}::lib lib
3665
3666    if {$opts(-keepalivesecs) && $lib(isinstream)} {
3667	if {[catch {
3668	    uplevel #0 $lib(transport,send) [list $jlibname "\n"]
3669	    flush $lib(sock)
3670	} err]} {
3671	    kill $jlibname
3672	    invoke_async_error $jlibname networkerror
3673	} else {
3674	    set locals(aliveid) [after [expr {1000 * $opts(-keepalivesecs)}] \
3675	      [list [namespace current]::schedule_keepalive $jlibname]]
3676	}
3677    }
3678}
3679
3680# OUTDATED !!!!!!!!!!!!!!!!!!!!
3681
3682# jlib::schedule_auto_away, cancel_auto_away, auto_away_cmd
3683#
3684#       Procedures for auto away things.
3685#       Better to use 'tk inactive' or 'tkinactive' and handle this on
3686#       application level.
3687
3688proc jlib::schedule_auto_away {jlibname} {
3689
3690    upvar ${jlibname}::locals locals
3691    upvar ${jlibname}::opts opts
3692
3693    cancel_auto_away $jlibname
3694    if {$opts(-autoawaymins) > 0} {
3695	set locals(afterawayid) [after [expr {60000 * $opts(-autoawaymins)}] \
3696	  [list [namespace current]::auto_away_cmd $jlibname away]]
3697    }
3698    if {$opts(-xautoawaymins) > 0} {
3699	set locals(afterxawayid) [after [expr {60000 * $opts(-xautoawaymins)}] \
3700	  [list [namespace current]::auto_away_cmd $jlibname xaway]]
3701    }
3702}
3703
3704proc jlib::cancel_auto_away {jlibname} {
3705
3706    upvar ${jlibname}::locals locals
3707
3708    if {[info exists locals(afterawayid)]} {
3709	after cancel $locals(afterawayid)
3710	unset locals(afterawayid)
3711    }
3712    if {[info exists locals(afterxawayid)]} {
3713	after cancel $locals(afterxawayid)
3714	unset locals(afterxawayid)
3715    }
3716}
3717
3718# jlib::auto_away_cmd --
3719#
3720#       what:       "away", or "xaway"
3721#
3722#       @@@ Replaced by idletime and AutoAway
3723
3724proc jlib::auto_away_cmd {jlibname what} {
3725
3726    variable statusPriority
3727    upvar ${jlibname}::locals locals
3728    upvar ${jlibname}::lib lib
3729    upvar ${jlibname}::opts opts
3730
3731    Debug 3 "jlib::auto_away_cmd what=$what"
3732
3733    if {$what eq "xaway"} {
3734	set status xa
3735    } else {
3736	set status $what
3737    }
3738
3739    # Auto away and extended away are only set when the
3740    # current status has a lower priority than away or xa respectively.
3741    if {$statusPriority($locals(status)) >= $statusPriority($status)} {
3742	return
3743    }
3744
3745    # Be sure not to trig ourselves.
3746    set locals(trigAutoAway) 0
3747
3748    switch -- $what {
3749	away {
3750	    send_presence $jlibname -show "away" -status $opts(-awaymsg)
3751	}
3752	xaway {
3753	    send_presence $jlibname -show "xa" -status $opts(-xawaymsg)
3754	}
3755    }
3756    set locals(trigAutoAway) 1
3757    uplevel #0 $lib(clientcmd) [list $jlibname $status]
3758}
3759
3760# jlib::getrecipientjid --
3761#
3762#       Tries to obtain the correct form of jid to send message to.
3763#       Follows the XMPP spec, section 4.1.
3764#
3765#       @@@ Perhaps this should go in app code?
3766
3767proc jlib::getrecipientjid {jlibname jid} {
3768    variable statics
3769
3770    set jid2 [barejid $jid]
3771    set isroom [[namespace current]::service::isroom $jlibname $jid2]
3772    if {$isroom} {
3773	return $jid
3774    } elseif {[info exists statics(roster)] &&  \
3775      [$jlibname roster isavailable $jid]} {
3776	return $jid
3777    } else {
3778	return $jid2
3779    }
3780}
3781
3782proc jlib::getlang {} {
3783
3784    if {[catch {package require msgcat}]} {
3785	return en
3786    } else {
3787	set lang [lindex [::msgcat::mcpreferences] end]
3788
3789	switch -- $lang {
3790	    "" - c - posix {
3791		return en
3792	    }
3793	    default {
3794		return $lang
3795	    }
3796	}
3797    }
3798}
3799
3800namespace eval jlib {
3801
3802    # We just the http error codes here since may be useful if we only
3803    # get the 'code' attribute in an error element.
3804    # @@@ Add to message catalogs.
3805    variable errCodeToText
3806    array set errCodeToText {
3807	100 "Continue"
3808	101 "Switching Protocols"
3809	200 "OK"
3810	201 "Created"
3811	202 "Accepted"
3812	203 "Non-Authoritative Information"
3813	204 "No Content"
3814	205 "Reset Content"
3815	206 "Partial Content"
3816	300 "Multiple Choices"
3817	301 "Moved Permanently"
3818	302 "Found"
3819	303 "See Other"
3820	304 "Not Modified"
3821	305 "Use Proxy"
3822	307 "Temporary Redirect"
3823	400 "Bad Request"
3824	401 "Unauthorized"
3825	402 "Payment Required"
3826	403 "Forbidden"
3827	404 "Not Found"
3828	405 "Method Not Allowed"
3829	406 "Not Acceptable"
3830	407 "Proxy Authentication Required"
3831	408 "Request Time-out"
3832	409 "Conflict"
3833	410 "Gone"
3834	411 "Length Required"
3835	412 "Precondition Failed"
3836	413 "Request Entity Too Large"
3837	414 "Request-URI Too Large"
3838	415 "Unsupported Media Type"
3839	416 "Requested Range Not Satisfiable"
3840	417 "Expectation Failed"
3841	500 "Internal Server Error"
3842	501 "Not Implemented"
3843	502 "Bad Gateway"
3844	503 "Service Unavailable"
3845	504 "Gateway Time-out"
3846	505 "HTTP Version not supported"
3847    }
3848}
3849
3850# Various utility procedures to handle jid's....................................
3851
3852# jlib::ESC --
3853#
3854#	array get and array unset accepts glob characters. These need to be
3855#	escaped if they occur as part of a JID.
3856#	NB1: 'string match pattern str' MUST have pattern escaped!
3857#	NB2: This also applies to 'lsearch'!
3858
3859proc jlib::ESC {s} {
3860    return [string map {* \\* ? \\? [ \\[ ] \\] \\ \\\\} $s]
3861}
3862
3863# STRINGPREPs for the differnt parts of jids.
3864
3865proc jlib::UnicodeListToRE {ulist} {
3866
3867    set str [string map {- -\\u} $ulist]
3868    set str "\\u[join $str \\u]"
3869    return [subst $str]
3870}
3871
3872# jlib::MakeHexHexEscList --
3873#
3874#       Takes a list of characters and transforms them to their hexhex form.
3875#       Used by: XEP-0106: JID Escaping
3876
3877proc jlib::MakeHexHexEscList {clist} {
3878
3879    set hexlist [list]
3880    foreach c $clist {
3881	scan $c %c n
3882	lappend hexlist [format %x $n]
3883    }
3884    return $hexlist
3885}
3886
3887proc jlib::MakeHexHexCharMap {clist} {
3888
3889    set map [list]
3890    foreach c $clist h [MakeHexHexEscList $clist] {
3891	lappend map $c \\$h
3892    }
3893    return $map
3894}
3895
3896proc jlib::MakeHexHexInvCharMap {clist} {
3897
3898    set map [list]
3899    foreach c $clist h [MakeHexHexEscList $clist] {
3900	lappend map \\$h $c
3901    }
3902    return $map
3903}
3904
3905namespace eval jlib {
3906
3907    # Characters that need to be escaped since non valid.
3908    #       XEP-0106: JID Escaping
3909    variable jidEsc { "\&'/:<>@\\}
3910    variable jidEscMap [MakeHexHexCharMap [split $jidEsc ""]]
3911    variable jidEscInvMap [MakeHexHexInvCharMap [split $jidEsc ""]]
3912
3913    # Prohibited ASCII characters.
3914    set asciiC12C22 {\x00-\x1f\x80-\x9f\x7f\xa0}
3915    set asciiC11 {\x20}
3916
3917    # C.1.1 is actually allowed (RFC3491), weird!
3918    set    asciiProhibit(domain) $asciiC11
3919    append asciiProhibit(domain) $asciiC12C22
3920    append asciiProhibit(domain) /@
3921
3922    # The nodeprep prohibits these characters in addition:
3923    # All whitespace characters (which reduce to U+0020, also called SP)
3924    # U+0022 (")
3925    # U+0026 (&)
3926    # U+0027 (')
3927    # U+002F (/)
3928    # U+003A (:)
3929    # U+003C (<)
3930    # U+003E (>)
3931    # U+0040 (@)
3932    set    asciiProhibit(node) {"&'/:<>@}
3933    append asciiProhibit(node) $asciiC11
3934    append asciiProhibit(node) $asciiC12C22
3935
3936    set asciiProhibit(resource) $asciiC12C22
3937
3938    # RFC 3454 (STRINGPREP); all unicode characters:
3939    #
3940    # Maps to nothing (empty).
3941    set mapB1 {
3942	00ad	034f	1806	180b	180c	180d	200b	200c
3943	200d	2060	fe00	fe01	fe02	fe03	fe04	fe05
3944	fe06	fe07	fe08	fe09	fe0a	fe0b	fe0c	fe0d
3945	fe0e	fe0f	feff
3946    }
3947
3948    # ASCII space characters. Just a space.
3949    set prohibitC11 {0020}
3950
3951    # Non-ASCII space characters
3952    set prohibitC12 {
3953	00a0	1680	2000	2001	2002	2003	2004	2005
3954	2006	2007	2008	2009	200a	200b	202f	205f
3955	3000
3956    }
3957
3958    # C.2.1 ASCII control characters
3959    set prohibitC21 {
3960	0000-001F   007F
3961    }
3962
3963    # C.2.2 Non-ASCII control characters
3964    set prohibitC22 {
3965	0080-009f	06dd	070f	180e	200c	200d	2028
3966	2029	2060	2061	2062	2063	206a-206f	feff
3967	fff9-fffc       1d173-1d17a
3968    }
3969
3970    # C.3 Private use
3971    set prohibitC3 {
3972	e000-f8ff	f0000-ffffd	100000-10fffd
3973    }
3974
3975    # C.4 Non-character code points
3976    set prohibitC4 {
3977	fdd0-fdef	fffe-ffff	1fffe-1ffff	2fffe-2ffff
3978	3fffe-3ffff	4fffe-4ffff	5fffe-5ffff	6fffe-6ffff
3979	7fffe-7ffff	8fffe-8ffff	9fffe-9ffff	afffe-affff
3980	bfffe-bffff	cfffe-cffff	dfffe-dffff	efffe-effff
3981	ffffe-fffff	10fffe-10ffff
3982    }
3983
3984    # C.5 Surrogate codes
3985    set prohibitC5 {d800-dfff}
3986
3987    # C.6 Inappropriate for plain text
3988    set prohibitC6 {
3989	fff9	fffa	fffb	fffc	fffd
3990    }
3991
3992    # C.7 Inappropriate for canonical representation
3993    set prohibitC7 {2ff0-2ffb}
3994
3995    # C.8 Change display properties or are deprecated
3996    set prohibitC8 {
3997	0340	0341	200e	200f	202a	202b	202c	202d
3998	202e	206a	206b	206c	206d	206e	206f
3999    }
4000
4001    # Test: 0, 1, 2, A-Z
4002    set test {
4003	0030    0031   0032    0041-005a
4004    }
4005
4006    # And many more...
4007
4008    variable mapB1RE       [UnicodeListToRE $mapB1]
4009    variable prohibitC11RE [UnicodeListToRE $prohibitC11]
4010    variable prohibitC12RE [UnicodeListToRE $prohibitC12]
4011
4012}
4013
4014# jlib::splitjid --
4015#
4016#       Splits a general jid into a jid-2-tier and resource
4017
4018proc jlib::splitjid {jid jid2Var resourceVar} {
4019
4020    set idx [string first / $jid]
4021    if {$idx == -1} {
4022	uplevel 1 [list set $jid2Var $jid]
4023	uplevel 1 [list set $resourceVar {}]
4024    } else {
4025	set jid2 [string range $jid 0 [expr {$idx - 1}]]
4026	set res [string range $jid [expr {$idx + 1}] end]
4027	uplevel 1 [list set $jid2Var $jid2]
4028	uplevel 1 [list set $resourceVar $res]
4029    }
4030}
4031
4032# jlib::splitjidex --
4033#
4034#       Split a jid into the parts: jid = [ node "@" ] domain [ "/" resource ]
4035#       Possibly empty. Doesn't check for valid content, only the form.
4036#
4037#       RFC3920 3.1:
4038#            jid             = [ node "@" ] domain [ "/" resource ]
4039
4040proc jlib::splitjidex {jid nodeVar domainVar resourceVar} {
4041
4042    set node   ""
4043    set domain ""
4044    set res    ""
4045
4046    # Node part:
4047    set idx [string first @ $jid]
4048    if {$idx > 0} {
4049	set node [string range $jid 0 [expr {$idx-1}]]
4050	set jid [string range $jid [expr {$idx+1}] end]
4051    }
4052
4053    # Resource part:
4054    set idx [string first / $jid]
4055    if {$idx > 0} {
4056	set res [string range $jid [expr {$idx+1}] end]
4057	set jid [string range $jid 0 [expr {$idx-1}]]
4058    }
4059
4060    # Domain part is what remains:
4061    set domain $jid
4062
4063    uplevel 1 [list set $nodeVar $node]
4064    uplevel 1 [list set $domainVar $domain]
4065    uplevel 1 [list set $resourceVar $res]
4066}
4067
4068proc jlib::barejid {jid} {
4069
4070    set idx [string first / $jid]
4071    if {$idx == -1} {
4072	return $jid
4073    } else {
4074	return [string range $jid 0 [expr {$idx-1}]]
4075    }
4076}
4077
4078proc jlib::resourcejid {jid} {
4079    set idx [string first / $jid]
4080    if {$idx > 0} {
4081	return [string range $jid [expr {$idx+1}] end]
4082    } else {
4083	return ""
4084    }
4085}
4086
4087proc jlib::isbarejid {jid} {
4088    return [expr {([string first / $jid] == -1) ? 1 : 0}]
4089}
4090
4091proc jlib::isfulljid {jid} {
4092    return [expr {([string first / $jid] == -1) ? 0 : 1}]
4093}
4094
4095# jlib::joinjid --
4096#
4097#       Joins the, optionally empty, parts into a jid.
4098#       domain must be nonempty though.
4099
4100proc jlib::joinjid {node domain resource} {
4101
4102    set jid $domain
4103    if {$node ne ""} {
4104	set jid ${node}@${jid}
4105    }
4106    if {$resource ne ""} {
4107	append jid "/$resource"
4108    }
4109    return $jid
4110}
4111
4112# jlib::jidequal --
4113#
4114#       Checks if two jids are actually equal after mapped. Does not check
4115#       for prohibited characters.
4116
4117proc jlib::jidequal {jid1 jid2} {
4118    return [string equal [jidmap $jid1] [jidmap $jid2]]
4119}
4120
4121# jlib::jidvalidate --
4122#
4123#       Checks if this is a valid jid interms of form and characters.
4124
4125proc jlib::jidvalidate {jid} {
4126
4127    if {$jid eq ""} {
4128	return 0
4129    } elseif {[catch {splitjidex $jid node name resource} ans]} {
4130	return 0
4131    }
4132    foreach what {node name resource} {
4133	if {$what ne ""} {
4134	    if {[catch {${what}prep [set $what]} ans]} {
4135		return 0
4136	    }
4137	}
4138    }
4139    return 1
4140}
4141
4142# String preparation (STRINGPREP) RFC3454:
4143#
4144#    The steps for preparing strings are:
4145#
4146#  1) Map -- For each character in the input, check if it has a mapping
4147#     and, if so, replace it with its mapping.  This is described in
4148#     section 3.
4149#
4150#  2) Normalize -- Possibly normalize the result of step 1 using Unicode
4151#     normalization.  This is described in section 4.
4152#
4153#  3) Prohibit -- Check for any characters that are not allowed in the
4154#     output.  If any are found, return an error.  This is described in
4155#     section 5.
4156#
4157#  4) Check bidi -- Possibly check for right-to-left characters, and if
4158#     any are found, make sure that the whole string satisfies the
4159#     requirements for bidirectional strings.  If the string does not
4160#     satisfy the requirements for bidirectional strings, return an
4161#     error.  This is described in section 6.
4162
4163# jlib::*map --
4164#
4165#       Does the mapping part.
4166
4167proc jlib::nodemap {node} {
4168
4169    return [string tolower $node]
4170}
4171
4172proc jlib::namemap {domain} {
4173
4174    return [string tolower $domain]
4175}
4176
4177proc jlib::resourcemap {resource} {
4178
4179    # Note that resources are case sensitive!
4180    return $resource
4181}
4182
4183# jlib::*prep --
4184#
4185#       Does the complete stringprep.
4186
4187proc jlib::nodeprep {node} {
4188    variable asciiProhibit
4189
4190    set node [nodemap $node]
4191    if {[regexp ".*\[${asciiProhibit(node)}\].*" $node]} {
4192	return -code error "node part contains illegal character(s)"
4193    }
4194    return $node
4195}
4196
4197proc jlib::nameprep {domain} {
4198    variable asciiProhibit
4199
4200    set domain [namemap $domain]
4201    if {[regexp ".*\[${asciiProhibit(domain)}\].*" $domain]} {
4202	return -code error "domain contains illegal character(s)"
4203    }
4204    return $domain
4205}
4206
4207proc jlib::resourceprep {resource} {
4208    variable asciiProhibit
4209
4210    set resource [resourcemap $resource]
4211
4212    # Orinary spaces are allowed!
4213    if {[regexp ".*\[${asciiProhibit(resource)}\].*" $resource]} {
4214	return -code error "resource contains illegal character(s)"
4215    }
4216    return $resource
4217}
4218
4219# jlib::jidmap --
4220#
4221#       Does the mapping part of STRINGPREP. Does not check for prohibited
4222#       characters.
4223#
4224# Results:
4225#       throws an error if form unrecognized, else the mapped jid.
4226
4227proc jlib::jidmap {jid} {
4228
4229    if {$jid eq ""} {
4230	return
4231    }
4232    # Guard against spurious spaces.
4233    set jid [string trim $jid]
4234    splitjidex $jid node domain resource
4235    return [joinjid [nodemap $node] [namemap $domain] [resourcemap $resource]]
4236}
4237
4238# jlib::jidprep --
4239#
4240#       Applies STRINGPREP to the individiual and specific parts of the jid.
4241#
4242# Results:
4243#       throws an error if prohibited, else the prepared jid.
4244
4245proc jlib::jidprep {jid} {
4246
4247    if {$jid eq ""} {
4248	return
4249    }
4250    splitjidex $jid node domain resource
4251    set node     [nodeprep $node]
4252    set domain   [nameprep $domain]
4253    set resource [resourceprep $resource]
4254    return [joinjid $node $domain $resource]
4255}
4256
4257proc jlib::MapStr {str } {
4258
4259    # TODO
4260}
4261
4262# jlib::escapestr, unescapestr, escapejid, unescapejid --
4263#
4264#       XEP-0106: JID Escaping
4265#       NB1: 'escapstr' and 'unescapstr' must only be applied to the node
4266#            part of a JID.
4267#       NB2: 'escapstr' must never be applied twice!
4268#       NB3: it is currently unclear if escaping should be allowed on "ordinary"
4269#            user JIDs
4270
4271proc jlib::escapestr {str} {
4272    variable jidEscMap
4273    return [string map $jidEscMap $str]
4274}
4275
4276proc jlib::unescapestr {str} {
4277    variable jidEscInvMap
4278    return [string map $jidEscInvMap $str]
4279}
4280
4281proc jlib::escapejid {jid} {
4282
4283    # Node part:
4284    # @@@ I think there is a protocol flaw here!!!
4285    set idx [string first @ $jid]
4286    if {$idx > 0} {
4287	set node [string range $jid 0 [expr {$idx-1}]]
4288	set rest [string range $jid [expr {$idx+1}] end]
4289	return [escapestr $node]@$rest
4290    } else {
4291	return $jid
4292    }
4293}
4294
4295proc jlib::unescapejid {jid} {
4296
4297    # Node part:
4298    # @@@ I think there is a protocol flaw here!!!
4299    set idx [string first @ $jid]
4300    if {$idx > 0} {
4301	set node [string range $jid 0 [expr {$idx-1}]]
4302	set rest [string range $jid [expr {$idx+1}] end]
4303	return [unescapestr $node]@$rest
4304    } else {
4305	return $jid
4306    }
4307}
4308
4309proc jlib::setdebug {args} {
4310    variable debug
4311
4312    if {[llength $args] == 0} {
4313	return $debug
4314    } elseif {[llength $args] == 1} {
4315	set debug $args
4316    } else {
4317	return -code error "Usage: jlib::setdebug ?integer?"
4318    }
4319}
4320
4321# jlib::generateuuid --
4322#
4323#       Simplified uuid generator. See the uuid package for a better one.
4324
4325proc jlib::generateuuid {} {
4326    set MAX_INT 0x7FFFFFFF
4327    # Bugfix Eric Hassold from Evolane
4328    set hex1 [format {%x} [expr {[clock clicks] & $MAX_INT}]]
4329    set hex2 [format {%x} [expr {int($MAX_INT*rand())}]]
4330    return $hex1-$hex2
4331}
4332
4333proc jlib::Debug {num str} {
4334    global  fdDebug
4335    variable debug
4336    if {$num <= $debug} {
4337	if {[info exists fdDebug]} {
4338	    puts $fdDebug $str
4339	    flush $fdDebug
4340	}
4341	puts $str
4342    }
4343}
4344
4345#-------------------------------------------------------------------------------
4346