Index: ClientSide.tcl ================================================================== --- ClientSide.tcl +++ ClientSide.tcl @@ -45,11 +45,11 @@ package require tdom 0.8 package require http 2 package require log package require uri -package provide WS::Client 2.5.0 +package provide WS::Client 2.5.1 namespace eval ::WS::Client { # register https only if not yet registered if {[catch { http::unregister https } lPortCmd]} { # not registered -> register on my own @@ -341,15 +341,15 @@ foreach {name value} $args { set name [string trimleft $name {-}] dict set serviceArr($serviceName) $name $value } - ::log::log debug "Setting Target Namespace tns1 as $target" + ::log::logsubst debug {Setting Target Namespace tns1 as $target} if {[dict exists $serviceArr($serviceName) xns]} { foreach xnsItem [dict get $serviceArr($serviceName) xns] { lassign $xnsItem tns xns - ::log::log debug "Setting targetNamespace $tns for $xns" + ::log::logsubst debug {Setting targetNamespace $tns for $xns} dict set serviceArr($serviceName) targetNamespace $tns $xns } } } @@ -1155,11 +1155,11 @@ set first [string first {<} $wsdlXML] if {$first > 0} { set wsdlXML [string range $wsdlXML $first end] } - ::log::log debug [list "Parsing WSDL" $wsdlXML] + ::log::logsubst debug {Parsing WSDL: $wsdlXML} # save parsed document node to tmpdoc dom parse $wsdlXML tmpdoc # save transformed document handle in variable wsdlDoc $tmpdoc xslt $::WS::Utils::xsltSchemaDom wsdlDoc @@ -1258,11 +1258,11 @@ # This may happen, if the element namespace prefix overwrites # a global one, like # # if { [dict exists $nsDict tns $ns] && $tns ne [dict get $nsDict tns $ns] } { - ::log::log debug "Namespace prefix '$ns' with different URI '$url': $nsDict" + ::log::logsubst debug {Namespace prefix '$ns' with different URI '$url': $nsDict} return \ -code error \ -errorcode [list WS CLIENT AMBIGNSPREFIX] \ "element namespace prefix '$ns' used again for different URI '$url'.\ Sorry, this is a current implementation limitation of TCLWS." @@ -1387,11 +1387,11 @@ ## not add any arguments... set inputMsgTypeDefinition [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] if {[dict exists $inputMsgTypeDefinition definition]} { set inputFields [dict keys [dict get $inputMsgTypeDefinition definition]] } else { - ::log::log debug "no definition found for inputMsgType $inputMsgType" + ::log::logsubst debug {no definition found for inputMsgType $inputMsgType} set inputFields {} } if {$inputFields ne {}} { lappend argList [lsort -dictionary $inputFields] } @@ -1403,11 +1403,11 @@ set operationName [string trim [namespace tail $procName] {:}] set argList {} foreach var [namespace eval ::${serviceName}:: [list info args $operationName]] { lappend argList $var [set $var] } - ::log::log debug [list ::WS::Client::DoCall $serviceName $operationName $argList] + ::log::logsubst debug {::WS::Client::DoCall $serviceName $operationName $argList} ::WS::Client::DoCall $serviceName $operationName $argList } proc $procName $argList $body append procList "\n\t[list $procName $argList]" } @@ -1466,11 +1466,11 @@ # ########################################################################### proc ::WS::Client::DoRawCall {serviceName operationName argList {headers {}}} { variable serviceArr - ::log::log debug "Entering ::WS::Client::DoRawCall {$serviceName $operationName $argList}" + ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" @@ -1510,11 +1510,11 @@ set body [::WS::Utils::geturl_fetchbody $url -query $query -type [dict get $serviceInfo contentType] -headers $headers] } else { set body [::WS::Utils::geturl_fetchbody $url -query $query -type [dict get $serviceInfo contentType]] } - ::log::log debug "Leaving ::WS::Client::DoRawCall with {$body}" + ::log::logsubst debug {Leaving ::WS::Client::DoRawCall with {$body}} return $body } ########################################################################### @@ -1570,11 +1570,11 @@ # ########################################################################### proc ::WS::Client::DoCall {serviceName operationName argList {headers {}}} { variable serviceArr - ::log::log debug "Entering ::WS::Client::DoCall {$serviceName $operationName $argList}" + ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" @@ -1631,16 +1631,16 @@ } set hadError [catch {parseResults $serviceName $operationName $body} results] if {$hadError} { lassign $::errorCode mainError subError if {$mainError eq {WSCLIENT} && $subError eq {NOSOAP}} { - ::log::log debug "\tHTTP error $body" + ::log::logsubst debug {\tHTTP error $body} set results $body set errorCode [list WSCLIENT HTTPERROR $body] set errorInfo {} } else { - ::log::log debug "Reply was $body" + ::log::logsubst debug {Reply was $body} set errorCode $::errorCode set errorInfo $::errorInfo } } } else { @@ -1651,11 +1651,11 @@ } SaveAndSetOptions $serviceName set hadError [catch {parseResults $serviceName $operationName $body} results] RestoreSavedOptions $serviceName if {$hadError} { - ::log::log debug "Reply was $body" + ::log::logsubst debug {Reply was $body} set errorCode $::errorCode set errorInfo $::errorInfo } } if {$hadError} { @@ -1664,11 +1664,11 @@ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $results } else { - ::log::log debug "Leaving ::WS::Client::DoCall with {$results}" + ::log::logsubst debug {Leaving ::WS::Client::DoCall with {$results}} return $results } } @@ -1777,11 +1777,11 @@ # ########################################################################### proc ::WS::Client::DoAsyncCall {serviceName operationName argList succesCmd errorCmd {headers {}}} { variable serviceArr - ::log::log debug "Entering ::WS::Client::DoAsyncCall [list $serviceName $operationName $argList $succesCmd $errorCmd $headers]" + ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" @@ -1803,35 +1803,31 @@ return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { RestoreSavedOptions $serviceName } if {[llength $headers]} { - ::log::log info [list \ - ::http::geturl $url \ + ::log::logsubst info {::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -headers $headers \ - -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] \ - ] + -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd]} ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -headers $headers \ -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] } else { - ::log::log info [list \ - ::http::geturl $url \ + ::log::logsubst info {::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ - -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] \ - ] + -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd]} ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] } - ::log::log debug "Leaving ::WS::Client::DoAsyncCall" + ::log::logsubst debug {Leaving ::WS::Client::DoAsyncCall} return; } ########################################################################### # @@ -2044,17 +2040,17 @@ # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::asyncCallDone {serviceName operationName succesCmd errorCmd token} { - ::log::log debug "Entering ::WS::Client::asyncCallDone {$serviceName $operationName $succesCmd $errorCmd $token}" + ::log::logsubst debug {Entering [info level 0]} ## ## Check for errors ## set body [::http::data $token] - ::log::log info "\nReceived: $body" + ::log::logsubst info {\nReceived: $body} set results {} if {[::http::status $token] ne {ok} || ( [::http::ncode $token] != 200 && $body eq {} )} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set hadError 1 @@ -2136,17 +2132,21 @@ # 2.4.2 2017-08-31 H.Oehlmann The response node name may also be the # output name and not only the output type. # (ticket [21f41e22bc]). # 2.4.3 2017-11-03 H.Oehlmann Extended upper commit also to search # for multiple child nodes. -# +# 2.5.1 2018-05-14 H.Oehlmann Add support to translate namespace prefixes +# in attribute values or text values. +# Translation dict "xnsDistantToLocalDict" is +# passed to ::WS::Utils::convertTypeToDict +# to translate abstract types. # ########################################################################### proc ::WS::Client::parseResults {serviceName operationName inXML} { variable serviceArr - ::log::log debug "In parseResults $serviceName $operationName {$inXML}" + ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set expectedMsgType [dict get $serviceInfo operation $operationName outputs] set expectedMsgTypeBase [lindex [split $expectedMsgType {:}] end] @@ -2155,22 +2155,58 @@ if {$first > 0} { set inXML [string range $inXML $first end] } # parse xml and save handle in variable doc and free it when out of scope dom parse $inXML doc + # save top node handle in variable top and free it if out of scope $doc documentElement top + set xns { ENV http://schemas.xmlsoap.org/soap/envelope/ xsi "http://www.w3.org/2001/XMLSchema-instance" xs "http://www.w3.org/2001/XMLSchema" } - foreach tmp [dict get $serviceInfo targetNamespace] { - lappend xns $tmp + foreach {prefixCur URICur} [dict get $serviceInfo targetNamespace] { + lappend xns $prefixCur $URICur } - ::log::log debug "Using namespaces {$xns}" + ::log::logsubst debug {Using namespaces {$xns}} $doc selectNodesNamespaces $xns + + ## + ## When arguments with tags are passed (example: abstract types), + ## the upper "selectNodesNamespaces translation must be executed manually. + ## Thus, we need a list of server namespace prefixes to our client namespace + ## prefixes. (bug 584bfb77) + ## + # Example xml: + # + + set xnsDistantToLocalDict {} + foreach attributeCur [$top attributes] { + # attributeCur is a list of "prefix local URI", + # which is for xmlns tags: "prefix prefix {}". + set attributeCur [lindex $attributeCur 0] + # Check if this is a namespace prefix + if { ! [$top hasAttribute "xmlns:$attributeCur"] } {continue} + set URIServer [$top getAttribute "xmlns:$attributeCur"] + # Check if it is included in xns + foreach {prefixCur URICur} $xns { + if {$URIServer eq $URICur} { + dict set xnsDistantToLocalDict $attributeCur $prefixCur + break + } + } + } + ::log::logsubst debug {Server to Client prefix dict: $xnsDistantToLocalDict} + + ## + ## Get body tag + ## set body [$top selectNodes ENV:Body] if {![llength $body]} { return \ -code error \ -errorcode [list WS CLIENT BADREPLY $inXML] \ @@ -2223,23 +2259,23 @@ if {[dict exists $serviceInfo operation $operationName outputsname]} { lappend nodeNameCandidateList [dict get $serviceInfo operation $operationName outputsname] } set rootNodeList [$body childNodes] - ::log::log debug "Have [llength $rootNodeList] node under Body" + ::log::logsubst debug {Have [llength $rootNodeList] node under Body} foreach rootNodeCur $rootNodeList { set rootNameCur [$rootNodeCur localName] if {$rootNameCur eq {}} { set rootNameCur [$rootNodeCur nodeName] } if {$rootNameCur in $nodeNameCandidateList} { set rootNode $rootNodeCur set rootName $rootNameCur - ::log::log debug "Result root name is '$rootName'" + ::log::logsubst debug {Result root name is '$rootName'} break } - ::log::log debug "Result root name '$rootNameCur' not in candidates '$nodeNameCandidateList'" + ::log::logsubst debug {Result root name '$rootNameCur' not in candidates '$nodeNameCandidateList'} } ## ## Exit if there is no such node ## if {![info exists rootName]} { @@ -2296,22 +2332,25 @@ } #if {[llength $outHeaderAttrs]} { # ::WS::Utils::setAttr $node $outHeaderAttrs #} - ::log::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode]" - lappend results [::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode] + ::log::logsubst debug {Calling convertTypeToDict from header node type '$outHeaderType'} + lappend results [::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode 0 $xnsDistantToLocalDict] } } - ::log::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $rootNode $expectedMsgType $body]" + ## + ## Call Utility function to build result list + ## if {$rootName ne {}} { + ::log::log debug "Calling convertTypeToDict with root node" set bodyData [::WS::Utils::convertTypeToDict \ - Client $serviceName $rootNode $expectedMsgType $body] + Client $serviceName $rootNode $expectedMsgType $body 0 $xnsDistantToLocalDict] if {![llength $bodyData] && ([dict get $serviceInfo skipLevelWhenActionPresent] || [dict get $serviceInfo skipLevelOnReply])} { - ::log::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $rootNode $expectedMsgType $body] -- skipLevelWhenActionPresent was set" + ::log::log debug "Calling convertTypeToDict with skipped action level (skipLevelWhenActionPresent was set)" set bodyData [::WS::Utils::convertTypeToDict \ - Client $serviceName $body $expectedMsgType $body] + Client $serviceName $body $expectedMsgType $body 0 $xnsDistantToLocalDict] } lappend results $bodyData } set results [join $results] $doc delete @@ -2393,11 +2432,11 @@ set inTransform [dict get $serviceInfo inTransform] if {$inTransform ne {}} { set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList] } - ::log::log debug "Leaving ::WS::Client::buildCallquery with {$xml}" + ::log::logsubst debug {Leaving ::WS::Client::buildCallquery with {$xml}} return $xml } ########################################################################### @@ -2441,11 +2480,11 @@ # ########################################################################### proc ::WS::Client::buildDocLiteralCallquery {serviceName operationName url argList} { variable serviceArr - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set msgType [dict get $serviceInfo operation $operationName inputs] set url [dict get $serviceInfo location] set xnsList [dict get $serviceInfo targetNamespace] @@ -2524,11 +2563,11 @@ if {[dict get $serviceInfo skipLevelWhenActionPresent] && [dict exists $serviceInfo operation $operationName action]} { set forceNs 1 set reply $bod } else { - ::log::log debug "$bod appendChild \[$doc createElement $xns:$msgType reply\]" + ::log::logsubst debug {$bod appendChild \[$doc createElement $xns:$msgType reply\]} $bod appendChild [$doc createElement $xns:$msgType reply] set forceNs 0 } ::WS::Utils::convertDictToType Client $serviceName $doc $reply $argList $xns:$msgType $forceNs @@ -2536,11 +2575,11 @@ set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {:}] end] {=}] end] set xml [format {} $encoding] append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] $doc delete - ::log::log debug "Leaving ::WS::Client::buildDocLiteralCallquery with {$xml}" + ::log::logsubst debug {Leaving ::WS::Client::buildDocLiteralCallquery with {$xml}} return [encoding convertto $encoding $xml] } @@ -2585,11 +2624,11 @@ # ########################################################################### proc ::WS::Client::buildRpcEncodedCallquery {serviceName operationName url argList} { variable serviceArr - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set msgType [dict get $serviceInfo operation $operationName inputs] set xnsList [dict get $serviceInfo targetNamespace] dom createDocument "SOAP-ENV:Envelope" doc @@ -2634,11 +2673,11 @@ set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {;}] end] {=}] end] set xml [format {} $encoding] append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] $doc delete - ::log::log debug "Leaving ::WS::Client::buildRpcEncodedCallquery with {$xml}" + ::log::logsubst debug {Leaving ::WS::Client::buildRpcEncodedCallquery with {$xml}} return [encoding convertto $encoding $xml] } @@ -2689,11 +2728,11 @@ proc ::WS::Client::buildServiceInfo {wsdlNode tnsDict {serviceInfo {}} {serviceAlias {}} {serviceNumber 1}} { ## ## Need to refactor to foreach service parseService ## Service drills down to ports, which drills down to bindings and messages ## - ::log::log debug [list "Entering ::WS::Client::buildServiceInfo with doc" $wsdlNode] + ::log::logsubst debug {Entering [info level 0]} ## ## Parse Service information ## # WSDL snippet: @@ -2729,11 +2768,11 @@ foreach serviceNode $serviceNameList { lappend serviceInfo [parseService $wsdlNode $serviceNode $serviceAlias $tnsDict] } - ::log::log debug [list "Leaving ::WS::Client::buildServiceInfo with" $serviceInfo] + ::log::logsubst debug {Leaving ::WS::Client::buildServiceInfo with $serviceInfo} return $serviceInfo } ########################################################################### # @@ -2778,11 +2817,11 @@ ########################################################################### proc ::WS::Client::parseService {wsdlNode serviceNode serviceAlias tnsDict} { variable serviceArr variable options - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} if {[string length $serviceAlias]} { set serviceName $serviceAlias } else { set serviceName [$serviceNode getAttribute name] } @@ -2843,11 +2882,11 @@ } set serviceArr($serviceName) $serviceInfo set ::WS::Utils::targetNs $tmpTargetNs - ::log::log debug "Leaving [lindex [info level 0] 0] with $serviceInfo" + ::log::logsubst debug {Leaving [lindex [info level 0] 0] with $serviceInfo} return $serviceInfo } ########################################################################### # @@ -3442,11 +3481,11 @@ # ########################################################################### proc ::WS::Client::DoRawRestCall {serviceName objectName operationName argList {headers {}} {location {}}} { variable serviceArr - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" @@ -3493,11 +3532,11 @@ set body [::WS::Utils::geturl_fetchbody $url -query $query -type [dict get $serviceInfo contentType] -headers $headers] } else { set body [::WS::Utils::geturl_fetchbody $url -query $query -type [dict get $serviceInfo contentType]] } - ::log::log debug "Leaving ::WS::Client::DoRawRestCall with {$body}" + ::log::logsubst debug {Leaving ::WS::Client::DoRawRestCall with {$body}} return $body } ########################################################################### @@ -3553,11 +3592,11 @@ # ########################################################################### proc ::WS::Client::DoRestCall {serviceName objectName operationName argList {headers {}} {location {}}} { variable serviceArr - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" @@ -3616,11 +3655,11 @@ RestoreSavedOptions $serviceName ::log::log debug "Leaving (error) ::WS::Client::DoRestCall" return -code error $results } RestoreSavedOptions $serviceName - ::log::log debug "Leaving ::WS::Client::DoRestCall with {$results}" + ::log::logsubst debug {Leaving ::WS::Client::DoRestCall with {$results}} return $results } ########################################################################### @@ -3683,11 +3722,11 @@ set svcHeaders [dict get $serviceArr($serviceName) headers] if {[llength $svcHeaders]} { set headers [concat $headers $svcHeaders] } - ::log::log debug "Entering ::WS::Client::DoAsyncRestCall [list $serviceName $objectName $operationName $argList $succesCmd $errorCmd $headers]" + ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" @@ -3709,29 +3748,25 @@ return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { RestoreSavedOptions $serviceName } if {[llength $headers]} { - ::log::log info [list \ - ::http::geturl $url \ + ::log::logsubst info {::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -headers $headers \ - -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] \ - ] + -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd]} ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -headers $headers \ -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] } else { - ::log::log info [list \ - ::http::geturl $url \ + ::log::logsubst info {::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ - -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] \ - ] + -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd]} ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] } @@ -3780,11 +3815,11 @@ # ########################################################################### proc ::WS::Client::buildRestCallquery {serviceName objectName operationName url argList} { variable serviceArr - ::log::log debug "Entering [info level 0]" + ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set msgType [dict get $serviceInfo object $objectName operation $operationName inputs] set xnsList [dict get $serviceInfo targetNamespace] dom createDocument "request" doc @@ -3798,11 +3833,11 @@ xmlns:$tns $target } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType] xns] - ::log::log debug "calling [list ::WS::Utils::convertDictToType Client $serviceName $doc $body $argList $msgType]" + ::log::logsubst debug {calling [list ::WS::Utils::convertDictToType Client $serviceName $doc $body $argList $msgType]} set options [::WS::Utils::SetOption] ::WS::Utils::SetOption UseNS 0 ::WS::Utils::SetOption genOutAttr 1 ::WS::Utils::SetOption valueAttr {} ::WS::Utils::convertDictToType Client $serviceName $doc $body $argList $msgType @@ -3820,11 +3855,11 @@ set inTransform [dict get $serviceInfo inTransform] if {$inTransform ne {}} { set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList] } - ::log::log debug "Leaving ::WS::Client::buildRestCallquery with {$xml}" + ::log::logsubst debug {Leaving ::WS::Client::buildRestCallquery with {$xml}} return $xml } @@ -3873,11 +3908,11 @@ # ########################################################################### proc ::WS::Client::parseRestResults {serviceName objectName operationName inXML} { variable serviceArr - ::log::log debug "In parseResults $serviceName $operationName {$inXML}" + ::log::logsubst debug {Entering [info level 0]} set first [string first {<} $inXML] if {$first > 0} { set inXML [string range $inXML $first end] } set serviceInfo $serviceArr($serviceName) @@ -3892,11 +3927,11 @@ $doc documentElement top set xns {} foreach tmp [dict get $serviceInfo targetNamespace] { lappend xns $tmp } - ::log::log debug "Using namespaces {$xns}" + ::log::logsubst debug {Using namespaces {$xns}} set body $top set status [$body getAttribute status] ## ## See if it is a standard error packet @@ -3919,11 +3954,11 @@ ## set results {} set options [::WS::Utils::SetOption] ::WS::Utils::SetOption UseNS 0 ::WS::Utils::SetOption parseInAttr 1 - ::log::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $body $expectedMsgType $body]" + ::log::logsubst debug {Calling ::WS::Utils::convertTypeToDict Client $serviceName $body $expectedMsgType $body} if {$expectedMsgType ne {}} { set node [$body childNodes] set nodeName [$node nodeName] if {$objectName ne $nodeName} { return \ @@ -3986,17 +4021,17 @@ # 1 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::asyncRestCallDone {serviceName objectName operationName succesCmd errorCmd token} { - ::log::log debug "Entering ::WS::Client::asyncCallDone {$serviceName $objectName $operationName $succesCmd $errorCmd $token}" + ::log::logsubst debug {Entering [info level 0]} ## ## Check for errors ## set body [::http::data $token] - ::log::log info "\nReceived: $body" + ::log::logsubst info {\nReceived: $body} if {[::http::status $token] ne {ok} || ( [::http::ncode $token] != 200 && $body eq {} )} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set hadError 1 set errorInfo [FormatHTTPError $token] Index: Utilities.tcl ================================================================== --- Utilities.tcl +++ Utilities.tcl @@ -77,11 +77,11 @@ } package require tdom 0.8 package require struct::set -package provide WS::Utils 2.4.1 +package provide WS::Utils 2.4.2 namespace eval ::WS {} namespace eval ::WS::Utils { set ::WS::Utils::typeInfo {} @@ -1380,13 +1380,18 @@ # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 07/06/2006 G.Lester Initial version # +# 2.4.2 2018-05-14 H.Oehlmann Add support to translate namespace prefixes +# in attribute values or text values. +# New parameter "xnsDistantToLocalDict". # ########################################################################### -proc ::WS::Utils::convertTypeToDict {mode serviceName node type root {isArray 0}} { +proc ::WS::Utils::convertTypeToDict { + mode serviceName node type root {isArray 0} {xnsDistantToLocalDict {}} +} { variable typeInfo variable mutableTypeInfo variable options if {$options(valueAttrCompatiblityMode)} { @@ -1447,11 +1452,11 @@ ## ## Type infomation being handled dynamically for this part ## set savedTypeInfo $typeInfo parseDynamicType $mode $serviceName $node $type - set tmp [convertTypeToDict $mode $serviceName $node $type $root] + set tmp [convertTypeToDict $mode $serviceName $node $type $root 0 $xnsDistantToLocalDict] foreach partName [dict keys $tmp] { dict set results $partName [dict get $tmp $partName] } set typeInfo $savedTypeInfo continue @@ -1604,12 +1609,32 @@ {1 0} { ## ## Non-simple non-array ## if {$options(parseInAttr)} { + ## Translate an abstract type from the WSDL to a type given + ## in the response + ## Example xml response from bug 584bfb772: + ## + ## + ## + ## + ## Layers + ## + ## + ## + ## The element FullExtend gets type "tns:EnvelopeN". + ## + ## xnsDistantToLocalDict if {$isAbstract && [$item hasAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type]} { - set partType [$item getAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type] + # partType is now tns::EnvelopeN + set partType [XNSDistantToLocal $xnsDistantToLocalDict\ + [$item getAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type]] + + # Remove this type attribute from the snippet. + # So, it is not handled in the loop below. $item removeAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type } foreach attrList [$item attributes] { catch { lassign $attrList attr nsAlias nsUrl @@ -1623,13 +1648,13 @@ set attrValue [$item getAttribute $attr] dict set results $partName $attr $attrValue } } } - dict set results $partName $valueAttr [convertTypeToDict $mode $serviceName $item $partType $root] + dict set results $partName $valueAttr [convertTypeToDict $mode $serviceName $item $partType $root 0 $xnsDistantToLocalDict] } else { - dict set results $partName [convertTypeToDict $mode $serviceName $item $partType $root] + dict set results $partName [convertTypeToDict $mode $serviceName $item $partType $root 0 $xnsDistantToLocalDict] } } {1 1} { ## ## Non-simple array @@ -1656,14 +1681,14 @@ set attrValue [$row getAttribute $attr] lappend rowList $attr $attrValue } } } - lappend rowList $valueAttr [convertTypeToDict $mode $serviceName $row $partType $root 1] + lappend rowList $valueAttr [convertTypeToDict $mode $serviceName $row $partType $root 1 $xnsDistantToLocalDict] lappend tmp $rowList } else { - lappend tmp [convertTypeToDict $mode $serviceName $row $partType $root 1] + lappend tmp [convertTypeToDict $mode $serviceName $row $partType $root 1 $xnsDistantToLocalDict] } } dict set results $partName $tmp } default { @@ -1671,13 +1696,65 @@ ## Placed here to shut up tclchecker ## } } } - ::log::logsubst debug {Leaving ::WS::Utils::convertTypeToDict with $results} + ::log::logsubst debug {Leaving ::WS::Utils::convertTypeToDict with result '$results'} return $results } + +########################################################################### +# +# Private Procedure Header - as this procedure is modified, please be sure +# that you update this header block. Thanks. +# +#>>BEGIN PRIVATE<< +# +# Procedure Name : ::WS::Utils::XNSDistantToLocal +# +# Description : Get a reference node. +# +# Arguments : +# xnsDistantToLocalDict - Dict to translate distant to local NS prefixes +# typeDistant - Type string with possible distant namespace prefix +# +# Returns : type with local namespace prefix +# +# Side-Effects : None +# +# Exception Conditions : None +# +# Pre-requisite Conditions : None +# +# Original Author : Harald Oehlmann +# +#>>END PRIVATE<< +# +# Maintenance History - as this file is modified, please be sure that you +# update this segment of the file header block by +# adding a complete entry at the bottom of the list. +# +# Version Date Programmer Comments / Changes / Reasons +# ------- ---------- ---------- ------------------------------------------- +# 2.4.2 2017-11-03 H.Oehlmann Initial version +# +########################################################################### +proc ::WS::Utils::XNSDistantToLocal {xnsDistantToLocalDict type} { + set collonPos [string first ":" $type] + # check for namespace prefix present + if {-1 < $collonPos} { + set prefixDistant [string range $type 0 $collonPos-1] + if {[dict exists $xnsDistantToLocalDict $prefixDistant]} { + set type [dict get $xnsDistantToLocalDict $prefixDistant][string range $type $collonPos end] + log::logsubst debug {Mapped distant namespace prefix '$prefixDistant' to type '$type'} + } else { + log::logsubst warning {Distant type '$type' does not have a known namespace prefix ([dict keys $xnsDistantToLocalDict])} + } + } + return $type +} + ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. @@ -2154,11 +2231,11 @@ set yajlType "string" } ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList}} set typeInfoList [lrange $typeInfoList 0 1] - switch $typeInfoList { + switch -- $typeInfoList { {0 0} { ## ## Simple non-array ## set resultValue [dict get $dict $itemName] @@ -2252,10 +2329,11 @@ # ::log::log debug " Parent xml: [$parent asXML]" variable typeInfo variable simpleTypes variable options variable standardAttributes + variable currentNs if {$options(valueAttrCompatiblityMode)} { set valueAttr {} } else { set valueAttr {::value} @@ -2359,16 +2437,17 @@ } {1 0} { ## ## Non-simple non-array ## - $parent appendChild [$doc createElement $itemName retnode] + $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys [dict get $dict $itemName]] set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {$isAbstract && [string equal $attr {::type}]} { + # *** HaO: useName is never defined set itemType [dict get $dict $useName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $itemType } elseif {[string equal $attr $valueAttr]} { set resultValue [dict get $dict $itemName $attr] } elseif {[string match {::*} $attr]} { @@ -2383,20 +2462,20 @@ set resultValue [dict get $dict $itemName] } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } - convertDictToTypeNoNs $mode $service $doc $retnode $resultValue $itemType $enforceRequired + convertDictToTypeNoNs $mode $service $doc $retNode $resultValue $itemType $enforceRequired } {1 1} { ## ## Non-simple array ## set dataList [dict get $dict $itemName] set tmpType [string trimright $itemType {()}] foreach row $dataList { - $parent appendChild [$doc createElement $itemName retnode] + $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys $row] set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {$isAbstract && [string equal $attr {::type}]} { @@ -2416,11 +2495,11 @@ set resultValue $row } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } - convertDictToTypeNoNs $mode $service $doc $retnode $resultValue $tmpType $enforceRequired + convertDictToTypeNoNs $mode $service $doc $retNode $resultValue $tmpType $enforceRequired } } default { ## ## Placed here to shut up tclchecker @@ -3388,10 +3467,31 @@ $middleNode setAttribute name $typeName parseComplexType $mode results $serviceName $middleNode $tns } simpleContent - complexContent { + ## + ## Save simple or complex content for abstract types, which + ## may have content type with no fields. [Bug 584bfb77] + ## Example xml type snippet: + ## + ## + ## + ## + ## + ## + ## ... + ## + ## + ## + + set isComplexContent [expr {$middle eq "complexContent"}] + ::log::logsubst debug {isComplexContent = $isComplexContent} + + ## + ## Loop over the components of the type + ## foreach child [$middleNode childNodes] { set parent [$child parent] set contentType [$child localName] ::log::logsubst debug {Content Type is {$contentType}} switch -exact -- $contentType { @@ -3459,12 +3559,22 @@ } ::log::logsubst debug {at end of foreach {$typeName} with {$partList}} if {[llength $partList] || $isAbstractType} { #dict set results types $tns:$typeName $partList dict set results types $typeName $partList - ::log:::log debug "Defining $typeName" - if {[llength $partList] && ![string equal [lindex $partList 0] {}]} { + ::log:::logsubst debug {Defining $typeName as '$partList'} + ## + ## Add complex type definition, if: + ## * there is a part list + ## * or it is an abstract type announced as complex + ## (see xml snipped above about [Bug 584bfb77]) + ## -> will set dict typeInfo client $service tns1:envelope { + ## definition {} xns tns1 abstract true} + ## + if { ([llength $partList] && ![string equal [lindex $partList 0] {}]) + || ($isAbstractType && [info exists isComplexContent] && $isComplexContent) + } { ::WS::Utils::ServiceTypeDef $mode $serviceName $typeName $partList $tns $isAbstractType } else { ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $typeName [list base $defaultType comment {}] $tns } @@ -4154,11 +4264,11 @@ array set fieldInfoArr $fieldDef if {$fieldInfoArr(minOccurs) && ![info exists fieldInfoArr($field)]} { ## ## Fields was required but is missing ## - set ::errorCode [list WS CHECK MISSREQFLD [list $type $field]] + set ::errorCode [list WS CHECK MISSREQFLD [list $typeName $field]] set result 0 } elseif {$fieldInfoArr(minOccurs) && ($fieldInfoArr(minOccurs) > [llength $fieldInfoArr($field)])} { ## ## Fields was required and present, but not enough times @@ -4169,11 +4279,11 @@ [string is integer fieldInfoArr(maxOccurs)] && ($fieldInfoArr(maxOccurs) < [llength $fieldInfoArr($field)])} { ## ## Fields was required and present, but too many times ## - set ::errorCode [list WS CHECK MAXOCCUR [list $type $field]] + set ::errorCode [list WS CHECK MAXOCCUR [list $typeName $field]] set result 0 } elseif {[info exists fieldInfoArr($field)]} { foreach node $fieldInfoArr($field) { set result [checkTags $mode $serviceName $node $fieldInfoArr(type)] if {!$result} { @@ -4246,27 +4356,28 @@ array set typeInfos { minLength 0 maxLength -1 fixed false } + # returns indexes type, xns, ... array set typeInfos [GetServiceTypeDef $mode $serviceName $type] foreach {var value} [array get typeInfos] { set $var $value } set result 1 if {$minLength >= 0 && [string length $value] < $minLength} { - set ::errorCode [list WS CHECK VALUE_TO_SHORT [list $key $value $minLength $typeInfo]] + set ::errorCode [list WS CHECK VALUE_TO_SHORT [list $type $value $minLength $typeInfo]] set result 0 } elseif {$maxLength >= 0 && [string length $value] > $maxLength} { - set ::errorCode [list WS CHECK VALUE_TO_LONG [list $key $value $maxLength $typeInfo]] + set ::errorCode [list WS CHECK VALUE_TO_LONG [list $type $value $maxLength $typeInfo]] set result 0 } elseif {[info exists enumeration] && ([lsearch -exact $enumeration $value] == -1)} { - set errorCode [list WS CHECK VALUE_NOT_IN_ENUMERATION [list $key $value $enumerationVals $typeInfo]] + set errorCode [list WS CHECK VALUE_NOT_IN_ENUMERATION [list $type $value $enumeration $typeInfo]] set result 0 } elseif {[info exists pattern] && (![regexp -- $pattern $value])} { - set errorCode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $key $value $pattern $typeInfo]] + set errorCode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $type $value $pattern $typeInfo]] set result 0 } return $result } @@ -4322,11 +4433,11 @@ ## Get the type information ## set baseTypeName [string trimright $typeName {()?}] set typeInfo [GetServiceTypeDef $mode $serviceName $baseTypeName] set typeName [string trimright $typeName {?}] - set xns [dict get $typeInfo $mode $service $type xns] + set xns [dict get $typeInfo $mode $serviceName $typeName xns] foreach {field fieldDef} [dict get $typeInfo definition] { ## ## Get info about this field and its type ## @@ -4370,11 +4481,11 @@ ## ## Fields was required and present, but too many times ## set minOccurs $fieldInfoArr(maxOccurs) return \ - -errorcode [list WS CHECK MAXOCCUR [list $type $field]] \ + -errorcode [list WS CHECK MAXOCCUR [list $typeName $field]] \ "Field '$field' of type '$typeName' could only occur $minOccurs time(s) but occured $valueListLenght time(s)" } elseif {[dict exists $valueInfos $field]} { foreach value $valueList { $currentNode appendChild [$doc createElement $xns:$field retNode] if {$isComplex} { Index: pkgIndex.tcl ================================================================== --- pkgIndex.tcl +++ pkgIndex.tcl @@ -8,11 +8,11 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. package ifneeded WS::AOLserver 2.4.0 [list source [file join $dir AOLserver.tcl]] package ifneeded WS::Channel 2.4.0 [list source [file join $dir ChannelServer.tcl]] -package ifneeded WS::Client 2.5.0 [list source [file join $dir ClientSide.tcl]] +package ifneeded WS::Client 2.5.1 [list source [file join $dir ClientSide.tcl]] package ifneeded WS::Embeded 2.4.0 [list source [file join $dir Embedded.tcl]] package ifneeded WS::Server 2.4.0 [list source [file join $dir ServerSide.tcl]] -package ifneeded WS::Utils 2.4.1 [list source [file join $dir Utilities.tcl]] +package ifneeded WS::Utils 2.4.2 [list source [file join $dir Utilities.tcl]] package ifneeded WS::Wub 2.4.0 [list source [file join $dir WubServer.tcl]] package ifneeded Wsdl 2.4.0 [list source [file join $dir WubServer.tcl]]