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] "\\&amp;" args
359  regsub -all "<" $args "\\&lt;" args
360  regsub -all ">" $args "\\&gt;" args
361  regsub -all "\"" $args "\\&\#34;" args
362  regsub -all "]" $args "\\&\#93;" args
363
364  return $args
365}
366
367########################################################################
368