Posted to tcl by colin at Fri Aug 05 02:25:34 GMT 2011view raw

  1. package require tdom
  2. package require fileutil
  3.  
  4. proc domattrs {node} {
  5. set result {}
  6. foreach n [$node attributes] {
  7. set n [lindex $n 0]
  8. if {[catch {lappend result $n [$node getAttribute $n]} e eo]} {
  9. puts stderr "attr error: $e ($eo)"
  10. }
  11. }
  12. return $result
  13. }
  14.  
  15. proc explore {node} {
  16. set type [$node nodeType]
  17. switch -- $type {
  18. ELEMENT_NODE {
  19. set name [$node nodeName]
  20. set attributes [$node attributes]
  21. switch -- $name {
  22. path - rect - circle -
  23. ellipse - line - polyline - polygon -
  24. image - use {
  25. puts "$node is a Graphic $name $type ($attributes)"
  26. set result [list $name {*}[domattrs $node]]
  27. set c {}
  28. foreach child [$node childNodes] {
  29. lappend c -[$child nodeName] [lindex [explore $child] 1]
  30. }
  31. if {[llength $c]} {
  32. lappend result $c
  33. }
  34. return $result
  35. }
  36.  
  37. text - title - desc - script {
  38. set text [[$node firstChild] nodeValue]
  39. puts "$node is a $name $type ($text)"
  40. return [list $name {*}[domattrs $node] $text]
  41. }
  42.  
  43. g - defs - symbol - clipPath -
  44. mask - pattern - marker - a - switch - svg {
  45. puts "$node is a Container $name $type ($attributes)"
  46. set c {}
  47. set m {}
  48. foreach child [$node childNodes] {
  49. set cname [$child nodeName]
  50. if {$cname in {title desc script}} {
  51. dict append m -$cname [lindex [explore $child] 1]
  52. } else {
  53. lappend c [explore $child]
  54. }
  55. }
  56. set result [list $name {*}$m {*}[domattrs $node]]
  57. if {[llength $c]} {
  58. lappend result $c
  59. }
  60. return $result
  61. }
  62.  
  63. default {
  64. error "unknown node type $name ($attributes)"
  65. }
  66. }
  67. }
  68. default {
  69. error "unknown element type $type"
  70. }
  71. }
  72. }
  73.  
  74. set XML [::fileutil::cat [lindex $argv 0]]
  75.  
  76. set doc [dom parse $XML]
  77. set root [$doc documentElement]
  78. puts "R: [explore $root]"
  79.  
  80. proc parse {} {
  81. package require tdom
  82. package require fileutil
  83.  
  84. set XML [::fileutil::cat [lindex $argv 0]]
  85.  
  86. set doc [dom parse $XML]
  87. set root [$doc documentElement]
  88. my explore $root
  89. }