1# disco.tcl -- 2# 3# This file is part of the jabberlib. 4# 5# Copyright (c) 2004-2007 Mats Bengtsson 6# 7# This file is distributed under BSD style license. 8# 9# $Id: disco.tcl,v 1.57 2008-06-11 08:12:05 matben Exp $ 10# 11############################# USAGE ############################################ 12# 13# NAME 14# disco - convenience command library for the disco part of XMPP. 15# 16# SYNOPSIS 17# jlib::disco::init jlibName ?-opt value ...? 18# 19# OPTIONS 20# -command tclProc 21# 22# INSTANCE COMMANDS 23# jlibname disco children jid 24# jlibname disco childs jid ?node? 25# jlibname disco send_get discotype jid cmd ?-opt value ...? 26# jlibname disco isdiscoed discotype jid ?node? 27# jlibname disco get discotype key jid ?node? 28# jlibname disco getallcategories pattern 29# jlibname disco get_async discotype jid cmd ?-node node? 30# jlibname disco getconferences 31# jlibname disco getjidsforcategory pattern 32# jlibname disco getjidsforfeature feature 33# jlibname disco getxml jid ?node? 34# jlibname disco features jid ?node? 35# jlibname disco hasfeature feature jid ?node? 36# jlibname disco isroom jid 37# jlibname disco iscategorytype category/type jid ?node? 38# jlibname disco name jid ?node? 39# jlibname disco nodes jid ?node? 40# jlibname disco types jid ?node? 41# jlibname disco reset ?jid ?node?? 42# 43# where discotype = (items|info) 44# 45################################################################################ 46# 47# Structures: 48# items(jid,node,children) list of any children JIDs 49# items(jid,node,childs) list of {JID node} 50# 51# jid must always be nonempty while node may be empty. 52# 53# rooms(jid,node) exists if children of 'conference' 54 55# NEW: In order to manage the complex jid/node structure it is best to 56# keep an internal structure always using a pair JID+node. 57# As array index: ($jid,$node,..) or list of childs: 58# {{JID1 node1} {JID2 node2} ..} where any of JID or node can be 59# empty but not both. 60# 61# This reflects the disco xml structure (node can be empty): 62# 63# JID node 64# JID node 65# JID node 66# ... 67# 68# @@@ While 'parent -> child' is uniquely defined 'parent <- child' is NOT! 69# A certain JID+node can appear in more than one place in the disco tree! 70# It is better to use another data structure to store this. 71 72package require jlib 73 74package provide jlib::disco 0.1 75 76namespace eval jlib::disco { 77 78 # Globals same for all instances of this jlib. 79 variable debug 0 80 if {[info exists ::debugLevel] && ($::debugLevel > 1) && ($debug == 0)} { 81 set debug 2 82 } 83 84 variable version 0.1 85 86 # Common xml namespaces. 87 variable xmlns 88 array set xmlns { 89 disco "http://jabber.org/protocol/disco" 90 items "http://jabber.org/protocol/disco#items" 91 info "http://jabber.org/protocol/disco#info" 92 muc "http://jabber.org/protocol/muc" 93 } 94 95 # Components register their feature elements for disco/info. 96 variable features [list] 97 98 # Note: jlib::ensamble_register is last in this file! 99} 100 101# jlib::disco::init -- 102# 103# Creates a new instance of the disco object. 104# 105# Arguments: 106# jlibname: name of existing jabberlib instance 107# args: 108# 109# Results: 110# namespaced instance command 111 112proc jlib::disco::init {jlibname args} { 113 114 variable xmlns 115 116 # Instance specific arrays. 117 namespace eval ${jlibname}::disco { 118 variable items 119 variable info 120 variable rooms 121 variable handler 122 variable state 123 variable identities [list] 124 } 125 upvar ${jlibname}::disco::items items 126 upvar ${jlibname}::disco::info info 127 upvar ${jlibname}::disco::rooms rooms 128 129 # Register service. 130 $jlibname service register disco disco 131 132 # Register some standard iq handlers that is handled internally. 133 $jlibname iq_register get $xmlns(items) \ 134 [list [namespace current]::handle_get items] 135 $jlibname iq_register get $xmlns(info) \ 136 [list [namespace current]::handle_get info] 137 138 # Clear any cache info we may have collected since likely invalid offline. 139 $jlibname presence_register_int unavailable [namespace current]::unavail_cb 140 141 # Register our own features. 142 registerfeature $xmlns(disco) 143 registerfeature $xmlns(items) 144 registerfeature $xmlns(info) 145 146 set info(conferences) [list] 147 148 return 149} 150 151# jlib::disco::cmdproc -- 152# 153# Just dispatches the command to the right procedure. 154# 155# Arguments: 156# jlibname: name of existing jabberlib instance 157# cmd: 158# args: all args to the cmd procedure. 159# 160# Results: 161# none. 162 163proc jlib::disco::cmdproc {jlibname cmd args} { 164 165 # Which command? Just dispatch the command to the right procedure. 166 return [eval {$cmd $jlibname} $args] 167} 168 169# jlib::disco::registerfeature -- 170# 171# @@@ Make instance specific instead! 172# 173# Components register their feature elements for disco#info. 174# Clients must handle this using the disco handler. 175# NB1: This is only for 'basic' features not associated with a caps ext 176# token. Those are handled by jlib::caps::register. 177# NB2: We consider everything inside jlib to be 'basic' but also client 178# level features can be basic. 179# NB3: Features registered here MUST NEVER change within a certain version. 180 181proc jlib::disco::registerfeature {feature} { 182 variable features 183 184 lappend features $feature 185 set features [lsort -unique $features] 186} 187 188proc jlib::disco::getregisteredfeatures {} { 189 variable features 190 191 return $features 192} 193 194# jlib::disco::registeridentity -- 195# 196# <identity category='client' type='pc' name='Coccinella'/> 197# as 'category type ?name?' 198 199proc jlib::disco::registeridentity {jlibname category type {name ""}} { 200 upvar ${jlibname}::identities identities 201 202 lappend identities [list $category $type $name] 203} 204 205proc jlib::disco::getidentities {jlibname} { 206 upvar ${jlibname}::identities identities 207 208 return $identities 209} 210 211# jlib::disco::registerhandler -- 212# 213# Register handler to deliver incoming disco queries. 214 215proc jlib::disco::registerhandler {jlibname cmdProc} { 216 217 upvar ${jlibname}::disco::handler handler 218 219 set handler $cmdProc 220} 221 222# jlib::disco::send_get -- 223# 224# Sends a get request within the disco namespace. 225# 226# Arguments: 227# jlibname: name of existing jabberlib instance 228# type: items|info 229# jid: to jid 230# cmd: callback tcl proc 231# args: -node chdata 232# 233# Results: 234# none. 235 236proc jlib::disco::send_get {jlibname type jid cmd args} { 237 238 variable xmlns 239 upvar ${jlibname}::disco::state state 240 241 set jid [jlib::jidmap $jid] 242 set node "" 243 set opts [list] 244 if {[set idx [lsearch -exact $args -node]] >= 0} { 245 set node [lindex $args [incr idx]] 246 set opts [list -node $node] 247 } 248 set state(pending,$type,$jid,$node) 1 249 250 eval {$jlibname iq_get $xmlns($type) -to $jid \ 251 -command [list [namespace current]::send_get_cb $type $jid $cmd]} $opts 252} 253 254# jlib::disco::get_async -- 255# 256# Do disco async using 'cmd' callback. 257# If cached it is returned directly using 'cmd', if pending the cmd 258# is invoked when getting result, else we do a send_get. 259 260proc jlib::disco::get_async {jlibname type jid cmd args} { 261 262 upvar ${jlibname}::disco::items items 263 upvar ${jlibname}::disco::info info 264 upvar ${jlibname}::disco::state state 265 266 set jid [jlib::jidmap $jid] 267 set node "" 268 set opts [list] 269 if {[set idx [lsearch -exact $args -node]] >= 0} { 270 set node [lindex $args [incr idx]] 271 set opts [list -node $node] 272 } 273 set var ${type}($jid,$node,xml) 274 if {[info exists $var]} { 275 set xml [set $var] 276 set etype [wrapper::getattribute $xml type] 277 278 # Errors are reported specially! 279 # @@@ BAD!!! 280 if {$etype eq "error"} { 281 set xml [lindex [wrapper::getchildren $xml] 0] 282 } 283 uplevel #0 $cmd [list $jlibname $etype $jid $xml] 284 } elseif {[info exists state(pending,$type,$jid,$node)]} { 285 lappend state(invoke,$type,$jid,$node) $cmd 286 } else { 287 eval {send_get $jlibname $type $jid $cmd} $opts 288 } 289 return 290} 291 292# jlib::disco::send_get_cb -- 293# 294# Fills in the internal state arrays, and invokes any callback. 295 296proc jlib::disco::send_get_cb {ditype from cmd jlibname type queryE args} { 297 298 upvar ${jlibname}::disco::items items 299 upvar ${jlibname}::disco::info info 300 upvar ${jlibname}::disco::state state 301 302 # We need to use both jid and any node for addressing since 303 # each item may have identical jid's but different node's. 304 305 # Do STRINGPREP. 306 set from [jlib::jidmap $from] 307 set node [wrapper::getattribute $queryE "node"] 308 309 unset -nocomplain state(pending,$ditype,$from,$node) 310 311 if {[string equal $type "error"]} { 312 313 # Cache xml for later retrieval. 314 set var ${ditype}($from,$node,xml) 315 set $var [eval {getfulliq $type $queryE} $args] 316 } else { 317 switch -- $ditype { 318 items { 319 parse_get_items $jlibname $from $queryE 320 } 321 info { 322 parse_get_info $jlibname $from $queryE 323 } 324 } 325 } 326 invoke_stacked $jlibname $ditype $type $from $queryE 327 328 # Invoke callback for this get. 329 uplevel #0 $cmd [list $jlibname $type $from $queryE] $args 330} 331 332proc jlib::disco::invoke_stacked {jlibname ditype type jid queryE} { 333 334 upvar ${jlibname}::disco::state state 335 336 set node [wrapper::getattribute $queryE "node"] 337 if {[info exists state(invoke,$ditype,$jid,$node)]} { 338 foreach cmd $state(invoke,$ditype,$jid,$node) { 339 uplevel #0 $cmd [list $jlibname $type $jid $queryE] 340 } 341 unset -nocomplain state(invoke,$ditype,$jid,$node) 342 } 343} 344 345proc jlib::disco::getfulliq {type queryE args} { 346 347 # Errors are reported specially! 348 # @@@ BAD!!! 349 # If error queryE is just a two element list {errtag text} 350 set attr [list type $type] 351 foreach {key value} $args { 352 lappend attr [string trimleft $key "-"] $value 353 } 354 return [wrapper::createtag iq -attrlist $attr -subtags [list $queryE]] 355} 356 357# jlib::disco::parse_get_items -- 358# 359# Fills the internal records with this disco items query result. 360# There are four parent-childs combinations: 361# 362# (0) JID1 363# JID JID1 != JID 364# 365# (1) JID1 366# JID1+node JID equal 367# 368# (2) JID1+node1 369# JID JID1 != JID 370# 371# (3) JID1+node1 372# JID+node JID1 != JID 373# 374# Typical xml: 375# <iq type='result' ...> 376# <query xmlns='http://jabber.org/protocol/disco#items' 377# node='music'> 378# <item jid='catalog.shakespeare.lit' 379# node='music/A'/> 380# ... 381# 382# Any of the following scenarios is perfectly acceptable: 383# 384# (0) Upon querying an entity (JID1) for items, one receives a list of items 385# that can be addressed as JIDs; each associated item has its own JID, 386# but no such JID equals JID1. 387# 388# (1) Upon querying an entity (JID1) for items, one receives a list of items 389# that cannot be addressed as JIDs; each associated item has its own 390# JID+node, where each JID equals JID1 and each NodeID is unique. 391# 392# (2) Upon querying an entity (JID1+NodeID1) for items, one receives a list 393# of items that can be addressed as JIDs; each associated item has its 394# own JID, but no such JID equals JID1. 395# 396# (3) Upon querying an entity (JID1+NodeID1) for items, one receives a list 397# of items that cannot be addressed as JIDs; each associated item has 398# its own JID+node, but no such JID equals JID1 and each NodeID is 399# unique in the context of the associated JID. 400# 401# In addition, the results MAY also be mixed, so that a query to a JID or a 402# JID+node could yield both (1) items that are addressed as JIDs and (2) 403# items that are addressed as JID+node combinations. 404 405proc jlib::disco::parse_get_items {jlibname from queryE} { 406 407 upvar ${jlibname}::disco::items items 408 upvar ${jlibname}::disco::info info 409 upvar ${jlibname}::disco::rooms rooms 410 411 # Parents node if any. 412 set pnode [wrapper::getattribute $queryE "node"] 413 set pitem [list $from $pnode] 414 415 set items($from,$pnode,xml) [getfulliq result $queryE -from $from] 416 unset -nocomplain items($from,$pnode,children) items($from,$pnode,nodes) 417 unset -nocomplain items($from,$pnode,childs) 418 419 # This is perhaps not a robust way. 420 if {0} { 421 if {![info exists items($from,parent)]} { 422 set items($from,parent) [list] 423 set items($from,parents) [list] 424 } 425 if {![info exists items($from,$pnode,parent2)]} { 426 set items($from,$pnode,parent2) [list] 427 set items($from,$pnode,parents2) [list] 428 } 429 } 430 if {![info exists items($from,$pnode,paL)]} { 431 set items($from,$pnode,paL) [list] 432 } 433 434 # Cache children of category='conference' as rooms. 435 if {[lsearch -exact $info(conferences) $from] >= 0} { 436 set isrooms 1 437 } else { 438 set isrooms 0 439 } 440 441 foreach c [wrapper::getchildren $queryE] { 442 if {![string equal [wrapper::gettag $c] "item"]} { 443 continue 444 } 445 unset -nocomplain attr 446 array set attr [wrapper::getattrlist $c] 447 448 # jid is a required attribute! 449 set jid [jlib::jidmap $attr(jid)] 450 set node "" 451 452 # Children---> 453 # Only 'childs' gives the full picture. 454 if {$jid ne $from} { 455 lappend items($from,$pnode,children) $jid 456 } 457 if {[info exists attr(node)]} { 458 459 # Not two nodes of a jid may be identical. Beware for infinite loops! 460 # We only do some rudimentary check. 461 set node $attr(node) 462 if {[string equal $pnode $node]} { 463 continue 464 } 465 lappend items($from,$pnode,nodes) $node 466 } 467 lappend items($from,$pnode,childs) [list $jid $node] 468 469 # Parents---> 470 471 # Keep list of parents since not unique. 472 lappend items($jid,$node,paL) $pitem 473 474 # Cache the optional attributes. 475 # Any {jid node} must have identical attributes and childrens. 476 foreach key {name action} { 477 if {[info exists attr($key)]} { 478 set items($jid,$node,$key) $attr($key) 479 } 480 } 481 if {$isrooms} { 482 set rooms($jid,$node) 1 483 } 484 } 485} 486 487# jlib::disco::parse_get_info -- 488# 489# Fills the internal records with this disco info query result. 490 491proc jlib::disco::parse_get_info {jlibname from queryE} { 492 variable xmlns 493 494 upvar ${jlibname}::disco::items items 495 upvar ${jlibname}::disco::info info 496 upvar ${jlibname}::disco::rooms rooms 497 498 set node [wrapper::getattribute $queryE "node"] 499 500 array unset info [jlib::ESC $from],[jlib::ESC $node],* 501 set info($from,$node,xml) [getfulliq result $queryE -from $from] 502 set isconference 0 503 504 foreach c [wrapper::getchildren $queryE] { 505 unset -nocomplain attr 506 array set attr [wrapper::getattrlist $c] 507 508 # There can be one or many of each 'identity' and 'feature'. 509 switch -- [wrapper::gettag $c] { 510 identity { 511 512 # Each <identity/> element MUST possess 'category' and 513 # 'type' attributes. (category/type) 514 # Each identity element SHOULD have the same name value. 515 # 516 # XEP 0030: 517 # If the hierarchy category is used, every node in the 518 # hierarchy MUST be identified as either a branch or a leaf; 519 # however, since a node MAY have multiple identities, any given 520 # node MAY also possess an identity other than 521 # "hierarchy/branch" or "hierarchy/leaf". 522 523 # Protect for entities which don't follow the rules. 524 if {![info exists attr(category)] || ![info exists attr(type)]} { 525 continue 526 } 527 set category [string tolower $attr(category)] 528 set ctype [string tolower $attr(type)] 529 set name "" 530 if {[info exists attr(name)]} { 531 set name $attr(name) 532 } 533 set info($from,$node,name) $name 534 set cattype $category/$ctype 535 lappend info($from,$node,cattypes) $cattype 536 lappend info($cattype,typelist) $from 537 set info($cattype,typelist) \ 538 [lsort -unique $info($cattype,typelist)] 539 540 if {![string match *@* $from]} { 541 542 switch -- $category { 543 conference { 544 lappend info(conferences) $from 545 set isconference 1 546 } 547 } 548 } 549 } 550 feature { 551 set feature $attr(var) 552 lappend info($from,$node,features) $feature 553 lappend info($feature,featurelist) $from 554 555 # Register any groupchat protocol with jlib. 556 # Note that each room also returns gc features; skip! 557 if {![string match *@* $from]} { 558 559 switch -- $feature { 560 "http://jabber.org/protocol/muc" { 561 $jlibname service registergcprotocol $from "muc" 562 } 563 "gc-1.0" { 564 $jlibname service registergcprotocol $from "gc-1.0" 565 } 566 } 567 } 568 } 569 } 570 } 571 572 # If this is a conference be sure to cache any children as rooms. 573 if {$isconference && [info exists items($from,,children)]} { 574 foreach c $items($from,,children) { 575 set rooms($c,) 1 576 } 577 } 578} 579 580proc jlib::disco::isdiscoed {jlibname discotype jid {node ""}} { 581 582 upvar ${jlibname}::disco::items items 583 upvar ${jlibname}::disco::info info 584 585 set jid [jlib::jidmap $jid] 586 587 switch -- $discotype { 588 items { 589 return [info exists items($jid,$node,xml)] 590 } 591 info { 592 return [info exists info($jid,$node,xml)] 593 } 594 } 595} 596 597proc jlib::disco::getxml {jlibname discotype jid {node ""}} { 598 return [get $jlibname $discotype xml $jid $node] 599} 600 601proc jlib::disco::get {jlibname discotype key jid {node ""}} { 602 603 upvar ${jlibname}::disco::items items 604 upvar ${jlibname}::disco::info info 605 606 set jid [jlib::jidmap $jid] 607 608 switch -- $discotype { 609 items { 610 if {[info exists items($jid,$node,$key)]} { 611 return $items($jid,$node,$key) 612 } 613 } 614 info { 615 if {[info exists info($jid,$node,$key)]} { 616 return $info($jid,$node,$key) 617 } 618 } 619 } 620 return 621} 622 623# Both the items and the info elements may have name attributes! Related??? 624 625# The login servers jid name attribute is not returned via any items 626# element; only via info/identity element. 627# 628 629proc jlib::disco::name {jlibname jid {node ""}} { 630 631 upvar ${jlibname}::disco::items items 632 upvar ${jlibname}::disco::info info 633 634 set jid [jlib::jidmap $jid] 635 if {[info exists items($jid,$node,name)]} { 636 return $items($jid,$node,name) 637 } elseif {[info exists info($jid,$node,name)]} { 638 return $info($jid,$node,name) 639 } else { 640 return 641 } 642} 643 644# jlib::disco::features -- 645# 646# Returns the var attributes of all feature elements for this jid/node. 647 648proc jlib::disco::features {jlibname jid {node ""}} { 649 650 upvar ${jlibname}::disco::info info 651 652 set jid [jlib::jidmap $jid] 653 if {[info exists info($jid,$node,features)]} { 654 return $info($jid,$node,features) 655 } else { 656 return 657 } 658} 659 660# jlib::disco::hasfeature -- 661# 662# Returns 1 if the jid/node has the specified feature var. 663 664proc jlib::disco::hasfeature {jlibname feature jid {node ""}} { 665 666 upvar ${jlibname}::disco::info info 667 668 set jid [jlib::jidmap $jid] 669 if {[info exists info($jid,$node,features)]} { 670 set features $info($jid,$node,features) 671 return [expr {[lsearch -exact $features $feature] < 0 ? 0 : 1}] 672 } else { 673 return 0 674 } 675} 676 677# jlib::disco::types -- 678# 679# Returns a list of all category/types of this jid/node. 680 681proc jlib::disco::types {jlibname jid {node ""}} { 682 683 upvar ${jlibname}::disco::info info 684 685 set jid [jlib::jidmap $jid] 686 if {[info exists info($jid,$node,cattypes)]} { 687 return $info($jid,$node,cattypes) 688 } else { 689 return 690 } 691} 692 693# jlib::disco::iscategorytype -- 694# 695# Search for any matching feature var glob pattern. 696 697proc jlib::disco::iscategorytype {jlibname cattype jid {node ""}} { 698 699 upvar ${jlibname}::disco::info info 700 701 set jid [jlib::jidmap $jid] 702 if {[info exists info($jid,$node,cattypes)]} { 703 set types $info($jid,$node,cattypes) 704 return [expr {[lsearch -glob $types $cattype] < 0 ? 0 : 1}] 705 } else { 706 return 0 707 } 708} 709 710# jlib::disco::getjidsforfeature -- 711# 712# Returns a list of all jids that support the specified feature. 713 714proc jlib::disco::getjidsforfeature {jlibname feature} { 715 716 upvar ${jlibname}::disco::info info 717 718 if {[info exists info($feature,featurelist)]} { 719 set info($feature,featurelist) [lsort -unique $info($feature,featurelist)] 720 return $info($feature,featurelist) 721 } else { 722 return 723 } 724} 725 726# jlib::disco::getjidsforcategory -- 727# 728# Returns all jids that match the glob pattern category/type. 729# 730# Arguments: 731# jlibname: name of existing jabberlib instance 732# pattern: a global pattern of jid type/subtype (gateway/*). 733# 734# Results: 735# List of jid's matching the type pattern. nodes??? 736 737proc jlib::disco::getjidsforcategory {jlibname pattern} { 738 739 upvar ${jlibname}::disco::info info 740 741 set jidL [list] 742 foreach {key jids} [array get info "$pattern,typelist"] { 743 set jidL [concat $jidL $jids] 744 } 745 return $jidL 746} 747 748# jlib::disco::getallcategories -- 749# 750# Returns all categories that match the glob pattern catpattern. 751# 752# Arguments: 753# jlibname: name of existing jabberlib instance 754# pattern: a global pattern of jid type/subtype (gateway/*). 755# 756# Results: 757# List of types matching the category/type pattern. 758 759proc jlib::disco::getallcategories {jlibname pattern} { 760 761 upvar ${jlibname}::disco::info info 762 763 set cattypes [list] 764 foreach {key jids} [array get info "$pattern,typelist"] { 765 lappend cattypes [string map {,typelist ""} $key] 766 } 767 return [lsort -unique $cattypes] 768} 769 770proc jlib::disco::getconferences {jlibname} { 771 772 upvar ${jlibname}::disco::info info 773 774 return [lsort -unique $info(conferences)] 775} 776 777# jlib::disco::isroom -- 778# 779# Room or not? The problem is that some components, notably some 780# msn gateways, have multiple categories, gateway and conference. BAD! 781# We therefore use a specific 'rooms' array. 782 783proc jlib::disco::isroom {jlibname jid} { 784 785 upvar ${jlibname}::disco::rooms rooms 786 787 if {[info exists rooms($jid,)]} { 788 return 1 789 } else { 790 return 0 791 } 792} 793 794# jlib::disco::children -- 795# 796# Returns a list of all child jids of this jid. 797 798proc jlib::disco::children {jlibname jid} { 799 800 upvar ${jlibname}::disco::items items 801 802 set jid [jlib::jidmap $jid] 803 if {[info exists items($jid,,children)]} { 804 return $items($jid,,children) 805 } else { 806 return 807 } 808} 809 810proc jlib::disco::childs {jlibname jid {node ""}} { 811 812 upvar ${jlibname}::disco::items items 813 814 set jid [jlib::jidmap $jid] 815 if {[info exists items($jid,$node,childs)]} { 816 return $items($jid,$node,childs) 817 } else { 818 return 819 } 820} 821 822# jlib::disco::nodes -- 823# 824# Returns a list of child nodes of this jid|node. 825 826proc jlib::disco::nodes {jlibname jid {node ""}} { 827 828 upvar ${jlibname}::disco::items items 829 830 set jid [jlib::jidmap $jid] 831 if {[info exists items($jid,$node,nodes)]} { 832 return $items($jid,$node,nodes) 833 } else { 834 return 835 } 836} 837 838proc jlib::disco::handle_get {discotype jlibname from queryE args} { 839 840 upvar ${jlibname}::disco::handler handler 841 842 set ishandled 0 843 if {[info exists handler]} { 844 set ishandled [uplevel #0 $handler \ 845 [list $jlibname $discotype $from $queryE] $args] 846 } 847 return $ishandled 848} 849 850# jlib::disco::unavail_cb -- 851# 852# Registered unavailable presence callback. 853# Frees internal cache related to this jid. 854 855proc jlib::disco::unavail_cb {jlibname xmldata} { 856 857 # This screws up gateway handling completely since a gateway is still 858 # a gateway even if unavailable! 859 # @@@ Perhaps we shall make a distinction here between ordinary users 860 # and services? 861 #set jid [wrapper::getattribute $xmldata from] 862 #reset $jlibname $jid 863} 864 865# jlib::disco::reset -- 866# 867# Clear this particular jid and all its children. 868 869proc jlib::disco::reset {jlibname {jid ""} {node ""}} { 870 871 upvar ${jlibname}::disco::items items 872 upvar ${jlibname}::disco::info info 873 upvar ${jlibname}::disco::rooms rooms 874 875 if {($jid eq "") && ($node eq "")} { 876 array unset items 877 array unset info 878 array unset rooms 879 880 set info(conferences) [list] 881 } else { 882 set jid [jlib::jidmap $jid] 883 884 # Can be problems with this (ICQ) ??? 885 if {[info exists items($jid,,children)]} { 886 foreach child $items($jid,,children) { 887 ResetJid $jlibname $child 888 } 889 } 890 ResetJid $jlibname $jid 891 } 892} 893 894# jlib::disco::ResetJid -- 895# 896# Clear only this particular jid. 897 898proc jlib::disco::ResetJid {jlibname jid} { 899 900 upvar ${jlibname}::disco::items items 901 upvar ${jlibname}::disco::info info 902 upvar ${jlibname}::disco::rooms rooms 903 904 if {$jid eq ""} { 905 unset -nocomplain items info rooms 906 set info(conferences) [list] 907 } else { 908 909 if {0} { 910 911 # Keep parents! 912 913 if {[info exists items($jid,parent)]} { 914 set parent $items($jid,parent) 915 } 916 if {[info exists items($jid,parents)]} { 917 set parents $items($jid,parents) 918 } 919 920 if {[info exists items($jid,,parent2)]} { 921 set parent2 $items($jid,,parent2) 922 } 923 if {[info exists items($jid,,parents2)]} { 924 set parents2 $items($jid,,parents2) 925 } 926 927 } 928 929 array unset items [jlib::ESC $jid],* 930 array unset info [jlib::ESC $jid],* 931 array unset rooms [jlib::ESC $jid],* 932 933 if {0} { 934 935 # Add back parent(s). 936 if {[info exists parent]} { 937 set items($jid,parent) $parent 938 } 939 if {[info exists parents]} { 940 set items($jid,parents) $parents 941 } 942 943 if {[info exists parent2]} { 944 set items($jid,,parent2) $parent2 945 } 946 if {[info exists parents2]} { 947 set items($jid,,parents2) $parents2 948 } 949 950 } 951 952 # Rest. 953 foreach {key value} [array get info "*,typelist"] { 954 set info($key) [lsearch -all -not -inline -exact $value $jid] 955 } 956 foreach {key value} [array get info "*,featurelist"] { 957 set info($key) [lsearch -all -not -inline -exact $value $jid] 958 } 959 } 960} 961 962proc jlib::disco::Debug {num str} { 963 variable debug 964 if {$num <= $debug} { 965 puts $str 966 } 967} 968 969# We have to do it here since need the initProc before doing this. 970 971namespace eval jlib::disco { 972 973 jlib::ensamble_register disco \ 974 [namespace current]::init \ 975 [namespace current]::cmdproc 976} 977 978#------------------------------------------------------------------------------- 979