1# roster.tcl -- 2# 3# An object for storing the roster and presence information for a 4# jabber client. Is used together with jabberlib. 5# 6# Copyright (c) 2001-2006 Mats Bengtsson 7# 8# This file is distributed under BSD style license. 9# 10# $Id: roster.tcl,v 1.68 2008-03-29 11:55:06 matben Exp $ 11# 12# Note that every jid in the rostA is usually (always) without any resource, 13# but the jid's in the presA are identical to the 'from' attribute, except 14# the presA($jid-2,res) which have any resource stripped off. The 'from' 15# attribute are (always) with /resource. 16# 17# All jid's in internal arrays are STRINGPREPed! 18# 19# Variables used in roster: 20# 21# rostA(groups) : List of all groups the exist in roster. 22# 23# rostA($jid,item) : $jid. 24# 25# rostA($jid,name) : Name of $jid. 26# 27# rostA($jid,groups) : Groups $jid is in. Note: PLURAL! 28# 29# rostA($jid,subscription) : Subscription of $jid (to|from|both|"") 30# 31# rostA($jid,ask) : "Ask" of $jid 32# (subscribe|unsubscribe|"") 33# 34# presA($jid-2,res) : List of resources for this $jid. 35# 36# presA($from,type) : One of 'available' or 'unavailable. 37# 38# presA($from,status) : The presence status element. 39# 40# presA($from,priority) : The presence priority element. 41# 42# presA($from,show) : The presence show element. 43# 44# presA($from,x,xmlns) : Storage for x elements. 45# xmlns is a namespace but where any 46# http://jabber.org/protocol/ stripped off 47# 48# oldpresA : As presA but any previous state. 49# 50# state($jid,*) : Keeps other info not directly related 51# to roster or presence elements. 52# 53############################# USAGE ############################################ 54# 55# Changes to the state of this object should only be made from jabberlib, 56# and never directly by the client! 57# 58# NAME 59# roster - an object for roster and presence information. 60# 61# SYNOPSIS 62# jlibname roster cmd ?? 63# 64# INSTANCE COMMANDS 65# jlibname roster availablesince jid 66# jlibname roster clearpresence ?jidpattern? 67# jlibname roster getgroups ?jid? 68# jlibname roster getask jid 69# jlibname roster getcapsattr jid name 70# jlibname roster getname jid 71# jlibname roster getpresence jid ?-resource, -type? 72# jlibname roster getresources jid 73# jlibname roster gethighestresource jid 74# jlibname roster getrosteritem jid 75# jlibname roster getstatus jid 76# jlibname roster getsubscription jid 77# jlibname roster getusers ?-type available|unavailable? 78# jlibname roster getx jid xmlns 79# jlibname roster getextras jid xmlns 80# jlibname roster isavailable jid 81# jlibname roster isitem jid 82# jlibname roster haveroster 83# jlibname roster reset 84# jlibname roster send_get ?-command tclProc? 85# jlibname roster send_remove ?-command tclProc? 86# jlibname roster send_set ?-command tclProc, -name, -groups? 87# jlibname roster wasavailable jid 88# 89# The 'clientCommand' procedure must have the following form: 90# 91# clientCommand {jlibname what {jid {}} args} 92# 93# where 'what' can be any of: enterroster, exitroster, presence, remove, set. 94# The args is a list of '-key value' pairs with the following keys for each 95# 'what': 96# enterroster: no keys 97# exitroster: no keys 98# presence: -resource (required) 99# -type (required) 100# -status (optional) 101# -priority (optional) 102# -show (optional) 103# -x (optional) 104# -extras (optional) 105# remove: no keys 106# set: -name (optional) 107# -subscription (optional) 108# -groups (optional) 109# -ask (optional) 110# 111################################################################################ 112 113package require jlib 114 115package provide jlib::roster 1.0 116 117namespace eval jlib::roster { 118 119 variable rostGlobals 120 121 # Globals same for all instances of this roster. 122 set rostGlobals(debug) 0 123 124 # List of all rostA element sub entries. First the actual roster, 125 # with 'rostA($jid,...)' 126 set rostGlobals(tags) {name groups ask subscription} 127 128 # ...and the presence arrays: 'presA($jid/$resource,...)' 129 # The list of resources is treated separately (presA($jid,res)) 130 set rostGlobals(presTags) {type status priority show x} 131 132 # Used for sorting resources. 133 variable statusPrio 134 array set statusPrio { 135 chat 1 136 available 2 137 away 3 138 xa 4 139 dnd 5 140 invisible 6 141 unavailable 7 142 } 143 144 # Note: jlib::ensamble_register is last in this file! 145} 146 147# jlib::roster::roster -- 148# 149# This creates a new instance of a roster. 150# 151# Arguments: 152# clientCmd: callback procedure when internals of roster or 153# presence changes. 154# args: 155# 156# Results: 157# 158 159proc jlib::roster::init {jlibname args} { 160 161 # Instance specific namespace. 162 namespace eval ${jlibname}::roster { 163 variable rostA 164 variable presA 165 variable options 166 variable priv 167 168 set priv(haveroster) 0 169 } 170 171 # Set simpler variable names. 172 upvar ${jlibname}::roster::rostA rostA 173 upvar ${jlibname}::roster::options options 174 175 # Register for roster pushes. 176 $jlibname iq_register set "jabber:iq:roster" [namespace code set_handler] 177 178 # Register for presence. Be sure they are first in order. 179 # @@@ We should have a separate internal register API to avoid any conflicts. 180 $jlibname presence_register_int available \ 181 [namespace code presence_handler] 10 182 $jlibname presence_register_int unavailable \ 183 [namespace code presence_handler] 10 184 185 set rostA(groups) [list] 186 set options(cmd) "" 187 188 jlib::register_package roster 189} 190 191# jlib::roster::cmdproc -- 192# 193# Just dispatches the command to the right procedure. 194# 195# Arguments: 196# jlibname: name of existing jabberlib instance 197# cmd: 198# args: all args to the cmd procedure. 199# 200# Results: 201# none. 202 203proc jlib::roster::cmdproc {jlibname cmd args} { 204 205 # Which command? Just dispatch the command to the right procedure. 206 return [eval {$cmd $jlibname} $args] 207} 208 209# jlib::roster::register_cmd -- 210# 211# This sets a client callback command. 212 213proc jlib::roster::register_cmd {jlibname cmd} { 214 upvar ${jlibname}::roster::options options 215 216 set options(cmd) $cmd 217} 218 219proc jlib::roster::haveroster {jlibname} { 220 upvar ${jlibname}::roster::priv priv 221 222 return $priv(haveroster) 223} 224 225# jlib::roster::send_get -- 226# 227# Request our complete roster. 228# 229# Arguments: 230# jlibname: name of existing jabberlib instance 231# args: -command tclProc 232# 233# Results: 234# none. 235 236proc jlib::roster::send_get {jlibname args} { 237 238 array set argsA {-command {}} 239 array set argsA $args 240 241 set queryE [wrapper::createtag "query" \ 242 -attrlist [list xmlns jabber:iq:roster]] 243 jlib::send_iq $jlibname "get" [list $queryE] \ 244 -command [list [namespace current]::send_get_cb $jlibname $argsA(-command)] 245 return 246} 247 248proc jlib::roster::send_get_cb {jlibname cmd type queryE} { 249 250 if {![string equal $type "error"]} { 251 enterroster $jlibname 252 handle_roster $jlibname $queryE 253 exitroster $jlibname 254 } 255 if {$cmd ne {}} { 256 uplevel #0 $cmd [list $type $queryE] 257 } 258} 259 260# jlib::roster::set_handler -- 261# 262# This gets called for roster pushes. 263 264proc jlib::roster::set_handler {jlibname from queryE args} { 265 266 handle_roster $jlibname $queryE 267 268 # RFC 3921, sect 8.1: 269 # The 'from' and 'to' addresses are OPTIONAL in roster pushes; ... 270 # A client MUST acknowledge each roster push with an IQ stanza of 271 # type "result"... 272 array set argsA $args 273 if {[info exists argsA(-id)]} { 274 $jlibname send_iq "result" {} -id $argsA(-id) 275 } 276 return 1 277} 278 279proc jlib::roster::handle_roster {jlibname queryE} { 280 281 upvar ${jlibname}::roster::itemA itemA 282 283 foreach itemE [wrapper::getchildren $queryE] { 284 if {[wrapper::gettag $itemE] ne "item"} { 285 continue 286 } 287 set subscription "none" 288 set opts [list] 289 set havejid 0 290 foreach {aname avalue} [wrapper::getattrlist $itemE] { 291 set $aname $avalue 292 if {$aname eq "jid"} { 293 set havejid 1 294 } else { 295 lappend opts -$aname $avalue 296 } 297 } 298 299 # This shall NEVER happen! 300 if {!$havejid} { 301 continue 302 } 303 set mjid [jlib::jidmap $jid] 304 if {$subscription eq "remove"} { 305 unset -nocomplain itemA($mjid) 306 removeitem $jlibname $jid 307 } else { 308 set itemA($mjid) $itemE 309 set groups [list] 310 foreach groupE [wrapper::getchildswithtag $itemE group] { 311 lappend groups [wrapper::getcdata $groupE] 312 } 313 if {[llength $groups]} { 314 lappend opts -groups $groups 315 } 316 eval {setitem $jlibname $jid} $opts 317 } 318 } 319} 320 321# jlib::roster::send_set -- 322# 323# To set/add an jid in/to your roster. 324# 325# Arguments: 326# jlibname: the instance of this jlib. 327# jid: jabber user id to add/set. 328# args: 329# -command tclProc 330# -name $name: A name to show the user-id as on roster to the user. 331# -groups $group_list: Groups of user. If you omit this, then the user's 332# groups will be set according to the user's options 333# stored in the roster object. If user doesn't exist, 334# or you haven't got your roster, user's groups will be 335# set to "", which means no groups. 336# 337# Results: 338# none. 339 340proc jlib::roster::send_set {jlibname jid args} { 341 342 upvar ${jlibname}::roster::rostA rostA 343 344 array set argsA {-command {}} 345 array set argsA $args 346 347 set mjid [jlib::jidmap $jid] 348 349 # Find group(s). 350 if {[info exists argsA(-groups)]} { 351 set groups $argsA(-groups) 352 } elseif {[info exists rostA($mjid,groups)]} { 353 set groups $rostA($mjid,groups) 354 } else { 355 set groups [list] 356 } 357 358 set attr [list jid $jid] 359 set name "" 360 if {[info exists argsA(-name)] && [string length $argsA(-name)]} { 361 set name $argsA(-name) 362 lappend attr name $name 363 } 364 set groupEs [list] 365 foreach group $groups { 366 if {$group ne ""} { 367 lappend groupEs [wrapper::createtag "group" -chdata $group] 368 } 369 } 370 371 # Roster items get pushed to us. Only any errors need to be taken care of. 372 set itemE [wrapper::createtag "item" -attrlist $attr -subtags $groupEs] 373 set queryE [wrapper::createtag "query" \ 374 -attrlist [list xmlns jabber:iq:roster] -subtags [list $itemE]] 375 jlib::send_iq $jlibname "set" [list $queryE] -command $argsA(-command) 376 return 377} 378 379proc jlib::roster::send_remove {jlibname jid args} { 380 381 array set argsA {-command {}} 382 array set argsA $args 383 384 # Roster items get pushed to us. Only any errors need to be taken care of. 385 set itemE [wrapper::createtag "item" \ 386 -attrlist [list jid $jid subscription remove]] 387 set queryE [wrapper::createtag "query" \ 388 -attrlist [list xmlns jabber:iq:roster] -subtags [list $itemE]] 389 jlib::send_iq $jlibname "set" [list $queryE] -command $argsA(-command) 390 return 391} 392 393# jlib::roster::setitem -- 394# 395# Adds or modifies an existing roster item. 396# Features not set are left as they are; features not set will give 397# nonexisting array entries, just to differentiate between an empty 398# element and a nonexisting one. 399# 400# Arguments: 401# jlibname: the instance of this jlib. 402# jid: 2-tier jid, with no /resource, usually. 403# Some transports keep a resource part in jid. 404# args: a list of '-key value' pairs, where '-key' is any of: 405# -name value 406# -subscription value 407# -groups list Note: GROUPS in plural! 408# -ask value 409# 410# Results: 411# none. 412 413proc jlib::roster::setitem {jlibname jid args} { 414 variable rostGlobals 415 upvar ${jlibname}::roster::rostA rostA 416 upvar ${jlibname}::roster::options options 417 418 Debug 2 "roster::setitem jid='$jid', args='$args'" 419 420 set mjid [jlib::jidmap $jid] 421 422 # Clear out the old state since an 'ask' element may still be lurking. 423 foreach key $rostGlobals(tags) { 424 unset -nocomplain rostA($mjid,$key) 425 } 426 427 # This array is better than list to keep track of users. 428 set rostA($mjid,item) $mjid 429 430 # Old values will be overwritten, nonexisting options will result in 431 # nonexisting array entries. 432 foreach {name value} $args { 433 set par [string trimleft $name "-"] 434 set rostA($mjid,$par) $value 435 if {[string equal $par "groups"]} { 436 foreach gr $value { 437 if {[lsearch -exact $rostA(groups) $gr] < 0} { 438 lappend rostA(groups) $gr 439 } 440 } 441 } 442 } 443 444 # Be sure to evaluate the registered command procedure. 445 if {[string length $options(cmd)]} { 446 uplevel #0 $options(cmd) [list $jlibname set $jid] $args 447 } 448 return 449} 450 451# jlib::roster::removeitem -- 452# 453# Removes an existing roster item and all its presence info. 454# 455# Arguments: 456# jlibname: the instance of this jlib. 457# jid: 2-tier jid with no /resource. 458# 459# Results: 460# none. 461 462proc jlib::roster::removeitem {jlibname jid} { 463 variable rostGlobals 464 465 upvar ${jlibname}::roster::rostA rostA 466 upvar ${jlibname}::roster::presA presA 467 upvar ${jlibname}::roster::oldpresA oldpresA 468 upvar ${jlibname}::roster::options options 469 470 Debug 2 "roster::removeitem jid='$jid'" 471 472 set mjid [jlib::jidmap $jid] 473 474 # Be sure to evaluate the registered command procedure. 475 # Do this BEFORE unsetting the internal state! 476 if {[string length $options(cmd)]} { 477 uplevel #0 $options(cmd) [list $jlibname remove $jid] 478 } 479 480 # First the roster, then presence... 481 foreach name $rostGlobals(tags) { 482 unset -nocomplain rostA($mjid,$name) 483 } 484 unset -nocomplain rostA($mjid,item) 485 486 # Be sure to unset all, also jid3 entries! 487 array unset presA [jlib::ESC $mjid]* 488 array unset oldpresA [jlib::ESC $mjid]* 489 return 490} 491 492# jlib::roster::ClearRoster -- 493# 494# Removes all existing roster items but keeps all presence info.(?) 495# and list of resources. 496# 497# Arguments: 498# jlibname: the instance of this jlib. 499# 500# Results: 501# none. Callback evaluated. 502 503proc jlib::roster::ClearRoster {jlibname} { 504 505 variable rostGlobals 506 upvar ${jlibname}::roster::rostA rostA 507 upvar ${jlibname}::roster::itemA itemA 508 upvar ${jlibname}::roster::options options 509 510 Debug 2 "roster::ClearRoster" 511 512 # Remove the roster. 513 foreach {x mjid} [array get rostA *,item] { 514 foreach key $rostGlobals(tags) { 515 unset -nocomplain rostA($mjid,$key) 516 } 517 } 518 array unset rostA *,item 519 unset -nocomplain itemA 520 521 # Be sure to evaluate the registered command procedure. 522 if {[string length $options(cmd)]} { 523 uplevel #0 $options(cmd) [list $jlibname enterroster] 524 } 525 return 526} 527 528# jlib::roster::enterroster -- 529# 530# Is called when new roster coming. 531# 532# Arguments: 533# jlibname: the instance of this jlib. 534# 535# Results: 536# none. 537 538proc jlib::roster::enterroster {jlibname} { 539 540 ClearRoster $jlibname 541} 542 543# jlib::roster::exitroster -- 544# 545# Is called when finished receiving a roster get command. 546# 547# Arguments: 548# jlibname: the instance of this jlib. 549# 550# Results: 551# none. Callback evaluated. 552 553proc jlib::roster::exitroster {jlibname} { 554 555 upvar ${jlibname}::roster::options options 556 upvar ${jlibname}::roster::priv priv 557 558 set priv(haveroster) 1 559 560 # Be sure to evaluate the registered command procedure. 561 if {[string length $options(cmd)]} { 562 uplevel #0 $options(cmd) [list $jlibname exitroster] 563 } 564} 565 566# jlib::roster::reset -- 567# 568# Removes everything stored in the roster object, including all roster 569# items and any presence information. 570 571proc jlib::roster::reset {jlibname} { 572 573 upvar ${jlibname}::roster::rostA rostA 574 upvar ${jlibname}::roster::presA presA 575 upvar ${jlibname}::roster::priv priv 576 577 unset -nocomplain rostA presA 578 set rostA(groups) {} 579 set priv(haveroster) 0 580} 581 582# jlib::roster::clearpresence -- 583# 584# Removes all presence cached internally for jid glob pattern. 585# Helpful when exiting a room. 586# 587# Arguments: 588# jlibname: the instance of this jlib. 589# jidpattern: glob pattern for items to remove. 590# 591# Results: 592# none. 593 594proc jlib::roster::clearpresence {jlibname {jidpattern ""}} { 595 596 upvar ${jlibname}::roster::presA presA 597 upvar ${jlibname}::roster::oldpresA oldpresA 598 599 Debug 2 "roster::clearpresence '$jidpattern'" 600 601 if {$jidpattern eq ""} { 602 unset -nocomplain presA 603 } else { 604 array unset presA $jidpattern 605 array unset oldpresA $jidpattern 606 } 607} 608 609proc jlib::roster::presence_handler {jlibname xmldata} { 610 presence $jlibname $xmldata 611 return 0 612} 613 614# jlib::roster::presence -- 615# 616# Registered internal presence handler for 'available' and 'unavailable' 617# that caches all presence info. 618 619proc jlib::roster::presence {jlibname xmldata} { 620 621 variable rostGlobals 622 upvar ${jlibname}::roster::rostA rostA 623 upvar ${jlibname}::roster::presA presA 624 upvar ${jlibname}::roster::oldpresA oldpresA 625 upvar ${jlibname}::roster::state state 626 627 Debug 2 "jlib::roster::presence" 628 629 set from [wrapper::getattribute $xmldata from] 630 set type [wrapper::getattribute $xmldata type] 631 if {$type eq ""} { 632 set type "available" 633 } 634 635 # We don't handle subscription types (remove?). 636 if {$type ne "available" && $type ne "unavailable"} { 637 return 638 } 639 640 set mjid [jlib::jidmap $from] 641 jlib::splitjid $mjid mjid2 res 642 643 # Set secs only if unavailable before. 644 if {![info exists presA($mjid,type)] \ 645 || ($presA($mjid,type) eq "unavailable")} { 646 set state($mjid,secs) [clock seconds] 647 } 648 649 # Keep cache of any old state. 650 # Note special handling of * for array unset - prefix with \\ to quote. 651 array unset oldpresA [jlib::ESC $mjid],* 652 array set oldpresA [array get presA [jlib::ESC $mjid],*] 653 654 # Clear out the old presence state since elements may still be lurking. 655 array unset presA [jlib::ESC $mjid],* 656 657 # Add to list of resources. 658 set presA($mjid2,res) [lsort -unique [lappend presA($mjid2,res) $res]] 659 660 set presA($mjid,type) $type 661 662 foreach E [wrapper::getchildren $xmldata] { 663 set tag [wrapper::gettag $E] 664 set chdata [wrapper::getcdata $E] 665 666 switch -- $tag { 667 priority { 668 if {[string is integer -strict $chdata]} { 669 set presA($mjid,$tag) $chdata 670 } 671 } 672 status { 673 set presA($mjid,$tag) $chdata 674 } 675 show { 676 if {[regexp {^(away|chat|dnd|xa)$} $chdata]} { 677 set presA($mjid,$tag) $chdata 678 } 679 } 680 x { 681 set ns [wrapper::getattribute $E xmlns] 682 regexp {http://jabber.org/protocol/(.*)$} $ns - ns 683 set presA($mjid,x,$ns) $E 684 } 685 default { 686 687 # This can be anything properly namespaced. 688 set ns [wrapper::getattribute $E xmlns] 689 set presA($mjid,extras,$ns) $E 690 } 691 } 692 } 693} 694 695 696# Firts attempt to keep the jid's as they are reported, with no separate 697# resource part. 698 699proc jlib::roster::setpresence2 {jlibname xmldata} { 700 701 702} 703 704# jlib::roster::getrosteritem -- 705# 706# Returns the state of an existing roster item. 707# 708# Arguments: 709# jlibname: the instance of this jlib. 710# jid: . 711# 712# Results: 713# a list of '-key value' pairs where key is any of: 714# name, groups, subscription, ask. Note GROUPS in plural! 715 716proc jlib::roster::getrosteritem {jlibname jid} { 717 718 variable rostGlobals 719 upvar ${jlibname}::roster::rostA rostA 720 upvar ${jlibname}::roster::options options 721 722 Debug 2 "roster::getrosteritem jid='$jid'" 723 724 set mjid [jlib::jidmap $jid] 725 if {![info exists rostA($mjid,item)]} { 726 return {} 727 } 728 set result [list] 729 foreach key $rostGlobals(tags) { 730 if {[info exists rostA($mjid,$key)]} { 731 lappend result -$key $rostA($mjid,$key) 732 } 733 } 734 return $result 735} 736 737proc jlib::roster::getitem {jlibname jid} { 738 739 upvar ${jlibname}::roster::itemA itemA 740 741 set mjid [jlib::jidmap $jid] 742 if {[info exists itemA($mjid)]} { 743 return $itemA($mjid) 744 } else { 745 return {} 746 } 747} 748 749# jlib::roster::isitem -- 750# 751# Does the jid exist in the roster? 752 753proc jlib::roster::isitem {jlibname jid} { 754 755 upvar ${jlibname}::roster::rostA rostA 756 757 set mjid [jlib::jidmap $jid] 758 return [expr {[info exists rostA($mjid,item)] ? 1 : 0}] 759} 760 761# jlib::roster::getrosterjid -- 762# 763# Returns the matching jid as reported by a roster item. 764# If given a full JID try match this, else bare JID. 765# If given a bare JID try match this, else find any matching full JID. 766# For ordinary users this is a jid2. 767# 768# @@@ NB: For the new xmpp lib we shall have a mapping from the roster JID 769# to a set of online JID's if any, which shall be completely indpendent 770# of bare vs. full JID forms! 771# 772# Arguments: 773# jlibname: the instance of this jlib. 774# jid: 775# 776# Results: 777# a jid or empty if no matching roster item. 778 779proc jlib::roster::getrosterjid {jlibname jid} { 780 781 upvar ${jlibname}::roster::rostA rostA 782 783 set mjid [jlib::jidmap $jid] 784 if {[info exists rostA($mjid,item)]} { 785 return $jid 786 } else { 787 set mjid2 [jlib::barejid $mjid] 788 if {[info exists rostA($mjid2,item)]} { 789 return [jlib::barejid $jid] 790 } else { 791 set name [array names rostA [jlib::ESC $mjid2]*,item] 792 if {[llength $name] == 1} { 793 # There should only be one. 794 return [string map {",item" ""} $name] 795 } 796 } 797 } 798 return 799} 800 801# jlib::roster::getusers -- 802# 803# Returns a list of jid's of all existing roster items. 804# 805# Arguments: 806# jlibname: the instance of this jlib. 807# args: -type available|unavailable 808# 809# Results: 810# list of all 2-tier jid's in roster 811 812proc jlib::roster::getusers {jlibname args} { 813 814 upvar ${jlibname}::roster::rostA rostA 815 upvar ${jlibname}::roster::presA presA 816 817 set all {} 818 foreach {x jid} [array get rostA *,item] { 819 lappend all $jid 820 } 821 array set argsA $args 822 set jidlist {} 823 if {$args == {}} { 824 set jidlist $all 825 } elseif {[info exists argsA(-type)]} { 826 set type $argsA(-type) 827 set jidlist {} 828 foreach jid2 $all { 829 set isavailable 0 830 831 # Be sure to handle empty resources as well: '1234@icq.host' 832 foreach key [array names presA "[jlib::ESC $jid2]*,type"] { 833 if {[string equal $presA($key) "available"]} { 834 set isavailable 1 835 break 836 } 837 } 838 if {$isavailable && [string equal $type "available"]} { 839 lappend jidlist $jid2 840 } elseif {!$isavailable && [string equal $type "unavailable"]} { 841 lappend jidlist $jid2 842 } 843 } 844 } 845 return $jidlist 846} 847 848# jlib::roster::getpresence -- 849# 850# Returns the presence state of an existing roster item. 851# This is as reported in presence element. 852# 853# Arguments: 854# jlibname: the instance of this jlib. 855# jid: username@server, without /resource. 856# args ?-resource, -type? 857# -resource: return presence for this alone, 858# else a list for each resource. 859# Allow empty resources!!?? 860# -type: return presence for (un)available only. 861# 862# Results: 863# a list of '-key value' pairs where key is any of: 864# resource, type, status, priority, show, x. 865# If the 'resource' in argument is not given, 866# the result contains a sublist for each resource. IMPORTANT! Bad? 867# BAD!!!!!!!!!!!!!!!!!!!!!!!! 868 869proc jlib::roster::getpresence {jlibname jid args} { 870 871 variable rostGlobals 872 upvar ${jlibname}::roster::rostA rostA 873 upvar ${jlibname}::roster::presA presA 874 upvar ${jlibname}::roster::options options 875 876 Debug 2 "roster::getpresence jid=$jid, args='$args'" 877 878 set jid [jlib::jidmap $jid] 879 array set argsA $args 880 set haveRes 0 881 if {[info exists argsA(-resource)]} { 882 set haveRes 1 883 set resource $argsA(-resource) 884 } 885 886 # It may happen that there is no roster item for this jid (groupchat). 887 if {![info exists presA($jid,res)] || ($presA($jid,res) eq "")} { 888 if {[info exists argsA(-type)] && \ 889 [string equal $argsA(-type) "available"]} { 890 return 891 } else { 892 if {$haveRes} { 893 return [list -resource $resource -type unavailable] 894 } else { 895 return [list [list -resource "" -type unavailable]] 896 } 897 } 898 } 899 900 set result [list] 901 if {$haveRes} { 902 903 # Return presence only from the specified resource. 904 # Be sure to handle empty resources as well: '1234@icq.host' 905 if {[lsearch -exact $presA($jid,res) $resource] < 0} { 906 return [list -resource $resource -type unavailable] 907 } 908 set result [list -resource $resource] 909 if {$resource eq ""} { 910 set jid3 $jid 911 } else { 912 set jid3 $jid/$resource 913 } 914 if {[info exists argsA(-type)] && \ 915 ![string equal $argsA(-type) $presA($jid3,type)]} { 916 return 917 } 918 foreach key $rostGlobals(presTags) { 919 if {[info exists presA($jid3,$key)]} { 920 lappend result -$key $presA($jid3,$key) 921 } 922 } 923 } else { 924 925 # Get presence for all resources. 926 # Be sure to handle empty resources as well: '1234@icq.host' 927 foreach res $presA($jid,res) { 928 set thisRes [list -resource $res] 929 if {$res eq ""} { 930 set jid3 $jid 931 } else { 932 set jid3 $jid/$res 933 } 934 if {[info exists argsA(-type)] && \ 935 ![string equal $argsA(-type) $presA($jid3,type)]} { 936 # Empty. 937 } else { 938 foreach key $rostGlobals(presTags) { 939 if {[info exists presA($jid3,$key)]} { 940 lappend thisRes -$key $presA($jid3,$key) 941 } 942 } 943 lappend result $thisRes 944 } 945 } 946 } 947 return $result 948} 949 950# UNFINISHED!!!!!!!!!! 951# Return empty list or -type unavailable ??? 952# '-key value' or 'key value' ??? 953# Returns a list of flat arrays 954 955proc jlib::roster::getpresence2 {jlibname jid args} { 956 957 variable rostGlobals 958 upvar ${jlibname}::roster::rostA rostA 959 upvar ${jlibname}::roster::presA2 presA2 960 upvar ${jlibname}::roster::options options 961 962 Debug 2 "roster::getpresence2 jid=$jid, args='$args'" 963 964 array set argsA { 965 -type * 966 } 967 array set argsA $args 968 969 set mjid [jlib::jidmap $jid] 970 jlib::splitjid $mjid jid2 resource 971 set result {} 972 973 if {$resource eq ""} { 974 975 # 2-tier jid. Match any resource. 976 set arrlist [concat [array get presA2 [jlib::ESC $mjid],jid] \ 977 [array get presA2 [jlib::ESC $mjid]/*,jid]] 978 foreach {key value} $arrlist { 979 set thejid $value 980 set jidresult {} 981 foreach {akey avalue} [array get presA2 [jlib::ESC $thejid],*] { 982 set thekey [string map [list $thejid, ""] $akey] 983 lappend jidresult -$thekey $avalue 984 } 985 if {[llength $jidresult]} { 986 lappend result $jidresult 987 } 988 } 989 } else { 990 991 # 3-tier jid. Only exact match. 992 if {[info exists presA2($mjid,type)]} { 993 if {[string match $argsA(-type) $presA2($mjid,type)]} { 994 set result [list [list -jid $jid -type $presA2($mjid,type)]] 995 } 996 } else { 997 set result [list [list -jid $jid -type unavailable]] 998 } 999 } 1000 return $result 1001} 1002 1003# jlib::roster::getoldpresence -- 1004# 1005# This makes a simplified assumption and uses the full JID. 1006 1007proc jlib::roster::getoldpresence {jlibname jid} { 1008 1009 variable rostGlobals 1010 upvar ${jlibname}::roster::rostA rostA 1011 upvar ${jlibname}::roster::oldpresA oldpresA 1012 1013 set jid [jlib::jidmap $jid] 1014 1015 if {[info exists oldpresA($jid,type)]} { 1016 set result [list] 1017 foreach key $rostGlobals(presTags) { 1018 if {[info exists oldpresA($jid,$key)]} { 1019 lappend result -$key $oldpresA($jid,$key) 1020 } 1021 } 1022 } else { 1023 set result [list -type unavailable] 1024 } 1025 return $result 1026} 1027 1028# jlib::roster::getgroups -- 1029# 1030# Returns the list of groups for this jid, or an empty list if not 1031# exists. If no jid, return a list of all groups existing in this roster. 1032# 1033# Arguments: 1034# jlibname: the instance of this jlib. 1035# jid: (optional). 1036# 1037# Results: 1038# a list of groups or empty. 1039 1040proc jlib::roster::getgroups {jlibname {jid {}}} { 1041 1042 upvar ${jlibname}::roster::rostA rostA 1043 1044 Debug 2 "roster::getgroups jid='$jid'" 1045 1046 set jid [jlib::jidmap $jid] 1047 if {[string length $jid]} { 1048 if {[info exists rostA($jid,groups)]} { 1049 return $rostA($jid,groups) 1050 } else { 1051 return 1052 } 1053 } else { 1054 set rostA(groups) [lsort -unique $rostA(groups)] 1055 return $rostA(groups) 1056 } 1057} 1058 1059# jlib::roster::getname -- 1060# 1061# Returns the roster name of this jid. 1062# 1063# Arguments: 1064# jlibname: the instance of this jlib. 1065# jid: 1066# 1067# Results: 1068# the roster name or empty. 1069 1070proc jlib::roster::getname {jlibname jid} { 1071 1072 upvar ${jlibname}::roster::rostA rostA 1073 1074 set jid [jlib::jidmap $jid] 1075 if {[info exists rostA($jid,name)]} { 1076 return $rostA($jid,name) 1077 } else { 1078 return "" 1079 } 1080} 1081 1082# jlib::roster::getsubscription -- 1083# 1084# Returns the 'subscription' state of this jid. 1085# 1086# Arguments: 1087# jlibname: the instance of this jlib. 1088# jid: 1089# 1090# Results: 1091# the 'subscription' state or "none" if no 'subscription' state. 1092 1093proc jlib::roster::getsubscription {jlibname jid} { 1094 1095 upvar ${jlibname}::roster::rostA rostA 1096 1097 set jid [jlib::jidmap $jid] 1098 if {[info exists rostA($jid,subscription)]} { 1099 return $rostA($jid,subscription) 1100 } else { 1101 return none 1102 } 1103} 1104 1105# jlib::roster::getask -- 1106# 1107# Returns the 'ask' state of this jid. 1108# 1109# Arguments: 1110# jlibname: the instance of this jlib. 1111# jid: 1112# 1113# Results: 1114# the 'ask' state or empty if no 'ask' state. 1115 1116proc jlib::roster::getask {jlibname jid} { 1117 1118 upvar ${jlibname}::roster::rostA rostA 1119 1120 Debug 2 "roster::getask jid='$jid'" 1121 1122 if {[info exists rostA($jid,ask)]} { 1123 return $rostA($jid,ask) 1124 } else { 1125 return "" 1126 } 1127} 1128 1129# jlib::roster::getresources -- 1130# 1131# Returns a list of all resources for this JID or empty. 1132# 1133# Arguments: 1134# jlibname: the instance of this jlib. 1135# jid: a JID without any resource (jid2) typically. 1136# it must be the JID which is reported by roster. 1137# args ?-type? 1138# -type: return presence for (un)available only. 1139# 1140# Results: 1141# a list of all resources for this jid or empty. 1142 1143proc jlib::roster::getresources {jlibname jid args} { 1144 1145 upvar ${jlibname}::roster::presA presA 1146 1147 Debug 2 "roster::getresources jid='$jid'" 1148 array set argsA $args 1149 1150 set jid [jlib::jidmap $jid] 1151 if {[info exists presA($jid,res)]} { 1152 if {[info exists argsA(-type)]} { 1153 1154 # Need to loop through all resources for this jid. 1155 set resL [list] 1156 set type $argsA(-type) 1157 foreach res $presA($jid,res) { 1158 1159 # Be sure to handle empty resources as well: '1234@icq.host' 1160 if {$res eq ""} { 1161 set jid3 $jid 1162 } else { 1163 set jid3 $jid/$res 1164 } 1165 if {[string equal $argsA(-type) $presA($jid3,type)]} { 1166 lappend resL $res 1167 } 1168 } 1169 return $resL 1170 } else { 1171 return $presA($jid,res) 1172 } 1173 } else { 1174 1175 # If the roster JID is something like: icq.home.se/registered 1176 set jid2 [jlib::barejid $jid] 1177 if {[info exists presA($jid2,res)]} { 1178 if {[info exists argsA(-type)]} { 1179 1180 # Need to loop through all resources for this jid. 1181 set resL [list] 1182 set type $argsA(-type) 1183 foreach res $presA($jid2,res) { 1184 1185 # Be sure to handle empty resources as well: '1234@icq.host' 1186 if {$res eq ""} { 1187 set jid3 $jid2 1188 } else { 1189 set jid3 $jid2/$res 1190 } 1191 if {[string equal $argsA(-type) $presA($jid3,type)]} { 1192 lappend resL $res 1193 } 1194 } 1195 return $resL 1196 } else { 1197 return $presA($jid2,res) 1198 } 1199 } else { 1200 return 1201 } 1202 } 1203} 1204 1205proc jlib::roster::getmatchingjids2 {jlibname jid args} { 1206 1207 upvar ${jlibname}::roster::presA2 presA2 1208 1209 set jidlist {} 1210 set arrlist [concat [array get presA2 [jlib::ESC $mjid],jid] \ 1211 [array get presA2 [jlib::ESC $mjid]/*,jid]] 1212 foreach {key value} $arrlist { 1213 lappend jidlist $value 1214 } 1215 return $jidlist 1216} 1217 1218# jlib::roster::gethighestresource -- 1219# 1220# Returns the resource with highest priority for this jid or empty. 1221# 1222# Arguments: 1223# jlibname: the instance of this jlib. 1224# jid: a jid without any resource (jid2). 1225# 1226# Results: 1227# a resource for this jid or empty if unavailable. 1228 1229proc jlib::roster::gethighestresource {jlibname jid} { 1230 1231 upvar ${jlibname}::roster::presA presA 1232 variable statusPrio 1233 1234 Debug 2 "roster::gethighestresource jid='$jid'" 1235 1236 set jid [jlib::jidmap $jid] 1237 set maxResL [list] 1238 1239 # @@@ Perhaps this sorting shall be made when receiving presence instead? 1240 1241 if {[info exists presA($jid,res)]} { 1242 1243 # Find the resource corresponding to the highest priority (D=0). 1244 set maxPrio -128 1245 1246 foreach res $presA($jid,res) { 1247 1248 # Be sure to handle empty resources as well: '1234@icq.host' 1249 if {$res eq ""} { 1250 set jid3 $jid 1251 } else { 1252 set jid3 $jid/$res 1253 } 1254 if {[info exists presA($jid3,type)]} { 1255 if {$presA($jid3,type) eq "available"} { 1256 set prio 0 1257 if {[info exists presA($jid3,priority)]} { 1258 set prio $presA($jid3,priority) 1259 } 1260 if {$prio > $maxPrio} { 1261 set maxPrio $prio 1262 set maxResL [list $res] 1263 } elseif {$prio == $maxPrio} { 1264 lappend maxResL $res 1265 } 1266 } 1267 } 1268 } 1269 } 1270 if {[llength $maxResL] == 1} { 1271 set maxRes [lindex $maxResL 0] 1272 } elseif {[llength $maxResL] > 1} { 1273 1274 # Sort according to show attributes. 1275 set resIndL [list] 1276 foreach res $maxResL { 1277 if {$res eq ""} { 1278 set jid3 $jid 1279 } else { 1280 set jid3 $jid/$res 1281 } 1282 set show "available" 1283 if {[info exists presA($jid3,show)]} { 1284 set show $presA($jid3,show) 1285 } 1286 lappend resIndL [list $res $statusPrio($show)] 1287 } 1288 set resIndL [lsort -integer -index 1 $resIndL] 1289 set maxRes [lindex $resIndL 0 0] 1290 } else { 1291 set maxRes "" 1292 } 1293 return $maxRes 1294} 1295 1296proc jlib::roster::getmaxpriorityjid2 {jlibname jid} { 1297 1298 upvar ${jlibname}::roster::presA2 presA2 1299 1300 Debug 2 "roster::getmaxpriorityjid2 jid='$jid'" 1301 1302 # Find the resource corresponding to the highest priority (D=0). 1303 set maxjid "" 1304 set maxpri 0 1305 foreach jid3 [getmatchingjids2 $jlibname $jid] { 1306 if {[info exists presA2($jid3,priority)]} { 1307 if {$presA2($jid3,priority) > $maxpri} { 1308 set maxjid $jid3 1309 set maxpri $presA2($jid3,priority) 1310 } 1311 } 1312 } 1313 return $jid3 1314} 1315 1316# jlib::roster::isavailable -- 1317# 1318# Returns boolean 0/1. Returns 1 only if presence is equal to available. 1319# If 'jid' without resource, return 1 if any is available. 1320# 1321# Arguments: 1322# jlibname: the instance of this jlib. 1323# jid: either 'username$hostname', or 'username$hostname/resource'. 1324# 1325# Results: 1326# 0/1. 1327 1328proc jlib::roster::isavailable {jlibname jid} { 1329 1330 upvar ${jlibname}::roster::presA presA 1331 1332 Debug 2 "roster::isavailable jid='$jid'" 1333 1334 set jid [jlib::jidmap $jid] 1335 1336 # If any resource in jid, we get it here. 1337 jlib::splitjid $jid jid2 resource 1338 1339 if {[string length $resource] > 0} { 1340 if {[info exists presA($jid2/$resource,type)]} { 1341 if {[string equal $presA($jid2/$resource,type) "available"]} { 1342 return 1 1343 } else { 1344 return 0 1345 } 1346 } else { 1347 return 0 1348 } 1349 } else { 1350 1351 # Be sure to allow for 'user@domain' with empty resource. 1352 foreach key [array names presA "[jlib::ESC $jid2]*,type"] { 1353 if {[string equal $presA($key) "available"]} { 1354 return 1 1355 } 1356 } 1357 return 0 1358 } 1359} 1360 1361proc jlib::roster::isavailable2 {jlibname jid} { 1362 1363 upvar ${jlibname}::roster::presA2 presA2 1364 1365 Debug 2 "roster::isavailable jid='$jid'" 1366 1367 set jid [jlib::jidmap $jid] 1368 1369 # If any resource in jid, we get it here. 1370 jlib::splitjid $jid jid2 resource 1371 1372 if {[string length $resource] > 0} { 1373 if {[info exists presA($jid2/$resource,type)]} { 1374 if {[string equal $presA($jid2/$resource,type) "available"]} { 1375 return 1 1376 } else { 1377 return 0 1378 } 1379 } else { 1380 return 0 1381 } 1382 } else { 1383 1384 # Be sure to allow for 'user@domain' with empty resource. 1385 foreach key [array names presA "[jlib::ESC $jid2]*,type"] { 1386 if {[string equal $presA($key) "available"]} { 1387 return 1 1388 } 1389 } 1390 return 0 1391 } 1392} 1393 1394# jlib::roster::wasavailable -- 1395# 1396# As 'isavailable' but for any "old" former presence state. 1397# 1398# Arguments: 1399# jlibname: the instance of this jlib. 1400# jid: either 'username$hostname', or 'username$hostname/resource'. 1401# 1402# Results: 1403# 0/1. 1404 1405proc jlib::roster::wasavailable {jlibname jid} { 1406 1407 upvar ${jlibname}::roster::oldpresA oldpresA 1408 1409 Debug 2 "roster::wasavailable jid='$jid'" 1410 1411 set jid [jlib::jidmap $jid] 1412 1413 # If any resource in jid, we get it here. 1414 jlib::splitjid $jid jid2 resource 1415 1416 if {[string length $resource] > 0} { 1417 if {[info exists oldpresA($jid2/$resource,type)]} { 1418 if {[string equal $oldpresA($jid2/$resource,type) "available"]} { 1419 return 1 1420 } else { 1421 return 0 1422 } 1423 } else { 1424 return 0 1425 } 1426 } else { 1427 1428 # Be sure to allow for 'user@domain' with empty resource. 1429 foreach key [array names oldpresA "[jlib::ESC $jid2]*,type"] { 1430 if {[string equal $oldpresA($key) "available"]} { 1431 return 1 1432 } 1433 } 1434 return 0 1435 } 1436} 1437 1438# jlib::roster::anychange -- 1439# 1440# Returns boolean telling us if any presence attributes as listed 1441# in 'nameList' has changed. 1442# 1443# Arguments: 1444# jlibname: the instance of this jlib. 1445# jid: the JID as reported in presence 1446# nameList: type | status | priority | show, D=type 1447# 1448# Results: 1449# 0/1. 1450 1451proc jlib::roster::anychange {jlibname jid {nameList type}} { 1452 1453 upvar ${jlibname}::roster::presA presA 1454 upvar ${jlibname}::roster::oldpresA oldpresA 1455 1456 set jid [jlib::jidmap $jid] 1457 1458 foreach name $nameList { 1459 set have1 [info exists presA($jid,$name)] 1460 set have2 [info exists oldpresA($jid,$name)] 1461 if {$have1 && $have2} { 1462 if {$presA($jid,$name) ne $oldpresA($jid,$name)} { 1463 return 1 1464 } 1465 } elseif {($have1 && !$have2) || (!$have1 && $have2)} { 1466 return 1 1467 } 1468 } 1469 return 0 1470} 1471 1472# jlib::roster::gettype -- 1473# 1474# Returns "available" or "unavailable". 1475 1476proc jlib::roster::gettype {jlibname jid} { 1477 1478 upvar ${jlibname}::roster::presA presA 1479 1480 set jid [jlib::jidmap $jid] 1481 if {[info exists presA($jid,type)]} { 1482 return $presA($jid,type) 1483 } else { 1484 return "unavailable" 1485 } 1486} 1487 1488proc jlib::roster::getshow {jlibname jid} { 1489 1490 upvar ${jlibname}::roster::presA presA 1491 1492 set jid [jlib::jidmap $jid] 1493 if {[info exists presA($jid,show)]} { 1494 return $presA($jid,show) 1495 } else { 1496 return "" 1497 } 1498} 1499proc jlib::roster::getstatus {jlibname jid} { 1500 1501 upvar ${jlibname}::roster::presA presA 1502 1503 set jid [jlib::jidmap $jid] 1504 if {[info exists presA($jid,status)]} { 1505 return $presA($jid,status) 1506 } else { 1507 return "" 1508 } 1509} 1510 1511# jlib::roster::getx -- 1512# 1513# Returns the xml list for this jid's x element with given xml namespace. 1514# Returns empty if no matching info. 1515# 1516# Arguments: 1517# jlibname: the instance of this jlib. 1518# jid: any jid 1519# xmlns: the (mandatory) xmlns specifier. Any prefix 1520# http://jabber.org/protocol/ must be stripped off. 1521# @@@ BAD!!!! 1522# 1523# Results: 1524# xml list or empty. 1525 1526proc jlib::roster::getx {jlibname jid xmlns} { 1527 1528 upvar ${jlibname}::roster::presA presA 1529 1530 set jid [jlib::jidmap $jid] 1531 if {[info exists presA($jid,x,$xmlns)]} { 1532 return $presA($jid,x,$xmlns) 1533 } else { 1534 return 1535 } 1536} 1537 1538# jlib::roster::getextras -- 1539# 1540# Returns the xml list for this jid's extras element with given xml namespace. 1541# Returns empty if no matching info. 1542# 1543# Arguments: 1544# jlibname: the instance of this jlib. 1545# jid: any jid 1546# xmlns: the (mandatory) full xmlns specifier. 1547# 1548# Results: 1549# xml list or empty. 1550 1551proc jlib::roster::getextras {jlibname jid xmlns} { 1552 1553 upvar ${jlibname}::roster::presA presA 1554 1555 set jid [jlib::jidmap $jid] 1556 if {[info exists presA($jid,extras,$xmlns)]} { 1557 return $presA($jid,extras,$xmlns) 1558 } else { 1559 return 1560 } 1561} 1562 1563# jlib::roster::getcapsattr -- 1564# 1565# Access function for the <c/> caps elements attributes: 1566# 1567# <presence> 1568# <c 1569# xmlns='http://jabber.org/protocol/caps' 1570# node='http://coccinella.sourceforge.net/protocol/caps' 1571# ver='0.95.2' 1572# ext='ftrans voip_h323 voip_sip'/> 1573# </presence> 1574# 1575# Arguments: 1576# jlibname: the instance of this jlib. 1577# jid: any jid 1578# attrname: 1579# 1580# Results: 1581# the value of the attribute or empty 1582 1583proc jlib::roster::getcapsattr {jlibname jid attrname} { 1584 1585 upvar jlib::jxmlns jxmlns 1586 upvar ${jlibname}::roster::presA presA 1587 1588 set attr "" 1589 set jid [jlib::jidmap $jid] 1590 set xmlnscaps $jxmlns(caps) 1591 if {[info exists presA($jid,extras,$xmlnscaps)]} { 1592 set cElem $presA($jid,extras,$xmlnscaps) 1593 set attr [wrapper::getattribute $cElem $attrname] 1594 } 1595 return $attr 1596} 1597 1598proc jlib::roster::havecaps {jlibname jid} { 1599 1600 upvar jlib::jxmlns jxmlns 1601 upvar ${jlibname}::roster::presA presA 1602 1603 set xmlnscaps $jxmlns(caps) 1604 return [info exists presA($jid,extras,$xmlnscaps)] 1605} 1606 1607# jlib::roster::availablesince -- 1608# 1609# Not sure exactly how delay elements are updated when new status set. 1610 1611proc jlib::roster::availablesince {jlibname jid} { 1612 1613 upvar ${jlibname}::roster::presA presA 1614 upvar ${jlibname}::roster::state state 1615 1616 set jid [jlib::jidmap $jid] 1617 set xmlns "jabber:x:delay" 1618 if {[info exists presA($jid,x,$xmlns)]} { 1619 1620 # An ISO 8601 point-in-time specification. clock works! 1621 set stamp [wrapper::getattribute $presA($jid,x,$xmlns) stamp] 1622 set time [clock scan $stamp -timezone :UTC] 1623 } elseif {[info exists state($jid,secs)]} { 1624 set time $state($jid,secs) 1625 } else { 1626 set time "" 1627 } 1628 return $time 1629} 1630 1631proc jlib::roster::getpresencesecs {jlibname jid} { 1632 1633 upvar ${jlibname}::roster::state state 1634 1635 set jid [jlib::jidmap $jid] 1636 if {[info exists state($jid,secs)]} { 1637 return $state($jid,secs) 1638 } else { 1639 return "" 1640 } 1641} 1642 1643proc jlib::roster::Debug {num str} { 1644 variable rostGlobals 1645 if {$num <= $rostGlobals(debug)} { 1646 puts "===========$str" 1647 } 1648} 1649 1650# We have to do it here since need the initProc before doing this. 1651 1652namespace eval jlib::roster { 1653 1654 jlib::ensamble_register roster \ 1655 [namespace current]::init \ 1656 [namespace current]::cmdproc 1657} 1658 1659#------------------------------------------------------------------------------- 1660