1# xpath.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net>
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
17if { [catch {package require dom 2.0}] } {
18    if { [catch {package require dom 1.6}] } {
19        error "require dom package greater than 1.6"
20    }
21}
22
23namespace eval SOAP::xpath {
24    variable version 0.2
25    variable rcsid { $Id: xpath.tcl,v 1.9 2003/09/06 17:08:46 patthoyts Exp $ }
26    namespace export xpath xmlnsSplit
27}
28
29# -------------------------------------------------------------------------
30
31# Given Envelope/Body/Fault and a DOM node, see if we can find a matching
32# element else return {}
33
34# TODO: Paths including attribute selection etc.
35
36proc ::SOAP::xpath::xpath { args } {
37    if { [llength $args] < 2 || [llength $args] > 3 } {
38        return -code error "wrong # args:\
39            should be \"xpath ?option? rootNode path\""
40    }
41
42    array set opts {
43        -node        0
44        -name        0
45        -attributes  0
46    }
47
48    if { [llength $args] == 3 } {
49        set opt [lindex $args 0]
50        switch -glob -- $opt {
51            -nod*   { set opts(-node) 1 }
52            -nam*   { set opts(-name) 1 }
53            -att*   { set opts(-attributes) 1 }
54            default {
55                return -code error "bad option \"$opt\":\
56                    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 {}
103proc ::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
149proc ::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#
177proc ::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#
195proc ::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.
211proc ::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#
228proc ::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	return -code error "wrong # elements:\
236            name should be namespaceName:elementName"
237    }
238    if { [catch {set fqns $xmlns([lindex $name 0])}] } {
239	return -code error "invalid namespace name:\
240            \"[lindex $name 0]\" not found"
241    }
242
243    return "${fqns}:[lindex $name 1]"
244}
245
246# -------------------------------------------------------------------------
247
248package provide SOAP::xpath $::SOAP::xpath::version
249
250# -------------------------------------------------------------------------
251# Local variables:
252#   indent-tabs-mode: nil
253# End:
254