1# $Id$ 2# Jabber Browser (XEP-0011) implementation. This XEP is deprecated, 3# so its code is moved to a plugin. 4 5package require msgcat 6 7namespace eval browser { 8 ::msgcat::mcload [file join [file dirname [info script]] msgs] 9 10 if {![::plugins::is_registered browser]} { 11 ::plugins::register browser \ 12 -namespace [namespace current] \ 13 -source [info script] \ 14 -description [::msgcat::mc "Whether the Jabber Browser plugin is loaded."] \ 15 -loadcommand [namespace code load] \ 16 -unloadcommand [namespace code unload] 17 return 18 } 19 20 set brwid 0 21 custom::defvar browse_list {} [::msgcat::mc "List of browsed JIDs."] \ 22 -group Hidden 23 24 image create photo "" 25} 26 27proc browser::load {} { 28 if {[winfo exists [set m .b2popmenu]]} { 29 destroy $m 30 } 31 menu $m -tearoff 0 32 $m add command -label [::msgcat::mc "Join group..."] -command { 33 join_group_dialog \ 34 $::plugins::browser::browser(xlib,$::plugins::browser::headwindow) \ 35 -server [::xmpp::jid::server $::plugins::browser::headjid] \ 36 -group [::xmpp::jid::node $::plugins::browser::headjid] 37 } 38 $m add command -label [::msgcat::mc "Add conference..."] -command { 39 plugins::conferences::add_conference_dialog \ 40 $::plugins::browser::browser(xlib,$::plugins::browser::headwindow) \ 41 -group [::xmpp::jid::node $::plugins::browser::headjid] \ 42 -server [::xmpp::jid::server $::plugins::browser::headjid] 43 } 44 $m add separator 45 $m add command -label [::msgcat::mc "Browse"] \ 46 -command {::plugins::browser::browser_action browse \ 47 $::plugins::browser::headwindow $::plugins::browser::headnode} 48 $m add command -label [::msgcat::mc "Sort items by name"] \ 49 -command {::plugins::browser::browser_action sort \ 50 $::plugins::browser::headwindow $::browser::headnode} 51 $m add command -label [::msgcat::mc "Sort items by JID"] \ 52 -command {::plugins::browser::browser_action sortjid \ 53 $::plugins::browser::headwindow $::plugins::browser::headnode} 54 55 if {[winfo exists [set m .b3popmenu]]} { 56 destroy $m 57 } 58 menu $m -tearoff 0 59 $m add command -label [::msgcat::mc "Browse"] \ 60 -command {::plugins::browser::browser_action browse \ 61 $::plugins::browser::headwindow $::plugins::browser::headnode} 62 $m add command -label [::msgcat::mc "Sort items by name"] \ 63 -command {::plugins::browser::browser_action sort \ 64 $::plugins::browser::headwindow $::plugins::browser::headnode} 65 $m add command -label [::msgcat::mc "Sort items by JID"] \ 66 -command {::plugins::browser::browser_action sortjid \ 67 $::plugins::browser::headwindow $::plugins::browser::headnode} 68 69 if {[winfo exists [set m .b4popmenu]]} { 70 destroy $m 71 } 72 menu $m -tearoff 0 73 $m add command -label [::msgcat::mc "Browse"] \ 74 -command {::plugins::browser::browser_action browse \ 75 $::plugins::browser::headwindow $::plugins::browser::headnode} 76 77 hook::add finload_hook [namespace current]::setup_menu 78 79 # Register disco#info and disco#items in browser only. 80 register_ns_handler http://jabber.org/protocol/disco#info \ 81 disco::browser::open_win \ 82 -desc [list * [::msgcat::mc "Discover service"]] 83 register_ns_handler http://jabber.org/protocol/disco#items \ 84 disco::browser::open_win \ 85 -desc [list * [::msgcat::mc "Discover service"]] 86 87 if {![catch {set m [.mainframe getmenu services]}] && $m != "" && \ 88 ![catch {set idx [$m index [::msgcat::mc "Service Discovery"]]}] && \ 89 $idx != "none"} { 90 $m insert $idx command -label [::msgcat::mc "Jabber Browser"] \ 91 -command [list [namespace current]::open] 92 } 93} 94 95proc browser::unload {} { 96 variable brwid 97 variable browser 98 variable config 99 variable headwindow 100 variable headnode 101 variable headjid 102 103 if {![catch {set m [.mainframe getmenu services]}] && $m != "" && \ 104 ![catch {set idx [$m index [::msgcat::mc "Jabber Browser"]]}] && \ 105 $idx != "none"} { 106 $m delete $idx 107 } 108 109 foreach bw [winfo children .] { 110 if {[info exists browser(xlib,$bw)]} { 111 destroy_win $bw 112 } 113 } 114 115 if {[winfo exists [set m .b2popmenu]]} { 116 destroy $m 117 } 118 if {[winfo exists [set m .b3popmenu]]} { 119 destroy $m 120 } 121 if {[winfo exists [set m .b4popmenu]]} { 122 destroy $m 123 } 124 125 hook::remove finload_hook [namespace current]::setup_menu 126 127 catch {unset brwid} 128 catch {unset browser} 129 catch {unset config} 130 catch {unset headwindow} 131 catch {unset headnode} 132 catch {unset headjid} 133} 134 135proc browser::open {{xlib ""}} { 136 variable brwid 137 variable browser 138 variable config 139 variable browse_list 140 variable brwserver$brwid 141 142 if {[llength [connections]] == 0} return 143 144 if {$xlib == ""} { 145 set xlib [lindex [connections] 0] 146 } 147 148 set brwserver$brwid [connection_server $xlib] 149 150 set bw .brw$brwid 151 set browser(xlib,$bw) $xlib 152 153 add_win $bw -title [::msgcat::mc "Jabber Browser"] \ 154 -tabtitle [::msgcat::mc "Browser"] \ 155 -raisecmd [list focus $bw.tree] \ 156 -class JDisco \ 157 -raise 1 158 159 set config(fill) [option get $bw fill JDisco] 160 set config(nscolor) [option get $bw featurecolor JDisco] 161 162 bind $bw <Destroy> [list [namespace current]::destroy_state $bw $brwid] 163 164 frame $bw.navigate 165 button $bw.navigate.back -text <- \ 166 -command [list [namespace current]::history_move $bw 1] 167 button $bw.navigate.forward -text -> \ 168 -command [list [namespace current]::history_move $bw -1] 169 label $bw.navigate.lab -text [::msgcat::mc "JID:"] 170 ComboBox $bw.navigate.entry -textvariable [namespace current]::brwserver$brwid \ 171 -dropenabled 1 -droptypes {JID {}} \ 172 -dropcmd [list [namespace current]::entrydropcmd $bw] \ 173 -command [list [namespace current]::go $bw] \ 174 -values $browse_list 175 button $bw.navigate.browse -text [::msgcat::mc "Browse"] \ 176 -command [list [namespace current]::go $bw] 177 178 #bind $bw.navigate.entry <Return> [list [namespace current]::go $bw] 179 180 pack $bw.navigate.back $bw.navigate.forward $bw.navigate.lab -side left 181 pack $bw.navigate.browse -side right 182 pack $bw.navigate.entry -side left -expand yes -fill x 183 pack $bw.navigate -fill x 184 185 set sw [ScrolledWindow $bw.sw] 186 187 set tw [Tree $bw.tree -dragenabled 1 \ 188 -draginitcmd [list [namespace current]::draginitcmd $bw]] 189 $sw setwidget $tw 190 191 pack $sw -side top -expand yes -fill both 192 set browser(tree,$bw) $tw 193 $tw bindText <Double-ButtonPress-1> [list [namespace current]::textaction $bw] 194 $tw bindText <<ContextMenu>> [list [namespace current]::textpopup $bw] 195 balloon::setup $tw -command [list [namespace current]::textballoon $bw] 196 197 bindscroll $tw.c 198 199 # HACK 200 bind $tw.c <Return> \ 201 "[namespace current]::textaction [list $bw] \[[list $tw] selection get\]" 202 203 set browser(ypos,$bw) 1 204 set browser(width,$bw) 0 205 set browser(hist,$bw) {} 206 set browser(histpos,$bw) 0 207 208 hook::run open_browser_post_hook $bw $sw $tw 209 210 incr brwid 211 go $bw 212} 213 214proc browser::enter {bw} { 215 variable browser 216 217 set jid [$bw.navigate.entry.e get] 218 219 ::xmpp::sendIQ $browser(xlib,$bw) get \ 220 -query [::xmpp::xml::create query \ 221 -xmlns jabber:iq:browse] \ 222 -to $jid -command [list [namespace current]::recv $bw $jid] 223} 224 225proc browser::go {bw} { 226 variable browser 227 variable browse_list 228 229 if {[winfo exists $bw]} { 230 set jid [$bw.navigate.entry.e get] 231 232 history_add $bw $jid 233 234 set browse_list [update_combo_list $browse_list $jid 20] 235 $bw.navigate.entry configure -values $browse_list 236 237 ::xmpp::sendIQ $browser(xlib,$bw) get \ 238 -query [::xmpp::xml::create query \ 239 -xmlns jabber:iq:browse] \ 240 -to $jid -command [list [namespace current]::recv $bw $jid] 241 } 242} 243 244proc browser::recv {bw jid status xml} { 245 variable config 246 variable browser 247 248 debugmsg browser "$status $xml" 249 250 if {[winfo exists $bw]} { 251 if {![string equal $status ok]} { 252 add_item_line $bw 0 $jid {} {} {} {} $jid 253 254 set tw $browser(tree,$bw) 255 foreach c [$tw nodes [jid_to_tag $jid]] { 256 $tw delete $c 257 } 258 set tnode [jid_to_tag "error $jid"] 259 set data [list error $jid] 260 set parent_tag [jid_to_tag $jid] 261 set desc [::msgcat::mc "Browse error: %s" [error_to_string $xml]] 262 set icon "" 263 264 add_line $tw $parent_tag $tnode $icon $desc $data \ 265 -fill $config(fill) 266 set browser(nchildren,$bw,$jid) 1 267 } else { 268 process $bw $jid $xml 0 269 } 270 } 271} 272 273proc browser::process {bw from item level} { 274 variable browser 275 276 ::xmpp::xml::split $item tag xmlns attrs cdata subels 277 278 switch -- $tag { 279 ns { 280 debugmsg browser "$level; ns $cdata" 281 if {![string equal $cdata ""]} { 282 return [add_ns_line $bw $from $level $cdata] 283 } 284 return "" 285 } 286 query - 287 item { 288 set category [::xmpp::xml::getAttr $attrs category] 289 } 290 default { 291 set category $tag 292 } 293 } 294 295 set jid [::xmpp::xml::getAttr $attrs jid] 296 297 if {[cequal $jid ""]} { 298 set jid $from 299 } 300 301 set type [::xmpp::xml::getAttr $attrs type] 302 set name [::xmpp::xml::getAttr $attrs name] 303 set version [::xmpp::xml::getAttr $attrs version] 304 305 debugmsg browser "$level; $jid; $category; $type; $name; $version" 306 add_item_line $bw $level $jid $category $type $name $version $from 307 308 set tw $browser(tree,$bw) 309 set children {} 310 set nchildren 0 311 312 foreach subel $subels { 313 lappend children [process $bw $jid $subel [expr {$level+1}]] 314 incr nchildren 315 } 316 317 set browser(nchildren,$bw,$jid) $nchildren 318 set node [jid_to_tag $jid] 319 if {![info exists browser(sort,$bw,$node)]} { 320 set browser(sort,$bw,$node) sort 321 } 322 set curchildren [$tw nodes $node] 323 324 if {$level == 0} { 325 foreach c $curchildren { 326 if {[lsearch -exact $children $c] < 0} { 327 $tw delete $c 328 } 329 } 330 browser_action $browser(sort,$bw,$node) $bw $node 331 update idletasks 332 } 333 debugmsg browser [list $children $curchildren] 334 335 return $node 336} 337 338proc browser::item_icon {category type} { 339 switch -- $category { 340 service - 341 gateway - 342 application { 343 if {[lsearch -exact [image names] browser/$type] >= 0} { 344 return browser/$type 345 } else { 346 return "" 347 } 348 } 349 default { 350 if {[lsearch -exact [image names] browser/$category] >= 0} { 351 return browser/$category 352 } else { 353 return "" 354 } 355 } 356 } 357} 358 359proc browser::add_line {tw parent node icon desc data args} { 360 if {[$tw exists $node]} { 361 if {[$tw parent $node] != $parent && [$tw exists $parent] && \ 362 $parent != $node} { 363 if {[catch { $tw move $parent $node end }]} { 364 debugmsg browser "MOVE FAILED: $parent $node" 365 } else { 366 debugmsg browser "MOVE: $parent $node" 367 } 368 } 369 if {[$tw itemcget $node -data] != $data} { 370 debugmsg browser RECONF 371 $tw itemconfigure $node -text $desc -image $icon -data $data 372 } 373 } elseif {[$tw exists $parent]} { 374 eval {$tw insert end $parent $node -text $desc -open 1 -image $icon \ 375 -data $data} $args 376 } else { 377 eval {$tw insert end root $node -text $desc -open 1 -image $icon \ 378 -data $data} $args 379 } 380 381} 382 383proc browser::add_item_line {bw level jid category type name version parent} { 384 variable browser 385 variable config 386 387 set icon [item_icon $category $type] 388 set tw $browser(tree,$bw) 389 set desc [item_desc $jid $name] 390 set data [list jid $jid $category $type $name $version] 391 set parent_tag [jid_to_tag $parent] 392 set node [jid_to_tag $jid] 393 394 add_line $tw $parent_tag $node $icon $desc $data \ 395 -fill $config(fill) 396} 397 398proc browser::item_text {jid name} { 399 if {![cequal $name ""]} { 400 return $name 401 } else { 402 return $jid 403 } 404} 405 406proc browser::item_desc {jid name} { 407 if {![cequal $name ""]} { 408 return "$name ($jid)" 409 } else { 410 return $jid 411 } 412} 413 414proc browser::item_balloon_text {bw jid category type name version} { 415 variable browser 416 417 set text "$jid: " 418 set delim "" 419 if {![cequal $category {}] || ![cequal $type {}]} { 420 append text "$delim$category/$type" 421 set delim ", " 422 } 423 if {![cequal $name {}]} { 424 append text "$delim[::msgcat::mc Description:] $name" 425 set delim ", " 426 } 427 if {![cequal $version {}]} { 428 append text "$delim[::msgcat::mc Version:] $version" 429 } 430 append text "\n[::msgcat::mc {Number of children:}] $browser(nchildren,$bw,$jid)" 431 return $text 432} 433 434proc browser::add_ns_line {bw jid level ns} { 435 variable browser 436 variable config 437 438 set tw $browser(tree,$bw) 439 440 set node ${ns}\#[jid_to_tag $jid] 441 set parent_tag [jid_to_tag $jid] 442 lassign [$tw itemcget $parent_tag -data] ignore1 ignore2 category type 443 set data [list ns $jid $ns $category $type] 444 set desc $ns 445 if {[info exists browser(ns_handler_desc,$ns)]} { 446 array set tmp $browser(ns_handler_desc,$ns) 447 if {[info exists tmp($category)]} { 448 set desc "$tmp($category) ($ns)" 449 } elseif {[info exists tmp(*)]} { 450 set desc "$tmp(*) ($ns)" 451 } 452 } elseif {[info exists ::disco::browser::browser(feature_handler_desc,$ns)]} { 453 array set tmp $::disco::browser::browser(feature_handler_desc,$ns) 454 if {[info exists tmp($category)]} { 455 set desc "$tmp($category) ($ns)" 456 } elseif {[info exists tmp(*)]} { 457 set desc "$tmp(*) ($ns)" 458 } 459 } 460 set icon "" 461 462 add_line $tw $parent_tag $node $icon $desc $data -fill $config(nscolor) 463 464 return $node 465} 466 467proc browser::history_move {bw shift} { 468 variable browser 469 470 set newpos [expr {$browser(histpos,$bw) + $shift}] 471 472 if {$newpos < 0} { 473 return 474 } 475 476 if {$newpos >= [llength $browser(hist,$bw)]} { 477 return 478 } 479 480 set newjid [lindex $browser(hist,$bw) $newpos] 481 set browser(histpos,$bw) $newpos 482 483 $bw.navigate.entry.e delete 0 end 484 $bw.navigate.entry.e insert 0 $newjid 485 enter $bw 486} 487 488proc browser::history_add {bw jid} { 489 variable browser 490 491 set browser(hist,$bw) [lreplace $browser(hist,$bw) 0 \ 492 [expr {$browser(histpos,$bw) - 1}]] 493 494 lvarpush browser(hist,$bw) $jid 495 set browser(histpos,$bw) 0 496 debugmsg browser $browser(hist,$bw) 497} 498 499proc browser::parse_items {from item} { 500 variable browser 501 502 debugmsg browser "BR: $item" 503 504 ::xmpp::xml::split $item tag xmlns attrs cdata subels 505 506 switch -- $tag { 507 ns { 508 return 509 } 510 item { 511 set category [::xmpp::xml::getAttr $attrs service] 512 } 513 default { 514 set category $tag 515 } 516 } 517 518 set jid [::xmpp::xml::getAttr $attrs jid] 519 520 if {[string equal $jid ""]} { 521 set jid $from 522 } 523 524 set type [::xmpp::xml::getAttr $attrs type] 525 set name [::xmpp::xml::getAttr $attrs name] 526 set version [::xmpp::xml::getAttr $attrs version] 527 528 debugmsg browser "$jid; $category; $type; $name; $version" 529 530 set browser(name,$jid) $name 531 set browser(category,$jid) $category 532 set browser(type,$jid) $type 533 534 foreach subel $subels { 535 parse_items $jid $subel 536 } 537 538} 539 540proc browser::goto {bw jid} { 541 $bw.navigate.entry.e delete 0 end 542 $bw.navigate.entry.e insert 0 $jid 543 go $bw 544} 545 546proc browser::textaction {bw node} { 547 variable browser 548 549 set tw $browser(tree,$bw) 550 set data [$tw itemcget $node -data] 551 set data2 [lassign $data type] 552 switch -- $type { 553 jid { 554 lassign $data2 jid 555 goto $bw $jid 556 } 557 ns { 558 lassign $data2 jid ns category subtype 559 debugmsg browser "$jid $ns" 560 if {[info exists browser(ns_handler,$ns)]} { 561 if {$browser(ns_handler_node,$ns)} { 562 eval $browser(ns_handler,$ns) [list $browser(xlib,$bw) $jid "" \ 563 -category $category -type $subtype] 564 } else { 565 eval $browser(ns_handler,$ns) [list $browser(xlib,$bw) $jid \ 566 -category $category -type $subtype] 567 } 568 } elseif {[info exists ::disco::browser::browser(feature_handler,$ns)]} { 569 if {$::disco::browser::browser(feature_handler_node,$ns)} { 570 eval $::disco::browser::browser(feature_handler,$ns) [list $browser(xlib,$bw) $jid "" \ 571 -category $category -type $subtype] 572 } else { 573 eval $::disco::browser::browser(feature_handler,$ns) [list $browser(xlib,$bw) $jid \ 574 -category $category -type $subtype] 575 } 576 } 577 } 578 } 579} 580 581proc browser::textpopup {bw node} { 582 variable browser 583 variable headwindow $bw 584 variable headnode $node 585 variable headjid 586 587 if {[catch { [set tw $browser(tree,$bw)] itemcget $node -data } data]} { 588 return 589 } 590 set type [lindex $data 0] 591 592 switch -- $type { 593 jid { 594 switch -- [lindex $data 2] { 595 user { 596 message::subject_menu [set bm .b1popmenu] $browser(xlib,$bw) \ 597 [lindex $data 1] message 598 } 599 600 conference { 601 if {[string first @ [set headjid [lindex $data 1]]] > 0} { 602 set bm .b2popmenu 603 } else { 604 set bm .b3popmenu 605 } 606 } 607 608 service 609 - 610 default { 611 set bm .b3popmenu 612 } 613 } 614 } 615 616 ns { 617 set bm .b4popmenu 618 } 619 } 620 621 tk_popup $bm [winfo pointerx .] [winfo pointery .] 622} 623 624proc browser::browser_action {action bw node} { 625 variable browser 626 627 if {[catch { [set tw $browser(tree,$bw)] itemcget $node -data } data]} { 628 return 629 } 630 set type [lindex $data 0] 631 632 switch -glob -- $type/$action { 633 jid/browse - 634 ns/browse { 635 textaction $bw $node 636 } 637 638 jid/sort { 639 set browser(sort,$bw,$node) sort 640 set namespaces {} 641 set children {} 642 foreach child [$tw nodes $node] { 643 set data [$tw itemcget $child -data] 644 switch -- [lindex $data 0] { 645 ns { 646 lappend namespaces [list $child [lindex $data 4]] 647 } 648 default { 649 lappend children [list $child [lindex $data 4]] 650 } 651 } 652 } 653 set neworder {} 654 foreach child [concat $namespaces \ 655 [lsort -dictionary -index 1 $children]] { 656 lappend neworder [lindex $child 0] 657 } 658 $tw reorder $node $neworder 659 660 foreach child [$tw nodes $node] { 661 browser_action $action $bw $child 662 } 663 } 664 665 jid/sortjid { 666 set browser(sort,$bw,$node) sortjid 667 set namespaces {} 668 set children {} 669 foreach child [$tw nodes $node] { 670 set data [$tw itemcget $child -data] 671 switch -- [lindex $data 0] { 672 ns { 673 lappend namespaces [list $child [lindex $data 1]] 674 } 675 default { 676 lappend children [list $child [lindex $data 1]] 677 } 678 } 679 } 680 set neworder {} 681 foreach child [concat $namespaces \ 682 [lsort -dictionary -index 1 $children]] { 683 lappend neworder [lindex $child 0] 684 } 685 $tw reorder $node $neworder 686 687 foreach child [$tw nodes $node] { 688 browser_action $action $bw $child 689 } 690 } 691 692 default { 693 } 694 } 695} 696 697proc browser::textballoon {bw node} { 698 variable browser 699 700 set tw $browser(tree,$bw) 701 set data [lassign [$tw itemcget $node -data] \ 702 type jid category subtype name version] 703 if {$type == "jid"} { 704 return [list $bw:$node \ 705 [item_balloon_text \ 706 $bw $jid $category $subtype $name $version]] 707 } else { 708 return [list $bw:$node ""] 709 } 710} 711 712proc browser::draginitcmd {bw t node top} { 713 set xlib browser(xlib,$bw) 714 set data [$t itemcget $node -data] 715 set data2 [linsert [lassign $data type] 0 $xlib] 716 717 if {$type == "jid"} { 718 if {[set img [$t itemcget $node -image]] != ""} { 719 pack [label $top.l -image $img -padx 0 -pady 0] 720 } 721 722 return [list JID {copy} $data2] 723 } else { 724 return {} 725 } 726} 727 728proc browser::entrydropcmd {bw target source pos op type data} { 729 set jid [lindex $data 1] 730 goto $bw $jid 731} 732 733proc browser::register_ns_handler {ns handler args} { 734 variable browser 735 736 set node 0 737 set desc "" 738 739 foreach {attr val} $args { 740 switch -- $attr { 741 -node {set node $val} 742 -desc {set desc $val} 743 } 744 } 745 746 set browser(ns_handler,$ns) $handler 747 set browser(ns_handler_node,$ns) $node 748 if {$desc != ""} { 749 set browser(ns_handler_desc,$ns) $desc 750 } 751} 752 753# Destroy all (global) state assotiated with the given browser window. 754# Intended to be bound to a <Destroy> event handler for browser windows. 755proc browser::destroy_state {bw brwid} { 756 variable browser 757 variable brwserver$brwid 758 759 array unset browser *,$bw 760 array unset browser *,$bw,* 761 762 unset brwserver$brwid 763} 764 765# Menu setup 766proc browser::setup_menu {} { 767 catch { 768 set m [.mainframe getmenu services] 769 770 set idx [$m index [::msgcat::mc "Service Discovery"]] 771 772 $m insert $idx command -label [::msgcat::mc "Jabber Browser"] \ 773 -command [list [namespace current]::open] 774 } 775} 776 777