home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / tclxml2.0 / xpath.tcl < prev   
Encoding:
Text File  |  2001-10-22  |  9.8 KB  |  355 lines
  1. # xpath.tcl --
  2. #
  3. #    Provides an XPath parser for Tcl,
  4. #    plus various support procedures
  5. #
  6. # Copyright (c) 2000 Zveno Pty Ltd
  7. #
  8. # $Id: xpath.tcl,v 1.5 2001/02/10 11:13:48 balls Exp $
  9.  
  10. package provide xpath 1.0
  11.  
  12. # We need the XML package for definition of Names
  13. package require xml
  14.  
  15. namespace eval xpath {
  16.     namespace export split join createnode
  17.  
  18.     variable axes {
  19.     ancestor
  20.     ancestor-or-self
  21.     attribute
  22.     child
  23.     descendant
  24.     descendant-or-self
  25.     following
  26.     following-sibling
  27.     namespace
  28.     parent
  29.     preceding
  30.     preceding-sibling
  31.     self
  32.     }
  33.  
  34.     variable nodeTypes {
  35.     comment
  36.     text
  37.     processing-instruction
  38.     node
  39.     }
  40.  
  41.     # NB. QName has parens for prefix
  42.  
  43.     variable nodetestExpr ^(${::xml::QName})${::xml::allWsp}(\\(${::xml::allWsp}(("|')(.*?)\\5)?${::xml::allWsp}\\))?${::xml::allWsp}(.*)
  44.  
  45.     variable nodetestExpr2 ((($::xml::QName)${::xml::allWsp}(\\(${::xml::allWsp}(("|')(.*?)\\7)?${::xml::allWsp}\\))?)|${::xml::allWsp}(\\*))${::xml::allWsp}(.*)
  46. }
  47.  
  48. # xpath::split --
  49. #
  50. #    Parse an XPath location path
  51. #
  52. # Arguments:
  53. #    locpath    location path
  54. #
  55. # Results:
  56. #    A Tcl list representing the location path.
  57. #    The list has the form: {{axis node-test {predicate predicate ...}} ...}
  58. #    Where each list item is a location step.
  59.  
  60. proc xpath::split locpath {
  61.     set leftover {}
  62.  
  63.     set result [InnerSplit $locpath leftover]
  64.  
  65.     if {[string length [string trim $leftover]]} {
  66.     return -code error "unexpected text \"$leftover\""
  67.     }
  68.  
  69.     return $result
  70. }
  71.  
  72. proc xpath::InnerSplit {locpath leftoverVar} {
  73.     upvar $leftoverVar leftover
  74.  
  75.     variable axes
  76.     variable nodetestExpr
  77.     variable nodetestExpr2
  78.  
  79.     # First determine whether we have an absolute location path
  80.     if {[regexp {^/(.*)} $locpath discard locpath]} {
  81.     set path {{}}
  82.     } else {
  83.     set path {}
  84.     }
  85.  
  86.     while {[string length [string trimleft $locpath]]} {
  87.     if {[regexp {^\.\.(.*)} $locpath discard locpath]} {
  88.         # .. abbreviation
  89.         #puts stderr [list .. abbrev]
  90.         set axis parent
  91.         set nodetest *
  92.     } elseif {[regexp {^/(.*)} $locpath discard locpath]} {
  93.         # // abbreviation
  94.         #puts stderr [list // abbrev]
  95.         set axis descendant-or-self
  96.         if {[regexp ^$nodetestExpr2 [string trimleft $locpath] discard discard discard nodetest discard typetest discard discard literal wildcard locpath]} {
  97.         set nodetest [ResolveWildcard $nodetest $typetest $wildcard $literal]
  98.         } else {
  99.         set leftover $locpath
  100.         return $path
  101.         }
  102.     } elseif {[regexp ^\\.${::xml::allWsp}(.*) $locpath discard locpath]} {
  103.         # . abbreviation
  104.         #puts stderr [list . abbrev]
  105.         set axis self
  106.         set nodetest *
  107.     } elseif {[regexp ^@($::xml::QName)${::xml::allWsp}=${::xml::allWsp}"(\[^"\])"(.*) $locpath discard attrName discard attrValue locpath]} {
  108.         # @ abbreviation
  109.         #puts stderr [list @ abbrev 1]
  110.         set axis attribute
  111.         set nodetest $attrName
  112.     } elseif {[regexp ^@($::xml::QName)${::xml::allWsp}=${::xml::allWsp}'(\[^'\])'(.*) $locpath discard attrName discard attrValue locpath]} {
  113.         # @ abbreviation
  114.         #puts stderr [list @ abbrev 2]
  115.         set axis attribute
  116.         set nodetest $attrName
  117.     } elseif {[regexp ^@($::xml::QName)(.*) $locpath discard attrName discard locpath]} {
  118.         # @ abbreviation
  119.         #puts stderr [list @ abbrev 3 ]
  120.         set axis attribute
  121.         set nodetest $attrName
  122.     } elseif {[regexp ^((${::xml::QName})${::xml::allWsp}::${::xml::allWsp})?\\*(.*) $locpath discard discard axis discard locpath]} {
  123.         # wildcard specified
  124.         #puts stderr [list got axis and/or wildcard]
  125.         set nodetest *
  126.         if {![string length $axis]} {
  127.         set axis child
  128.         }
  129.     } elseif {[regexp ^((${::xml::QName})${::xml::allWsp}::${::xml::allWsp})?$nodetestExpr2 $locpath discard discard axis discard discard discard nodetest discard typetest discard discard literal wildcard locpath]} {
  130.         # nodetest, with or without axis
  131.         #puts stderr [list no axis, got a nodetest]
  132.         if {![string length $axis]} {
  133.         set axis child
  134.         }
  135.         set nodetest [ResolveWildcard $nodetest $typetest $wildcard $literal]
  136.     } else {
  137.         #puts stderr [list else case]
  138.         set leftover $locpath
  139.         return $path
  140.     }
  141.  
  142.     # ParsePredicates
  143.     set predicates {}
  144.     set locpath [string trimleft $locpath]
  145.     while {[regexp {^\[(.*)} $locpath discard locpath]} {
  146.         if {[regexp {^([0-9]+)(\].*)} [string trim $locpath] discard posn locpath]} {
  147.         set predicate [list = {function position {}} [list number $posn]]
  148.         } else {
  149.         set leftover2 {}
  150.         set predicate [ParseExpr $locpath leftover2]
  151.         set locpath $leftover2
  152.         unset leftover2
  153.         }
  154.  
  155.         if {[regexp {^\](.*)} [string trimleft $locpath] discard locpath]} {
  156.         lappend predicates $predicate
  157.         } else {
  158.         return -code error "unexpected text in predicate \"$locpath\""
  159.         }
  160.     }
  161.  
  162.     set axis [string trim $axis]
  163.     set nodetest [string trim $nodetest]
  164.  
  165.     # This step completed
  166.     if {[lsearch $axes $axis] < 0} {
  167.         return -code error "invalid axis \"$axis\""
  168.     }
  169.     lappend path [list $axis $nodetest $predicates]
  170.  
  171.     # Move to next step
  172.  
  173.     if {[string length $locpath] && ![regexp /(.*) $locpath discard locpath]} {
  174.         set leftover $locpath
  175.         return $path
  176.     }
  177.  
  178.     }
  179.  
  180.     return $path
  181. }
  182.  
  183. proc xpath::ParseExpr {locpath leftoverVar} {
  184.     upvar $leftoverVar leftover
  185.     variable nodeTypes
  186.  
  187.     set expr {}
  188.     set mode expr
  189.     set stack {}
  190.  
  191.     while {[string index [string trimleft $locpath] 0] != "\]"} {
  192.     set locpath [string trimleft $locpath]
  193.     switch $mode {
  194.         expr {
  195.         # We're looking for a term
  196.         #puts stderr [list looking for term in $locpath]
  197.         if {[regexp ^-(.*) $locpath discard locpath]} {
  198.             # UnaryExpr
  199.             lappend stack "-"
  200.         } elseif {[regexp ^\\\$({$::xml::QName})(.*) $locpath discard varname discard locpath]} {
  201.             # VariableReference
  202.             lappend stack [list varRef $varname]
  203.             set mode term
  204.         } elseif {[regexp {^\((.*)} $locpath discard locpath]} {
  205.             # Start grouping
  206.             set leftover2 {}
  207.             lappend stack [list group [ParseExpr $locpath leftover2]]
  208.             set locpath $leftover2
  209.             unset leftover2
  210.  
  211.             if {[regexp {^\)(.*)} [string trimleft $locpath] discard locpath]} {
  212.             set mode term
  213.             } else {
  214.             return -code error "unexpected text \"$locpath\", expected \")\""
  215.             }
  216.  
  217.         } elseif {[regexp {^"([^"]*)"(.*)} $locpath discard literal locpath]} {
  218.             # Literal (" delimited)
  219.             lappend stack [list literal $literal]
  220.             set mode term
  221.         } elseif {[regexp {^'([^']*)'(.*)} $locpath discard literal locpath]} {
  222.             # Literal (' delimited)
  223.             lappend stack [list literal $literal]
  224.             set mode term
  225.         } elseif {[regexp {^([0-9]+(\.[0-9]+)?)(.*)} $locpath discard number discard locpath]} {
  226.             # Number
  227.             lappend stack [list number $number]
  228.             set mode term
  229.         } elseif {[regexp {^(\.[0-9]+)(.*)} $locpath discard number locpath]} {
  230.             # Number
  231.             lappend stack [list number $number]
  232.             set mode term
  233.         } elseif {[regexp ^(${::xml::QName})\\(${::xml::allWsp}(.*) $locpath discard functionName discard locpath]} {
  234.             # Function call start
  235.  
  236.             if {[lsearch $nodeTypes $functionName] >= 0} {
  237.             return -code error "invalid function name \"$functionName\""
  238.             }
  239.  
  240.             if {[regexp ^\\)${::xml::allWsp}(.*) $locpath discard locpath]} {
  241.             set parameters {}
  242.             } else {
  243.             set leftover2 {}
  244.             set parameters [ParseExpr $locpath leftover2]
  245.             set locpath $leftover2
  246.             unset leftover2
  247.             while {[regexp {^,(.*)} $locpath discard locpath]} {
  248.                 set leftover2 {}
  249.                 lappend parameters [ParseExpr $locpath leftover2]
  250.                 set locpath $leftover2
  251.                 unset leftover2
  252.             }
  253.  
  254.             if {![regexp ^\\)${::xml::allWsp}(.*) [string trimleft $locpath] discard locpath]} {
  255.                 return -code error "unexpected text \"locpath\" - expected \")\""
  256.             }
  257.             }
  258.  
  259.             lappend stack [list function $functionName $parameters]
  260.             set mode term
  261.  
  262.         } else {
  263.             # LocationPath
  264.             #puts stderr [list ParseExpr found location path]
  265.             set leftover2 {}
  266.             lappend stack [list path [InnerSplit $locpath leftover2]]
  267.             set locpath $leftover2
  268.             unset leftover2
  269.             set mode term
  270.         }
  271.         }
  272.         term {
  273.         # We're looking for an expression operator
  274.         #puts stderr [list looking for operator in $locpath]
  275.         if {[regexp ^-(.*) $locpath discard locpath]} {
  276.             # UnaryExpr
  277.             set stack [linsert $stack 0 expr "-"]
  278.             set mode expr
  279.         } elseif {[regexp ^(and|or|\\=|!\\=|<|>|<\\=|>\\=|\\||\\+|\\-|\\*|div|mod)(.*) $locpath discard exprtype locpath]} {
  280.             # AndExpr, OrExpr, EqualityExpr, RelationalExpr or UnionExpr
  281.             set stack [linsert $stack 0 $exprtype]
  282.             set mode expr
  283.         } else {
  284.             return -code error "unexpected text \"$locpath\", expecting operator"
  285.         }
  286.         }
  287.         default {
  288.         # Should never be here!
  289.         return -code error "internal error"
  290.         }
  291.     }
  292.     }
  293.  
  294.     set leftover $locpath
  295.     return $stack
  296. }
  297.  
  298. # xpath::ResolveWildcard --
  299.  
  300. proc xpath::ResolveWildcard {nodetest typetest wildcard literal} {
  301.     variable nodeTypes
  302.  
  303.     switch -glob -- [string length $nodetest],[string length $typetest],[string length $wildcard],[string length $literal] {
  304.     0,0,0,* {
  305.         return -code error "bad location step (nothing parsed)"
  306.     }
  307.     0,0,* {
  308.         # Name wildcard specified
  309.         return *
  310.     }
  311.     *,0,0,* {
  312.         # Element type test - nothing to do
  313.         return $nodetest
  314.     }
  315.     *,0,*,* {
  316.         # Internal error?
  317.         return -code error "bad location step (found both nodetest and wildcard)"
  318.     }
  319.     *,*,0,0 {
  320.         # Node type test
  321.         if {[lsearch $nodeTypes $nodetest] < 0} {
  322.         return -code error "unknown node type \"$typetest\""
  323.         }
  324.         return [list $nodetest $typetest]
  325.     }
  326.     *,*,0,* {
  327.         # Node type test
  328.         if {[lsearch $nodeTypes $nodetest] < 0} {
  329.         return -code error "unknown node type \"$typetest\""
  330.         }
  331.         return [list $nodetest $literal]
  332.     }
  333.     default {
  334.         # Internal error?
  335.         return -code error "bad location step"
  336.     }
  337.     }
  338. }
  339.  
  340. # xpath::join --
  341. #
  342. #    Reconstitute an XPath location path from a
  343. #    Tcl list representation.
  344. #
  345. # Arguments:
  346. #    spath    split path
  347. #
  348. # Results:
  349. #    Returns an Xpath location path
  350.  
  351. proc xpath::join spath {
  352.     return -code error "not yet implemented"
  353. }
  354.  
  355.