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 / utils.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  13.7 KB  |  457 lines
  1. # utils.tcl - Copyright (C) 2001 Pat Thoyts <Pat.Thoyts@bigfoot.com>
  2. #
  3. # DOM data access utilities for use in the TclSOAP package.
  4. #
  5. # -------------------------------------------------------------------------
  6. # This software is distributed in the hope that it will be useful, but
  7. # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  8. # or FITNESS FOR A PARTICULAR PURPOSE.  See the accompanying file `LICENSE'
  9. # for more details.
  10. # -------------------------------------------------------------------------
  11.  
  12. package provide SOAP::Utils 1.0
  13.  
  14. namespace eval SOAP {
  15.     namespace eval Utils {
  16.         variable rcsid {$Id: utils.tcl,v 1.6 2001/10/07 22:28:08 patthoyts Exp $}
  17.         namespace export getElements \
  18.                 getElementValue getElementName \
  19.                 getElementValues getElementNames \
  20.                 getElementNamedValues \
  21.                 getElementAttributes getElementAttribute \
  22.                 decomposeSoap decomposeXMLRPC selectNode \
  23.                 namespaceURI nodeName
  24.     }
  25. }
  26.  
  27. # -------------------------------------------------------------------------
  28.  
  29. # Description:
  30. #   Provide a version independent selectNode implementation. We either use
  31. #   the version from the dom package or use the SOAP::xpath version if there
  32. #   is no dom one.
  33. # Parameters:
  34. #   node  - reference to a dom tree
  35. #   path  - XPath selection
  36. # Result:
  37. #   Returns the selected node or a list of matching nodes or an empty list
  38. #   if no match.
  39. #
  40. proc SOAP::Utils::selectNode {node path} {
  41.     if {[dom::DOMImplementation hasFeature query 1.0]} {
  42.         return [dom::DOMImplementation selectNode $node $path]
  43.     } else {
  44.     package require SOAP::xpath
  45.         if {[catch {SOAP::xpath::xpath -node $node $path} r]} {
  46.             set r {}
  47.         }
  48.         return $r
  49.     }
  50. }
  51.  
  52. # -------------------------------------------------------------------------
  53.  
  54. # for extracting the parameters from a SOAP packet.
  55. # Arrays -> list
  56. # Structs -> list of name/value pairs.
  57. # a methods parameter list comes out looking like a struct where the member
  58. # names == parameter names. This allows us to check the param name if we need
  59. # to.
  60.  
  61. proc SOAP::Utils::is_array {domElement} {
  62.     # Look for "xsi:type"="SOAP-ENC:Array"
  63.     # FIX ME
  64.     # This code should check the namespace using namespaceURI code (CGI)
  65.     #
  66.     set attr [dom::node cget $domElement -attributes]
  67.     if {[info exists [subst $attr](SOAP-ENC:arrayType)]} {
  68.         return 1
  69.     }
  70.     if {[info exists [subst $attr](xsi:type)]} {
  71.         set type [set [subst $attr](xsi:type)]
  72.         if {[string match -nocase {*:Array} $type]} {
  73.             return 1
  74.         }
  75.     }
  76.  
  77.     # If all the child element names are the same, it's an array
  78.     # but of there is only one element???
  79.     set names [getElementNames $domElement]
  80.     if {[llength $names] > 1 && [llength [lsort -unique $names]] == 1} {
  81.         return 1
  82.     }
  83.  
  84.     return 0
  85. }
  86.  
  87. # -------------------------------------------------------------------------
  88.  
  89. # Break down a SOAP packet into a Tcl list of the data.
  90. proc SOAP::Utils::decomposeSoap {domElement} {
  91.     set result {}
  92.  
  93.     # get a list of the child elements of this base element.
  94.     set child_elements [getElements $domElement]
  95.  
  96.     # if no child element - return the value.
  97.     if {$child_elements == {}} {
  98.     set result [getElementValue $domElement]
  99.     } else {
  100.     # decide if this is an array or struct
  101.     if {[is_array $domElement] == 1} {
  102.         foreach child $child_elements {
  103.         lappend result [decomposeSoap $child]
  104.         }
  105.     } else {
  106.         foreach child $child_elements {
  107.         lappend result [nodeName $child] [decomposeSoap $child]
  108.         }
  109.     }
  110.     }
  111.  
  112.     return $result
  113. }
  114.  
  115. # -------------------------------------------------------------------------
  116.  
  117. # I expect domElement to be the params element.
  118. proc SOAP::Utils::decomposeXMLRPC {domElement} {
  119.     set result {}
  120.     foreach param_elt [getElements $domElement] {
  121.         lappend result [getXMLRPCValue [getElements $param_elt]]
  122.     }
  123.     return $result
  124. }
  125.  
  126. # -------------------------------------------------------------------------
  127.  
  128. proc SOAP::Utils::getXMLRPCValue {value_elt} {
  129.     set value {}
  130.     if {$value_elt == {}} { return $value }
  131.  
  132.     # if there is not type element then the specs say it's a string type.
  133.     set type_elt [getElements $value_elt]
  134.     if {$type_elt == {}} {
  135.         return [getElementValue $value_elt]
  136.     }
  137.  
  138.     set type [getElementName $type_elt]
  139.     if {[string match "struct" $type]} {
  140.         foreach member_elt [getElements $type_elt] {
  141.             foreach elt [getElements $member_elt] {
  142.                 set eltname [getElementName $elt]
  143.                 if {[string match "name" $eltname]} {
  144.                     set m_name [getElementValue $elt]
  145.                 } elseif {[string match "value" $eltname]} {
  146.                     set m_value [getXMLRPCValue $elt]
  147.                 }
  148.             }
  149.             lappend value $m_name $m_value
  150.         }
  151.     } elseif {[string match "array" $type]} {
  152.         foreach elt [getElements [lindex [getElements $type_elt] 0]] {
  153.             lappend value [getXMLRPCValue $elt]
  154.         }
  155.     } else {
  156.         set value [getElementValue $type_elt]
  157.     }
  158.     return $value
  159. }
  160.  
  161. # -------------------------------------------------------------------------
  162.  
  163. # Description:
  164. #   Return a list of all the immediate children of domNode that are element
  165. #   nodes.
  166. # Parameters:
  167. #   domNode  - a reference to a node in a dom tree
  168. #
  169. proc SOAP::Utils::getElements {domNode} {
  170.     set elements {}
  171.     if {$domNode != {}} {
  172.         foreach node [dom::node children $domNode] {
  173.             if {[dom::node cget $node -nodeType] == "element"} {
  174.                 lappend elements $node
  175.             }
  176.         }
  177.     }
  178.     return $elements
  179. }
  180.  
  181. # -------------------------------------------------------------------------
  182.  
  183. # Description:
  184. #   If there are child elements then recursively call this procedure on each
  185. #   child element. If this is a leaf element, then get the element value data.
  186. # Parameters:
  187. #   domElement - a reference to a dom element node
  188. # Result:
  189. #   Returns a value or a list of values.
  190. #
  191. proc SOAP::Utils::getElementValues {domElement} {
  192.     set result {}
  193.     if {$domElement != {}} {
  194.         set nodes [getElements $domElement]
  195.         if {$nodes =={}} {
  196.             set result [getElementValue $domElement]
  197.         } else {
  198.             foreach node $nodes {
  199.                 lappend result [getElementValues $node]
  200.             }
  201.         }
  202.     }
  203.     return $result
  204. }
  205.  
  206. # -------------------------------------------------------------------------
  207.  
  208. proc SOAP::Utils::getElementValuesList {domElement} {
  209.     set result {}
  210.     if {$domElement != {}} {
  211.         set nodes [getElements $domElement]
  212.         if {$nodes =={}} {
  213.             set result [getElementValue $domElement]
  214.         } else {
  215.             foreach node $nodes {
  216.                 lappend result [getElementValues $node]
  217.             }
  218.         }
  219.     }
  220.     return $result
  221. }
  222.  
  223. # -------------------------------------------------------------------------
  224.  
  225. proc SOAP::Utils::getElementNames {domElement} {
  226.     set result {}
  227.     if {$domElement != {}} {
  228.         set nodes [getElements $domElement]
  229.         if {$nodes == {}} {
  230.             set result [getElementName $domElement]
  231.         } else {
  232.             foreach node $nodes {
  233.                 lappend result [getElementName $node]
  234.             }
  235.         }
  236.     }
  237.     return $result
  238. }
  239.  
  240. # -------------------------------------------------------------------------
  241.  
  242. proc SOAP::Utils::getElementNamedValues {domElement} {
  243.     set name [getElementName $domElement]
  244.     set value {}
  245.     set nodes [getElements $domElement]
  246.     if {$nodes == {}} {
  247.     set value [getElementValue $domElement]
  248.     } else {
  249.     foreach node $nodes {
  250.         lappend value [getElementNamedValues $node]
  251.     }
  252.     }
  253.     return [list $name $value]
  254. }
  255.  
  256. # -------------------------------------------------------------------------
  257.  
  258. # Description:
  259. #   Merge together all the child node values under a given dom element
  260. #   This procedure will also cope with elements whose data is elsewhere
  261. #   using the href attribute. We currently expect the data to be a local
  262. #   reference.
  263. # Params:
  264. #   domElement  - a reference to an element node in a dom tree
  265. # Result:
  266. #   A string containing the elements value
  267. #
  268. proc SOAP::Utils::getElementValue {domElement} {
  269.     set r {}
  270.     set dataNodes [dom::node children $domElement]
  271.     if {[set href [href $domElement]] != {}} {
  272.         if {[string match "\#*" $href]} {
  273.             set href [string trimleft $href "\#"]
  274.         } else {
  275.             error "cannot follow non-local href"
  276.         }
  277.         set r [[uplevel proc:name] [getNodeById \
  278.                 [getDocumentElement $domElement] $href]]
  279.     }
  280.     foreach dataNode $dataNodes {
  281.         append r [dom::node cget $dataNode -nodeValue]
  282.     }
  283.     return $r
  284. }
  285.  
  286. # -------------------------------------------------------------------------
  287.  
  288. # Description:
  289. #   Get the name of the current proc
  290. #   - from http://purl.org/thecliff/tcl/wiki/526.html
  291. proc SOAP::Utils::proc:name {} {
  292.     lindex [info level -1] 0
  293. } 
  294.  
  295. # -------------------------------------------------------------------------
  296.  
  297. proc SOAP::Utils::href {node} {
  298.     set a [dom::node cget $node -attributes]
  299.     if {[info exists [subst $a](href)]} {
  300.         return [set [subst $a](href)]
  301.     }
  302.     return {}
  303. }
  304.  
  305. # -------------------------------------------------------------------------
  306.  
  307. proc SOAP::Utils::id {node} {
  308.     set a [dom::node cget $node -attributes]
  309.     if {[info exists [subst $a](id)]} {
  310.         return [set [subst $a](id)]
  311.     }
  312.     return {}
  313. }
  314. # -------------------------------------------------------------------------
  315.  
  316. proc SOAP::Utils::getElementName {domElement} {
  317.     return [dom::node cget $domElement -nodeName]
  318. }
  319.  
  320. # -------------------------------------------------------------------------
  321.  
  322. proc SOAP::Utils::getElementAttributes {domElement} {
  323.     set attr [dom::node cget $domElement -attributes]
  324.     set attrlist [array get $attr]
  325.     return $attrlist
  326. }
  327.  
  328. # -------------------------------------------------------------------------
  329.  
  330. # Find a node by id (sort of the xpath id() function)
  331. proc SOAP::Utils::getNodeById {base id} {
  332.     if {[string match $id [id $base]]} {
  333.         return $base
  334.     }
  335.     set r {}
  336.     set children [dom::node children $base]
  337.     foreach child $children {
  338.         set r [getNodeById $child $id]
  339.         if {$r != {}} { return $r }
  340.     }
  341.     return {}
  342. }
  343.  
  344. # -------------------------------------------------------------------------
  345.  
  346. # Walk up the DOM until you get to the top.
  347. proc SOAP::Utils::getDocumentElement {node} {
  348.     set parent [dom::node parent $node]
  349.     if {$parent == {}} {
  350.         return $node
  351.     } else {
  352.         return [getDocumentElement $parent]
  353.     }
  354. }
  355.  
  356. # -------------------------------------------------------------------------
  357.  
  358. # Return the value of the specified atribute. First check for an exact match,
  359. # if that fails look for an attribute name without any namespace specification.
  360. # Result:
  361. #  Returns the value of the attribute.
  362. #
  363. proc SOAP::Utils::getElementAttribute {node attrname} {
  364.     set r {}
  365.     set attrs [array get [dom::node cget $node -attributes]]
  366.     if {[set ndx [lsearch -exact $attrs $attrname]] == -1} {
  367.         set ndx [lsearch -regexp $attrs ":${attrname}\$"]
  368.     }
  369.  
  370.     if {$ndx != -1} {
  371.         incr ndx
  372.         set r [lindex $attrs $ndx]
  373.     }
  374.     return $r
  375. }
  376.  
  377. # -------------------------------------------------------------------------
  378.  
  379. # Description:
  380. #  Get the namespace of the given node. This code will examine the nodes 
  381. #  attributes and if necessary the parent nodes attributes until it finds
  382. #  a relevant namespace declaration.
  383. # Parameters:
  384. #  node - the node for which to return a namespace
  385. # Result:
  386. #  returns either the namespace uri or an empty string.
  387. # Notes:
  388. #  The TclDOM 2.0 package provides a -namespaceURI option. The C code module
  389. #  does not, so we have the second chunk of code.
  390. #  The hasFeature method doesn't seem to provide information about this
  391. #  but the versions that support 'query' seem to have the namespaceURI
  392. #  method so we'll use this test for now.
  393. #
  394. proc SOAP::Utils::namespaceURI {node} {
  395.     if {[dom::DOMImplementation hasFeature query 1.0]} {
  396.         return [dom::node cget $node -namespaceURI]
  397.     } else {
  398.         set nodeName [dom::node cget $node -nodeName]
  399.         set ndx [string last : $nodeName]
  400.         set nodeNS [string range $nodeName 0 $ndx]
  401.         set nodeNS [string trimright $nodeNS :]
  402.         
  403.         return [find_namespaceURI $node $nodeNS]
  404.     }
  405. }
  406.  
  407. # -------------------------------------------------------------------------
  408.  
  409. # Description:
  410. #   Obtain the unqualified part of a node name.
  411. # Parameters:
  412. #   node - a DOM node
  413. # Result:
  414. #   the node name without any namespace prefix.
  415. #
  416. proc SOAP::Utils::nodeName {node} {
  417.     set nodeName [dom::node cget $node -nodeName]
  418.     set nodeName [string range $nodeName [string last : $nodeName] end]
  419.     return [string trimleft $nodeName :]
  420. }
  421.  
  422. # -------------------------------------------------------------------------
  423.  
  424. # Description:
  425. #   Obtain the uri for the nsname namespace name working up the DOM tree
  426. #   from the given node.
  427. # Parameters:
  428. #   node - the starting point in the tree.
  429. #   nsname - the namespace name. May be an null string.
  430. # Result:
  431. #   Returns the namespace uri or an empty string.
  432. #
  433. proc SOAP::Utils::find_namespaceURI {node nsname} {
  434.     if {$node == {}} { return {} }
  435.     set atts [dom::node cget $node -attributes]
  436.  
  437.     # check for the default namespace
  438.     if {$nsname == {} && [info exists [subst $atts](xmlns)]} {
  439.     return [set [subst $atts](xmlns)]
  440.     }
  441.     
  442.     # check the defined namespace names.
  443.     foreach {attname attvalue} [array get $atts] {
  444.     if {[string match "xmlns:$nsname" $attname]} {
  445.         return $attvalue
  446.     }
  447.     }
  448.     
  449.     # recurse through the parents.
  450.     return [find_namespaceURI [dom::node parent $node] $nsname]
  451. }
  452.  
  453. # -------------------------------------------------------------------------       
  454. # Local variables:
  455. #    indent-tabs-mode: nil
  456. # End:
  457.