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