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