/[webpac]/trunk/openisis/tcl/dexml
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/openisis/tcl/dexml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 239 - (show annotations)
Mon Mar 8 17:49:13 2004 UTC (20 years ago) by dpavlin
File size: 2742 byte(s)
including openisis 0.9.0 into webpac tree

1 #!/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 }

Properties

Name Value
svn:executable

  ViewVC Help
Powered by ViewVC 1.1.26