Annotation of /openisis/current/tcl/dexml

#!/opt/isis/OpenIsis/tcl/bin/isish
# let editor know it's Tcl vim:syntax=tcl

package require openIsis;
package require xml;


# map element names to tags
array set tag {}
# highest ag used; set to 99 so we start from 100
set ltag 99
# map attribute names to subfields
# map keys are "tag\tatt"
array set subf {}

openIsisRec rec

proc cdata {data} { # text
        # puts "0\t[string map {\n " "} $data]"
        rec add 0 [string map {\n " "} $data]
}

proc comment {data} {
        # puts "#\t[string map {\n " "} $data]"
}

proc doctype {data} {
        puts "#\t$data"
}

proc estart {name attlist args} {
        global tag ltag subf lsubf
        set start +
        foreach {arg val} $args {
                switch -- $arg -empty { if $val { set start - } }
        }
        if [catch {set t $tag($name)}] {
                set t [set tag($name) [incr ltag]]
        }
        set line $start
        foreach {att val} $attlist {
                set attkey "$t\t$att"
                if [catch {set s $subf($attkey)}] {
                        # use $subf($t) as counter for last subfield
                        if [catch {set c [incr subf($t)]}] {
                                set c [set subf($t) 97]
                        }
                        set s [set subf($attkey) [format %c $c]]
                }
                append line "^$s$val"
        }
        # puts "$t\t$line"
        rec add $t $line
}

proc eend {name args} {
        global tag
        foreach {arg val} $args {
                switch -- $arg -empty { if $val { return } }
        }
        # puts $tag($name)
        rec add $tag($name) ""
}

set xp [xml::parser \
        -ignorewhitespace yes \
        -reportempty yes \
        -characterdatacommand cdata \
        -commentcommand comment \
        -doctypecommand doctype \
        -elementstartcommand estart \
        -elementendcommand eend \
        -defaultcommand error
]
# doesn't like that:
# -endcdatasectioncommand ecdata
#       -startcdatasectioncommand scdata

$xp parse [read stdin]


# invert the FDT tag,subf to name,attr
foreach {n v} [array get tag] { set name($v) $n}
foreach {n v} [array get subf] {
        if {2 == [scan $n "%u\t%s" t a]} { set attr($t\t$v) $a }
}

foreach t [lsort [array names name]] {
        # puts stderr "$t\t$name($t)" ;# verbose entry
        set line $name($t)
        foreach s [lsort [array names attr "$t\t*"]] {
                # puts stderr "$s\t$attr($s)" ;# verbose entry
                scan $s "%u\t%s" - c
                append line "^$c$attr($s)"
        }
        puts stderr "$t\t$line" ;# the one-line DTD ;)
}

# use the inverted FDT to create the XML text
puts "<!--
[rec serialize]
-->"
set depth 0
rec do t v {
        if !$t { # text
                puts [string repeat \t $depth]$v
                continue
        }
        if {"" == $v} { # close
                incr depth -1
                puts [string repeat \t $depth]</$name($t)>
                continue
        }
        set line "<$name($t)"
        set alist [split $v ^]
        set hasChilds [expr {"+" == [lindex $alist 0]}]
        foreach a [lrange $alist 1 end] {
                append line " $attr($t\t[string index $a 0])=\"[string range $a 1 end]\""
        }
        if $hasChilds {
                append line >
        } else {
                append line />
        }
        puts [string repeat \t $depth]$line
        if $hasChilds {
                incr depth
        }
}
1	dpavlin	237	#!/opt/isis/OpenIsis/tcl/bin/isish
2			# let editor know it's Tcl vim:syntax=tcl
3
4			package require openIsis;
5			package require xml;
6
7
8			# map element names to tags
9			array set tag {}
10			# highest ag used; set to 99 so we start from 100
11			set ltag 99
12			# map attribute names to subfields
13			# map keys are "tag\tatt"
14			array set subf {}
15
16			openIsisRec rec
17
18			proc cdata {data} { # text
19			# puts "0\t[string map {\n " "} $data]"
20			rec add 0 [string map {\n " "} $data]
21			}
22
23			proc comment {data} {
24			# puts "#\t[string map {\n " "} $data]"
25			}
26
27			proc doctype {data} {
28			puts "#\t$data"
29			}
30
31			proc estart {name attlist args} {
32			global tag ltag subf lsubf
33			set start +
34			foreach {arg val} $args {
35			switch -- $arg -empty { if $val { set start - } }
36			}
37			if [catch {set t $tag($name)}] {
38			set t [set tag($name) [incr ltag]]
39			}
40			set line $start
41			foreach {att val} $attlist {
42			set attkey "$t\t$att"
43			if [catch {set s $subf($attkey)}] {
44			# use $subf($t) as counter for last subfield
45			if [catch {set c [incr subf($t)]}] {
46			set c [set subf($t) 97]
47			}
48			set s [set subf($attkey) [format %c $c]]
49			}
50			append line "^$s$val"
51			}
52			# puts "$t\t$line"
53			rec add $t $line
54			}
55
56			proc eend {name args} {
57			global tag
58			foreach {arg val} $args {
59			switch -- $arg -empty { if $val { return } }
60			}
61			# puts $tag($name)
62			rec add $tag($name) ""
63			}
64
65			set xp [xml::parser \
66			-ignorewhitespace yes \
67			-reportempty yes \
68			-characterdatacommand cdata \
69			-commentcommand comment \
70			-doctypecommand doctype \
71			-elementstartcommand estart \
72			-elementendcommand eend \
73			-defaultcommand error
74			]
75			# doesn't like that:
76			# -endcdatasectioncommand ecdata
77			# -startcdatasectioncommand scdata
78
79			$xp parse [read stdin]
80
81
82			# invert the FDT tag,subf to name,attr
83			foreach {n v} [array get tag] { set name($v) $n}
84			foreach {n v} [array get subf] {
85			if {2 == [scan $n "%u\t%s" t a]} { set attr($t\t$v) $a }
86			}
87
88			foreach t [lsort [array names name]] {
89			# puts stderr "$t\t$name($t)" ;# verbose entry
90			set line $name($t)
91			foreach s [lsort [array names attr "$t\t*"]] {
92			# puts stderr "$s\t$attr($s)" ;# verbose entry
93			scan $s "%u\t%s" - c
94			append line "^$c$attr($s)"
95			}
96			puts stderr "$t\t$line" ;# the one-line DTD ;)
97			}
98
99			# use the inverted FDT to create the XML text
100			puts "<!--
101			[rec serialize]
102			-->"
103			set depth 0
104			rec do t v {
105			if !$t { # text
106			puts [string repeat \t $depth]$v
107			continue
108			}
109			if {"" == $v} { # close
110			incr depth -1
111			puts [string repeat \t $depth]</$name($t)>
112			continue
113			}
114			set line "<$name($t)"
115			set alist [split $v ^]
116			set hasChilds [expr {"+" == [lindex $alist 0]}]
117			foreach a [lrange $alist 1 end] {
118			append line " $attr($t\t[string index $a 0])=\"[string range $a 1 end]\""
119			}
120			if $hasChilds {
121			append line >
122			} else {
123			append line />
124			}
125			puts [string repeat \t $depth]$line
126			if $hasChilds {
127			incr depth
128			}
129			}