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