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 / tclsoap1.6.1 / xpath.tcl < prev   
Encoding:
Text File  |  2001-10-22  |  7.6 KB  |  249 lines
  1. # xpath.tcl - Copyright (C) 2001 Pat Thoyts <Pat.Thoyts@bigfoot.com>
  2. #
  3. # Provide a _SIGNIFICANTLY_ simplified version of XPath querying for DOM
  4. # document objects. This might get expanded to eventually conform to the
  5. # W3Cs XPath specification but at present this is purely for use in querying
  6. # DOM documents for specific elements by the SOAP package.
  7. #
  8. # Subject to interface changes
  9. #
  10. # -------------------------------------------------------------------------
  11. # This software is distributed in the hope that it will be useful, but
  12. # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  13. # or FITNESS FOR A PARTICULAR PURPOSE.  See the accompanying file `LICENSE'
  14. # for more details.
  15. # -------------------------------------------------------------------------
  16.  
  17. package provide SOAP::xpath 0.2
  18.  
  19. if { [catch {package require dom 2.0}] } {
  20.     if { [catch {package require dom 1.6}] } {
  21.         error "require dom package greater than 1.6"
  22.     }
  23. }
  24.  
  25. namespace eval SOAP::xpath {
  26.     variable version 0.2
  27.     variable rcsid { $Id: xpath.tcl,v 1.8 2001/10/07 22:28:08 patthoyts Exp $ }
  28.     namespace export xpath xmlnsSplit
  29. }
  30.  
  31. # -------------------------------------------------------------------------
  32.  
  33. # Given Envelope/Body/Fault and a DOM node, see if we can find a matching
  34. # element else return {}
  35.  
  36. # TODO: Paths including attribute selection etc.
  37.  
  38. proc SOAP::xpath::xpath { args } {
  39.     if { [llength $args] < 2 || [llength $args] > 3 } {
  40.         error "wrong # args: should be \"xpath ?option? rootNode path\""
  41.     }
  42.  
  43.     array set opts {
  44.         -node        0
  45.         -name        0
  46.         -attributes  0
  47.     }
  48.  
  49.     if { [llength $args] == 3 } {
  50.         set opt [lindex $args 0]
  51.         switch -glob -- $opt {
  52.             -nod*   { set opts(-node) 1 }
  53.             -nam*   { set opts(-name) 1 }
  54.             -att*   { set opts(-attributes) 1 }
  55.             default {
  56.                 error "bad option \"$opt\": must be [array names opts]"
  57.             }
  58.         }
  59.         set args [lrange $args 1 end]
  60.     }
  61.  
  62.     set root [lindex $args 0]
  63.     set path [lindex $args 1]
  64.  
  65.     # split the path up and call find_node to get the new node or nodes.
  66.     set root [find_node $root [split [string trimleft $path {/}] {/}]]
  67.  
  68.     # return the elements value (if any)
  69.     if { $opts(-node) } {
  70.         return $root
  71.     }
  72.  
  73.     set value {}
  74.     if { $opts(-attributes) } {
  75.         foreach node $root {
  76.             append value [array get [dom::node cget $node -attributes]]
  77.         }
  78.         return $value
  79.     }
  80.  
  81.     if { $opts(-name) } {
  82.         foreach node $root {
  83.             lappend value [dom::node cget $node -nodeName]
  84.         }
  85.         return $value
  86.     }
  87.  
  88.     foreach node $root {
  89.         set children [dom::node children $node]
  90.         set v ""
  91.         foreach child $children {
  92.             append v [string trim [dom::node cget $child -nodeValue] "\n"]
  93.         }
  94.         lappend value $v
  95.     }
  96.     return $value
  97. }
  98.  
  99. # -------------------------------------------------------------------------
  100.  
  101. # check for an element (called $target) that is a child of root. Returns
  102. # the node(s) or {}
  103. proc SOAP::xpath::find_node { root pathlist } {
  104.     set r {}
  105.     set kids ""
  106.  
  107.     if { $pathlist == {} } {
  108.         return {} 
  109.     }
  110.  
  111.     #set target [split $path {/}]
  112.     set remainder [lrange $pathlist 1 end]
  113.     set target [lindex $pathlist 0]
  114.  
  115.     # split the target into XML namespace and element names.
  116.     set targetName [xmlnsSplit $target]
  117.     set targetNamespace [lindex $targetName 0]
  118.     set targetName [lindex $targetName 1]
  119.  
  120.     # get information about the child elements.
  121.     foreach element $root { 
  122.         append kids [child_elements $element]
  123.     }
  124.  
  125.     # match name and (optionally) namespace
  126.     foreach {node ns elt} $kids {
  127.         if { [string match $targetName $elt] } {
  128.             #puts "$node nodens=$ns elt=$elt targetNS=$targetNamespace\
  129.                     #targetName=$targetName"
  130.             if { $targetNamespace == {} || [string match $targetNamespace $ns] } {
  131.                 if {$remainder != ""} {
  132.                     set rr [find_node $node $remainder]
  133.                 } else {
  134.                     set rr $node
  135.                 }
  136.                 set r [concat $r $rr]
  137.                 #puts "$kids : $targetName : $remainder -> $r"
  138.             }
  139.         }
  140.     }
  141.  
  142.     # Flatten the list out.
  143.     return [eval "list $r"]
  144. }
  145.  
  146. # -------------------------------------------------------------------------
  147.  
  148. # Return list of {node namespace elementname} for each child element of root
  149. proc SOAP::xpath::child_elements { root } {
  150.     set kids {}
  151.     set children [dom::node children $root]
  152.     foreach node $children {
  153.         set type [string trim [dom::node cget $node -nodeType ]]
  154.         if { $type == "element" } {
  155.             catch {unset xmlns}
  156.             array set xmlns [xmlnsConstruct $node]
  157.  
  158.             #set name [xmlnsQualify xmlns [dom::node cget $node -nodeName]]
  159.             set name [dom::node cget $node -nodeName]
  160.             set name [xmlnsSplit $name]
  161.             lappend kids $node [lindex $name 0] [lindex $name 1]
  162.         }
  163.     }
  164.     return $kids
  165. }
  166.  
  167. # -------------------------------------------------------------------------
  168.  
  169. # Description:
  170. #   Split a DOM element tag into the namespace and tag components. This
  171. #   will even work for fully qualified namespace names eg:
  172. #      Body                      -> {} Body
  173. #      SOAP-ENV:Body             -> SOAP-ENV Body
  174. #      urn:test:Body             -> urn:test Body
  175. #      http://localhost:80/:Body -> http://localhost:80/ Body
  176. #
  177. proc SOAP::xpath::xmlnsSplit {elementName} {
  178.     set name [split $elementName :]
  179.     set len [llength $name]
  180.     if { $len == 1 } {
  181.         set ns {}
  182.     } else {
  183.         incr len -2
  184.         set ns   [join [lrange $name 0 $len] :]
  185.         set name [lindex $name end]
  186.     }
  187.     return [list $ns $name]
  188. }
  189.  
  190. # -------------------------------------------------------------------------
  191.  
  192. # Build a list of any XML namespace definitions for node
  193. # Returns a list of {namesnameName qualifiedName}
  194. #
  195. proc SOAP::xpath::xmlnsGet {node} {
  196.     set result {}
  197.     foreach {ns fqns} [array get [dom::node cget $node -attributes]] {
  198.     set ns [split $ns :]
  199.     if { [lindex $ns 0] == "xmlns" } {
  200.         lappend result [lindex $ns 1] $fqns
  201.     }
  202.     }
  203.     return $result
  204. }
  205.  
  206. # -------------------------------------------------------------------------
  207.  
  208. # Build a list of {{xml namespace name} {qualified namespace}} working up the
  209. # DOM tree from node. You should look for the last occurrence of your name
  210. # in the list.
  211. proc SOAP::xpath::xmlnsConstruct {node} {
  212.     set result [xmlnsGet $node]
  213.     set parent [dom::node parent $node]
  214.     while { [dom::node cget $parent -nodeType] == "element" } {
  215.         set result [concat [xmlnsGet $parent] $result]
  216.         set parent [dom::node parent $parent]
  217.     }
  218.     return $result
  219. }
  220.  
  221. # -------------------------------------------------------------------------
  222.  
  223. # Split an XML element name into its namespace and name parts and return
  224. # a fully qualified XML element name.
  225. # xmlnsNamespaces should be an array of namespaceNames to qualified names
  226. # constructed using array set var [xmlnsConstruct $node]
  227. #
  228. proc SOAP::xpath::xmlnsQualify {xmlnsNamespaces elementName} {
  229.     upvar $xmlnsNamespaces xmlns
  230.     set name [split $elementName :]
  231.     if { [llength $name] == 1} {
  232.         return $elementName
  233.     }
  234.     if { [llength $name] != 2 } {
  235.     error "wrong # elements: name should be namespaceName:elementName"
  236.     }
  237.     if { [catch {set fqns $xmlns([lindex $name 0])}] } {
  238.     error "invalid namespace name: \"[lindex $name 0]\" not found"
  239.     }
  240.  
  241.     return "${fqns}:[lindex $name 1]"
  242. }
  243.  
  244. # -------------------------------------------------------------------------
  245.  
  246. # Local variables:
  247. #   indent-tabs-mode: nil
  248. # End:
  249.