1# $Id$
2
3option add *RawXML.inforeground       DarkRed     widgetDefault
4option add *RawXML.outforeground      DarkBlue    widgetDefault
5option add *RawXML.intagforeground    DarkRed     widgetDefault
6option add *RawXML.inattrforeground   DarkRed     widgetDefault
7option add *RawXML.invalueforeground  Purple4     widgetDefault
8option add *RawXML.incdataforeground  SteelBlue   widgetDefault
9option add *RawXML.outtagforeground   DarkMagenta widgetDefault
10option add *RawXML.outattrforeground  DarkMagenta widgetDefault
11option add *RawXML.outvalueforeground DarkGreen   widgetDefault
12option add *RawXML.outcdataforeground DarkBlue    widgetDefault
13option add *RawXML.inputheight        4           widgetDefault
14
15
16namespace eval rawxml {
17    custom::defgroup Plugins [::msgcat::mc "Plugins options."] -group Tkabber
18    custom::defgroup RawXML \
19	[::msgcat::mc "Options for Raw XML Input module,\
20		       which allows you to monitor\
21		       incoming/outgoing traffic from connection to server\
22		       and send custom XML stanzas."] \
23	-group Plugins -tag "Raw XML Input"
24
25    custom::defvar options(pretty_print) 1 \
26	[::msgcat::mc "Pretty print incoming and outgoing XML stanzas."] \
27	-group RawXML -type boolean
28    custom::defvar options(indent) 2 \
29	[::msgcat::mc "Indentation for pretty-printed XML subtags."] \
30	-group RawXML -type integer
31    custom::defvar options(view_all_xlibs) 1 \
32	[::msgcat::mc "Show stanzas for all (current and past) connections\
33		       in Raw XML window."] \
34	-group RawXML -type boolean
35
36    variable tabs
37    variable rawxml_xlib_jid
38    variable rawxml_xlib
39}
40
41
42if {![catch {clock milliseconds}]} {
43    proc rawxml::timestamp {} {
44	set ms [clock milliseconds]
45	set seconds [expr {$ms/1000}]
46	set fraction [format %03d [expr {$ms%1000}]]
47	return [clock format $seconds -format %T].$fraction
48    }
49} else {
50    proc rawxml::timestamp {} {
51	clock format [clock seconds] -format %T
52    }
53}
54
55
56proc rawxml::format_comment {xlib prefix} {
57    set id "($xlib)"
58    catch {set id "($xlib, [connection_jid $xlib])"}
59    set safe_id [string map { -- -- } $id]
60
61    return "<!-- [timestamp] $prefix $safe_id -->"
62}
63
64
65proc rawxml::handle_inout {xlib dir type msg} {
66    variable options
67
68    set w .rawxml
69    if {![winfo exists $w]} return
70
71    if {$options(pretty_print) && $type == "xml"} {
72	handle_inout_x $xlib $dir $msg
73	return
74    } elseif {$type == "xml"} {
75	set msg [::xmpp::xml::toText $msg]
76    }
77
78    switch -- $dir {
79	output {
80	    set prefix OUT
81	    set tag out
82	}
83	default {
84	    set prefix IN
85	    set tag in
86	}
87    }
88
89    set dump $w.dump
90    $dump configure -state normal
91
92    set scroll [expr {[lindex [$dump yview] 1] == 1}]
93
94    $dump insert end \
95	[format_comment $xlib $prefix]\n [list xlib$xlib] \
96	$msg [list $tag xlib$xlib]
97
98    if {![$dump compare "end -1 chars linestart" == "end -1 chars"]} {
99	$dump insert end "\n" [list xlib$xlib]
100    }
101
102    if {$scroll} {
103	after idle [list $dump yview moveto 1]
104    }
105
106    $dump configure -state disabled
107}
108
109proc rawxml::handle_inout_x {xlib dir xml} {
110    variable options
111
112    set w .rawxml
113    if {![winfo exists $w]} return
114    if {!$options(pretty_print)} return
115
116    switch -- $dir {
117	output {
118	    set prefix OUT
119	    set tag out
120	}
121	default {
122	    set prefix IN
123	    set tag in
124	}
125    }
126
127    set dump $w.dump
128    $dump configure -state normal
129
130    set scroll [expr {[lindex [$dump yview] 1] == 1}]
131
132    $dump insert end [format_comment $xlib $prefix]\n [list xlib$xlib]
133
134    pretty_print $dump $xml "" $tag $xlib
135
136    if {![$dump compare "end -1 chars linestart" == "end -1 chars"]} {
137	$dump insert end "\n" [list xlib$xlib]
138    }
139
140    if {$scroll} {
141	$dump see end
142    }
143
144    $dump configure -state disabled
145}
146
147proc rawxml::pretty_print {t xmldata prefix tag {xlib {}} {pxmlns jabber:client}
148	    {prefixes {xml xml http://etherx.jabber.org/streams stream}}} {
149    variable options
150    variable tabs
151    variable rawxml_xlib
152
153    ::xmpp::xml::split $xmldata stag xmlns attrs cdata subels
154
155    array set p $prefixes
156    set ps {}
157    foreach ns [array names p] {
158        lappend ps $p($ns)
159    }
160    set attrs1 {}
161    foreach {attr value} $attrs {
162        set l [::split $attr :]
163        if {[llength $l] > 1} {
164            set axmlns [join [lrange $l 0 end-1] :]
165            set aattr [lindex $l end]
166
167            if {[string equal $axmlns $xmlns]} {
168                lappend attrs1 $aattr $value
169            } elseif {[info exists p($axmlns)]} {
170                lappend attrs1 $p($axmlns):$aattr $value
171            } else {
172                set p($axmlns) [::xmpp::xml::FindNewPrefix $ps]
173                lappend attrs1 xmlns:$p($axmlns) $axmlns $p($axmlns):$aattr $value
174            }
175        } else {
176            lappend attrs1 $attr $value
177        }
178    }
179
180    if {$pxmlns != $xmlns && $xmlns != ""} {
181	if {![info exists p($xmlns)]} {
182	    lappend attrs1 xmlns $xmlns
183	    set pxmlns $xmlns
184	} else {
185	    set stag $p($xmlns):$stag
186	}
187    }
188
189    $t insert end "$prefix<" [list xlib$xlib] $stag [list ${tag}tag xlib$xlib]
190    if {[llength $attrs1] != 0} {
191	set arr_index "$prefix<$stag "
192	if {![info exists tabs($arr_index)]} {
193	    set tabs($arr_index) [font measure [$t cget -font] $arr_index]
194	}
195	$t tag configure $arr_index -tabs [list $tabs($arr_index)]
196
197	set attrs2 [lassign $attrs1 attr value]
198	if {$tag == "template" && $attr == "id" && $value == "" && $rawxml_xlib!=""} {
199	    set value [::xmpp::packetID $rawxml_xlib]
200	}
201	$t insert end \
202	    " $attr" [list ${tag}attr xlib$xlib] \
203	    "=" [list xlib$xlib] \
204	    "'[::xmpp::xml::Escape $value]'" [list ${tag}value xlib$xlib]
205	foreach {attr value} $attrs2 {
206	    if {$tag == "template" && $attr == "id" && $value == "" && $rawxml_xlib!=""} {
207		set value [::xmpp::packetID $rawxml_xlib]
208	    }
209	    $t insert end \
210		"\n\t$attr" [list ${tag}attr $arr_index xlib$xlib]\
211		"=" [list xlib$xlib] \
212		"'[::xmpp::xml::Escape $value]'" [list ${tag}value xlib$xlib]
213	}
214    }
215    if {$cdata == "" && [llength $subels] == 0} {
216	$t insert end "/>\n" [list xlib$xlib]
217	return
218    } else {
219	$t insert end ">" [list xlib$xlib]
220    }
221
222    if {[llength $subels] == 0} {
223	$t insert end [::xmpp::xml::Escape $cdata] [list ${tag}cdata xlib$xlib]
224	$t insert end "</" [list xlib$xlib] $stag [list ${tag}tag xlib$xlib] ">\n" [list xlib$xlib]
225    } else {
226	$t insert end "\n" [list xlib$xlib]
227        foreach subdata $subels {
228	    pretty_print $t $subdata \
229		$prefix[string repeat " " $options(indent)] $tag $xlib \
230		$pxmlns [array get p]
231	}
232	$t insert end "$prefix</" [list xlib$xlib] $stag [list ${tag}tag xlib$xlib] ">\n" [list xlib$xlib]
233    }
234}
235
236hook::add log_hook [namespace current]::rawxml::handle_inout
237
238proc rawxml::open_window {} {
239    variable rawxml_xlib
240    variable rawxml_xlib_jid
241    set w .rawxml
242    if {[winfo exists $w]} {
243	return
244    }
245
246    add_win $w -title [::msgcat::mc "Raw XML"] \
247	-tabtitle [::msgcat::mc "Raw XML"] \
248	-class RawXML \
249	-raisecmd [list focus $w.input] \
250	-raise 1
251
252
253    set tools [frame $w.tools]
254    pack $tools -side top -anchor w -fill x
255
256    #checkbutton $tools.pp -text [::msgcat::mc "Pretty print XML"] \
257    #	-variable [namespace current]::options(pretty_print)
258    #pack $tools.pp -side left -anchor w
259
260    menubutton $tools.templates -text [::msgcat::mc "Templates"] \
261    	-relief $::tk_relief \
262	-menu .rawxml.tools.templates.root
263    pack $tools.templates -side left -anchor w
264    create_template_menu
265
266    button $tools.clear -text [::msgcat::mc "Clear"] \
267        -command "
268                [list $w.dump] configure -state normal
269                [list $w.dump] delete 0.0 end
270                [list $w.dump] configure -state disabled
271        "
272    pack $tools.clear -side left -anchor w
273
274    set connection_jids {}
275    foreach c [connections] {
276	lappend connection_jids [connection_jid $c]
277    }
278    set rawxml_xlib [lindex [connections] 0]
279    set rawxml_xlib_jid [lindex $connection_jids 0]
280    label $tools.lconnection -text [::msgcat::mc "Connection:"]
281    ComboBox $tools.connection -textvariable [namespace current]::rawxml_xlib_jid \
282			       -values $connection_jids \
283			       -editable false \
284			       -modifycmd [namespace current]::select_xlib
285
286    checkbutton $tools.allxlibs -variable [namespace current]::options(view_all_xlibs) \
287				-command [namespace current]::select_xlib \
288				-text [::msgcat::mc "Show all connections"]
289
290    if {[llength $connection_jids] > 1} {
291	pack $tools.lconnection -side left -anchor w
292	pack $tools.connection -side left -anchor w
293    }
294
295    pack $tools.allxlibs -side left -anchor w
296
297    PanedWin $w.pw -side right -pad 0 -width 4
298    pack $w.pw -fill both -expand yes
299
300    set uw [PanedWinAdd $w.pw -weight 1 -minsize 100]
301    set dw [PanedWinAdd $w.pw -weight 0 -minsize 32]
302
303
304    set isw [ScrolledWindow $w.isw -scrollbar vertical]
305    pack $isw -side bottom -fill both -expand yes -in $dw
306    set input [textUndoable $w.input \
307		   -height [option get $w inputheight RawXML]]
308    $isw setwidget $input
309    [winfo parent $dw] configure -height [winfo reqheight $input]
310
311    set sw [ScrolledWindow $w.sw -scrollbar vertical]
312    pack $sw -side top -fill both -expand yes -in $uw
313    set dump [text $w.dump]
314    $sw setwidget $dump
315
316    $dump configure -state disabled
317
318    bind $input <Control-Key-Return> "
319	[namespace current]::send_xml
320	break"
321
322    $dump tag configure in \
323	-foreground [option get $w inforeground RawXML]
324    $dump tag configure out \
325	-foreground [option get $w outforeground RawXML]
326
327    $dump tag configure intag \
328	-foreground [option get $w intagforeground RawXML]
329    $dump tag configure inattr \
330	-foreground [option get $w inattrforeground RawXML]
331    $dump tag configure invalue \
332	-foreground [option get $w invalueforeground RawXML]
333    $dump tag configure incdata \
334	-foreground [option get $w incdataforeground RawXML]
335
336    $dump tag configure outtag \
337	-foreground [option get $w outtagforeground RawXML]
338    $dump tag configure outattr \
339	-foreground [option get $w outattrforeground RawXML]
340    $dump tag configure outvalue \
341	-foreground [option get $w outvalueforeground RawXML]
342    $dump tag configure outcdata \
343	-foreground [option get $w outcdataforeground RawXML]
344
345    variable history
346    bind $input <Control-Key-Up> \
347	[list [namespace current]::history_move 1]
348    bind $input <Control-Key-Down> \
349	[list [namespace current]::history_move -1]
350
351    set history(stack) [list {}]
352    set history(pos) 0
353
354    regsub -all %W [bind Text <Prior>] [double% $dump] prior_binding
355    regsub -all %W [bind Text <Next>]  [double% $dump] next_binding
356    bind $input <Meta-Prior> $prior_binding
357    bind $input <Meta-Next> $next_binding
358    bind $input <Alt-Prior> $prior_binding
359    bind $input <Alt-Next> $next_binding
360
361    hook::run open_rawxml_post_hook $w
362}
363
364proc rawxml::select_xlib {} {
365    variable rawxml_xlib_jid
366    variable rawxml_xlib
367    variable options
368    set w .rawxml.dump
369
370    set rawxml_xlib {}
371    foreach c [connections] {
372	if {[connection_jid $c] == $rawxml_xlib_jid} {
373	    set rawxml_xlib $c
374	    break
375	}
376    }
377
378    foreach tag [lsearch -all -glob -inline [.rawxml.dump tag names] xlib*] {
379	set elide [expr {"xlib$rawxml_xlib" != $tag && !$options(view_all_xlibs) \
380		   && $rawxml_xlib != ""}]
381	$w tag configure $tag -elide $elide
382    }
383}
384
385proc rawxml::update_xlib_choice {action xlib} {
386    variable rawxml_xlib_jid
387    variable rawxml_xlib
388
389    set tools .rawxml.tools
390    set combobox $tools.connection
391    if {![winfo exists $combobox]} return
392
393    set connection_jids [lindex [$combobox configure -values] 4]
394    set connection_jid [connection_jid $xlib]
395    switch $action {
396	add {
397	    lappend connection_jids $connection_jid
398	    if {[llength $connection_jids] == 1} {
399		set rawxml_xlib_jid $connection_jid
400		set rawxml_xlib $xlib
401	    }
402	}
403	remove {
404	    set idx [lsearch -exact $connection_jids $connection_jid]
405	    set connection_jids [lreplace $connection_jids $idx $idx]
406	    if {$rawxml_xlib == $xlib} {
407		set rawxml_xlib [lindex [connections] 0]
408		if {$rawxml_xlib != ""} {
409		    set rawxml_xlib_jid [connection_jid $rawxml_xlib]
410		} else {
411		    set rawxml_xlib_jid ""
412		}
413		select_xlib
414	    }
415	}
416    }
417    $combobox configure -values $connection_jids
418
419    if {[llength $connection_jids] > 1} {
420        pack $tools.lconnection -side left -anchor w -before $tools.allxlibs
421        pack $combobox -side left -anchor w -before $tools.allxlibs
422    } else {
423	pack forget $tools.lconnection $combobox
424    }
425}
426
427hook::add connected_hook [list [namespace current]::rawxml::update_xlib_choice add]
428hook::add disconnected_hook [list [namespace current]::rawxml::update_xlib_choice remove]
429
430proc rawxml::history_move {shift} {
431    variable history
432
433    set newpos [expr $history(pos) + $shift]
434
435    if {!($newpos < 0 || $newpos >= [llength $history(stack)])} {
436	set iw .rawxml.input
437	set body [$iw get 1.0 "end -1 chars"]
438
439	if {$history(pos) == 0} {
440	    set history(stack) \
441		[lreplace $history(stack) 0 0 $body]
442	}
443
444	set history(pos) $newpos
445	set newbody [lindex $history(stack) $newpos]
446	$iw delete 1.0 end
447	$iw insert 0.0 $newbody
448    }
449}
450
451proc rawxml::send_xml {} {
452    variable history
453    variable rawxml_xlib
454
455    set input .rawxml.input
456    set xml [$input get 0.0 "end - 1c"]
457
458    lvarpush history(stack) $xml 1
459    set history(pos) 0
460
461    if {[llength [connections]] == 0} {
462	return -code error [::msgcat::mc "Not connected"]
463    } else {
464	::xmpp::outText $rawxml_xlib $xml
465    }
466    $input delete 1.0 end
467}
468
469
470proc rawxml::setup_menu {} {
471    catch {
472        set m [.mainframe getmenu debug]
473
474        $m add command -label [::msgcat::mc "Open raw XML window"] \
475	    -command [namespace current]::open_window
476    }
477}
478hook::add finload_hook [namespace current]::rawxml::setup_menu
479
480
481proc rawxml::add_template_group {parent group name} {
482    set m .rawxml.tools.templates.$group
483    set mparent .rawxml.tools.templates.$parent
484
485    if {![winfo exists $m]} {
486	menu $m -tearoff 0
487    }
488
489    $mparent add cascade -label $name -menu $m
490}
491
492proc rawxml::add_template {group name xmldata} {
493    set m .rawxml.tools.templates.$group
494    set input .rawxml.input
495
496    $m add command -label $name \
497	-command [list [namespace current]::pretty_print \
498		      $input $xmldata "" template]
499}
500
501
502proc rawxml::create_template_menu {} {
503    if {[winfo exists .rawxml.tools.templates.root]} {
504	destroy .rawxml.tools.templates.root
505    } else {
506	menu .rawxml.tools.templates.root -tearoff 0
507    }
508
509    add_template_group root message [::msgcat::mc "Message"]
510
511    add_template message [::msgcat::mc "Normal message"] \
512	[::xmpp::xml::create message \
513	     -attrs {to "" type normal} \
514	     -subelement [::xmpp::xml::create body -cdata " "]]
515
516    add_template message [::msgcat::mc "Chat message"] \
517	[::xmpp::xml::create message \
518	     -attrs {to "" type chat} \
519	     -subelement [::xmpp::xml::create body -cdata " "]]
520
521    add_template message [::msgcat::mc "Headline message"] \
522	[::xmpp::xml::create message \
523	     -attrs {to "" type headline} \
524	     -subelement [::xmpp::xml::create subject -cdata " "] \
525	     -subelement [::xmpp::xml::create body -cdata " "] \
526	     -subelement [::xmpp::xml::create x \
527				-xmlns jabber:x:oob \
528				-subelement [::xmpp::xml::create url -cdata " "] \
529				-subelement [::xmpp::xml::create desc -cdata " "]]]
530
531    add_template_group root presence [::msgcat::mc "Presence"]
532
533    add_template presence [::msgcat::mc "Available presence"] \
534	[::xmpp::xml::create presence \
535	     -attrs {to ""} \
536	     -subelement [::xmpp::xml::create status -cdata " "] \
537	     -subelement [::xmpp::xml::create show -cdata " "]]
538
539    add_template presence [::msgcat::mc "Unavailable presence"] \
540	[::xmpp::xml::create presence \
541	     -attrs {to "" type unavailable} \
542	     -subelement [::xmpp::xml::create status -cdata " "]]
543
544    add_template_group root iq [::msgcat::mc "IQ"]
545
546    add_template iq [::msgcat::mc "Generic IQ"] \
547	[::xmpp::xml::create iq \
548	     -attrs {to "" type "" id ""} \
549	     -subelement [::xmpp::xml::create query \
550				-xmlns ""]]
551
552    add_template iq "jabber:iq:time get" \
553	[::xmpp::xml::create iq \
554	     -attrs {to "" type get id ""} \
555	     -subelement [::xmpp::xml::create query \
556				-xmlns jabber:iq:time]]
557
558    add_template iq "jabber:iq:version get" \
559	[::xmpp::xml::create iq \
560	     -attrs {to "" type get id ""} \
561	     -subelement [::xmpp::xml::create query \
562				-xmlns jabber:iq:version]]
563
564    add_template iq "jabber:iq:last get" \
565	[::xmpp::xml::create iq \
566	     -attrs {to "" type get id ""} \
567	     -subelement [::xmpp::xml::create query \
568				-xmlns jabber:iq:last]]
569
570    add_template_group iq pubsub [::msgcat::mc "Pub/sub"]
571
572    pubsub_template [::msgcat::mc "Create node"] set \
573	[::xmpp::xml::create create \
574	     -attrs {node ""}]
575    pubsub_template [::msgcat::mc "Publish node"] set \
576	[::xmpp::xml::create publish \
577	     -attrs {node ""} \
578	     -subelement [::xmpp::xml::create item]]
579    pubsub_template [::msgcat::mc "Retract node"] set \
580	[::xmpp::xml::create retract \
581	     -attrs {node ""} \
582	     -subelement [::xmpp::xml::create item]]
583    pubsub_template [::msgcat::mc "Subscribe to a node"] set \
584	[::xmpp::xml::create subscribe \
585	     -attrs {node "" jid ""}]
586    pubsub_template [::msgcat::mc "Unsubscribe from a node"] set \
587	[::xmpp::xml::create unsubscribe \
588	     -attrs {node "" jid ""}]
589    pubsub_template [::msgcat::mc "Get items"] get \
590	[::xmpp::xml::create items \
591	     -attrs {node ""}]
592}
593
594proc rawxml::pubsub_template {name type subtag} {
595    add_template pubsub $name \
596	[::xmpp::xml::create iq \
597	     -attrs [list to "" type $type id ""] \
598	     -subelement [::xmpp::xml::create pubsub \
599				-xmlns http://jabber.org/protocol/pubsub \
600				-subelement $subtag]]
601}
602
603##############################################################################
604
605proc rawxml::restore_window {args} {
606    open_window
607}
608
609proc rawxml::save_session {vsession} {
610    upvar 2 $vsession session
611    global usetabbar
612
613    # We don't need JID at all, so make it empty (special case)
614    set user     ""
615    set server   ""
616    set resource ""
617
618    # TODO
619    if {!$usetabbar} return
620
621    set prio 0
622    foreach page [.nb pages] {
623	set path [ifacetk::nbpath $page]
624
625	if {[string equal $path .rawxml]} {
626	    lappend session [list $prio $user $server $resource \
627		[list [namespace current]::restore_window] \
628	    ]
629	}
630	incr prio
631    }
632}
633
634hook::add save_session_hook [namespace current]::rawxml::save_session
635
636# vim:ts=8:sw=4:sts=4:noet
637