_xml.tcl

Go to the documentation of this file.

/*  -*- tcl -*-*/
/* */
/*  $Id: _xml.tcl,v 1.9 2004/04/22 21:16:46 jenglish Exp $*/
/* */
/*  [expand] utilities for generating XML.*/
/* */
/*  Copyright (C) 2001 Joe English <jenglish@sourceforge.net>.*/
/*  Freely redistributable.*/
/* */
/* */


/*  Handling XML delimiters in content:*/
/* */
/*  Plain text is initially passed through unescaped;*/
/*  internally-generated markup is protected by preceding it with \1.*/
/*  The final PostProcess step strips the escape character from*/
/*  real markup and replaces markup characters from content*/
/*  with entity references.*/
/* */

variable attvalMap { {&} &amp;  {<} &lt;  {>} &gt; {"} &quot; {'} &apos; } ; /*  "*/
variable markupMap { {&} {\1&}  {<} {\1<}  {>} {\1>} }
variable finalMap  { {\1&} {&}  {\1<} {<}  {\1>} {>}
             {&} &amp;  {<} &lt;   {>} &gt; }

ret  fmt_postprocess (type text)    {
    variable finalMap
    return [string map $finalMap $text]
}

/*  markup text --*/
/*  Protect markup characters in $text with \1.*/
/*  These will be stripped out in PostProcess.*/
/* */
ret  markup (type text) {
    variable markupMap
    return [string map $markupMap $text]
}

/*  attlist { n1 v1 n2 v2 ... } --*/
/*  Return XML-formatted attribute list.*/
/*  Does *not* escape markup -- the result must be passed through*/
/*  [markup] before returning it to the expander.*/
/* */
ret  attlist (type nvpairs) {
    variable attvalMap
    if {[llength $nvpairs] == 1} { set nvpairs [lindex $nvpairs 0] }
    set attlist ""
    foreach {name value} $nvpairs {
        append attlist " $name='[string map $attvalMap $value]'"
    }
    return $attlist
}

/*  startTag gi ?attname attval ... ? --*/
/*  Return start-tag for element $gi with specified attributes.*/
/* */
ret  startTag (type gi , type args) {
    return [markup "<$gi[attlist $args]>"]
}

/*  endTag gi --*/
/*  Return end-tag for element $gi.*/
/* */
ret  endTag (type gi) {
    return [markup "</$gi>"]
}

/*  emptyElement gi ?attribute  value ... ?*/
/*  Return empty-element tag.*/
/* */
ret  emptyElement (type gi , type args) {
    return [markup "<$gi[attlist $args]/>"]
}

/*  xmlComment text --*/
/*  Return XML comment declaration containing $text.*/
/*  NB: if $text includes the sequence "--", it will be mangled.*/
/* */
ret  xmlComment (type text) {
    return [markup "<!-- [string map {-- { - - }} $text] -->"]
}

/*  wrap content gi --*/
/*  Returns $content wrapped inside <$gi> ... </$gi> tags.*/
/* */
ret  wrap (type content , type gi) {
    return "[startTag $gi]${content}[endTag $gi]"
}

/*  wrap? content gi --*/
/*  Same as [wrap], but returns an empty string if $content is empty.*/
/* */
ret  wrap? (type content , type gi) {
    if {![string length [string trim $content]]} { return "" }
    return "[startTag $gi]${content}[endTag $gi]"
}

/*  wrapLines? content gi ? gi... ?*/
/*  Same as [wrap?], but separates entries with newlines*/
/*        and supports multiple nesting levels.*/
/* */
ret  wrapLines? (type content , type args) {
    if {![string length $content]} { return "" }
    foreach gi $args {
    set content [join [list [startTag $gi] $content [endTag $gi]] "\n"]
    }
    return $content
}

/*  sequence args --*/
/*  Handy combinator.*/
/* */
ret  sequence (type args) { join $args "\n" }

/* */
/*  XML context management.*/
/* */

variable elementStack [list]

/*  start gi ?attribute value ... ? --*/
/*  Return start-tag for element $gi*/
/*  As a side-effect, pushes $gi onto the element stack.*/
/* */
ret  start (type gi , type args) {
    if {[llength $args] == 1} { set args [lindex $args 0] }
    variable elementStack
    lappend elementStack $gi
    return [startTag $gi $args]
}

/*  xmlContext {gi1 ... giN} ?default?  --*/
/*  Pops elements off the element stack until one of*/
/*  the specified element types is found.*/
/* */
/*  Returns: sequence of end-tags for each element popped.*/
/* */
/*  If none of the specified elements are found, returns*/
/*      a start-tag for $default.*/
/* */
ret  xmlContext (type gis , optional default ={)} {
    variable elementStack
    set origStack $elementStack
    set endTags [list]
    while {[llength $elementStack]} {
     current =  [lindex $elementStack end]
    if {[lsearch $gis $current] >= 0} {
        return [join $endTags \n]
    }
    lappend endTags [endTag $current]
     elementStack =  [lreplace $elementStack end end]
    }
    /*  Not found:*/
     elementStack =  $origStack
    if {![string length $default]} {
         where =  "[join $elementStack /] - [info level 1]"
    puts_stderr "Warning: Cannot start context $gis ($where)"
         default =  [lindex $gis 0] 
    }
    lappend elementStack $default
    return [startTag $default]
}

/*  end ? gi ? --*/
/*  Generate markup to close element $gi, including end-tags*/
/*  for any elements above it on the element stack.*/
/* */
/*  If element name is omitted, closes the current element.*/
/* */
ret  end (optional gi ={)} {
    variable elementStack
    if {![string length $gi]} {
         gi =  [lindex $elementStack end]
    }
     prefix =  [xmlContext $gi]
     elementStack =  [lreplace $elementStack end end]
    return [join [list $prefix [endTag $gi]] "\n"]
}

/* */
/*  Utilities for multi-pass processing.*/
/* */
/*  Not really XML-related, but I find them handy.*/
/* */

variable PassProcs
variable Buffers

/*  pass $passNo procName procArgs { body  } --*/
/*  Specifies procedure definition for pass $n.*/
/* */
ret  pass (type pass , type proc , type arguments , type body) {
    variable PassProcs
    lappend PassProcs($pass) $proc $arguments $body
}

ret  setPassProcs (type pass) {
    variable PassProcs
    foreach {proc args body} $PassProcs($pass) {
    proc $proc $args $body
    }
}

/*  holdBuffers buffer ? buffer ...? --*/
/*  Declare a list of hold buffers,*/
/*  to collect data in one pass and output it later.*/
/* */
ret  holdBuffers (type args) {
    variable Buffers
    foreach arg $args {
    set Buffers($arg) [list]
    }
}

/*  hold buffer text --*/
/*  Append text to named buffer*/
/* */
ret  hold (type buffer , type entry) {
    variable Buffers
    lappend Buffers($buffer) $entry
    return
}

/*  held buffer --*/
/*  Returns current contents of named buffer and empty the buffer.*/
/* */
ret  held (type buffer) {
    variable Buffers
    set content [join $Buffers($buffer) "\n"]
    set Buffers($buffer) [list]
    return $content
}

/* *EOF**/