home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / xuibuilder / TclDOM-1.6 / dom.tcl < prev    next >
Text File  |  2000-11-02  |  50KB  |  2,016 lines
  1. # dom.tcl --
  2. #
  3. #    This file implements the Tcl language binding for the DOM -
  4. #    the Document Object Model.  Support for the core specification
  5. #    is given here.  Layered support for specific languages, 
  6. #    such as HTML and XML, will be in separate modules.
  7. #
  8. # Copyright (c) 1998 Zveno Pty Ltd
  9. # http://www.zveno.com/
  10. #
  11. # Zveno makes this software available free of charge for any purpose.
  12. # Copies may be made of this software but all of this notice must be included
  13. # on any copy.
  14. #
  15. # The software was developed for research purposes only and Zveno does not
  16. # warrant that it is error free or fit for any purpose.  Zveno disclaims any
  17. # liability for all claims, expenses, losses, damages and costs any user may
  18. # incur as a result of using, copying or modifying this software.
  19. #
  20. # $Id: dom.tcl,v 1.2 1996/02/28 09:12:54 daniel Exp $
  21.  
  22. package provide dom 1.6
  23.  
  24. namespace eval dom {
  25.     namespace export DOMImplementation
  26.     namespace export document documentFragment node
  27.     namespace export element textNode attribute
  28.     namespace export processingInstruction
  29. }
  30.  
  31. # Data structure
  32. #
  33. # Documents are stored in an array within the dom namespace.
  34. # Each element of the array is indexed by a unique identifier.
  35. # Each element of the array is a key-value list with at least
  36. # the following fields:
  37. #    id docArray
  38. #    node:parentNode node:childNodes node:nodeType
  39. # Nodes of a particular type may have additional fields defined.
  40. # Note that these fields in many circumstances are configuration options
  41. # for a node type.
  42. #
  43. # "Live" data objects are stored as a separate Tcl variable.
  44. # Lists, such as child node lists, are Tcl list variables (ie scalar)
  45. # and keyed-value lists, such as attribute lists, are Tcl array
  46. # variables.  The accessor function returns the variable name,
  47. # which the application should treat as a read-only object.
  48. #
  49. # A token is a FQ array element reference for a node.
  50.  
  51. # dom::GetHandle --
  52. #
  53. #    Checks that a token is valid and sets an array variable
  54. #    in the caller to contain the node's fields.
  55. #
  56. #    This is expensive, so it is only used when called by
  57. #    the application.
  58. #
  59. # Arguments:
  60. #    type    node type (for future use)
  61. #    token    token passed in
  62. #    varName    variable name in caller to associate with node
  63. #
  64. # Results:
  65. #    Variable gets node's fields, otherwise returns error.
  66. #    Returns empty string.
  67.  
  68. proc dom::GetHandle {type token varName} {
  69.  
  70.     if {![info exists $token]} {
  71.     return -code error "invalid token \"$token\""
  72.     }
  73.  
  74.     upvar 1 $varName data
  75.     array set data [set $token]
  76.  
  77. # Type checking not implemented
  78. #    if {[string compare $data(node:nodeType) "document"]} {
  79. #    return -code error "node is not of type document"
  80. #    }
  81.  
  82.     return {}
  83. }
  84.  
  85. # dom::PutHandle --
  86. #
  87. #    Writes the values from the working copy of the node's data
  88. #    into the document's global array.
  89. #
  90. #    NB. Token checks are performed in GetHandle
  91. #    NB(2). This is still expensive, so is not used.
  92. #
  93. # Arguments:
  94. #    token    token passed in
  95. #    varName    variable name in caller to associate with node
  96. #
  97. # Results:
  98. #    Sets array element for this node to have new values.
  99. #    Returns empty string.
  100.  
  101. proc dom::PutHandle {token varName} {
  102.  
  103.     upvar 1 $varName data
  104.     set $token [array get data]
  105.  
  106.     return {}
  107. }
  108.  
  109. # dom::DOMImplementation --
  110. #
  111. #    Implementation-dependent functions.
  112. #    Most importantly, this command provides a function to
  113. #    create a document instance.
  114. #
  115. # Arguments:
  116. #    method    method to invoke
  117. #    token    token for node
  118. #    args    arguments for method
  119. #
  120. # Results:
  121. #    Depends on method used.
  122.  
  123. namespace eval dom {
  124.     variable DOMImplementationOptions {}
  125.     variable DOMImplementationCounter 0
  126. }
  127.  
  128. proc dom::DOMImplementation {method args} {
  129.     variable DOMImplementationOptions
  130.     variable DOMImplementationCounter
  131.  
  132.     switch -- $method {
  133.  
  134.     hasFeature {
  135.  
  136.         if {[llength $args] != 2} {
  137.         return -code error "wrong number of arguments"
  138.         }
  139.  
  140.         # Later on, could use Tcl package facility
  141.         if {[regexp {create|destroy|parse|serialize|trim} [lindex $args 0]]} {
  142.         if {![string compare [lindex $args 1] "1.0"]} {
  143.             return 1
  144.         } else {
  145.             return 0
  146.         }
  147.         } else {
  148.         return 0
  149.         }
  150.  
  151.     }
  152.  
  153.     create {
  154.  
  155.         # Bootstrap a document instance
  156.  
  157.         switch [llength $args] {
  158.         0 {
  159.             # Allocate unique document array name
  160.                 set name [namespace current]::document[incr DOMImplementationCounter]
  161.         }
  162.         1 {
  163.             # Use array name provided.  Should check that it is safe.
  164.             set name [lindex $args 0]
  165.             catch {unset $name}
  166.         }
  167.         default {
  168.             return -code error "wrong number of arguments"
  169.         }
  170.         }
  171.  
  172.         set varPrefix ${name}var
  173.         set arrayPrefix ${name}arr
  174.  
  175.         array set $name [list counter 1 \
  176.         node1 [list id node1 docArray $name        \
  177.             node:nodeType documentFragment        \
  178.             node:parentNode {}            \
  179.             node:childNodes ${varPrefix}1        \
  180.             documentFragment:masterDoc node1    \
  181.             document:implementation {}        \
  182.             document:xmldecl {version 1.0}        \
  183.             document:documentElement {}        \
  184.             document:doctype {}            \
  185.         ]]
  186.  
  187.         # Initialise child node list
  188.         set ${varPrefix}1 {}
  189.  
  190.         # Return the new toplevel node
  191.         return ${name}(node1)
  192.  
  193.     }
  194.  
  195.     destroy {
  196.  
  197.         # Cleanup a document
  198.  
  199.         if {[llength $args] != 1} {
  200.         return -code error "wrong number of arguments"
  201.         }
  202.         array set node [set [lindex $args 0]]
  203.  
  204.         # Patch from Gerald Lester
  205.  
  206.         ##
  207.         ## First release all the associated variables
  208.         ##
  209.         upvar #0 $node(docArray) docArray
  210.         for {set i 0} {$i < $docArray(counter)} {incr i} {
  211.         catch {unset ${docArrayName}var$i}
  212.         catch {unset ${docArrayName}arr$i}
  213.         }
  214.              
  215.         ##
  216.         ## Then release the main document array
  217.         ##
  218.         if {[catch {unset $node(docArray)}]} {
  219.         return -code error "unable to destroy document"
  220.         }
  221.  
  222.         return {}
  223.  
  224.     }
  225.  
  226.     parse {
  227.  
  228.         # This implementation allows use of either of two event-based,
  229.         # non-validating XML parsers:
  230.         # . TclXML Tcl-only parser (version 1.3 or higher)
  231.         # . TclExpat parser
  232.  
  233.         array set opts {-parser {} -progresscommand {} -chunksize 8196}
  234.         if {[catch {array set opts [lrange $args 1 end]}]} {
  235.         return -code error "bad configuration options"
  236.         }
  237.  
  238.         # Create a state array for this parse session
  239.         set state [namespace current]::parse[incr DOMImplementationCounter]
  240.         array set $state [array get opts -*]
  241.         array set $state [list progCounter 0]
  242.         set errorCleanup {}
  243.  
  244.         switch -- $opts(-parser) {
  245.         expat {
  246.             if {[catch {package require expat} version]} {
  247.             eval $errorCleanup
  248.             return -code error "expat extension is not available"
  249.             }
  250.             set parser [expat [namespace current]::xmlparser]
  251.         }
  252.         tcl {
  253.  
  254.             if {[catch {package require xml 1.3} version]} {
  255.             eval $errorCleanup
  256.             return -code error "XML parser package is not available"
  257.             }
  258.             set parser [::xml::parser xmlparser]
  259.         }
  260.         default {
  261.  
  262.             # Automatically determine which parser to use
  263.             if {[catch {package require expat} version]} {
  264.             if {[catch {package require xml 1.3} version]} {
  265.                 eval $errorCleanup
  266.                 return -code error "unable to load XML parser"
  267.             } else {
  268.  
  269.                 set parser [::xml::parser xmlparser]
  270.  
  271.             }
  272.             } else {
  273.             set parser [expat [namespace current]::xmlparser]
  274.             }
  275.         }
  276.         }
  277.  
  278.         $parser configure \
  279.         -elementstartcommand [namespace code [list ParseElementStart $state]]    \
  280.         -elementendcommand [namespace code [list ParseElementEnd $state]]    \
  281.         -characterdatacommand [namespace code [list ParseCharacterData $state]] \
  282.         -processinginstructioncommand [namespace code [list ParseProcessingInstruction $state]] \
  283.         -final true
  284.  
  285.         # TclXML has features missing from expat
  286.         catch {
  287.         $parser configure \
  288.             -xmldeclcommand [namespace code [list ParseXMLDeclaration $state]] \
  289.             -doctypecommand [namespace code [list ParseDocType $state]]
  290.         }
  291.  
  292.         # Create top-level document
  293.         array set $state [list docNode [DOMImplementation create]]
  294.         array set $state [list current [lindex [array get $state docNode] 1]]
  295.  
  296.         # Parse data
  297.         # Bug in TclExpat - doesn't handle non-final inputs
  298.         if {0 && [string length $opts(-progresscommand)]} {
  299.  
  300.         $parser configure -final false
  301.         while {[string length [lindex $args 0]]} {
  302.             $parser parse [string range [lindex $args 0] 0 $opts(-chunksize)]
  303.             set args [lreplace $args 0 0 \
  304.             [string range [lindex $args 0] $opts(-chunksize) end]]
  305.             uplevel #0 $opts(-progresscommand)
  306.         }
  307.         $parser configure -final true
  308.         } elseif {[catch {$parser parse [lindex $args 0]} err]} {
  309.  
  310.  
  311.         catch {rename $parser {}}
  312.         catch {unset $state}
  313.         return -code error $err
  314.         }
  315.  
  316.         # Free data structures which are no longer required
  317.         catch {rename $parser {}}
  318.  
  319.         set doc [lindex [array get $state docNode] 1]
  320.         unset $state
  321.         return $doc
  322.  
  323.     }
  324.  
  325.     serialize {
  326.  
  327.         if {[llength $args] < 1} {
  328.         return -code error "wrong number of arguments"
  329.         }
  330.  
  331.         GetHandle documentFragment [lindex $args 0] node
  332.         return [eval [list Serialize:$node(node:nodeType)] $args]
  333.  
  334.     }
  335.  
  336.     trim {
  337.  
  338.         # Removes textNodes that only contain white space
  339.  
  340.         if {[llength $args] != 1} {
  341.         return -code error "wrong number of arguments"
  342.         }
  343.  
  344.         Trim [lindex $args 0]
  345.  
  346.         return {}
  347.  
  348.     }
  349.  
  350.     default {
  351.         return -code error "unknown method \"$method\""
  352.     }
  353.  
  354.     }
  355.  
  356.     return {}
  357. }
  358.  
  359. # dom::document --
  360. #
  361. #    Functions for a document node.
  362. #
  363. # Arguments:
  364. #    method    method to invoke
  365. #    token    token for node
  366. #    args    arguments for method
  367. #
  368. # Results:
  369. #    Depends on method used.
  370.  
  371. namespace eval dom {
  372.     variable documentOptionsRO doctype|implementation|documentElement
  373.     variable documentOptionsRW {}
  374. }
  375.  
  376. proc dom::document {method token args} {
  377.     variable documentOptionsRO
  378.     variable documentOptionsRW
  379.  
  380.     # GetHandle also checks token
  381.     GetHandle document $token node
  382.  
  383.     set result {}
  384.  
  385.     switch -- $method {
  386.     cget {
  387.         if {[llength $args] != 1} {
  388.         return -code error "too many arguments"
  389.         }
  390.         if {[regexp [format {^-(%s)$} $documentOptionsRO] [lindex $args 0] discard option]} {
  391.         return $node(document:$option)
  392.         } elseif {[regexp [format {^-(%s)$} $documentOptionsRW] [lindex $args 0] discard option]} {
  393.         return $node(document:$option)
  394.         } else {
  395.         return -code error "unknown option \"[lindex $args 0]\""
  396.         }
  397.     }
  398.     configure {
  399.         if {[llength $args] == 1} {
  400.         return [document cget $token [lindex $args 0]]
  401.         } elseif {[expr [llength $args] % 2]} {
  402.         return -code error "no value specified for option \"[lindex $args end]\""
  403.         } else {
  404.         foreach {option value} $args {
  405.             if {[regexp [format {^-(%s)$} $documentOptionsRW] $option discard opt]} {
  406.             set node(document:$opt) $value
  407.             } elseif {[regexp [format {^-(%s)$} $documentOptionsRO] $option discard opt]} {
  408.             return -code error "attribute \"$option\" is read-only"
  409.             } else {
  410.             return -code error "unknown option \"$option\""
  411.             }
  412.         }
  413.         }
  414.  
  415.         PutHandle $token node
  416.  
  417.     }
  418.  
  419.     createElement {
  420.         if {[llength $args] != 1} {
  421.         return -code error "wrong number of arguments"
  422.         }
  423.  
  424.         # Check that the element name is kosher
  425.         # BUG: The definition of 'Letter' here as ASCII letters
  426.         # is not sufficient.  Also, CombiningChar and Extenders
  427.         # must be added.
  428.         if {![regexp {^[A-Za-z_:][-A-Za-z0-9._:]*$} [lindex $args 0]]} {
  429.         return -code error "invalid element name \"[lindex $args 0]\""
  430.         }
  431.  
  432.         # Invoke internal factory function
  433.         set result [CreateElement $token [lindex $args 0] {}]
  434.  
  435.     }
  436.     createDocumentFragment {
  437.         if {[llength $args]} {
  438.         return -code error "wrong number of arguments"
  439.         }
  440.  
  441.         set result [CreateGeneric $token node:nodeType documentFragment]
  442.     }
  443.     createTextNode {
  444.         if {[llength $args] != 1} {
  445.         return -code error "wrong number of arguments"
  446.         }
  447.  
  448.         set result [CreateTextNode $token [lindex $args 0]]
  449.     }
  450.     createComment {
  451.         if {[llength $args] != 1} {
  452.         return -code error "wrong number of arguments"
  453.         }
  454.  
  455.         set result [CreateGeneric $token node:nodeType comment node:nodeValue [lindex $args 0]]
  456.     }
  457.     createCDATASection {
  458.         if {[llength $args] != 1} {
  459.         return -code error "wrong number of arguments"
  460.         }
  461.  
  462.         set result [CreateGeneric $token node:nodeType CDATASection node:nodeValue [lindex $args 0]]
  463.     }
  464.     createProcessingInstruction {
  465.         if {[llength $args] != 2} {
  466.         return -code error "wrong number of arguments"
  467.         }
  468.  
  469.         set result [CreateGeneric $token node:nodeType processingInstruction \
  470.             node:nodeName [lindex $args 0] node:nodeValue [lindex $args 1]]
  471.     }
  472.     createAttribute {
  473.         if {[llength $args] != 1} {
  474.         return -code error "wrong number of arguments"
  475.         }
  476.  
  477.         set result [CreateGeneric $token node:nodeType attribute node:nodeName [lindex $args 0]]
  478.     }
  479.     createEntity {
  480.         set result [CreateGeneric $token node:nodeType entity]
  481.     }
  482.     createEntityReference {
  483.         set result [CreateGeneric $token node:nodeType entityReference]
  484.     }
  485.  
  486.     createDocTypeDecl {
  487.         # This is not a standard DOM 1.0 method
  488.         if {[llength $args] < 1 || [llength $args] > 5} {
  489.         return -code error "wrong number of arguments"
  490.         }
  491.  
  492.         foreach {name extid dtd entities notations} $args break
  493.         set result [CreateDocType $token $name $extid $dtd $entities $notations]
  494.     }
  495.  
  496.     getElementsByTagName {
  497.         if {[llength $args] != 1} {
  498.         return -code error "wrong number of arguments"
  499.         }
  500.  
  501.         return [Element:GetByTagName $token [lindex $args 0]]
  502.     }
  503.  
  504.     default {
  505.         return -code error "unknown method \"$method\""
  506.     }
  507.  
  508.     }
  509.  
  510.     return $result
  511. }
  512.  
  513. ###    Factory methods
  514. ###
  515. ### These are lean-and-mean for fastest possible tree building
  516.  
  517. # dom::CreateElement --
  518. #
  519. #    Append an element to the given (parent) node (if any)
  520. #
  521. # Arguments:
  522. #    token    parent node
  523. #    name    element name (no checking performed here)
  524. #    aList    attribute list
  525. #    args    configuration options
  526. #
  527. # Results:
  528. #    New node created, parent optionally modified
  529.  
  530. proc dom::CreateElement {token name aList args} {
  531.     if {[string length $token]} {
  532.     array set parent [set $token]
  533.     upvar #0 $parent(docArray) docArray
  534.     set docArrayName $parent(docArray)
  535.     } else {
  536.     array set opts $args
  537.     upvar #0 $opts(-docarray) docArray
  538.     set docArrayName $opts(-docarray)
  539.     }
  540.  
  541.     set id node[incr docArray(counter)]
  542.     set child ${docArrayName}($id)
  543.  
  544.     # Create the new node
  545.     # NB. normally we'd use Node:create here,
  546.     # but inline it instead for performance
  547.     set docArray($id) [list id $id docArray $docArrayName \
  548.         node:parentNode $token        \
  549.         node:childNodes ${docArrayName}var$docArray(counter)    \
  550.         node:nodeType element        \
  551.         node:nodeName $name            \
  552.         node:nodeValue {}            \
  553.         element:attributeList ${docArrayName}arr$docArray(counter) \
  554.     ]
  555.  
  556.     # Initialise associated variables
  557.     set ${docArrayName}var$docArray(counter) {}
  558.     array set ${docArrayName}arr$docArray(counter) $aList
  559.  
  560.     # Update parent record
  561.  
  562.     # Does this element qualify as the document element?
  563.     # If so, then has a document element already been set?
  564.  
  565.     if {[string length $token]} {
  566.  
  567.     if {![string compare $parent(node:nodeType) documentFragment]} {
  568.         if {$parent(id) == $parent(documentFragment:masterDoc)} {
  569.         if {[info exists parent(document:documentElement)] && \
  570.             [string length $parent(document:documentElement)]} {
  571.             unset docArray($id)
  572.             return -code error "document element already exists"
  573.         } else {
  574.  
  575.             # Check against document type decl
  576.             if {[string length $parent(document:doctype)]} {
  577.             array set doctypedecl [set $parent(document:doctype)]
  578.             if {[string compare $name $doctypedecl(doctype:name)]} {
  579.                 return -code error "mismatch between root element type in document type declaration \"$doctypedecl(doctype:name)\" and root element \"$name\""
  580.             }
  581.  
  582.             } else {
  583.             # Synthesize document type declaration
  584.             CreateDocType $token $name {} {}
  585.             # Resynchronise parent record
  586.             array set parent [set $token]
  587.             }
  588.  
  589.             set parent(document:documentElement) $child
  590.             set $token [array get parent]
  591.         }
  592.         }
  593.     }
  594.  
  595.     lappend $parent(node:childNodes) $child
  596.  
  597.     }
  598.  
  599.     return $child
  600. }
  601.  
  602. # dom::CreateTextNode --
  603. #
  604. #    Append a textNode node to the given (parent) node (if any).
  605. #
  606. #    This factory function can also be performed by
  607. #    CreateGeneric, but text nodes are created so often
  608. #    that this specific factory procedure speeds things up.
  609. #
  610. # Arguments:
  611. #    token    parent node
  612. #    text    initial text
  613. #    args    additional configuration options
  614. #
  615. # Results:
  616. #    New node created, parent optionally modified
  617.  
  618. proc dom::CreateTextNode {token text args} {
  619.     if {[string length $token]} {
  620.     array set parent [set $token]
  621.     upvar #0 $parent(docArray) docArray
  622.     set docArrayName $parent(docArray)
  623.     } else {
  624.     array set opts $args
  625.     upvar #0 $opts(-docarray) docArray
  626.     set docArrayName $opts(-docarray)
  627.     }
  628.  
  629.     set id node[incr docArray(counter)]
  630.     set child ${docArrayName}($id)
  631.  
  632.     # Create the new node
  633.     # NB. normally we'd use Node:create here,
  634.     # but inline it instead for performance
  635.  
  636.     # Text nodes never have children, so don't create a variable
  637.  
  638.     set docArray($id) [list id $id docArray $docArrayName \
  639.         node:parentNode $token        \
  640.         node:childNodes {}            \
  641.         node:nodeType textNode        \
  642.         node:nodeValue $text        \
  643.     ]
  644.  
  645.     if {[string length $token]} {
  646.     # Update parent record
  647.     lappend $parent(node:childNodes) $child
  648.     set $token [array get parent]
  649.     }
  650.  
  651.     return $child
  652. }
  653.  
  654. # dom::CreateGeneric --
  655. #
  656. #    This is a template used for type-specific factory procedures
  657. #
  658. # Arguments:
  659. #    token    parent node
  660. #    args    optional values
  661. #
  662. # Results:
  663. #    New node created, parent modified
  664.  
  665. proc dom::CreateGeneric {token args} {
  666.     if {[string length $token]} {
  667.     array set parent [set $token]
  668.     upvar #0 $parent(docArray) docArray
  669.     set docArrayName $parent(docArray)
  670.     } else {
  671.     array set opts $args
  672.     upvar #0 $opts(-docarray) docArray
  673.     set docArrayName $opts(-docarray)
  674.     array set tmp [array get opts]
  675.     foreach opt [array names tmp -*] {
  676.         unset tmp($opt)
  677.     }
  678.     set args [array get tmp]
  679.     }
  680.  
  681.     set id node[incr docArray(counter)]
  682.     set child ${docArrayName}($id)
  683.  
  684.     # Create the new node
  685.     # NB. normally we'd use Node:create here,
  686.     # but inline it instead for performance
  687.     set docArray($id) [eval list [list id $id docArray $docArrayName \
  688.         node:parentNode $token        \
  689.         node:childNodes ${docArrayName}var$docArray(counter)]    \
  690.         $args
  691.     ]
  692.     set ${docArrayName}var$docArray(counter) {}
  693.  
  694.     if {[string length $token]} {
  695.     # Update parent record
  696.     lappend $parent(node:childNodes) $child
  697.     set $token [array get parent]
  698.     }
  699.  
  700.     return $child
  701. }
  702.  
  703. ### Specials
  704.  
  705. # dom::CreateDocType --
  706. #
  707. #    Create a Document Type Declaration node.
  708. #
  709. # Arguments:
  710. #    token    node id for the document node
  711. #    name    root element type
  712. #    extid    external entity id
  713. #    dtd    internal DTD subset
  714. #
  715. # Results:
  716. #    Returns node id of the newly created node.
  717.  
  718. proc dom::CreateDocType {token name {extid {}} {dtd {}} {entities {}} {notations {}}} {
  719.     array set doc [set $token]
  720.     upvar #0 $doc(docArray) docArray
  721.  
  722.     set id node[incr docArray(counter)]
  723.     set child $doc(docArray)($id)
  724.  
  725.     set docArray($id) [list \
  726.         id $id docArray $doc(docArray) \
  727.         node:parentNode $token \
  728.         node:childNodes {} \
  729.         node:nodeType docType \
  730.         node:nodeName {} \
  731.         node:nodeValue {} \
  732.         doctype:name $name \
  733.         doctype:entities {} \
  734.         doctype:notations {} \
  735.         doctype:externalid $extid \
  736.         doctype:internaldtd $dtd \
  737.     ]
  738.     # NB. externalid and internaldtd are not standard DOM 1.0 attributes
  739.  
  740.     # Update parent
  741.  
  742.     set doc(document:doctype) $child
  743.  
  744.     # Add this node to the parent's child list
  745.     # This must come before the document element,
  746.     # so this implementation may be buggy
  747.     lappend $doc(node:childNodes) $child
  748.  
  749.     set $token [array get doc]
  750.  
  751.     return $child
  752. }
  753.  
  754. # dom::node --
  755. #
  756. #    Functions for a general node.
  757. #
  758. # Arguments:
  759. #    method    method to invoke
  760. #    token    token for node
  761. #    args    arguments for method
  762. #
  763. # Results:
  764. #    Depends on method used.
  765.  
  766. namespace eval dom {
  767.     variable nodeOptionsRO nodeName|nodeType|parentNode|childNodes|firstChild|lastChild|previousSibling|nextSibling|attributes
  768.     variable nodeOptionsRW nodeValue
  769. }
  770.  
  771. proc dom::node {method token args} {
  772.     variable nodeOptionsRO
  773.     variable nodeOptionsRW
  774.  
  775.     GetHandle node $token node
  776.  
  777.     set result {}
  778.  
  779.     switch -glob -- $method {
  780.     cg* {
  781.         # cget
  782.  
  783.         # Some read-only configuration options are computed
  784.         if {[llength $args] != 1} {
  785.         return -code error "too many arguments"
  786.         }
  787.         if {[regexp [format {^-(%s)$} $nodeOptionsRO] [lindex $args 0] discard option]} {
  788.         switch $option {
  789.             childNodes {
  790.             # How are we going to handle documentElement?
  791.             set result $node(node:childNodes)
  792.             }
  793.             firstChild {
  794.             upvar #0 $node(node:childNodes) children
  795.             switch $node(node:nodeType) {
  796.                 documentFragment {
  797.                 set result [lindex $children 0]
  798.                 catch {set result $node(document:documentElement)}
  799.                 }
  800.                 default {
  801.                 set result [lindex $children 0]
  802.                 }
  803.             }
  804.             }
  805.             lastChild {
  806.             upvar #0 $node(node:childNodes) children
  807.             switch $node(node:nodeType) {
  808.                 documentFragment {
  809.                 set result [lindex $children end]
  810.                 catch {set result $node(document:documentElement)}
  811.                 }
  812.                 default {
  813.                 set result [lindex $children end]
  814.                 }
  815.             }
  816.             }
  817.             previousSibling {
  818.             # BUG: must take documentElement into account
  819.             # Find the parent node
  820.             GetHandle node $node(node:parentNode) parent
  821.             upvar #0 $parent(node:childNodes) children
  822.             set idx [lsearch $children $token]
  823.             if {$idx >= 0} {
  824.                 set sib [lindex $children [incr idx -1]]
  825.                 if {[llength $sib]} {
  826.                 set result $sib
  827.                 } else {
  828.                 set result {}
  829.                 }
  830.             } else {
  831.                 set result {}
  832.             }
  833.             }
  834.             nextSibling {
  835.             # BUG: must take documentElement into account
  836.             # Find the parent node
  837.             GetHandle node $node(node:parentNode) parent
  838.             upvar #0 $parent(node:childNodes) children
  839.             set idx [lsearch $children $token]
  840.             if {$idx >= 0} {
  841.                 set sib [lindex $children [incr idx]]
  842.                 if {[llength $sib]} {
  843.                 set result $sib
  844.                 } else {
  845.                 set result {}
  846.                 }
  847.             } else {
  848.                 set result {}
  849.             }
  850.             }
  851.             attributes {
  852.             if {[string compare $node(node:nodeType) element]} {
  853.                 set result {}
  854.             } else {
  855.                 set result $node(element:attributeList)
  856.             }
  857.             }
  858.             default {
  859.             return [GetField node(node:$option)]
  860.             }
  861.         }
  862.         } elseif {[regexp [format {^-(%s)$} $nodeOptionsRW] [lindex $args 0] discard option]} {
  863.         return [GetField node(node:$option)]
  864.         } else {
  865.         return -code error "unknown option \"[lindex $args 0]\""
  866.         }
  867.     }
  868.     co* {
  869.         # configure
  870.  
  871.         if {[llength $args] == 1} {
  872.         return [document cget $token [lindex $args 0]]
  873.         } elseif {[expr [llength $args] % 2]} {
  874.         return -code error "no value specified for option \"[lindex $args end]\""
  875.         } else {
  876.         foreach {option value} $args {
  877.             if {[regexp [format {^-(%s)$} $nodeOptionsRW] $option discard opt]} {
  878.             set node(node:$opt) $value
  879.             } elseif {[regexp [format {^-(%s)$} $nodeOptionsRO] $option discard opt]} {
  880.             return -code error "attribute \"$option\" is read-only"
  881.             } else {
  882.             return -code error "unknown option \"$option\""
  883.             }
  884.         }
  885.         }
  886.     }
  887.  
  888.     in* {
  889.  
  890.         # insertBefore
  891.  
  892.         # Previous and next sibling relationships are OK, 
  893.         # because they are dynamically determined
  894.  
  895.         if {[llength $args] < 1 || [llength $args] > 2} {
  896.         return -code error "wrong number of arguments"
  897.         }
  898.  
  899.         GetHandle node [lindex $args 0] newChild
  900.         if {[string compare $newChild(docArray) $node(docArray)]} {
  901.         return -code error "new node must be in the same document"
  902.         }
  903.  
  904.         switch [llength $args] {
  905.         1 {
  906.             # Append as the last node
  907.             if {[string length $newChild(node:parentNode)]} {
  908.             node removeChild $newChild(node:parentNode) [lindex $args 0]
  909.             }
  910.             lappend $node(node:childNodes) [lindex $args 0]
  911.             set newChild(node:parentNode) $token
  912.         }
  913.         2 {
  914.  
  915.             GetHandle node [lindex $args 1] refChild
  916.             if {[string compare $refChild(docArray) $newChild(docArray)]} {
  917.             return -code error "nodes must be in the same document"
  918.             }
  919.             set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]]
  920.             if {$idx < 0} {
  921.             return -code error "no such reference child"
  922.             } else {
  923.  
  924.             # Remove from previous parent
  925.             if {[string length $newChild(node:parentNode)]} {
  926.                 node removeChild $newChild(node:parentNode) [lindex $args 0]
  927.             }
  928.  
  929.             # Insert into new node
  930.             set $node(node:childNodes) \
  931.                 [linsert [set $node(node:childNodes)] $idx [lindex $args 0]]
  932.             set newChild(node:parentNode) $token
  933.             }
  934.         }
  935.         }
  936.         PutHandle [lindex $args 0] newChild
  937.     }
  938.  
  939.     rep* {
  940.  
  941.         # replaceChild
  942.  
  943.         if {[llength $args] != 2} {
  944.         return -code error "wrong number of arguments"
  945.         }
  946.  
  947.         GetHandle node [lindex $args 0] newChild
  948.         GetHandle node [lindex $args 1] oldChild
  949.  
  950.         # Find where to insert new child
  951.         set idx [lsearch [set $node(node:childNodes)] [lindex $args 1]]
  952.         if {$idx < 0} {
  953.         return -code error "no such old child"
  954.         }
  955.  
  956.         # Remove new child from current parent
  957.         if {[string length $newChild(node:parentNode)]} {
  958.         node removeChild $newChild(node:parentNode) [lindex $args 0]
  959.         }
  960.  
  961.         set $node(node:childNodes) \
  962.         [lreplace [set $node(node:childNodes)] $idx $idx [lindex $args 0]]
  963.         set newChild(node:parentNode) $token
  964.  
  965.         # Update old child to reflect lack of parentage
  966.         set oldChild(node:parentNode) {}
  967.  
  968.         PutHandle [lindex $args 1] oldChild
  969.         PutHandle [lindex $args 0] newChild
  970.  
  971.         set result [lindex $args 0]
  972.  
  973.     }
  974.  
  975.     rem* {
  976.  
  977.         # removeChild
  978.  
  979.         if {[llength $args] != 1} {
  980.         return -code error "wrong number of arguments"
  981.         }
  982.         array set oldChild [set [lindex $args 0]]
  983.         if {$oldChild(docArray) != $node(docArray)} {
  984.         return -code error "node \"[lindex $args 0]\" is not a child"
  985.         }
  986.  
  987.         # Remove the child from the parent
  988.         upvar #0 $node(node:childNodes) myChildren
  989.         if {[set idx [lsearch $myChildren [lindex $args 0]]] < 0} {
  990.         return -code error "node \"[lindex $args 0]\" is not a child"
  991.         }
  992.         set myChildren [lreplace $myChildren $idx $idx]
  993.  
  994.         # Update the child to reflect lack of parentage
  995.         set oldChild(node:parentNode) {}
  996.         set [lindex $args 0] [array get oldChild]
  997.  
  998.         set result [lindex $args 0]
  999.     }
  1000.  
  1001.     ap* {
  1002.  
  1003.         # appendChild
  1004.  
  1005.         if {[llength $args] != 1} {
  1006.         return -code error "wrong number of arguments"
  1007.         }
  1008.  
  1009.         # Add to new parent
  1010.         node insertBefore $token [lindex $args 0]
  1011.  
  1012.     }
  1013.  
  1014.     hasChildNodes {
  1015.         set result [Min 1 [llength [set $node(node:childNodes)]]]
  1016.     }
  1017.  
  1018.     cl* {
  1019.         # cloneNode
  1020.  
  1021.         set deep 0
  1022.         switch [llength $args] {
  1023.         0 {
  1024.         }
  1025.         1 {
  1026.             set deep [Boolean [lindex $args 0]]
  1027.         }
  1028.         default {
  1029.             return -code error "too many arguments"
  1030.         }
  1031.         }
  1032.  
  1033.         switch $node(node:nodeType) {
  1034.         element {
  1035.             set result [CreateElement {} $node(node:nodeName) [array get $node(element:attributeList)] -docarray $node(docArray)]
  1036.             if {$deep} {
  1037.             foreach child [set $node(node:childNodes)] {
  1038.                 node appendChild $result [node cloneNode $child]
  1039.             }
  1040.             }
  1041.         }
  1042.         textNode {
  1043.             set result [CreateTextNode {} $node(node:nodeValue) -docarray $node(docArray)]
  1044.         }
  1045.         document -
  1046.         documentFragment -
  1047.         default {
  1048.             set result [CreateGeneric {} node:nodeType $node(node:nodeType) -docarray $node(docArray)]
  1049.             if {$deep} {
  1050.             foreach child [set $node(node:childNodes)] {
  1051.                 node appendChild $result [node cloneNode $child]
  1052.             }
  1053.             }
  1054.         }
  1055.         }
  1056.  
  1057.     }
  1058.  
  1059.     ch* {
  1060.         # children -- non-standard method
  1061.  
  1062.         # If this is a textNode, then catch the error
  1063.         set result {}
  1064.         catch {set result [set $node(node:childNodes)]}
  1065.  
  1066.     }
  1067.  
  1068.     pa* {
  1069.         # parent -- non-standard method
  1070.  
  1071.         return $node(node:parentNode)
  1072.  
  1073.     }
  1074.  
  1075.     default {
  1076.         return -code error "unknown method \"$method\""
  1077.     }
  1078.  
  1079.     }
  1080.  
  1081.     PutHandle $token node
  1082.  
  1083.     return $result
  1084. }
  1085.  
  1086. # dom::Node:create --
  1087. #
  1088. #    Generic node creation.
  1089. #    See also CreateElement, CreateTextNode, CreateGeneric.
  1090. #
  1091. # Arguments:
  1092. #    pVar    array in caller which contains parent details
  1093. #    args    configuration options
  1094. #
  1095. # Results:
  1096. #    New child node created.
  1097.  
  1098. proc dom::Node:create {pVar args} {
  1099.     upvar $pVar parent
  1100.  
  1101.     array set opts {-name {} -value {}}
  1102.     array set opts $args
  1103.  
  1104.     upvar #0 $parent(docArray) docArray
  1105.  
  1106.     # Create new node
  1107.     if {![info exists opts(-id)]} {
  1108.     set opts(-id) node[incr docArray(counter)]
  1109.     }
  1110.     set docArray($opts(-id)) [list id $opts(-id) \
  1111.         docArray $parent(docArray)        \
  1112.         node:parentNode $opts(-parent)    \
  1113.         node:childNodes $parent(docArray)var$docArray(counter)    \
  1114.         node:nodeType $opts(-type)        \
  1115.         node:nodeName $opts(-name)        \
  1116.         node:nodeValue $opts(-value)    \
  1117.         element:attributeList $parent(docArray)arr$docArray(counter) \
  1118.     ]
  1119.     set $parent(docArray)var$docArray(counter) {}
  1120.     array set $parent(docArray)arr$docArray(counter) {}
  1121.  
  1122.     # Update parent node
  1123.     if {![info exists parent(document:documentElement)]} {
  1124.     lappend parent(node:childNodes) [list [lindex $opts(-parent) 0] $opts(-id)]
  1125.     }
  1126.  
  1127.     return $parent(docArray)($opts(-id))
  1128.  
  1129. }
  1130.  
  1131. # dom::Node:set --
  1132. #
  1133. #    Generic node update
  1134. #
  1135. # Arguments:
  1136. #    token    node token
  1137. #    args    configuration options
  1138. #
  1139. # Results:
  1140. #    Node modified.
  1141.  
  1142. proc dom::Node:set {token args} {
  1143.     upvar $token node
  1144.  
  1145.     foreach {key value} $args {
  1146.     set node($key) $value
  1147.     }
  1148.  
  1149.     set $token [array get node]
  1150.  
  1151.     return {}
  1152. }
  1153.  
  1154. # dom::element --
  1155. #
  1156. #    Functions for an element.
  1157. #
  1158. # Arguments:
  1159. #    method    method to invoke
  1160. #    token    token for node
  1161. #    args    arguments for method
  1162. #
  1163. # Results:
  1164. #    Depends on method used.
  1165.  
  1166. namespace eval dom {
  1167.     variable elementOptionsRO {tagName|empty}
  1168.     variable elementOptionsRW {}
  1169. }
  1170.  
  1171. proc dom::element {method token args} {
  1172.     variable elementOptionsRO
  1173.     variable elementOptionsRW
  1174.  
  1175.     GetHandle node $token node
  1176.  
  1177.     set result {}
  1178.  
  1179.     switch -- $method {
  1180.  
  1181.     cget {
  1182.         # Some read-only configuration options are computed
  1183.         if {[llength $args] != 1} {
  1184.         return -code error "too many arguments"
  1185.         }
  1186.         if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} {
  1187.         switch $option {
  1188.             tagName {
  1189.             set result [lindex $node(node:nodeName) 0]
  1190.             }
  1191.             empty {
  1192.             if {![info exists node(element:empty)]} {
  1193.                 return 0
  1194.             } else {
  1195.                 return $node(element:empty)
  1196.             }
  1197.             }
  1198.             default {
  1199.             return $node(node:$option)
  1200.             }
  1201.         }
  1202.         } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} {
  1203.         return $node(node:$option)
  1204.         } else {
  1205.         return -code error "unknown option \"[lindex $args 0]\""
  1206.         }
  1207.     }
  1208.     configure {
  1209.         if {[llength $args] == 1} {
  1210.         return [document cget $token [lindex $args 0]]
  1211.         } elseif {[expr [llength $args] % 2]} {
  1212.         return -code error "no value specified for option \"[lindex $args end]\""
  1213.         } else {
  1214.         foreach {option value} $args {
  1215.             if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} {
  1216.             return -code error "attribute \"$option\" is read-only"
  1217.             } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} {
  1218.             return -code error "not implemented"
  1219.             } else {
  1220.             return -code error "unknown option \"$option\""
  1221.             }
  1222.         }
  1223.         }
  1224.     }
  1225.  
  1226.     getAttribute {
  1227.         if {[llength $args] != 1} {
  1228.         return -code error "wrong number of arguments"
  1229.         }
  1230.  
  1231.         upvar #0 $node(element:attributeList) attrList
  1232.         catch {set result $attrList([lindex $args 0])}
  1233.  
  1234.     }
  1235.  
  1236.     setAttribute {
  1237.         if {[llength $args] == 0 || [llength $args] > 2} {
  1238.         return -code error "wrong number of arguments"
  1239.         }
  1240.  
  1241.         # TODO: Check that the attribute name is legal
  1242.  
  1243.         upvar #0 $node(element:attributeList) attrList
  1244.         set attrList([lindex $args 0]) [lindex $args 1]
  1245.  
  1246.     }
  1247.  
  1248.     removeAttribute {
  1249.         if {[llength $args] != 1} {
  1250.         return -code error "wrong number of arguments"
  1251.         }
  1252.  
  1253.         upvar #0 $node(element:attributeList) attrList
  1254.         catch {unset attrList([lindex $args 0])}
  1255.  
  1256.     }
  1257.  
  1258.     getAttributeNode {
  1259.     }
  1260.  
  1261.     setAttributeNode {
  1262.     }
  1263.  
  1264.     removeAttributeNode {
  1265.     }
  1266.  
  1267.     getElementsByTagName {
  1268.         if {[llength $args] != 1} {
  1269.         return -code error "wrong number of arguments"
  1270.         }
  1271.  
  1272.         return [Element:GetByTagName $token [lindex $args 0]]
  1273.     }
  1274.  
  1275.     normalize {
  1276.         if {[llength $args]} {
  1277.         return -code error "wrong number of arguments"
  1278.         }
  1279.  
  1280.         Element:Normalize node [set $node(node:childNodes)]
  1281.     }
  1282.  
  1283.     default {
  1284.         return -code error "unknown method \"$method\""
  1285.     }
  1286.  
  1287.     }
  1288.  
  1289.     PutHandle $token node
  1290.  
  1291.     return $result
  1292. }
  1293.  
  1294. # Element:GetByTagName --
  1295. #
  1296. #    Search for (child) elements
  1297. #    NB. This does not descend the hierarchy.  Check the DOM spec.
  1298. #
  1299. # Arguments:
  1300. #    token    parent node
  1301. #    name    (child) elements to search for
  1302. #
  1303. # Results:
  1304. #    List of matching node tokens
  1305.  
  1306. proc dom::Element:GetByTagName {token name} {
  1307.     array set node [set $token]
  1308.  
  1309.     set result {}
  1310.  
  1311.     if {[string compare $node(node:nodeType) "documentFragment"]} {
  1312.     foreach child [set $node(node:childNodes)] {
  1313.         catch {unset childNode}
  1314.         array set childNode [set $child]
  1315.         if {![string compare $childNode(node:nodeType) element] && \
  1316.         ![string compare [GetField childNode(node:nodeName)] $name]} {
  1317.         lappend result $child
  1318.         }
  1319.     }
  1320.     } elseif {[llength $node(document:documentElement)]} {
  1321.     # Document Element must exist and must be an element type node
  1322.     catch {unset childNode}
  1323.     array set childNode [set $node(document:documentElement)]
  1324.     if {![string compare $childNode(node:nodeName) $name]} {
  1325.         set result $node(document:documentElement)
  1326.     }
  1327.     }
  1328.  
  1329.     return $result
  1330. }
  1331.  
  1332. # Element:Normalize --
  1333. #
  1334. #    Normalize the text nodes
  1335. #
  1336. # Arguments:
  1337. #    pVar    parent array variable in caller
  1338. #    nodes    list of node tokens
  1339. #
  1340. # Results:
  1341. #    Adjacent text nodes are coalesced
  1342.  
  1343. proc dom::Element:Normalize {pVar nodes} {
  1344.     upvar $pVar parent
  1345.  
  1346.     set textNode {}
  1347.  
  1348.     foreach n $nodes {
  1349.     GetHandle node $n child
  1350.     set cleanup {}
  1351.  
  1352.     switch $child(node:nodeType) {
  1353.         textNode {
  1354.         if {[llength $textNode]} {
  1355.             # Coalesce into previous node
  1356.             append text(node:nodeValue) $child(node:nodeValue)
  1357.             # Remove this child
  1358.             upvar #0 $parent(node:childNodes) childNodes
  1359.             set idx [lsearch $childNodes $n]
  1360.             set childNodes [lreplace $childNodes $idx $idx]
  1361.             unset $n
  1362.             set cleanup {}
  1363.  
  1364.             PutHandle $textNode text
  1365.         } else {
  1366.             set textNode $n
  1367.             catch {unset text}
  1368.             array set text [array get child]
  1369.         }
  1370.         }
  1371.         element -
  1372.         document -
  1373.         documentFragment {
  1374.         set textNode {}
  1375.         Element:Normalize child [set $child(node:childNodes)]
  1376.         }
  1377.         default {
  1378.         set textNode {}
  1379.         }
  1380.     }
  1381.  
  1382.     eval $cleanup
  1383.     }
  1384.  
  1385.     return {}
  1386. }
  1387.  
  1388. # dom::processinginstruction --
  1389. #
  1390. #    Functions for a processing intruction.
  1391. #
  1392. # Arguments:
  1393. #    method    method to invoke
  1394. #    token    token for node
  1395. #    args    arguments for method
  1396. #
  1397. # Results:
  1398. #    Depends on method used.
  1399.  
  1400. namespace eval dom {
  1401.     variable piOptionsRO target
  1402.     variable piOptionsRW data
  1403. }
  1404.  
  1405. proc dom::processinginstruction {method token args} {
  1406.     variable piOptionsRO
  1407.     variable piOptionsRW
  1408.  
  1409.     GetHandle node $token node
  1410.  
  1411.     set result {}
  1412.  
  1413.     switch -- $method {
  1414.  
  1415.     cget {
  1416.         # Some read-only configuration options are computed
  1417.         if {[llength $args] != 1} {
  1418.         return -code error "too many arguments"
  1419.         }
  1420.         if {[regexp [format {^-(%s)$} $elementOptionsRO] [lindex $args 0] discard option]} {
  1421.         switch $option {
  1422.             target {
  1423.             set result [lindex $node(node:nodeName) 0]
  1424.             }
  1425.             default {
  1426.             return $node(node:$option)
  1427.             }
  1428.         }
  1429.         } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] [lindex $args 0] discard option]} {
  1430.         switch $option {
  1431.             data {
  1432.             return $node(node:nodeValue)
  1433.             }
  1434.             default {
  1435.             return $node(node:$option)
  1436.             }
  1437.         }
  1438.         } else {
  1439.         return -code error "unknown option \"[lindex $args 0]\""
  1440.         }
  1441.     }
  1442.     configure {
  1443.         if {[llength $args] == 1} {
  1444.         return [document cget $token [lindex $args 0]]
  1445.         } elseif {[expr [llength $args] % 2]} {
  1446.         return -code error "no value specified for option \"[lindex $args end]\""
  1447.         } else {
  1448.         foreach {option value} $args {
  1449.             if {[regexp [format {^-(%s)$} $elementOptionsRO] $option discard opt]} {
  1450.             return -code error "attribute \"$option\" is read-only"
  1451.             } elseif {[regexp [format {^-(%s)$} $elementOptionsRW] $option discard opt]} {
  1452.             switch $opt {
  1453.                 data {
  1454.                 set node(node:nodeValue) $value
  1455.                 }
  1456.                 default {
  1457.                 set node(node:$opt) $value
  1458.                 }
  1459.             }
  1460.             } else {
  1461.             return -code error "unknown option \"$option\""
  1462.             }
  1463.         }
  1464.         }
  1465.     }
  1466.  
  1467.     default {
  1468.         return -code error "unknown method \"$method\""
  1469.     }
  1470.  
  1471.     }
  1472.  
  1473.     PutHandle $token node
  1474.  
  1475.     return $result
  1476. }
  1477.  
  1478. #################################################
  1479. #
  1480. # Serialisation
  1481. #
  1482. #################################################
  1483.  
  1484. # dom::Serialize:documentFragment --
  1485. #
  1486. #    Produce text for documentFragment.
  1487. #
  1488. # Arguments:
  1489. #    token    node token
  1490. #    args    configuration options
  1491. #
  1492. # Results:
  1493. #    XML format text.
  1494.  
  1495. proc dom::Serialize:documentFragment {token args} {
  1496.     array set node [set $token]
  1497.  
  1498.     if {[string compare "node1" $node(documentFragment:masterDoc)]} {
  1499.     return [eval [list Serialize:node $token] $args]
  1500.     } else {
  1501.     if {[string compare {} [GetField node(document:documentElement)]]} {
  1502.         return [eval Serialize:document [list $token] $args]
  1503.     } else {
  1504.         return -code error "document has no document element"
  1505.     }
  1506.     }
  1507.  
  1508. }
  1509.  
  1510. # dom::Serialize:document --
  1511. #
  1512. #    Produce text for document.
  1513. #
  1514. # Arguments:
  1515. #    token    node token
  1516. #    args    configuration options
  1517. #
  1518. # Results:
  1519. #    XML format text.
  1520.  
  1521. proc dom::Serialize:document {token args} {
  1522.     array set node [set $token]
  1523.  
  1524.     if {![info exists node(document:documentElement)]} {
  1525.     return -code error "document has no document element"
  1526.     } elseif {![string length node(document:doctype)]} {
  1527.     return -code error "no document type declaration given"
  1528.     } else {
  1529.  
  1530.     array set doctype [set $node(document:doctype)]
  1531.  
  1532.     # BUG: Want to serialize all children except for the 
  1533.     # document element, and then do the document element.
  1534.  
  1535.     # Bug fix: can't use Serialize:attributeList for XML declaration,
  1536.     # since attributes must occur in a given order (XML 2.8 [23])
  1537.  
  1538.     return "<?xml[Serialize:XMLDecl version $node(document:xmldecl)][Serialize:XMLDecl encoding $node(document:xmldecl)][Serialize:XMLDecl standalone $node(document:xmldecl)]?>\n<!DOCTYPE $doctype(doctype:name)[expr {[string length $doctype(doctype:externalid)] ? " PUBLIC[Serialize:ExternalID $doctype(doctype:externalid)]" : {}}][expr {[string length $doctype(doctype:internaldtd)] ? " \[$doctype(doctype:internaldtd)\]" : {}}]>\n[eval Serialize:element [list $node(document:documentElement)] $args]"
  1539.     }
  1540.  
  1541. }
  1542.  
  1543. # dom::Serialize:ExternalID --
  1544. #
  1545. #    Returned appropriately quoted external identifiers
  1546. #
  1547. # Arguments:
  1548. #    id    external indentifiers
  1549. #
  1550. # Results:
  1551. #    text
  1552.  
  1553. proc dom::Serialize:ExternalID id {
  1554.     set result {}
  1555.  
  1556.     foreach ident $id {
  1557.     append result { } \"$ident\"
  1558.     }
  1559.  
  1560.     return $result
  1561. }
  1562.  
  1563. # dom::Serialize:XMLDecl --
  1564. #
  1565. #    Produce text for an arbitrary node.
  1566. #    This simply serializes the child nodes of the node.
  1567. #
  1568. # Arguments:
  1569. #    attr    required attribute
  1570. #    attList    attribute list
  1571. #
  1572. # Results:
  1573. #    XML format text.
  1574.  
  1575. proc dom::Serialize:XMLDecl {attr attrList} {
  1576.     array set data $attrList
  1577.     if {![info exists data($attr)]} {
  1578.     return {}
  1579.     } elseif {[string length $data($attr)]} {
  1580.     return " $attr='$data($attr)'"
  1581.     } else {
  1582.     return {}
  1583.     }
  1584. }
  1585.  
  1586. # dom::Serialize:node --
  1587. #
  1588. #    Produce text for an arbitrary node.
  1589. #    This simply serializes the child nodes of the node.
  1590. #
  1591. # Arguments:
  1592. #    token    node token
  1593. #    args    configuration options
  1594. #
  1595. # Results:
  1596. #    XML format text.
  1597.  
  1598. proc dom::Serialize:node {token args} {
  1599.     array set node [set $token]
  1600.  
  1601.     set result {}
  1602.     foreach childToken [set $node(node:childNodes)] {
  1603.     catch {unset child}
  1604.     array set child [set $childToken]
  1605.     append result [eval [list Serialize:$child(node:nodeType) $childToken] $args]
  1606.     }
  1607.  
  1608.     return $result
  1609. }
  1610.  
  1611. # dom::Serialize:element --
  1612. #
  1613. #    Produce text for an element.
  1614. #
  1615. # Arguments:
  1616. #    token    node token
  1617. #    args    configuration options
  1618. #
  1619. # Results:
  1620. #    XML format text.
  1621.  
  1622. proc dom::Serialize:element {token args} {
  1623.     array set node [set $token]
  1624.     array set opts {-newline {}}
  1625.     array set opts $args
  1626.  
  1627.     set result {}
  1628.     set newline {}
  1629.     if {[lsearch $opts(-newline) $node(node:nodeName)] >= 0} {
  1630.     append result \n
  1631.     set newline \n
  1632.     }
  1633.     append result "<$node(node:nodeName)"
  1634.     append result [Serialize:attributeList [array get $node(element:attributeList)]]
  1635.  
  1636.     if {![llength [set $node(node:childNodes)]]} {
  1637.  
  1638.     append result />$newline
  1639.  
  1640.     } else {
  1641.  
  1642.     append result >$newline
  1643.  
  1644.     # Do the children
  1645.     append result [eval Serialize:node [list $token] $args]
  1646.  
  1647.     append result "$newline</$node(node:nodeName)>$newline"
  1648.  
  1649.     }
  1650.  
  1651.     return $result
  1652. }
  1653.  
  1654. # dom::Serialize:textNode --
  1655. #
  1656. #    Produce text for a text node.
  1657. #
  1658. # Arguments:
  1659. #    token    node token
  1660. #    args    configuration options
  1661. #
  1662. # Results:
  1663. #    XML format text.
  1664.  
  1665. proc dom::Serialize:textNode {token args} {
  1666.     array set node [set $token]
  1667.  
  1668.     return [Encode $node(node:nodeValue)]
  1669. }
  1670.  
  1671. # dom::Serialize:processingInstruction --
  1672. #
  1673. #    Produce text for a PI node.
  1674. #
  1675. # Arguments:
  1676. #    token    node token
  1677. #    args    configuration options
  1678. #
  1679. # Results:
  1680. #    XML format text.
  1681.  
  1682. proc dom::Serialize:processingInstruction {token args} {
  1683.     array set node [set $token]
  1684.  
  1685.     return "<$node(node:nodeName) $node(node:nodeValue)>"
  1686. }
  1687.  
  1688. # dom::Serialize:comment --
  1689. #
  1690. #    Produce text for a comment node.
  1691. #
  1692. # Arguments:
  1693. #    token    node token
  1694. #    args    configuration options
  1695. #
  1696. # Results:
  1697. #    XML format text.
  1698.  
  1699. proc dom::Serialize:comment {token args} {
  1700.     array set node [set $token]
  1701.  
  1702.     return <!--$node(node:nodeValue)-->
  1703. }
  1704.  
  1705. # dom::Encode --
  1706. #
  1707. #    Encode special characters
  1708. #
  1709. # Arguments:
  1710. #    value    text value
  1711. #
  1712. # Results:
  1713. #    XML format text.
  1714.  
  1715. proc dom::Encode value {
  1716.     array set Entity {
  1717.     $ $
  1718.     < <
  1719.     > >
  1720.     & &
  1721.     \" "
  1722.     ' '
  1723.     }
  1724.  
  1725.     regsub -all {([$<>&"'])} $value {$Entity(\1)} value
  1726.  
  1727.     return [subst -nocommand -nobackslash $value]
  1728. }
  1729.  
  1730. # dom::Serialize:attributeList --
  1731. #
  1732. #    Produce text for an attribute list.
  1733. #
  1734. # Arguments:
  1735. #    l    name/value paired list
  1736. #
  1737. # Results:
  1738. #    XML format text.
  1739.  
  1740. proc dom::Serialize:attributeList {l} {
  1741.  
  1742.     set result {}
  1743.     foreach {name value} $l {
  1744.  
  1745.     append result { } $name =
  1746.  
  1747.     # Handle special characters
  1748.     regsub -all < $value {\<} value
  1749.  
  1750.     if {![string match *\"* $value]} {
  1751.         append result \"$value\"
  1752.     } elseif {![string match *'* $value]} {
  1753.         append result '$value'
  1754.     } else {
  1755.         regsub -all \" $value {\"} value
  1756.         append result \"$value\"
  1757.     }
  1758.  
  1759.     }
  1760.  
  1761.     return $result
  1762. }
  1763.  
  1764. #################################################
  1765. #
  1766. # Parsing
  1767. #
  1768. #################################################
  1769.  
  1770. # ParseElementStart --
  1771. #
  1772. #    Push a new element onto the stack.
  1773. #
  1774. # Arguments:
  1775. #    stateVar    global state array variable
  1776. #    name        element name
  1777. #    attrList    attribute list
  1778. #    args        configuration options
  1779. #
  1780. # Results:
  1781. #    An element is created within the currently open element.
  1782.  
  1783. proc dom::ParseElementStart {stateVar name attrList args} {
  1784.     upvar #0 $stateVar state
  1785.     array set opts $args
  1786.  
  1787.     lappend state(current) \
  1788.     [CreateElement [lindex $state(current) end] $name $attrList]
  1789.  
  1790.     if {[info exists opts(-empty)] && $opts(-empty)} {
  1791.     # Flag this node as being an empty element
  1792.     array set node [set [lindex $state(current) end]]
  1793.     set node(element:empty) 1
  1794.     set [lindex $state(current) end] [array get node]
  1795.     }
  1796.  
  1797.     # Temporary: implement -progresscommand here, because of broken parser
  1798.     if {[string length $state(-progresscommand)]} {
  1799.     if {!([incr state(progCounter)] % $state(-chunksize))} {
  1800.         uplevel #0 $state(-progresscommand)
  1801.     }
  1802.     }
  1803. }
  1804.  
  1805. # ParseElementEnd --
  1806. #
  1807. #    Pop an element from the stack.
  1808. #
  1809. # Arguments:
  1810. #    stateVar    global state array variable
  1811. #    name        element name
  1812. #    args        configuration options
  1813. #
  1814. # Results:
  1815. #    Currently open element is closed.
  1816.  
  1817. proc dom::ParseElementEnd {stateVar name args} {
  1818.     upvar #0 $stateVar state
  1819.  
  1820.     set state(current) [lreplace $state(current) end end]
  1821. }
  1822.  
  1823. # ParseCharacterData --
  1824. #
  1825. #    Add a textNode to the currently open element.
  1826. #
  1827. # Arguments:
  1828. #    stateVar    global state array variable
  1829. #    data        character data
  1830. #
  1831. # Results:
  1832. #    A textNode is created.
  1833.  
  1834. proc dom::ParseCharacterData {stateVar data} {
  1835.     upvar #0 $stateVar state
  1836.  
  1837.     CreateTextNode [lindex $state(current) end] $data
  1838. }
  1839.  
  1840. # ParseProcessingInstruction --
  1841. #
  1842. #    Add a PI to the currently open element.
  1843. #
  1844. # Arguments:
  1845. #    stateVar    global state array variable
  1846. #    name        PI name
  1847. #    target        PI target
  1848. #
  1849. # Results:
  1850. #    A processingInstruction node is created.
  1851.  
  1852. proc dom::ParseProcessingInstruction {stateVar name target} {
  1853.     upvar #0 $stateVar state
  1854.  
  1855.     CreateGeneric [lindex $state(current) end] node:nodeType processingInstruction node:nodeName $name node:nodeValue $target
  1856. }
  1857.  
  1858. # ParseXMLDeclaration --
  1859. #
  1860. #    Add information from the XML Declaration to the document.
  1861. #
  1862. # Arguments:
  1863. #    stateVar    global state array variable
  1864. #    version        version identifier
  1865. #    encoding    character encoding
  1866. #    standalone    standalone document declaration
  1867. #
  1868. # Results:
  1869. #    Document node modified.
  1870.  
  1871. proc dom::ParseXMLDeclaration {stateVar version encoding standalone} {
  1872.     upvar #0 $stateVar state
  1873.  
  1874.     array set node [set $state(docNode)]
  1875.     array set xmldecl $node(document:xmldecl)
  1876.  
  1877.     array set xmldecl [list version $version    \
  1878.         standalone $standalone        \
  1879.         encoding $encoding            \
  1880.     ]
  1881.  
  1882.     set node(document:xmldecl) [array get xmldecl]
  1883.     set $state(docNode) [array get node]
  1884.  
  1885.     return {}
  1886. }
  1887.  
  1888. # ParseDocType --
  1889. #
  1890. #    Add a Document Type Declaration node to the document.
  1891. #
  1892. # Arguments:
  1893. #    stateVar    global state array variable
  1894. #    root        root element type
  1895. #    publit        public identifier literal
  1896. #    systemlist    system identifier literal
  1897. #    dtd        internal DTD subset
  1898. #
  1899. # Results:
  1900. #    DocType node added
  1901.  
  1902. proc dom::ParseDocType {stateVar root {publit {}} {systemlit {}} {dtd {}}} {
  1903.     upvar #0 $stateVar state
  1904.  
  1905.     CreateDocType $state(docNode) $root [list $publit $systemlit] $dtd {} {}
  1906.     # Last two are entities and notaions (as namedNodeMap's)
  1907.  
  1908.     return {}
  1909. }
  1910.  
  1911. #################################################
  1912. #
  1913. # Trim white space
  1914. #
  1915. #################################################
  1916.  
  1917. # dom::Trim --
  1918. #
  1919. #    Remove textNodes that only contain white space
  1920. #
  1921. # Arguments:
  1922. #    nodeid    node to trim
  1923. #
  1924. # Results:
  1925. #    textNode nodes may be removed (from descendants)
  1926.  
  1927. proc dom::Trim nodeid {
  1928.     array set node [set $nodeid]
  1929.  
  1930.     switch $node(node:nodeType) {
  1931.  
  1932.     textNode {
  1933.         if {![string length [string trim $node(node:nodeValue)]]} {
  1934.         node removeChild $node(node:parentNode) $nodeid
  1935.         }
  1936.     }
  1937.  
  1938.     default {
  1939.         foreach child [set $node(node:childNodes)] {
  1940.         Trim $child
  1941.         }
  1942.     }
  1943.  
  1944.     }
  1945.  
  1946.     return {}
  1947. }
  1948.  
  1949. #################################################
  1950. #
  1951. # Miscellaneous
  1952. #
  1953. #################################################
  1954.  
  1955. # GetField --
  1956. #
  1957. #    Return a value, or empty string if not defined
  1958. #
  1959. # Arguments:
  1960. #    var    name of variable to return
  1961. #
  1962. # Results:
  1963. #    Returns the value, or empty string if variable is not defined.
  1964.  
  1965. proc GetField var {
  1966.     upvar $var v
  1967.     return [expr {[info exists v] ? $v : {}}]
  1968. }
  1969.  
  1970. # dom::Min --
  1971. #
  1972. #    Return the minimum of two numeric values
  1973. #
  1974. # Arguments:
  1975. #    a    a value
  1976. #    b    another value
  1977. #
  1978. # Results:
  1979. #    Returns the value which is lower than the other.
  1980.  
  1981. proc dom::Min {a b} {
  1982.     return [expr {$a < $b ? $a : $b}]
  1983. }
  1984.  
  1985. # dom::Max --
  1986. #
  1987. #    Return the maximum of two numeric values
  1988. #
  1989. # Arguments:
  1990. #    a    a value
  1991. #    b    another value
  1992. #
  1993. # Results:
  1994. #    Returns the value which is greater than the other.
  1995.  
  1996. proc dom::Max {a b} {
  1997.     return [expr {$a > $b ? $a : $b}]
  1998. }
  1999.  
  2000. # dom::Boolean --
  2001. #
  2002. #    Return a boolean value
  2003. #
  2004. # Arguments:
  2005. #    b    value
  2006. #
  2007. # Results:
  2008. #    Returns 0 or 1
  2009.  
  2010. proc dom::Boolean b {
  2011.     regsub -nocase {^(true|yes|1|on)$} $b 1 b
  2012.     regsub -nocase {^(false|no|0|off)$} $b 0 b
  2013.     return $b
  2014. }
  2015.  
  2016.