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