Posted to tcl by colin at Fri Aug 05 02:25:34 GMT 2011view raw
- package require tdom
- package require fileutil
- proc domattrs {node} {
- set result {}
- foreach n [$node attributes] {
- set n [lindex $n 0]
- if {[catch {lappend result $n [$node getAttribute $n]} e eo]} {
- puts stderr "attr error: $e ($eo)"
- }
- }
- return $result
- }
- proc explore {node} {
- set type [$node nodeType]
- switch -- $type {
- ELEMENT_NODE {
- set name [$node nodeName]
- set attributes [$node attributes]
- switch -- $name {
- path - rect - circle -
- ellipse - line - polyline - polygon -
- image - use {
- puts "$node is a Graphic $name $type ($attributes)"
- set result [list $name {*}[domattrs $node]]
- set c {}
- foreach child [$node childNodes] {
- lappend c -[$child nodeName] [lindex [explore $child] 1]
- }
- if {[llength $c]} {
- lappend result $c
- }
- return $result
- }
- text - title - desc - script {
- set text [[$node firstChild] nodeValue]
- puts "$node is a $name $type ($text)"
- return [list $name {*}[domattrs $node] $text]
- }
- g - defs - symbol - clipPath -
- mask - pattern - marker - a - switch - svg {
- puts "$node is a Container $name $type ($attributes)"
- set c {}
- set m {}
- foreach child [$node childNodes] {
- set cname [$child nodeName]
- if {$cname in {title desc script}} {
- dict append m -$cname [lindex [explore $child] 1]
- } else {
- lappend c [explore $child]
- }
- }
- set result [list $name {*}$m {*}[domattrs $node]]
- if {[llength $c]} {
- lappend result $c
- }
- return $result
- }
- default {
- error "unknown node type $name ($attributes)"
- }
- }
- }
- default {
- error "unknown element type $type"
- }
- }
- }
- set XML [::fileutil::cat [lindex $argv 0]]
- set doc [dom parse $XML]
- set root [$doc documentElement]
- puts "R: [explore $root]"
- proc parse {} {
- package require tdom
- package require fileutil
- set XML [::fileutil::cat [lindex $argv 0]]
- set doc [dom parse $XML]
- set root [$doc documentElement]
- my explore $root
- }