1######################################################################## 2# 3# xmlgen -- generate XML by writing Tcl code 4# 5# (C) 2002 Harald Kirsch 6# 7# $Revision: 1.9 $, $Date: 2002/09/21 14:55:55 $ 8######################################################################## 9namespace eval ::xmlgen { 10 11 namespace export buffer channel declaretag esc put doTag \ 12 setTagformat 13 14 ## will be elongated and trimmed back by (recursive) calls to doTag, 15 ## i.e. by tag-procs. However, it is only used by makeTagAndBody. 16 variable indent "" 17 18 ## a regular expression used by makeTagAndBody to identify 19 ## tag-arguments which are attribute-value pairs as well as to 20 ## dissect them into these two parts. The attribute name must match 21 ## the definition of 'Name' found in the XML spec: 22 ## http://www.w3c.org/TR/2000/REC-xml-20001006#NT-Name 23 ## 'CombiningChar' and 'Extender' are not yet considered. 24 variable attrre {^ *([A-Za-z_:][a-zA-Z0-9_.:-]*)=(.*)} 25 26 ## A pattern used with [string match] to check if the first body 27 ## argument of a markup proc is a control character which describes 28 ## how to handle the body. 29 set controlchars {[-!+.]} 30 31 ## The following array specifies how to format the output. For every 32 ## control character listed above it tells us what to put in front 33 ## of the open and close tags --- typically a newline and some 34 ## indentation. Note that the respective strings are ran through 35 ## [subst] in order to expand references to $indent. Consequently 36 ## you must be careful to put other Tcl special characters into the 37 ## string. 38 array set tagformat { 39 -o {\n$indent$tag} -c {$tag} 40 +o {\n$indent$tag} +c {\n$indent$tag} 41 !o {\n$indent$tag} !c {\n$indent$tag} 42 .o {$tag} .c {$tag} 43 } 44 45 ## Output normally goes just to stdout, but proc buffer may be used 46 ## to generate a context in which output is appended to this 47 ## variable. 48 ## NOTE: this is not thread-save if two threads operate in the same 49 ## interpreter. 50 variable buffer "" 51 52 ## We want to replace the original puts by our own implementations 53 ## depending on context. However, we need of course the original 54 ## somewhere, so we keep it as tclputs. Then, initially, we make the 55 ## "normal" ::puts an alias for the saved proc. 56 57 ## EAS: This is very confusing and didn't work on my system 58 ## Left the original TCL puts alone and called our proc "putx" instead 59 # rename ::puts ::xmlgen::tclputs 60 # HK: no put, use just [put] for redirectable and channelable output. 61 #interp alias {} ::putx {} ::xmlgen::putx 62 63 ## The main output-generating function is [put]. In contrast to puts 64 ## it takes several arguments which are simply [join]ed and no 65 ## newline is automatically appended. When called in the context of 66 ## [buffer] or [channel], the output is redirected either to a 67 ## variable or another output channel than stdout respectively. The 68 ## default is output to stdout. 69 interp alias {} ::xmlgen::put {} ::xmlgen::putStream stdout 70} 71 72proc ::xmlgen::putx-no-longer-needed-use-just-put {args} { 73 set i 0 74 if { "-nonewline" == [lindex $args $i] } { 75 set nl "" 76 incr i 77 } else { 78 set nl \n 79 } 80 81 ## If there are still two args, the first is supposed to be an 82 ## explicit output channel and we leave it to the original puts to 83 ## handle that. 84 if { [llength $args]-$i != 1 } { 85 eval puts $args 86 return 87 } 88 variable buffer 89 append buffer [lindex $args $i] $nl 90 91 return 92} 93 94## A version of [put] used when collecting output in a buffer. 95proc ::xmlgen::putBuf {args} { 96 variable buffer 97 98 append buffer [join $args] 99 return 100} 101 102## A version of [put] used when printing to a channel. 103proc ::xmlgen::putStream {channel args} { 104 puts -nonewline $channel [join $args] 105 return 106} 107 108## Arranges for further output to be appended to variable bufname 109## instead of being sent automatically to stdout 110proc ::xmlgen::buffer {bufname body} { 111 ## save the current buffer locally 112 variable buffer 113 set keptBuffer $buffer 114 set buffer {} 115 116 ## stack the current redirection 117 set keptPut [interp alias {} ::xmlgen::put] 118 119 ## redirect [put] 120 ## FIXME: Is it really necessary to work with the namespace-variable 121 ## buffer to collect the output or could we do something like 122 ## interp .... {} xmlgen::putBuf $bufname 123 ## Probably not, because then $bufname could not refer to a local 124 ## variable of the calling function. 125 interp alias {} ::xmlgen::put {} ::xmlgen::putBuf 126 127 ## run the body safely 128 set err [catch {uplevel 1 $body}] 129 130 ## Restore [put] 131 eval interp alias {{}} ::xmlgen::put {{}} $keptPut 132 133 ## copy the collected buffer to the requested var and restore the 134 ## previous buffer 135 upvar $bufname b 136 set b $buffer 137 set buffer $keptBuffer 138 if {$err} { 139 return -code error -errorinfo $::errorInfo 140 } 141 142 return 143} 144 145proc ::xmlgen::channel {chan body} { 146 ## stack the current redirection 147 set keptPut [interp alias {} ::xmlgen::put] 148 149 ## redirect [put] 150 interp alias {} ::xmlgen::put {} ::xmlgen::putStream $chan 151 152 ## run the body safely 153 set err [catch {uplevel 1 $body}] 154 155 ## Restore [put] 156 eval interp alias {{}} ::xmlgen::put {{}} $keptPut 157 158 if {$err} { 159 return -code error -errorinfo $::errorInfo 160 } 161 162 return 163} 164 165## See manual page for description of this function. 166proc ::xmlgen::makeTagAndBody {tagname l {specialAttributes {}} } { 167 variable attrre 168 variable indent 169 variable controlchars 170 171 ## If specialAttributes is set, we put those attributes into the 172 ## array instead of assembling them into the tag. 173 if {"$specialAttributes"==""} { 174 array set sAttr {} 175 } else { 176 upvar $specialAttributes sAttr 177 } 178 179 ## Collect arguments as long as they look like attribute-value 180 ## pairs, i.e. as long as they match $attrre. 181 ## As a convenience, an argument which is the empty string is simply 182 ## ignored. This allows optional, auto-generated attributes to be 183 ## empty and skipped like in 184 ## if {...} {set align ""} else {set align "align=center"} 185 ## p $align - {Some text, sometimes centered} 186 ## If $align=="", it will not stop attribute processing. 187 ## 188 set opentag "<$tagname" 189 set L [llength $l] 190 for {set i 0} {$i<$L} {incr i} { 191 set arg [lindex $l $i] 192 if {""=="$arg"} continue 193 if {![regexp $attrre $arg -> attr value]} break 194 if {[info exists sAttr($attr)] || ""=="$tagname"} { 195 set sAttr($attr) $value 196 } else { 197 append opentag " $attr=\"[esc $value]\"" 198 } 199 } 200 201 ## If there is at least one element left in $l, the first element of 202 ## $l is already stored in arg. It could be the argument controlling 203 ## how to handle the body. 204 set haveControl 0; # see safety belt below 205 set control . 206 if {$i<$L} { 207 if {[string match $controlchars $arg]} { 208 set control $arg 209 incr i 210 set haveControl 1 211 } elseif {[string length $arg]==1} { 212 append emsg \ 213 " starting the body with a single character is not allowed " \ 214 "in order to guard against bugs" 215 return -code error $emsg 216 } 217 } 218 219 ## If there are elements left in $l they are joined into the 220 ## body. Otherwise the body is empty and opentag and closetag need 221 ## special handling. 222 if {$i<$L} { 223 set body [lrange $l $i end] 224 if 0 { 225 ## If the body is a one-element list, we unpack one list 226 ## level. Otherwise we are most likely on a continued line like 227 ## table ! tr ! td bla 228 ## where the body of e.g. table has already several elements 229 if {[llength $body]==1} {set body [lindex $body 0]} 230 } else { 231 set body [join $body] 232 } 233 append opentag ">" 234 set closetag "</$tagname>" 235 236 ## Do some indenting. 237 set opentag [formatTag ${control}o $indent $opentag] 238 set closetag [formatTag ${control}c $indent $closetag] 239 240 } else { 241 ## Leave a space in front of "/>" for being able to use XHTML 242 ## with most HTML-browsers 243 set body {} 244 append opentag " />" 245 set closetag "" 246 } 247 248 ## Put on the safety belt. If we did not have a control character 249 ## and the body starts with a blank line, the author most probably 250 ## just forgot the control character. 251 if {!$haveControl && [regexp "^\[\t \]*\n" $body]} { 252 append msg \ 253 "body starts with newline but no control " \ 254 "character was given:" 255 set b [split $body \n] 256 if {[llength $b]>3} { 257 append msg [join [lrange $b 0 3] \n] " ..." 258 } else { 259 append msg $body 260 } 261 return -code error $msg 262 } 263 264 return [list $opentag $control $body $closetag] 265} 266######################################################################## 267## With the help of variable tagformat we put some indentation in 268## front of a tag to make the output look nicer. 269proc ::xmlgen::formatTag {which indent tag} { 270 variable tagformat 271 return [subst $tagformat($which)] 272} 273######################################################################## 274## 275## Sets an element of variable tagformat in a controlled way, i.e. we 276## test if the array index 'which' makes sense. 277## 278proc ::xmlgen::setTagformat {which format} { 279 variable tagformat 280 variable controlchars 281 if {![regexp "$controlchars\[oc\]" $which]} { 282 return -code error \ 283 "the string `$which' is not a valid target to format" 284 } 285 set tagformat($which) $format 286} 287######################################################################## 288## Evaluate, substitute and print or just return the body 289## enclosed in the given opentag and closetag. 290proc ::xmlgen::runbody {opentag control body closetag} { 291 292 switch -exact -- $control { 293 "!" { 294 variable indent 295 set ind $indent 296 append indent { } 297 uplevel 1 [list ::xmlgen::put $opentag] 298 uplevel 1 $body 299 uplevel 1 [list ::xmlgen::put $closetag] 300 set indent $ind 301 } 302 "+" { 303 set body [string trim $body "\n \t"] 304 uplevel 1 [list ::xmlgen::put $opentag] 305 uplevel 1 "::xmlgen::put \[subst {$body}\]" 306 uplevel 1 [list ::xmlgen::put $closetag] 307 } 308 "-" { 309 set body [string trim $body "\n \t"] 310 uplevel 1 [list ::xmlgen::put $opentag] 311 uplevel 1 [list ::xmlgen::put $body] 312 uplevel 1 [list ::xmlgen::put $closetag] 313 } 314 "." { 315 return "$opentag$body$closetag" 316 } 317 default { 318 return -code error "unknown control string `$control'" 319 } 320 } 321 322 return 323} 324######################################################################## 325 326 327## Generic function to handle a tag-proc and its arguments. 328proc ::xmlgen::doTag {tagname args} { 329 variable tagAndBodyProc 330 331 foreach {opentag control body closetag} \ 332 [makeTagAndBody $tagname $args] break 333 334 set result [uplevel 1 [list ::xmlgen::runbody $opentag \ 335 $control $body $closetag]] 336 337 return $result 338} 339 340## Makes a tagname into a tag-proc by making it into an alias for 341## doTag. 342proc ::xmlgen::declaretag {funcname {tagname {}}} { 343 if {"$tagname"==""} { 344 set tagname $funcname 345 } 346 set ns [string trimright [uplevel 1 "namespace current"] :] 347 interp alias {} [set ns]::$funcname {} ::xmlgen::doTag $tagname 348 349 return 350} 351 352## Convert text so that it is safe to use it as an attribute value 353## surrouned by double quotes as well as character data. See the 354## definition of AttValue and CharData: 355## http://www.w3c.org/TR/2000/REC-xml-20001006#NT-AttValue 356## http://www.w3c.org/TR/2000/REC-xml-20001006#NT-CharData 357proc ::xmlgen::esc {args} { 358 regsub -all "&" [eval concat $args] "\\&" args 359 regsub -all "<" $args "\\<" args 360 regsub -all ">" $args "\\>" args 361 regsub -all "\"" $args "\\&\#34;" args 362 regsub -all "]" $args "\\&\#93;" args 363 364 return $args 365} 366 367######################################################################## 368