Posted to tcl by mjanssen at Thu Apr 26 08:12:50 GMT 2018view raw
- namespace eval inspect {
- proc xml {xml {title {}}} {
- return [xml::inspect $xml $title]
- }
- namespace eval xml {
- proc inspect {xml title} {
- package require Tk
- package require tdom
- # parse XML
- set doc [dom parse $xml]
- set nsprefixlist {}
- foreach {item} [$doc selectNodes {//namespace::*}] {
- lassign $item fullprefix uri
- lassign [split $fullprefix :] _ prefix
- lappend nsprefixlist $prefix $uri
- }
- # build ui
- set tl [toplevel .$doc]
- wm protocol $tl WM_DELETE_WINDOW [namespace code [list cleanup $doc $tl]]
- ttk::panedwindow $tl.pane -orient horizontal
- ttk::treeview $tl.tv -selectmode extended -show tree
- bind $tl.tv <<TreeviewSelect>> [namespace code [list updateText $tl.txt %W]]
- text $tl.txt
- fillTree $tl.tv [list [$doc documentElement]]
- $tl.pane add $tl.tv -weight 1
- $tl.pane add $tl.txt -weight 2
- entry $tl.entry
- pack $tl.pane -expand 1 -fill both
- pack $tl.entry -expand 1 -fill x
- bind $tl.entry <Return> [namespace code [list evaluateXPath $doc $nsprefixlist %W $tl.tv]]
- if {$title ne {}} {
- wm title $tl $title
- }
- return $tl
- }
- proc evaluateXPath {doc nsprefixlist xpathWidget tv} {
- set xpath [$xpathWidget get]
- if {$xpath eq {} } {
- set nodes [list [$doc documentElement]]
- } else {
- set nodes [$doc selectNodes -namespaces $nsprefixlist $xpath]
- }
- fillTree $tv $nodes
- }
- proc cleanup {doc tl} {
- $doc delete
- destroy $tl
- }
- proc fillTree {tv nodes} {
- # puts stderr "Adding [llength $nodes] nodes"
- foreach item [$tv children {}] {
- $tv detach $item
- }
- $tv selection remove [$tv selection]
- if {[catch {addNodes $tv {} $nodes } result]} {
- # Just add the text of the XPath result if it's not a list of nodes.
- # Call it in a callback because the clearing of the selection will clear the txt view.
- puts stderr $result
- after 0 [list [winfo parent $tv].txt insert end [join $nodes \n]]
- }
- }
- proc updateText {txt lv} {
- $txt delete 1.0 end
- foreach node [$lv selection] {
- $txt insert end [$node asXML]
- $txt insert end \n
- }
- }
- proc addNodes {tv parent nodes} {
- set index 0
- # puts stderr $parent-$nodes
- foreach node $nodes {
- set name [$node nodeName]
- if {$name eq "#text"} {
- continue
- }
- if [$tv exists $node] {
- $tv move $node $parent $index
- } else {
- $tv insert $parent $index -id $node -text $name
- }
- set children [$node childNodes]
- # puts stderr "Children -> $children"
- if {$children ne {}} {
- addNodes $tv $node $children
- }
- incr index
- }
- }
- }
- }