1# utils.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net>
2#             Copyright (C) 2008 Andreas Kupries <andreask@activestate.com>
3#
4# DOM data access utilities for use in the TclSOAP package.
5# This is the only place which has to be modified to switch
6# between different dom implementations, like TclDOM and tDOM.
7#
8# -------------------------------------------------------------------------
9# This software is distributed in the hope that it will be useful, but
10# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
11# or FITNESS FOR A PARTICULAR PURPOSE.  See the accompanying file `LICENSE'
12# for more details.
13# -------------------------------------------------------------------------
14
15package require tdom
16
17namespace eval ::SOAP {
18    namespace eval Utils {
19        variable version 1.1
20        variable rcsid {$Id: utils.tcl,v 1.10 2008/07/09 16:14:23 andreas_kupries Exp $}
21        namespace export getElements getElementsByName \
22                getElementValue getElementName \
23                getElementValues getElementNames \
24                getElementNamedValues \
25                getElementAttributes getElementAttribute \
26                decomposeSoap decomposeXMLRPC selectNode \
27                namespaceURI targetNamespaceURI \
28                nodeName baseElementName \
29                newDocument deleteDocument \
30                parseXML generateXML \
31                addNode addTextNode setElementAttribute \
32                documentElement getSimpleElementValue
33    }
34}
35
36# -------------------------------------------------------------------------
37
38proc ::SOAP::Utils::createDocument {name} {
39    return [addNode [newDocument] $name]
40}
41
42proc ::SOAP::Utils::newDocument {} {
43    return [NamespaceSetup [dom createDocumentNode]]
44}
45
46proc ::SOAP::Utils::deleteDocument {doc} {
47    $doc delete
48    return
49}
50
51# -------------------------------------------------------------------------
52
53proc ::SOAP::Utils::parseXML {xml} {
54    return [NamespaceSetup [dom parse -keepEmpties $xml]]
55}
56
57proc ::SOAP::Utils::generateXML {doc} {
58    set    xml "<?xml version=\"1.0\"?>\n"
59    append xml [$doc asXML -indent 0]
60    return $xml
61}
62
63# -------------------------------------------------------------------------
64
65proc ::SOAP::Utils::NamespaceSetup {doc} {
66    $doc selectNodesNamespaces [list \
67         SENC  "http://schemas.xmlsoap.org/soap/encoding/" \
68         SENV  "http://schemas.xmlsoap.org/soap/envelope/" \
69         xsd   "http://www.w3.org/1999/XMLSchema"          \
70         xsi   "http://www.w3.org/1999/XMLSchema-instance" \
71    ]
72    return $doc
73}
74
75# -------------------------------------------------------------------------
76
77proc ::SOAP::Utils::addNode {parent tag} {
78   return [$parent appendChild [[$parent ownerDocument] createElement $tag]]
79}
80
81proc ::SOAP::Utils::addTextNode {parent value} {
82   return [$parent appendChild [[$parent ownerDocument] createTextNode $value]]
83}
84
85proc ::SOAP::Utils::setElementAttribute {node name value} {
86    $node setAttribute $name $value
87    return
88}
89
90# -------------------------------------------------------------------------
91
92# Description:
93#   Provide a version independent selectNode implementation. We either use
94#   the version from the dom package or use the SOAP::xpath version if there
95#   is no dom one.
96# Parameters:
97#   node  - reference to a dom tree
98#   path  - XPath selection
99# Result:
100#   Returns the selected node or a list of matching nodes or an empty list
101#   if no match.
102#
103proc ::SOAP::Utils::selectNode {node path} {
104    return [$node selectNodes $path]
105}
106
107# -------------------------------------------------------------------------
108
109# for extracting the parameters from a SOAP packet.
110# Arrays -> list
111# Structs -> list of name/value pairs.
112# a methods parameter list comes out looking like a struct where the member
113# names == parameter names. This allows us to check the param name if we need
114# to.
115
116proc ::SOAP::Utils::is_array {domElement} {
117    # Look for "xsi:type"="SOAP-ENC:Array"
118    # FIX ME
119    # This code should check the namespace using namespaceURI code (CGI)
120    #
121    array set Attr [getElementAttributes $domElement]
122    if {[info exists Attr(SOAP-ENC:arrayType)]} {
123        return 1
124    }
125    if {[info exists Attr(xsi:type)]} {
126        set type $Attr(xsi:type)
127        if {[string match -nocase {*:Array} $type]} {
128            return 1
129        }
130    }
131
132    # If all the child element names are the same, it's an array
133    # but of there is only one element???
134    set names [getElementNames $domElement]
135    if {[llength $names] > 1 && [llength [lsort -unique $names]] == 1} {
136        return 1
137    }
138
139    return 0
140}
141
142# -------------------------------------------------------------------------
143
144# Break down a SOAP packet into a Tcl list of the data.
145proc ::SOAP::Utils::decomposeSoap {domElement} {
146    set result {}
147
148    # get a list of the child elements of this base element.
149    set child_elements [getElements $domElement]
150
151    # if no child element - return the value.
152    if {$child_elements == {}} {
153	set result [getElementValue $domElement]
154    } else {
155	# decide if this is an array or struct
156	if {[is_array $domElement] == 1} {
157	    foreach child $child_elements {
158		lappend result [decomposeSoap $child]
159	    }
160	} else {
161	    foreach child $child_elements {
162		lappend result [nodeName $child] [decomposeSoap $child]
163	    }
164	}
165    }
166
167    return $result
168}
169
170# -------------------------------------------------------------------------
171
172# I expect domElement to be the params element.
173proc ::SOAP::Utils::decomposeXMLRPC {domElement} {
174    set result {}
175    foreach param_elt [getElements $domElement] {
176        lappend result [getXMLRPCValue [getElements $param_elt]]
177    }
178    return $result
179}
180
181# -------------------------------------------------------------------------
182
183proc ::SOAP::Utils::getXMLRPCValue {value_elt} {
184    set value {}
185    if {$value_elt == {}} { return $value }
186
187    # if there is not type element then the specs say it's a string type.
188    set type_elt [getElements $value_elt]
189    if {$type_elt == {}} {
190        return [getElementValue $value_elt]
191    }
192
193    set type [getElementName $type_elt]
194    if {[string match "struct" $type]} {
195        foreach member_elt [getElements $type_elt] {
196            foreach elt [getElements $member_elt] {
197                set eltname [getElementName $elt]
198                if {[string match "name" $eltname]} {
199                    set m_name [getElementValue $elt]
200                } elseif {[string match "value" $eltname]} {
201                    set m_value [getXMLRPCValue $elt]
202                }
203            }
204            lappend value $m_name $m_value
205        }
206    } elseif {[string match "array" $type]} {
207        foreach elt [getElements [lindex [getElements $type_elt] 0]] {
208            lappend value [getXMLRPCValue $elt]
209        }
210    } else {
211        set value [getElementValue $type_elt]
212    }
213    return $value
214}
215
216# -------------------------------------------------------------------------
217
218# Description:
219#   Return a list of all the immediate children of domNode that are element
220#   nodes.
221# Parameters:
222#   domNode  - a reference to a node in a dom tree
223#
224proc ::SOAP::Utils::getElements {domNode} {
225    set elements {}
226    if {$domNode != {}} {
227        foreach node [Children $domNode] {
228            if {[IsElement $node]} {
229                lappend elements $node
230            }
231        }
232    }
233    return $elements
234}
235
236# -------------------------------------------------------------------------
237
238# Description:
239#   If there are child elements then recursively call this procedure on each
240#   child element. If this is a leaf element, then get the element value data.
241# Parameters:
242#   domElement - a reference to a dom element node
243# Result:
244#   Returns a value or a list of values.
245#
246proc ::SOAP::Utils::getElementValues {domElement} {
247    set result {}
248    if {$domElement != {}} {
249        set nodes [getElements $domElement]
250        if {$nodes =={}} {
251            set result [getElementValue $domElement]
252        } else {
253            foreach node $nodes {
254                lappend result [getElementValues $node]
255            }
256        }
257    }
258    return $result
259}
260
261# -------------------------------------------------------------------------
262
263proc ::SOAP::Utils::getElementValuesList {domElement} {
264    set result {}
265    if {$domElement != {}} {
266        set nodes [getElements $domElement]
267        if {$nodes =={}} {
268            set result [getElementValue $domElement]
269        } else {
270            foreach node $nodes {
271                lappend result [getElementValues $node]
272            }
273        }
274    }
275    return $result
276}
277
278# -------------------------------------------------------------------------
279
280proc ::SOAP::Utils::getElementNames {domElement} {
281    set result {}
282    if {$domElement != {}} {
283        set nodes [getElements $domElement]
284        if {$nodes == {}} {
285            set result [getElementName $domElement]
286        } else {
287            foreach node $nodes {
288                lappend result [getElementName $node]
289            }
290        }
291    }
292    return $result
293}
294
295# -------------------------------------------------------------------------
296
297proc ::SOAP::Utils::getElementNamedValues {domElement} {
298    set name [getElementName $domElement]
299    set value {}
300    set nodes [getElements $domElement]
301    if {$nodes == {}} {
302	set value [getElementValue $domElement]
303    } else {
304	foreach node $nodes {
305	    lappend value [getElementNamedValues $node]
306	}
307    }
308    return [list $name $value]
309}
310
311# -------------------------------------------------------------------------
312
313# Description:
314#   Merge together all the child node values under a given dom element
315#   This procedure will also cope with elements whose data is elsewhere
316#   using the href attribute. We currently expect the data to be a local
317#   reference.
318# Params:
319#   domElement  - a reference to an element node in a dom tree
320# Result:
321#   A string containing the elements value
322#
323proc ::SOAP::Utils::getElementValue {domElement} {
324    set r {}
325    set dataNodes [Children $domElement]
326    if {[set href [href $domElement]] != {}} {
327        if {[string match "\#*" $href]} {
328            set href [string trimleft $href "\#"]
329        } else {
330            return -code error "cannot follow non-local href"
331        }
332        set r [[uplevel proc:name] [getNodeById \
333                [getDocumentElement $domElement] $href]]
334    }
335    foreach dataNode $dataNodes {
336        append r [NodeValue $dataNode]
337    }
338    return $r
339}
340
341proc ::SOAP::Utils::getSimpleElementValue {domElement} {
342    set r {}
343    set dataNodes [Children $domElement]
344    foreach dataNode $dataNodes {
345        append r [NodeValue $dataNode]
346    }
347    return $r
348}
349
350# -------------------------------------------------------------------------
351
352# Description:
353#   Get the name of the current proc
354#   - from http://purl.org/thecliff/tcl/wiki/526.html
355proc ::SOAP::Utils::proc:name {} {
356    lindex [info level -1] 0
357}
358
359# -------------------------------------------------------------------------
360
361proc ::SOAP::Utils::href {node} {
362    array set A [getElementAttributes $node]
363    if {[info exists A(href)]} {
364        return $A(href)
365    }
366    return {}
367}
368
369# -------------------------------------------------------------------------
370
371proc ::SOAP::Utils::id {node} {
372    array set A [getElementAttributes $node]
373    if {[info exists A(id)]} {
374        return $A(id)
375    }
376    return {}
377}
378# -------------------------------------------------------------------------
379
380proc ::SOAP::Utils::getElementName {domElement} {
381    return [$domElement nodeName]
382}
383
384# -------------------------------------------------------------------------
385
386proc ::SOAP::Utils::getElementAttributes {domElement} {
387    set res {}
388    foreach item [$domElement attributes] {
389        foreach {name prefix ns} $item break
390        if {[catch {$domElement getAttributeNS $ns $name} r]} continue
391        lappend res $name $r
392    }
393    return $res
394}
395
396# -------------------------------------------------------------------------
397
398# Find a node by id (sort of the xpath id() function)
399proc ::SOAP::Utils::getNodeById {base id} {
400    if {[string match $id [id $base]]} {
401        return $base
402    }
403    set r {}
404    set children [Children $base]
405    foreach child $children {
406        set r [getNodeById $child $id]
407        if {$r != {}} { return $r }
408    }
409    return {}
410}
411
412# -------------------------------------------------------------------------
413
414# Walk up the DOM until you get to the top.
415proc ::SOAP::Utils::getDocumentElement {node} {
416    while {1} {
417        set parent [Parent $node]
418        if {$parent == {}} {
419            return $node
420        }
421        set node $parent
422    }
423}
424
425proc ::SOAP::Utils::documentElement {domNode} {
426    return [$domNode documentElement]
427}
428
429# -------------------------------------------------------------------------
430
431# Return the value of the specified atribute. First check for an exact match,
432# if that fails look for an attribute name without any namespace specification.
433# Result:
434#  Returns the value of the attribute.
435#
436proc ::SOAP::Utils::getElementAttribute {node attrname} {
437    set r {}
438    set attrs [getElementAttributes $node]
439    if {[set ndx [lsearch -exact $attrs $attrname]] == -1} {
440        set ndx [lsearch -regexp $attrs ":${attrname}\$"]
441    }
442
443    if {$ndx != -1} {
444        incr ndx
445        set r [lindex $attrs $ndx]
446    }
447    return $r
448}
449
450# -------------------------------------------------------------------------
451
452# Description:
453#  Get the namespace of the given node. This code will examine the nodes
454#  attributes and if necessary the parent nodes attributes until it finds
455#  a relevant namespace declaration.
456# Parameters:
457#  node - the node for which to return a namespace
458# Result:
459#  returns either the namespace uri or an empty string.
460# Notes:
461#  The TclDOM 2.0 package provides a -namespaceURI option. The C code module
462#  does not, so we have the second chunk of code.
463#  The hasFeature method doesn't seem to provide information about this
464#  but the versions that support 'query' seem to have the namespaceURI
465#  method so we'll use this test for now.
466#
467proc ::SOAP::Utils::namespaceURI {node} {
468    if {[catch {
469        $node namespaceURI
470    } result]} {
471        set nodeName [getElementName $node]
472        set ndx [string last : $nodeName]
473        set nodeNS [string range $nodeName 0 $ndx]
474        set nodeNS [string trimright $nodeNS :]
475
476        set result [find_namespaceURI $node $nodeNS]
477    }
478    return $result
479}
480
481# Description:
482#  As for namespaceURI except that we are interested in the targetNamespace
483#  URI. This is commonly used in XML schemas to specify the default namespace
484#  for the defined items.
485#
486proc ::SOAP::Utils::targetNamespaceURI {node value} {
487    set ndx [string last : $value]
488    set ns [string trimright [string range $value 0 $ndx] :]
489    #set base [string trimleft [string range $value $ndx end] :]
490    return [find_namespaceURI $node $ns 1]
491}
492
493# -------------------------------------------------------------------------
494
495# Description:
496#   Obtain the unqualified part of a node name.
497# Parameters:
498#   node - a DOM node
499# Result:
500#   the node name without any namespace prefix.
501#
502proc ::SOAP::Utils::nodeName {node} {
503    set nodeName [$node nodeName]
504    set nodeName [string range $nodeName [string last : $nodeName] end]
505    return [string trimleft $nodeName :]
506}
507
508proc ::SOAP::Utils::baseElementName {nodeName} {
509    set nodeName [string range $nodeName [string last : $nodeName] end]
510    return [string trimleft $nodeName :]
511}
512# -------------------------------------------------------------------------
513
514# Description:
515#   Obtain the uri for the nsname namespace name working up the DOM tree
516#   from the given node.
517# Parameters:
518#   node - the starting point in the tree.
519#   nsname - the namespace name. May be an null string.
520# Result:
521#   Returns the namespace uri or an empty string.
522#
523proc ::SOAP::Utils::find_namespaceURI {node nsname {find_targetNamespace 0}} {
524    if {$node == {}} { return {} }
525    array set Atts [getElementAttributes $node]
526
527    # check for the default namespace or targetNamespace
528    if {$nsname == {}} {
529        if {$find_targetNamespace} {
530            if {[info exists Atts(targetNamespace)]} {
531                return $Atts(targetNamespace)
532            }
533        } else {
534            if {[info exists Atts(xmlns)]} {
535                return $Atts(xmlns)
536            }
537        }
538    } else {
539
540        # check the defined namespace names.
541        foreach {attname attvalue} [array get $atts] {
542            if {[string match "xmlns:$nsname" $attname]} {
543                return $attvalue
544            }
545        }
546
547    }
548
549    # recurse through the parents.
550    return [find_namespaceURI [Parent $node] $nsname $find_targetNamespace]
551}
552
553# -------------------------------------------------------------------------
554
555# Description:
556#   Return a list of all the immediate children of domNode that are element
557#   nodes.
558# Parameters:
559#   domNode  - a reference to a node in a dom tree
560#
561proc ::SOAP::Utils::getElementsByName {domNode name} {
562    set elements {}
563    if {$domNode != {}} {
564        foreach node [Children $domNode] {
565            if {[IsElement $node]
566                && [string match $name [getElementName $node]]} {
567                lappend elements $node
568            }
569        }
570    }
571    return $elements
572}
573
574# -------------------------------------------------------------------------
575
576proc ::SOAP::Utils::IsElement {domNode} {
577    return [string equal [$domNode nodeType] ELEMENT_NODE]
578}
579
580proc ::SOAP::Utils::Children {domNode} {
581    return [$domNode childNodes]
582}
583
584proc ::SOAP::Utils::NodeValue {domNode} {
585    return [$domNode nodeValue]
586}
587
588proc ::SOAP::Utils::Parent {domNode} {
589    return [$domNode nodeParent]
590}
591
592# -------------------------------------------------------------------------
593package provide SOAP::Utils $::SOAP::Utils::version
594
595# -------------------------------------------------------------------------
596# Local variables:
597#    indent-tabs-mode: nil
598# End:
599