Posted to tcl by mjanssen at Thu Apr 26 08:12:50 GMT 2018view raw

  1. namespace eval inspect {
  2. proc xml {xml {title {}}} {
  3. return [xml::inspect $xml $title]
  4. }
  5. namespace eval xml {
  6. proc inspect {xml title} {
  7. package require Tk
  8. package require tdom
  9.  
  10. # parse XML
  11. set doc [dom parse $xml]
  12. set nsprefixlist {}
  13. foreach {item} [$doc selectNodes {//namespace::*}] {
  14. lassign $item fullprefix uri
  15. lassign [split $fullprefix :] _ prefix
  16. lappend nsprefixlist $prefix $uri
  17. }
  18.  
  19. # build ui
  20. set tl [toplevel .$doc]
  21. wm protocol $tl WM_DELETE_WINDOW [namespace code [list cleanup $doc $tl]]
  22. ttk::panedwindow $tl.pane -orient horizontal
  23. ttk::treeview $tl.tv -selectmode extended -show tree
  24. bind $tl.tv <<TreeviewSelect>> [namespace code [list updateText $tl.txt %W]]
  25. text $tl.txt
  26. fillTree $tl.tv [list [$doc documentElement]]
  27. $tl.pane add $tl.tv -weight 1
  28. $tl.pane add $tl.txt -weight 2
  29. entry $tl.entry
  30. pack $tl.pane -expand 1 -fill both
  31. pack $tl.entry -expand 1 -fill x
  32. bind $tl.entry <Return> [namespace code [list evaluateXPath $doc $nsprefixlist %W $tl.tv]]
  33.  
  34. if {$title ne {}} {
  35. wm title $tl $title
  36. }
  37.  
  38. return $tl
  39.  
  40. }
  41.  
  42. proc evaluateXPath {doc nsprefixlist xpathWidget tv} {
  43. set xpath [$xpathWidget get]
  44. if {$xpath eq {} } {
  45. set nodes [list [$doc documentElement]]
  46. } else {
  47. set nodes [$doc selectNodes -namespaces $nsprefixlist $xpath]
  48. }
  49. fillTree $tv $nodes
  50. }
  51.  
  52. proc cleanup {doc tl} {
  53. $doc delete
  54. destroy $tl
  55. }
  56.  
  57. proc fillTree {tv nodes} {
  58. # puts stderr "Adding [llength $nodes] nodes"
  59. foreach item [$tv children {}] {
  60. $tv detach $item
  61. }
  62. $tv selection remove [$tv selection]
  63. if {[catch {addNodes $tv {} $nodes } result]} {
  64. # Just add the text of the XPath result if it's not a list of nodes.
  65. # Call it in a callback because the clearing of the selection will clear the txt view.
  66. puts stderr $result
  67. after 0 [list [winfo parent $tv].txt insert end [join $nodes \n]]
  68. }
  69. }
  70.  
  71. proc updateText {txt lv} {
  72. $txt delete 1.0 end
  73. foreach node [$lv selection] {
  74. $txt insert end [$node asXML]
  75. $txt insert end \n
  76. }
  77.  
  78. }
  79.  
  80. proc addNodes {tv parent nodes} {
  81. set index 0
  82. # puts stderr $parent-$nodes
  83. foreach node $nodes {
  84. set name [$node nodeName]
  85. if {$name eq "#text"} {
  86. continue
  87. }
  88. if [$tv exists $node] {
  89. $tv move $node $parent $index
  90. } else {
  91. $tv insert $parent $index -id $node -text $name
  92. }
  93. set children [$node childNodes]
  94. # puts stderr "Children -> $children"
  95. if {$children ne {}} {
  96. addNodes $tv $node $children
  97. }
  98. incr index
  99. }
  100. }
  101. }
  102. }
  103.