Index: AOLserver.tcl
==================================================================
--- AOLserver.tcl
+++ AOLserver.tcl
@@ -110,6 +110,6 @@
}
}
}
}
-package provide WS::AOLserver 2.0.0
+package provide WS::AOLserver 2.4.0
Index: ChannelServer.tcl
==================================================================
--- ChannelServer.tcl
+++ ChannelServer.tcl
@@ -52,11 +52,11 @@
package require uri
package require base64
package require html
-package provide WS::Channel 2.0.0
+package provide WS::Channel 2.4.0
namespace eval ::WS::Channel {
array set portInfo {}
array set dataArray {}
Index: ClientSide.tcl
==================================================================
--- ClientSide.tcl
+++ ClientSide.tcl
@@ -45,14 +45,14 @@
package require tdom 0.8
package require http 2
package require log
package require uri
-package provide WS::Client 2.3.9
+package provide WS::Client 2.4.0
namespace eval ::WS::Client {
- # register https only if not jet registered
+ # register https only if not yet registered
if {[catch { http::unregister https } lPortCmd]} {
# not registered -> register on my own
if {[catch {
package require tls
http::register https 443 [list ::tls::socket -ssl2 no -ssl3 no -tls1 yes]
@@ -311,11 +311,11 @@
lappend validOptionList location targetNamespace
if {[lsearch -exact $validOptionList $item] == -1} {
return -code error "Uknown option '$item' -- must be one of: [join $validOptionList {, }]"
}
- if {![string equal $value {}]} {
+ if {$value ne {}} {
dict set serviceInfo $item $value
set serviceArr($serviceName) $serviceInfo
}
return [dict get $serviceInfo $item]
@@ -470,17 +470,17 @@
}
if {![llength $location]} {
set location [dict get $serviceArr($serviceName) location]
}
- if {![string equal $inputArgs {}]} {
+ if {$inputArgs ne {}} {
set inType $objectName.$operationName.Request
::WS::Utils::ServiceTypeDef Client $serviceName $inType $inputArgs
} else {
set inType {}
}
- if {![string equal $returnType {}]} {
+ if {$returnType ne {}} {
set outType $objectName.$operationName.Results
::WS::Utils::ServiceTypeDef Client $serviceName $outType $returnType
} else {
set outType {}
}
@@ -563,11 +563,11 @@
dict lappend serviceInfo imports $url
::WS::Utils::ProcessImportXml Client $url $xml $serviceName serviceInfo tnsCount
set serviceArr($serviceName) $serviceInfo
set result {}
foreach {result target} [dict get $serviceArr($serviceName) targetNamespace] {
- if {[string equal $target $url]} {
+ if {$target eq $url} {
break
}
}
return $result
}
@@ -609,11 +609,11 @@
#
###########################################################################
proc ::WS::Client::GetOperationList {serviceName {object {}}} {
variable serviceArr
- if {[string equal $object {}]} {
+ if {$object eq {}} {
return [dict get $serviceArr($serviceName) operList]
} else {
return [list $object [dict get $serviceArr($serviceName) operation $object inputs] [dict get $serviceArr($serviceName) operation $object outputs]]
}
@@ -842,11 +842,11 @@
if {[dict exists $serviceInfo types]} {
foreach {typeName partList} [dict get $serviceInfo types] {
set definition [dict get $partList definition]
set xns [dict get $partList xns]
set isAbstarct [dict get $partList abstract]
- if {[string equal [lindex [split $typeName {:}] 1] {}]} {
+ if {[lindex [split $typeName {:}] 1] eq {}} {
::WS::Utils::ServiceTypeDef Client $serviceName $typeName $definition tns1 $isAbstarct
} else {
#set typeName [lindex [split $typeName {:}] 1]
::WS::Utils::ServiceTypeDef Client $serviceName $typeName $definition $xns $isAbstarct
}
@@ -854,11 +854,11 @@
}
if {[dict exists $serviceInfo simpletypes]} {
foreach partList [dict get $serviceInfo simpletypes] {
lassign $partList typeName definition
- if {[string equal [lindex [split $typeName {:}] 1] {}]} {
+ if {[lindex [split $typeName {:}] 1] eq {}} {
::WS::Utils::ServiceSimpleTypeDef Client $serviceName $typeName $definition tns1
} else {
set xns [lindex [split $typeName {:}] 0]
#set typeName [lindex [split $typeName {:}] 1]
::WS::Utils::ServiceSimpleTypeDef Client $serviceName $typeName $definition $xns
@@ -931,11 +931,11 @@
set token [::WS::Utils::geturl_followRedirects $url -headers $headers]
} else {
set token [::WS::Utils::geturl_followRedirects $url]
}
::http::wait $token
- if {![string equal [::http::status $token] ok] ||
+ if {[::http::status $token] ne {ok} ||
[::http::ncode $token] != 200} {
set errorCode [list WS CLIENT HTTPERROR [::http::code $token]]
set errorInfo [FormatHTTPError $token]
::http::cleanup $token
return \
@@ -1175,16 +1175,16 @@
}
set procName [format {::%s::%s} $serviceName $operationName]
set argList {}
foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] {
set inputHeaderType [lindex $inputHeaderTypeItem 0]
- if {[string equal $inputHeaderType {}]} {
+ if {$inputHeaderType eq {}} {
continue
}
set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType]
set headerFields [dict keys [dict get $headerTypeInfo definition]]
- if {![string equal $headerFields {}]} {
+ if {$headerFields ne {}} {
lappend argList [lsort -dictionary $headerFields]
}
}
set inputMsgType [dict get $serviceInfo operation $operationName inputs]
## Petasis, 14 July 2008: If an input message has no elements, just do
@@ -1194,11 +1194,11 @@
set inputFields [dict keys [dict get $inputMsgTypeDefinition definition]]
} else {
::log::log debug "no definition found for inputMsgType $inputMsgType"
set inputFields {}
}
- if {![string equal $inputFields {}]} {
+ if {$inputFields ne {}} {
lappend argList [lsort -dictionary $inputFields]
}
set argList [join $argList]
set body {
@@ -1309,12 +1309,12 @@
##
## Check for errors
##
set body [::http::data $token]
::log::log info "\nReceived: $body"
- if {![string equal [::http::status $token] ok] ||
- ([::http::ncode $token] != 200 && [string equal $body {}])} {
+ if {[::http::status $token] ne {ok} ||
+ ( [::http::ncode $token] != 200 && $body eq {} )} {
set errorCode [list WS CLIENT HTTPERROR [::http::code $token]]
set errorInfo {}
set results [FormatHTTPError $token]
set hadError 1
} else {
@@ -1433,23 +1433,23 @@
##
## Check for errors
##
set httpStatus [::http::status $token]
- if {[string equal $httpStatus ok] && [::http::ncode $token] == 500} {
+ if {$httpStatus eq {ok} && [::http::ncode $token] == 500} {
set body [::http::data $token]
::log::log debug "\tReceived: $body"
set outTransform [dict get $serviceInfo outTransform]
- if {![string equal $outTransform {}]} {
+ if {$outTransform ne {}} {
SaveAndSetOptions $serviceName
catch {set body [$outTransform $serviceName $operationName REPLY $body]}
RestoreSavedOptions $serviceName
}
set hadError [catch {parseResults $serviceName $operationName $body} results]
if {$hadError} {
lassign $::errorCode mainError subError
- if {[string equal $mainError WSCLIENT] && [string equal $subError NOSOAP]} {
+ if {$mainError eq WSCLIENT && $subError eq NOSOAP} {
::log::log debug "\tHTTP error $body"
set results $body
set errorCode [list WSCLIENT HTTPERROR $body]
set errorInfo {}
set hadError 1
@@ -1457,21 +1457,21 @@
::log::log debug "Reply was $body"
set errorCode $::errorCode
set errorInfo $::errorInfo
}
}
- } elseif {![string equal $httpStatus ok] || [::http::ncode $token] != 200} {
+ } elseif {$httpStatus ne {ok} || [::http::ncode $token] != 200} {
::log::log debug "\tHTTP error [array get $token]"
set results [FormatHTTPError $token]
set errorCode [list WSCLIENT HTTPERROR [::http::code $token]]
set errorInfo {}
set hadError 1
} else {
set body [::http::data $token]
::log::log debug "\tReceived: $body"
set outTransform [dict get $serviceInfo outTransform]
- if {![string equal $outTransform {}]} {
+ if {$outTransform ne {}} {
SaveAndSetOptions $serviceName
catch {set body [$outTransform $serviceName $operationName REPLY $body]}
RestoreSavedOptions $serviceName
}
SaveAndSetOptions $serviceName
@@ -1535,11 +1535,11 @@
# 1 06/02/2015 H.Oehlmann Initial version
#
#
###########################################################################
proc ::WS::Client::FormatHTTPError {token} {
- if {[string equal [::http::status $token] ok]} {
+ if {[::http::status $token] eq {ok}} {
if {[::http::size $token] == 0} {
return "HTTP failure socket closed"
}
return "HTTP failure code [::http::ncode $token]"
} else {
@@ -1718,25 +1718,25 @@
}
set procName $operationName
set argList {}
foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] {
set inputHeaderType [lindex $inputHeaderTypeItem 0]
- if {[string equal $inputHeaderType {}]} {
+ if {$inputHeaderType eq {}} {
continue
}
set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType]
set headerFields [dict keys [dict get $headerTypeInfo definition]]
- if {![string equal $headerFields {}]} {
+ if {$headerFields ne {}} {
lappend argList [lsort -dictionary $headerFields]
}
}
set inputMsgType [dict get $serviceInfo operation $operationName inputs]
- if {![string equal $inputMsgType {}]} {
+ if {$inputMsgType ne {}} {
set inTypeDef [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType]
if {[dict exists $inTypeDef definition]} {
set inputFields [dict keys [dict get $inTypeDef definition]]
- if {![string equal $inputFields {}]} {
+ if {$inputFields ne {}} {
lappend argList [lsort -dictionary $inputFields]
}
}
}
set argList [join $argList]
@@ -1803,22 +1803,22 @@
foreach operationName [dict keys [dict get $serviceInfo object $object operations]] {
set procName $operationName
set argList {}
foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] {
set inputHeaderType [lindex $inputHeaderTypeItem 0]
- if {[string equal $inputHeaderType {}]} {
+ if {$inputHeaderType eq {}} {
continue
}
set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType]
set headerFields [dict keys [dict get $headerTypeInfo definition]]
- if {![string equal $headerFields {}]} {
+ if {$headerFields ne {}} {
lappend argList [lsort -dictionary $headerFields]
}
}
set inputMsgType [dict get $serviceInfo operation $operationName inputs]
set inputFields [dict keys [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] definition]]
- if {![string equal $inputFields {}]} {
+ if {$inputFields ne {}} {
lappend argList [lsort -dictionary $inputFields]
}
set argList [join $argList]
append procList "\n\t$object $procName $argList"
@@ -1878,12 +1878,12 @@
## Check for errors
##
set body [::http::data $token]
::log::log info "\nReceived: $body"
set results {}
- if {![string equal [::http::status $token] ok] ||
- ([::http::ncode $token] != 200 && [string equal $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]
} else {
SaveAndSetOptions $serviceName
@@ -1998,22 +1998,22 @@
set rootNode [$body childNodes]
::log::log debug "Have [llength $rootNode] node under Body"
if {[llength $rootNode] > 1} {
foreach tmp $rootNode {
#puts "\t Got {[$tmp localName]} looking for {$expectedMsgTypeBase}"
- if {[string equal [$tmp localName] $expectedMsgTypeBase] ||
- [string equal [$tmp nodeName] $expectedMsgTypeBase] ||
- [string equal [$tmp localName] Fault] ||
- [string equal [$tmp nodeName] Fault]} {
+ if {[$tmp localName] eq $expectedMsgTypeBase ||
+ [$tmp nodeName] eq $expectedMsgTypeBase ||
+ [$tmp localName] eq Fault ||
+ [$tmp nodeName] eq Fault} {
set rootNode $tmp
break
}
}
}
- if {([llength $rootNode] == 1) && ![string equal $rootNode {}]} {
+ if {([llength $rootNode] == 1) && $rootNode ne {}} {
set rootName [$rootNode localName]
- if {[string equal $rootName {}]} {
+ if {$rootName eq {}} {
set rootName [$rootNode nodeName]
}
} else {
set rootName {}
}
@@ -2020,20 +2020,20 @@
::log::log debug "root name is {$rootName}"
##
## See if it is a standard error packet
##
- if {[string equal $rootName {Fault}]} {
+ if {$rootName eq {Fault}} {
set faultcode {}
set faultstring {}
set detail {}
foreach item {faultcode faultstring detail} {
set tmpNode [$rootNode selectNodes ENV:$item]
- if {[string equal $tmpNode {}]} {
+ if {$tmpNode eq {}} {
set tmpNode [$rootNode selectNodes $item]
}
- if {![string equal $tmpNode {}]} {
+ if {$tmpNode ne {}} {
if {[$tmpNode hasAttribute href]} {
set tmpNode [GetReferenceNode $top [$tmpNode getAttribute href]]
}
set $item [$tmpNode asText]
}
@@ -2047,11 +2047,11 @@
}
##
## Validated that it is the expected packet type
##
- if {![string equal $rootName $expectedMsgTypeBase]} {
+ if {$rootName ne $expectedMsgTypeBase} {
$doc delete
return \
-code error \
-errorcode [list WS CLIENT BADREPLY [list $rootName $expectedMsgTypeBase]] \
"Bad reply type, received '$rootName; but expected '$expectedMsgTypeBase'."
@@ -2062,11 +2062,11 @@
##
set results {}
set headerRootNode [$top selectNodes ENV:Header]
if {[llength $headerRootNode]} {
foreach outHeaderType [dict get $serviceInfo operation $operationName soapReplyHeader] {
- if {[string equal $outHeaderType {}]} {
+ if {$outHeaderType eq {}} {
continue
}
set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $outHeaderType] xns]
set node [$headerRootNode selectNodes $outHeaderType]
if {![llength $node]} {
@@ -2082,11 +2082,11 @@
::log::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode]"
lappend results [::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode]
}
}
::log::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $rootNode $expectedMsgType $body]"
- if {![string equal $rootName {}]} {
+ if {$rootName ne {}} {
set bodyData [::WS::Utils::convertTypeToDict \
Client $serviceName $rootNode $expectedMsgType $body]
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"
set bodyData [::WS::Utils::convertTypeToDict \
@@ -2170,11 +2170,11 @@
}
}
::WS::Utils::SetOption suppressNS $inSuppressNs
set inTransform [dict get $serviceInfo inTransform]
- if {![string equal $inTransform {}]} {
+ if {$inTransform ne {}} {
set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList]
}
::log::log debug "Leaving ::WS::Client::buildCallquery with {$xml}"
return $xml
@@ -2257,11 +2257,11 @@
#parray tnsArray
set firstHeader 1
foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] {
lassign $inputHeaderTypeItem inputHeaderType attrList
- if {[string equal $inputHeaderType {}]} {
+ if {$inputHeaderType eq {}} {
continue
}
set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] xns]
if {[info exists tnsArray($xns)]} {
set xns $tnsArray($xns)
@@ -2381,11 +2381,11 @@
$env setAttribute xmlns:$tns $target
}
set firstHeader 1
foreach inputHeaderType [dict get $serviceInfo operation $operationName soapRequestHeader] {
- if {[string equal $inputHeaderType {}]} {
+ if {$inputHeaderType eq {}} {
continue
}
set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] xns]
if {$firstHeader} {
$env appendChild [$doc createElement "SOAP-ENV:Header" header]
@@ -2716,11 +2716,11 @@
set operList [$binding selectNodes w:operation]
set styleNode [$binding selectNodes d:binding]
if {![info exists style]} {
if {[catch {$styleNode getAttribute style} tmpStyle]} {
set styleNode [$binding selectNodes {w:operation[1]/d:operation}]
- if {[string equal $styleNode {}]} {
+ if {$styleNode eq {}} {
##
## This binding is for a SOAP level other than 1.1
##
::log:::log debug "Skiping non-SOAP 1.1 binding [$binding asXML]"
continue
@@ -2729,22 +2729,22 @@
#puts "Using style for first operation {$style}"
} else {
set style $tmpStyle
#puts "Using style for first binding {$style}"
}
- if {!([string equal $style document] || [string equal $style rpc])} {
+ if {!($style eq {document} || $style eq {rpc} )} {
::log:::log debug "Leaving [lindex [info level 0] 0] with error @1"
return \
-code error \
-errorcode [list WS CLIENT UNSSTY $style] \
"Unsupported calling style: '$style'"
}
if {![info exists use]} {
set use [[$binding selectNodes {w:operation[1]/w:input/d:body}] getAttribute use]
- if {!([string equal $style document] && [string equal $use literal]) &&
- !([string equal $style rpc] && [string equal $use encoded])} {
+ if {!($style eq {document} && $use eq {literal} ) &&
+ !($style eq {rpc} && $use eq {encoded} )} {
::log:::log debug "Leaving [lindex [info level 0] 0] with error @2"
return \
-code error \
-errorcode [list WS CLIENT UNSMODE $use] \
"Unsupported mode: $style/$use"
@@ -2800,11 +2800,11 @@
dict set serviceInfo operation $operName isClone 0
}
#puts "Processing operation $operName"
set actionNode [$oper selectNodes d:operation]
- if {[string equal $actionNode {}]} {
+ if {$actionNode eq {}} {
::log:::log debug "Skiping operation with no action [$oper asXML]"
continue
}
dict lappend serviceInfo operList $operName
dict set serviceInfo operation $operName cloneList {}
@@ -2828,11 +2828,11 @@
##
set soapRequestHeaderList {{}}
foreach inHeader [$oper selectNodes w:input/d:header] {
##set part [$inHeader getAttribute part]
set tmp [$inHeader getAttribute use]
- if {![string equal $tmp $use]} {
+ if {$tmp ne $use} {
::log:::log debug "Leaving [lindex [info level 0] 0] with error @3"
return \
-code error \
-errorcode [list WS CLIENT MIXUSE $use $tmp] \
"Mixed usageage not supported!'"
@@ -2852,11 +2852,11 @@
##
set soapReplyHeaderList {{}}
foreach outHeader [$oper selectNodes w:output/d:header] {
##set part [$outHeader getAttribute part]
set tmp [$outHeader getAttribute use]
- if {![string equal $tmp $use]} {
+ if {$tmp ne $use} {
::log:::log debug "Leaving [lindex [info level 0] 0] with error @4"
return \
-code error \
-errorcode [list WS CLIENT MIXUSE $use $tmp] \
"Mixed usageage not supported!'"
@@ -2875,11 +2875,11 @@
set inUse $use
set outUse $use
catch {set inUse [[$oper selectNodes w:input/d:body] getAttribute use]}
catch {set outUse [[$oper selectNodes w:output/d:body] getAttribute use]}
foreach tmp [list $inUse $outUse] {
- if {![string equal $tmp $use]} {
+ if {$tmp ne $use} {
::log:::log debug "Leaving [lindex [info level 0] 0] with error @5"
return \
-code error \
-errorcode [list WS CLIENT MIXUSE $use $tmp] \
"Mixed usageage not supported!'"
@@ -2894,11 +2894,11 @@
if {[dict exists $serviceInfo inputMessages $inMessage] } {
set operList [dict get $serviceInfo inputMessages $inMessage]
} else {
set operList {}
}
- lappend operList $operName
+ lappend operList $operName
dict set serviceInfo inputMessages $inMessage $operList
##
## Handle target namespace defined at WSDL level for older RPC/Encoded
##
@@ -2966,35 +2966,35 @@
set inType {}
set outType {}
#set portQuery [format {w:portType[attribute::name='%s']} $portName]
#set portNode [lindex [$wsdlNode selectNodes $portQuery] 0]
- if {[string equal $inName {}]} {
+ if {$inName eq {}} {
set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']} \
$portName $operName]
} else {
set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']/w:input[attribute::name='%s']/parent::*} \
$portName $operName $inName]
}
::log:::log debug "\t operNode query is {$operQuery}"
set operNode [$wsdlNode selectNodes $operQuery]
- if {[string equal $operNode {}] && ![string equal $inName {}]} {
+ if {$operNode eq {} && $inName ne {}} {
set operQuery [format {w:portType[attribute::name='%s']/w:operation[attribute::name='%s']} \
$portName $operName]
::log:::log debug "\t operNode query is {$operQuery}"
set operNode [$wsdlNode selectNodes $operQuery]
}
set inputMsgNode [$operNode selectNodes {w:input}]
- if {![string equal $inputMsgNode {}]} {
+ if {$inputMsgNode ne {}} {
set inputMsgPath [$inputMsgNode getAttribute message]
set inputMsg [lindex [split $inputMsgPath {:}] end]
set inType [messageToType $wsdlNode $serviceName $operName $inputMsg serviceInfo $style]
}
set outputMsgNode [$operNode selectNodes {w:output}]
- if {![string equal $outputMsgNode {}]} {
+ if {$outputMsgNode ne {}} {
set outputMsgPath [$outputMsgNode getAttribute message]
set outputMsg [lindex [split $outputMsgPath {:}] end]
set outType [messageToType $wsdlNode $serviceName $operName $outputMsg serviceInfo $style]
}
@@ -3053,17 +3053,17 @@
#puts "Message to Type $serviceName $operName $msgName"
set msgQuery [format {w:message[attribute::name='%s']} $msgName]
set msg [$wsdlNode selectNodes $msgQuery]
- if {[string equal $msg {}] &&
+ if {$msg eq {} &&
[llength [set msgNameList [split $msgName {:}]]] > 1} {
set tmpMsgName [join [lrange $msgNameList 1 end] {:}]
set msgQuery [format {w:message[attribute::name='%s']} $tmpMsgName]
set msg [$wsdlNode selectNodes $msgQuery]
}
- if {[string equal $msg {}]} {
+ if {$msg eq {}} {
return \
-code error \
-errorcode [list WS CLIENT BADMSGSEC $msgName] \
"Can not find message '$msgName'"
}
@@ -3200,11 +3200,11 @@
return \
-code error \
-errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \
"Unknown operation '$operationName' for object '$objectName' of service '$serviceName'"
}
- if {![string equal $location {}]} {
+ if {$location ne {}} {
set url $location
} else {
set url [dict get $serviceInfo object $objectName location]
}
SaveAndSetOptions $serviceName
@@ -3228,12 +3228,12 @@
##
## Check for errors
##
set body [::http::data $token]
- if {![string equal [::http::status $token] ok] ||
- ([::http::ncode $token] != 200 && [string equal $body {}])} {
+ if {[::http::status $token] ne {ok} ||
+ ( [::http::ncode $token] != 200 && $body eq {} )} {
set errorCode [list WS CLIENT HTTPERROR [::http::code $token]]
set errorInfo {}
set results [FormatHTTPError $token]
set hadError 1
} else {
@@ -3325,11 +3325,11 @@
return \
-code error \
-errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \
"Unknown operation '$operationName' for object '$objectName' of service '$serviceName'"
}
- if {![string equal $location {}]} {
+ if {$location ne {}} {
set url $location
} else {
set url [dict get $serviceInfo object $objectName location]
}
SaveAndSetOptions $serviceName
@@ -3357,12 +3357,12 @@
set body [::http::data $token]
::log::log info "\tReceived: $body"
set httpStatus [::http::status $token]
set hadError 0
set results {}
- if {![string equal $httpStatus ok] ||
- ([::http::ncode $token] != 200 && [string equal $body {}])} {
+ if {$httpStatus ne {ok} ||
+ ( [::http::ncode $token] != 200 && $body eq {} )} {
::log::log debug "\tHTTP error [array get $token]"
set results [FormatHTTPError $token]
set errorCode [list WS CLIENT HTTPERROR [::http::code $token]]
set errorInfo {}
set hadError 1
@@ -3588,11 +3588,11 @@
#regsub "\]*>\n" [::dom::DOMImplementation serialize $doc] {} xml
$doc delete
set xml [encoding convertto $encoding $xml]
set inTransform [dict get $serviceInfo inTransform]
- if {![string equal $inTransform {}]} {
+ if {$inTransform ne {}} {
set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList]
}
::log::log debug "Leaving ::WS::Client::buildRestCallquery with {$xml}"
@@ -3652,11 +3652,11 @@
if {$first > 0} {
set inXML [string range $inXML $first end]
}
set serviceInfo $serviceArr($serviceName)
set outTransform [dict get $serviceInfo outTransform]
- if {![string equal $outTransform {}]} {
+ if {$outTransform ne {}} {
set inXML [$outTransform $serviceName $operationName REPLY $inXML]
}
set expectedMsgType [dict get $serviceInfo object $objectName operation $operationName outputs]
dom parse $inXML doc
$doc documentElement top
@@ -3669,11 +3669,11 @@
set status [$body getAttribute status]
##
## See if it is a standard error packet
##
- if {![string equal $status {ok}]} {
+ if {$status ne {ok}} {
set faultstring {}
if {[catch {set faultstring [[$body selectNodes error] asText]}]} {
catch {set faultstring [[$body selectNodes error] asText]}
}
$doc delete
@@ -3690,14 +3690,14 @@
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]"
- if {![string equal $expectedMsgType {}]} {
+ if {$expectedMsgType ne {}} {
set node [$body childNodes]
set nodeName [$node nodeName]
- if {![string equal $objectName $nodeName]} {
+ if {$objectName ne $nodeName} {
return \
-code error \
-errorcode [list WS CLIENT BADRESPONSE [list $objectName $nodeName]] \
-errorinfo {} \
"Unexpected message type {$nodeName}, expected {$objectName}"
@@ -3763,12 +3763,12 @@
##
## Check for errors
##
set body [::http::data $token]
::log::log info "\nReceived: $body"
- if {![string equal [::http::status $token] ok] ||
- ([::http::ncode $token] != 200 && [string equal $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]
} else {
SaveAndSetOptions $serviceName
Index: Embedded.tcl
==================================================================
--- Embedded.tcl
+++ Embedded.tcl
@@ -42,11 +42,11 @@
package require uri
package require base64
package require html
package require log
-package provide WS::Embeded 2.3.0
+package provide WS::Embeded 2.4.0
namespace eval ::WS::Embeded {
array set portInfo {}
Index: ServerSide.tcl
==================================================================
--- ServerSide.tcl
+++ ServerSide.tcl
@@ -37,16 +37,16 @@
## POSSIBILITY OF SUCH DAMAGE. ##
## ##
###############################################################################
package require Tcl 8.4
-package require WS::Utils 2.3.7 ; # provides dict
+package require WS::Utils 2.4 ; # provides dict
package require html
package require log
package require tdom
-package provide WS::Server 2.3.7
+package provide WS::Server 2.4.0
namespace eval ::WS::Server {
array set ::WS::Server::serviceArr {}
set ::WS::Server::procInfo {}
set ::WS::Server::mode {}
@@ -126,10 +126,16 @@
# -traceEnabled - Boolean to enable/disable trace being passed back in exception
# Defaults to "Y"
# -docFormat - Format of the documentation for operations ("text" or "html").
# Defaults to "text"
# -stylesheet - The CSS stylesheet URL used in the HTML documentation
+# -errorCallback - Callback to be invoked in the event of an error being produced
+# -verifyUserArgs - Boolean to enable/disable validating user supplied arguments
+# Defaults to "N"
+# -enforceRequired - Throw an error if a required field is not included in the
+# response.
+# Defaults to "N"
#
#
# Returns : Nothing
#
# Side-Effects : None
@@ -173,10 +179,14 @@
-mode {tclhttpd}
-ports {80}
-traceEnabled {Y}
-docFormat {text}
-stylesheet {}
+ -beautifyJson {N}
+ -errorCallback {}
+ -verifyUserArgs {N}
+ -enforceRequired {N}
}
array set defaults $args
if {[string equal $defaults(-mode) channel]} {
set defaults(-ports) {stdin stdout}
array set defaults $args
@@ -198,23 +208,23 @@
if {![info exists defaults(-prefix)]} {
set defaults(-prefix) /service/$service
}
# find default host
if {![info exists defaults(-host)]} {
- switch -exact -- $defaults(-mode) {
- embedded {
- set me [socket -server garbage_word -myaddr [info hostname] 0]
- set defaults(-host) [lindex [fconfigure $me -sockname] 0]
- close $me
- if {0 !=[llength $defaults(-ports)] && 80 != [lindex $defaults(-ports) 0]} {
- append defaults(-host) ":[lindex $defaults(-ports) 0]"
- }
- }
- default {
- set defaults(-host) localhost
- }
- }
+ switch -exact -- $defaults(-mode) {
+ embedded {
+ set me [socket -server garbage_word -myaddr [info hostname] 0]
+ set defaults(-host) [lindex [fconfigure $me -sockname] 0]
+ close $me
+ if {0 !=[llength $defaults(-ports)] && 80 != [lindex $defaults(-ports) 0]} {
+ append defaults(-host) ":[lindex $defaults(-ports) 0]"
+ }
+ }
+ default {
+ set defaults(-host) localhost
+ }
+ }
}
set defaults(-uri) $service
namespace eval ::$service {}
set serviceArr($service) [array get defaults]
@@ -242,11 +252,11 @@
}
wub {
package require WS::Wub
}
aolserver {
- package require WS::AOLserver
+ package require WS::AOLserver
}
rivet {
package require Rivet
}
wibble {
@@ -728,15 +738,15 @@
"text/xml; charset=UTF-8" \
"
Webservice Error$msg
" \
404
}
rivet {
- headers type text/html
+ headers type "text/html; charset=UTF-8"
headers numeric 404
puts "Webservice Error$msg
"
}
- aolserver {
+ aolserver {
::WS::AOLserver::ReturnData \
$sock \
text/html \
"Webservice Error$msg
" \
404
@@ -773,11 +783,11 @@
set xml [GetWsdl $serviceName]
::WS::Embeded::ReturnData $sock "text/xml; charset=UTF-8" $xml 200
}
rivet {
set xml [GetWsdl $serviceName]
- headers type text/xml
+ headers type "text/xml; charset=UTF-8"
headers numeric 200
puts $xml
}
aolserver {
set xml [GetWsdl $serviceName]
@@ -840,10 +850,155 @@
array set serviceData $serviceArr($serviceName)
set targetNamespace "http://$serviceData(-host)$serviceData(-prefix)"
return [::WS::Utils::GenerateScheme $mode $serviceName $doc $parent $targetNamespace]
}
+
+
+###########################################################################
+#
+# Private Procedure Header - as this procedure is modified, please be sure
+# that you update this header block. Thanks.
+#
+#>>BEGIN PRIVATE<<
+#
+# Procedure Name : ::WS::Server::generateJsonInfo
+#
+# Description : Generate an json description of the service, the operations
+# and all applicable type definitions.
+#
+# Arguments :
+# serviceName - The name of the service
+# sock - The socket to return the WSDL on
+# args - not used
+#
+# Returns :
+# 1 - On error
+# 0 - On success
+#
+# Side-Effects : None
+#
+# Exception Conditions : None
+#
+# Pre-requisite Conditions : None
+#
+# Original Author : James Sulak
+#
+#>>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
+# ------- ---------- ---------- -------------------------------------------
+# 1 05/16/2012 J.Sulak Initial version
+#
+#
+###########################################################################
+# NOTE: This proc only works with Rivet
+# TODO: Update to handle jsonp?
+proc ::WS::Server::generateJsonInfo { service sock args } {
+ variable serviceArr
+ variable procInfo
+
+ ::log::log debug "Generating JSON Documentation for $service on $sock with {$args}"
+ set serviceInfo $serviceArr($service)
+ array set serviceData $serviceInfo
+ set doc [yajl create #auto -beautify $serviceData(-beautifyJson)]
+
+ $doc map_open
+
+ $doc string operations array_open
+ ::log::log debug "\tDisplay Operations (json)"
+
+ foreach oper [lsort -dictionary [dict get $procInfo $service operationList]] {
+ $doc map_open
+
+ # operation name
+ $doc string name string $oper
+
+ # description
+ set description [dict get $procInfo $service op$oper docs]
+ $doc string description string $description
+
+ # parameters
+ if {[llength [dict get $procInfo $service op$oper argOrder]]} {
+ $doc string inputs array_open
+
+ foreach arg [dict get $procInfo $service op$oper argOrder] {
+ ::log::log debug "\t\t\tDisplaying '$arg'"
+ if {[dict exists $procInfo $service op$oper argList $arg comment]} {
+ set comment [dict get $procInfo $service op$oper argList $arg comment]
+ } else {
+ set comment {}
+ }
+
+ set type [dict get $procInfo $service op$oper argList $arg type]
+
+ $doc map_open string name string $arg string type string $type string comment string $comment map_close
+ }
+
+ $doc array_close
+ } else {
+ $doc string inputs array_open array_close
+ }
+
+ $doc string returns map_open
+
+ if {[dict exists $procInfo $service op$oper returnInfo comment]} {
+ set comment [dict get $procInfo $service op$oper returnInfo comment]
+ } else {
+ set comment {}
+ }
+
+ set type [dict get $procInfo $service op$oper returnInfo type]
+
+ $doc string comment string $comment string type string $type
+ $doc map_close
+
+ $doc map_close
+ }
+
+ $doc array_close
+
+ ::log::log debug "\tDisplay custom types"
+ $doc string types array_open
+ set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $service]
+ foreach type [lsort -dictionary [dict keys $localTypeInfo]] {
+ ::log::log debug "\t\tDisplaying '$type'"
+
+ $doc map_open
+ $doc string name string $type
+ $doc string fields array_open
+
+ set typeDetails [dict get $localTypeInfo $type definition]
+ foreach part [lsort -dictionary [dict keys $typeDetails]] {
+ ::log::log debug "\t\t\tDisplaying '$part'"
+ set subType [dict get $typeDetails $part type]
+ set comment {}
+ if {[dict exists $typeDetails $part comment]} {
+ set comment [dict get $typeDetails $part comment]
+ }
+ $doc map_open string field string $part string type string $subType string comment string $comment map_close
+ }
+
+ $doc array_close
+ $doc map_close
+ }
+
+ $doc array_close
+
+ $doc map_close
+
+ set contentType "application/json; charset=UTF-8"
+ headers type $contentType
+ headers numeric 200
+ puts [$doc get]
+ $doc delete
+}
+
###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
# that you update this header block. Thanks.
@@ -989,11 +1144,11 @@
channel {
::WS::Channel::ReturnData $sock "text/html; charset=UTF-8" $msg 200
}
rivet {
headers numeric 200
- headers type text/html
+ headers type "text/html; charset=UTF-8"
puts $msg
}
aolserver {
::WS::AOLserver::ReturnData $sock text/html $msg 200
}
@@ -1044,11 +1199,11 @@
# 1 07/06/2006 G.Lester Initial version
#
#
###########################################################################
proc ::WS::Server::displayType {serviceName type} {
- set testType [string trimright $type {()}]
+ set testType [string trimright $type {()?}]
if {([lindex [::WS::Utils::TypeInfo Server $serviceName $testType] 0] == 0) &&
([info exists ::WS::Utils::simpleTypes($testType)])} {
set result $type
} else {
set result [format {%2$s} $testType $type]
@@ -1117,10 +1272,16 @@
default {
upvar #0 Httpd$sock data
set inXML $data(query)
}
}
+
+ # decide if SOAP or REST mode should be used.
+ set flavor "soap"
+ if {[lsearch -exact $args "-rest"] != -1} {
+ set flavor "rest"
+ }
::log::log debug "In ::WS::Server::callOperation {$service $sock $args}"
array set serviceInfo $serviceArr($service)
::log::log debug "\tDocument is {$inXML}"
@@ -1128,83 +1289,121 @@
set ::errorCode {}
set ns $service
set inTransform $serviceInfo(-intransform)
set outTransform $serviceInfo(-outtransform)
- set first [string first {<} $inXML]
- if {$first > 0} {
- set inXML [string range $inXML $first end]
- }
+ # set first [string first {<} $inXML]
+ # if {$first > 0} {
+ # set inXML [string range $inXML $first end]
+ # }
if {![string equal $inTransform {}]} {
set inXML [$inTransform REQUEST $inXML]
}
- dom parse $inXML doc
- $doc documentElement top
- ::log::log debug [list $doc selectNodesNamespaces \
- [list ENV http://schemas.xmlsoap.org/soap/envelope/ \
- $service http://$serviceInfo(-host)$serviceInfo(-prefix)]]
- $doc selectNodesNamespaces \
- [list ENV http://schemas.xmlsoap.org/soap/envelope/ \
- $service http://$serviceInfo(-host)$serviceInfo(-prefix)]
- $doc documentElement rootNode
-
-
- ##
- ## Determine the name of the method being invoked.
- ##
- set top [$rootNode selectNodes /ENV:Envelope/ENV:Body/*]
- catch {$top localName} requestMessage
- set legacyRpcMode 0
- if {$requestMessage == ""} {
- # older RPC/Encoded clients need to try nodeName instead.
- # Python pySoap needs this.
- catch {$top nodeName} requestMessage
- set legacyRpcMode 1
- }
- ::log::log debug "requestMessage = {$requestMessage}"
- if {[string match {*Request} $requestMessage]} {
- set operation [string range $requestMessage 0 end-7]
- } else {
- # broken clients might not have sent the correct Document Wrapped name.
- # Python pySoap and Perl SOAP::Lite need this.
- set operation $requestMessage
- set legacyRpcMode 1
- }
-
+
+ # Get a reference to the error callback
+ set errorCallback $serviceInfo(-errorCallback)
+
+ ##
+ ## Parse the input and determine the name of the method being invoked.
+ ##
+ switch -exact -- $flavor {
+ rest {
+ package require yajltcl ; # only needed for rest, not soap.
+
+ set operation [lindex $inXML 0]
+ set contentType "application/json"
+ set doc ""
+
+ array set rawargs [lindex $inXML 1]
+ if {[info exists rawargs(jsonp_callback)]} {
+ if {![regexp {^[a-zA-Z_0-9]+$} $rawargs(jsonp_callback)]} {
+ # sanitize the JSONP callback function name for security.
+ set rawargs(jsonp_callback) FlightXmlCallback
+ }
+ set contentType "text/javascript"
+ }
+ }
+ soap {
+ # parse the XML request
+ dom parse $inXML doc
+ $doc documentElement top
+ ::log::log debug [list $doc selectNodesNamespaces \
+ [list ENV http://schemas.xmlsoap.org/soap/envelope/ \
+ $service http://$serviceInfo(-host)$serviceInfo(-prefix)]]
+ $doc selectNodesNamespaces \
+ [list ENV http://schemas.xmlsoap.org/soap/envelope/ \
+ $service http://$serviceInfo(-host)$serviceInfo(-prefix)]
+ $doc documentElement rootNode
+
+ # extract the name of the method
+ set top [$rootNode selectNodes /ENV:Envelope/ENV:Body/*]
+ catch {$top localName} requestMessage
+ set legacyRpcMode 0
+ if {$requestMessage == ""} {
+ # older RPC/Encoded clients need to try nodeName instead.
+ # Python pySoap needs this.
+ catch {$top nodeName} requestMessage
+ set legacyRpcMode 1
+ }
+ ::log::log debug "requestMessage = {$requestMessage}"
+ if {[string match {*Request} $requestMessage]} {
+ set operation [string range $requestMessage 0 end-7]
+ } else {
+ # broken clients might not have sent the correct Document Wrapped name.
+ # Python pySoap and Perl SOAP::Lite need this.
+ set operation $requestMessage
+ set legacyRpcMode 1
+ }
+ set contentType "text/xml"
+ }
+ default {
+ if {$errorCallback ne {}} { $errorCallback "BAD_FLAVOR No supported protocol" {} "UnknownMethod" $flavor }
+ error "bad flavor"
+ }
+ }
##
## Check that the method exists.
##
if {![dict exists $procInfo $service op$operation argList]} {
set msg "Method $operation not found"
::log::log error $msg
set ::errorInfo {}
set ::errorCode [list Server UNKNOWN_METHOD $operation]
- set xml [generateError \
+ set response [generateError \
$serviceInfo(-traceEnabled) \
CLIENT \
$msg \
- [list "errorCode" $::errorCode "stackTrace" $::errorInfo]]
+ [list "errorCode" $::errorCode "stackTrace" $::errorInfo] \
+ $flavor]
catch {$doc delete}
- ::log::log debug "Leaving @ error 1::WS::Server::callOperation $xml"
+ set httpStatus 404
+ if {$errorCallback ne {}} { $errorCallback "UNKNOWN_METHOD $msg" httpStatus $operation $flavor }
+ ::log::log debug "Leaving @ error 1::WS::Server::callOperation $response"
+
+ # wrap in JSONP
+ if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
+ set response "$rawargs(jsonp_callback)($response)"
+ }
+
switch -exact -- $mode {
tclhttpd {
- ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 500
+ ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus
}
embedded {
- ::WS::Embeded::ReturnData $sock "text/xml; charset=UTF-8" $xml 500
+ ::WS::Embeded::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus
}
rivet {
- headers type text/xml
- headers numeric 500
- puts $xml
+ headers type "$contentType; charset=UTF-8"
+ headers numeric $httpStatus
+ puts $response
}
aolserver {
- ::WS::AOLserver::ReturnData $sock text/xml $xml 500
+ ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus
}
wibble {
- ::WS::Wibble::ReturnData responseDict text/xml $xml 500
+ ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus
}
default {
## Do nothing
}
}
@@ -1217,112 +1416,174 @@
##
## Parse the arguments for the method.
##
set argInfo [dict get $procInfo $ns $cmdName argList]
if {[catch {
- foreach pass [list 1 2 3] {
- set tclArgList {}
- set gotAnyArgs 0
- set argIndex 0
- foreach argName [dict get $procInfo $ns $cmdName argOrder] {
- set argType [string trim [dict get $argInfo $argName type]]
- set typeInfoList [::WS::Utils::TypeInfo Server $service $argType]
- if {$pass == 1} {
- # access arguments by name using full namespace
- set path $service:$argName
- set node [$top selectNodes $path]
- } elseif {$pass == 2} {
- # legacyRpcMode only, access arguments by unqualified name
- set path $argName
- set node [$top selectNodes $path]
- } else {
- # legacyRpcMode only, access arguments by index
- set path "legacy argument index $argIndex"
- set node [lindex [$top childNodes] $argIndex]
- incr argIndex
- }
- if {[string equal $node {}]} {
- ::log::log debug "did not find argument for $argName using $path, leaving blank"
- lappend tclArgList {}
- continue
- }
- ::log::log debug "found argument $argName using $path, processing $node"
- set gotAnyArgs 1
- switch -exact -- $typeInfoList {
- {0 0} {
- ##
- ## Simple non-array
- ##
- lappend tclArgList [$node asText]
- }
- {0 1} {
- ##
- ## Simple array
- ##
- set tmp {}
- foreach row $node {
- lappend tmp [$row asText]
- }
- lappend tclArgList $tmp
- }
- {1 0} {
- ##
- ## Non-simple non-array
- ##
- lappend tclArgList [::WS::Utils::convertTypeToDict Server $service $node $argType $top]
- }
- {1 1} {
- ##
- ## Non-simple array
- ##
- set tmp {}
- set argType [string trimright $argType {()}]
- foreach row $node {
- lappend tmp [::WS::Utils::convertTypeToDict Server $service $row $argType $top]
- }
- lappend tclArgList $tmp
- }
- default {
- ## Do nothing
- }
- }
- }
- ::log::log debug "gotAnyArgs $gotAnyArgs, legacyRpcMode $legacyRpcMode"
- if {$gotAnyArgs || !$legacyRpcMode} break
+ # Check that all supplied arguments are valid
+ set methodArgs [dict get $procInfo $ns $cmdName argOrder]
+ if {$serviceInfo(-verifyUserArgs)} {
+ foreach {key value} [array get rawargs] {
+ if {[lsearch -exact $methodArgs $key] == -1} {
+ error "Invalid argument '$key' supplied"
+ }
+ }
+ }
+ switch -exact -- $flavor {
+ rest {
+ set tclArgList {}
+ foreach argName $methodArgs {
+ set argType [string trim [dict get $argInfo $argName type]]
+ set typeInfoList [::WS::Utils::TypeInfo Server $service $argType]
+
+ if {![info exists rawargs($argName)]} {
+ ::log::log debug "did not find argument for $argName, leaving blank"
+ lappend tclArgList {}
+ continue
+ }
+
+ switch -exact -- $typeInfoList {
+ {0 0} {
+ ## Simple non-array
+ lappend tclArgList $rawargs($argName)
+ }
+ {0 1} {
+ ## Simple array
+ lappend tclArgList $rawargs($argName)
+ }
+ {1 0} {
+ ## Non-simple non-array
+ error "TODO JSON"
+ #lappend tclArgList [::WS::Utils::convertTypeToDict Server $service $node $argType $top]
+ }
+ {1 1} {
+ ## Non-simple array
+ error "TODO JSON"
+ #set tmp {}
+ #set argType [string trimright $argType {()?}]
+ #foreach row $node {
+ # lappend tmp [::WS::Utils::convertTypeToDict Server $service $row $argType $top]
+ #}
+ #lappend tclArgList $tmp
+ }
+ default {
+ ## Do nothing
+ }
+ }
+
+ }
+ }
+ soap {
+ foreach pass [list 1 2 3] {
+ set tclArgList {}
+ set gotAnyArgs 0
+ set argIndex 0
+ foreach argName $methodArgs {
+ set argType [string trim [dict get $argInfo $argName type]]
+ set typeInfoList [::WS::Utils::TypeInfo Server $service $argType]
+ if {$pass == 1} {
+ # access arguments by name using full namespace
+ set path $service:$argName
+ set node [$top selectNodes $path]
+ } elseif {$pass == 2} {
+ # legacyRpcMode only, access arguments by unqualified name
+ set path $argName
+ set node [$top selectNodes $path]
+ } else {
+ # legacyRpcMode only, access arguments by index
+ set path "legacy argument index $argIndex"
+ set node [lindex [$top childNodes] $argIndex]
+ incr argIndex
+ }
+ if {[string equal $node {}]} {
+ ::log::log debug "did not find argument for $argName using $path, leaving blank"
+ lappend tclArgList {}
+ continue
+ }
+ ::log::log debug "found argument $argName using $path, processing $node"
+ set gotAnyArgs 1
+ switch -exact -- $typeInfoList {
+ {0 0} {
+ ## Simple non-array
+ lappend tclArgList [$node asText]
+ }
+ {0 1} {
+ ## Simple array
+ set tmp {}
+ foreach row $node {
+ lappend tmp [$row asText]
+ }
+ lappend tclArgList $tmp
+ }
+ {1 0} {
+ ## Non-simple non-array
+ set argType [string trimright $argType {?}]
+ lappend tclArgList [::WS::Utils::convertTypeToDict Server $service $node $argType $top]
+ }
+ {1 1} {
+ ## Non-simple array
+ set tmp {}
+ set argType [string trimright $argType {()?}]
+ foreach row $node {
+ lappend tmp [::WS::Utils::convertTypeToDict Server $service $row $argType $top]
+ }
+ lappend tclArgList $tmp
+ }
+ default {
+ ## Do nothing
+ }
+ }
+ }
+ ::log::log debug "gotAnyArgs $gotAnyArgs, legacyRpcMode $legacyRpcMode"
+ if {$gotAnyArgs || !$legacyRpcMode} break
+ }
+ }
+ default {
+ if {$errorCallback ne {}} { $errorCallback "BAD_FLAVOR No supported protocol" {} $operation $flavor }
+ error "invalid flavor"
+ }
}
::log::log debug "finalargs $tclArgList"
} errMsg]} {
::log::log error $errMsg
set localerrorCode $::errorCode
set localerrorInfo $::errorInfo
- set xml [generateError \
+ set response [generateError \
$serviceInfo(-traceEnabled) \
CLIENT \
"Error Parsing Arguments -- $errMsg" \
- [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo]]
+ [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \
+ $flavor]
catch {$doc delete}
- ::log::log debug "Leaving @ error 3::WS::Server::callOperation $xml"
+ set httpStatus 400
+ if {$errorCallback ne {}} { $errorCallback "INVALID_ARGUMENT $errMsg" httpStatus $operation $flavor }
+ ::log::log debug "Leaving @ error 3::WS::Server::callOperation $response"
+
+ # wrap in JSONP
+ if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
+ set response "$rawargs(jsonp_callback)($response)"
+ }
+
switch -exact -- $mode {
tclhttpd {
- ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 500
+ ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus
}
embedded {
- ::WS::Embeded::ReturnData $sock "text/xml; charset=UTF-8" $xml 500
+ ::WS::Embeded::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus
}
channel {
- ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $xml 500
+ ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus
}
rivet {
- headers type text/xml
- headers numeric 500
- puts $xml
+ headers type "$contentType; charset=UTF-8"
+ headers numeric $httpStatus
+ puts $response
}
aolserver {
- ::WS::AOLserver::ReturnData $sock text/xml $xml 500
+ ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus
}
wibble {
- ::WS::Wibble::ReturnData responseDict text/xml $xml 500
+ ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus
}
default {
## Do nothing
}
}
@@ -1373,44 +1634,54 @@
}
}
eval $cmd
set results [eval \$methodName $tclArgList]
# generate a reply packet
- set xml [generateReply $ns $baseName $results]
- # regsub "\]+>\n" $xml {} xml
+ set response [generateReply $ns $baseName $results $flavor]
+
+ # wrap in JSONP
+ if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
+ set response "$rawargs(jsonp_callback)($response)"
+ }
+
+ # mangle the XML declaration
+ if {$flavor == "soap"} {
+ # regsub "\]+>\n" $response {} response
+ set response [string map {{} {}} $response]
+ }
+
catch {$doc delete}
- set xml [string map {{} {}} $xml]
if {![string equal $outTransform {}]} {
- set xml [$outTransform REPLY $xml $operation $results]
+ set response [$outTransform REPLY $response $operation $results]
}
if {[info exists serviceInfo(-postmonitor)] &&
[string length $serviceInfo(-postmonitor)]} {
set precmd $serviceInfo(-postmonitor)
lappend precmd POST $service $operation OK $results
catch $precmd
}
- ::log::log debug "Leaving ::WS::Server::callOperation $xml"
+ ::log::log debug "Leaving ::WS::Server::callOperation $response"
switch -exact -- $mode {
tclhttpd {
- ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 200
+ ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response 200
}
embedded {
- ::WS::Embeded::ReturnData $sock "text/xml; charset=UTF-8" $xml 200
+ ::WS::Embeded::ReturnData $sock "$contentType; charset=UTF-8" $response 200
}
channel {
- ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $xml 200
+ ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response 200
}
rivet {
- headers type text/xml
+ headers type "$contentType; charset=UTF-8"
headers numeric 200
- puts $xml
+ puts $response
}
aolserver {
- ::WS::AOLserver::ReturnData $sock text/xml $xml 200
+ ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response 200
}
wibble {
- ::WS::Wibble::ReturnData responseDict text/xml $xml 200
+ ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response 200
}
default {
## Do nothing
}
}
@@ -1424,37 +1695,50 @@
[string length $serviceInfo(-postmonitor)]} {
set precmd $serviceInfo(-postmonitor)
lappend precmd POST $service $operation ERROR $msg
catch $precmd
}
- set xml [generateError \
+ set response [generateError \
$serviceInfo(-traceEnabled) \
CLIENT \
$msg \
- [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo]]
+ [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \
+ $flavor]
catch {$doc delete}
- ::log::log debug "Leaving @ error 2::WS::Server::callOperation $xml"
+ set httpStatus 500
+ if {$errorCallback ne {}} { $errorCallback $msg httpStatus $operation $flavor }
+ ::log::log debug "Leaving @ error 2::WS::Server::callOperation $response"
+
+ # wrap in JSONP
+ if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} {
+ set response "$rawargs(jsonp_callback)($response)"
+ }
+
switch -exact -- $mode {
tclhttpd {
- ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 500
+ ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus
}
embedded {
- ::WS::Embeded::ReturnData $sock "text/xml; charset=UTF-8" $xml 500
+ ::WS::Embeded::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus
}
channel {
- ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $xml 500
+ ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus
}
rivet {
- headers type text/xml
- headers numeric 500
- puts $xml
+ if {[lindex $localerrorCode 0] == "RIVET" && [lindex $localerrorCode 1] == "ABORTPAGE"} {
+ # if we caught an abort_page, then re-trigger it.
+ abort_page
+ }
+ headers type "$contentType; charset=UTF-8"
+ headers numeric $httpStatus
+ puts $response
}
aolserver {
- ::WS::AOLserver::ReturnData $sock text/xml $xml 500
+ ::WS::AOLserver::ReturnData $sock $contentType $response $httpStatus
}
wibble {
- ::WS::Wibble::ReturnData responseDict text/xml $xml 500
+ ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus
}
default {
## Do nothing
}
}
@@ -1477,10 +1761,11 @@
# Arguments :
# includeTrace - Boolean indicate if the trace is to be included.
# faultcode - The code describing the error
# faultstring - The string describing the error.
# detail - Optional details of error.
+# flavor - Output mode: "soap" or "rest"
#
# Returns : XML formatted standard error packet
#
# Side-Effects : None
#
@@ -1500,11 +1785,11 @@
# ------- ---------- ---------- -------------------------------------------
# 1 07/06/2006 G.Lester Initial version
#
#
###########################################################################
-proc ::WS::Server::generateError {includeTrace faultcode faultstring detail} {
+proc ::WS::Server::generateError {includeTrace faultcode faultstring detail flavor} {
::log::log debug "Entering ::WS::Server::generateError $faultcode $faultstring {$detail}"
set code [lindex $detail 1]
switch -exact -- $code {
"VersionMismatch" {
set code "SOAP-ENV:VersionMismatch"
@@ -1520,46 +1805,60 @@
}
default {
## Do nothing
}
}
- dom createDocument "SOAP-ENV:Envelope" doc
- $doc documentElement env
- $env setAttribute \
- "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \
- "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" \
- "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" \
- "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/"
- $env appendChild [$doc createElement "SOAP-ENV:Body" bod]
- $bod appendChild [$doc createElement "SOAP-ENV:Fault" flt]
- $flt appendChild [$doc createElement "faultcode" fcd]
- $fcd appendChild [$doc createTextNode $faultcode]
- $flt appendChild [$doc createElement "faultstring" fst]
- $fst appendChild [$doc createTextNode $faultstring]
-
- if { $detail != {} } {
- $flt appendChild [$doc createElement "SOAP-ENV:detail" dtl0]
- $dtl0 appendChild [$doc createElement "e:errorInfo" dtl]
- $dtl setAttribute "xmlns:e" "urn:TclErrorInfo"
-
- foreach {detailName detailInfo} $detail {
- if {!$includeTrace && $detailName == "stackTrace"} {
- continue
- }
- $dtl appendChild [$doc createElement $detailName err]
- $err appendChild [$doc createTextNode $detailInfo]
- }
- }
-
- # serialize the DOM document and return the XML text
- append xml \
- {} \
- "\n" \
- [$doc asXML -indent none -doctypeDeclaration 0]
- $doc delete
- ::log::log debug "Leaving (error) ::WS::Server::generateError $xml"
- return $xml
+
+ switch -exact -- $flavor {
+ rest {
+ set doc [yajl create #auto]
+ $doc map_open string "error" string $faultstring map_close
+ set response [$doc get]
+ $doc delete
+ }
+ soap {
+ dom createDocument "SOAP-ENV:Envelope" doc
+ $doc documentElement env
+ $env setAttribute \
+ "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \
+ "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" \
+ "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" \
+ "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/"
+ $env appendChild [$doc createElement "SOAP-ENV:Body" bod]
+ $bod appendChild [$doc createElement "SOAP-ENV:Fault" flt]
+ $flt appendChild [$doc createElement "faultcode" fcd]
+ $fcd appendChild [$doc createTextNode $faultcode]
+ $flt appendChild [$doc createElement "faultstring" fst]
+ $fst appendChild [$doc createTextNode $faultstring]
+
+ if { $detail != {} } {
+ $flt appendChild [$doc createElement "SOAP-ENV:detail" dtl0]
+ $dtl0 appendChild [$doc createElement "e:errorInfo" dtl]
+ $dtl setAttribute "xmlns:e" "urn:TclErrorInfo"
+
+ foreach {detailName detailInfo} $detail {
+ if {!$includeTrace && $detailName == "stackTrace"} {
+ continue
+ }
+ $dtl appendChild [$doc createElement $detailName err]
+ $err appendChild [$doc createTextNode $detailInfo]
+ }
+ }
+
+ # serialize the DOM document and return the XML text
+ append response \
+ {} \
+ "\n" \
+ [$doc asXML -indent none -doctypeDeclaration 0]
+ $doc delete
+ }
+ default {
+ error "unsupported flavor"
+ }
+ }
+ ::log::log debug "Leaving (error) ::WS::Server::generateError $response"
+ return $response
}
###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
@@ -1573,10 +1872,11 @@
#
# Arguments :
# serviceName - The name of the service
# operation - The name of the operation
# results - The results as a dictionary object
+# flavor - Output mode: "soap" or "rest"
#
#
# Returns : The results as an XML formatted packet.
#
# Side-Effects : None
@@ -1597,57 +1897,75 @@
# ------- ---------- ---------- -------------------------------------------
# 1 07/06/2006 G.Lester Initial version
#
#
###########################################################################
-proc ::WS::Server::generateReply {serviceName operation results} {
+proc ::WS::Server::generateReply {serviceName operation results flavor} {
::log::log debug "Entering ::WS::Server::generateReply $serviceName $operation {$results}"
variable serviceArr
array set serviceData $serviceArr($serviceName)
- if {[info exists ::Config(docRoot)] && [file exists [file join $::Config(docRoot) $serviceName $operation.css]]} {
- set replaceText [format {}\
- $serviceData(-host) \
- $serviceName \
- $operation]
- append replaceText "\n"
- } else {
- set replaceText {}
- }
-
- dom createDocument "SOAP-ENV:Envelope" doc
- $doc documentElement env
- $env setAttribute \
- "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \
- "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" \
- "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" \
- "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" \
- xmlns:$serviceName "http://$serviceData(-host)$serviceData(-prefix)"
- if {[llength $serviceData(-outheaders)]} {
- $env appendChild [$doc createElement "SOAP-ENV:Header" header]
- foreach headerType $serviceData(-outheaders) {
- #$header appendChild [$doc createElement ${serviceName}:${headerType} part]
- #::WS::Utils::convertDictToType Server $serviceName $doc $part $results $headerType
- ::WS::Utils::convertDictToType Server $serviceName $doc $header $results $headerType
- }
- }
- $env appendChild [$doc createElement "SOAP-ENV:Body" body]
- $body appendChild [$doc createElement ${serviceName}:${operation}Results reply]
-
- ::WS::Utils::convertDictToType Server $serviceName $doc $reply $results ${serviceName}:${operation}Results
-
- append xml \
- {} \
- "\n" \
- [$doc asXML -indent none -doctypeDeclaration 0]
- #regsub "\]*>\n" [::dom::DOMImplementation serialize $doc] $replaceText xml
- $doc delete
-
- ::log::log debug "Leaving ::WS::Server::generateReply $xml"
- return $xml
+
+ switch -exact -- $flavor {
+ rest {
+ set doc [yajl create #auto -beautify $serviceData(-beautifyJson)]
+
+ $doc map_open
+ ::WS::Utils::convertDictToJson Server $serviceName $doc $results ${serviceName}:${operation}Results $serviceData(-enforceRequired)
+ $doc map_close
+
+ set output [$doc get]
+ $doc delete
+ }
+ soap {
+ if {[info exists ::Config(docRoot)] && [file exists [file join $::Config(docRoot) $serviceName $operation.css]]} {
+ set replaceText [format {}\
+ $serviceData(-host) \
+ $serviceName \
+ $operation]
+ append replaceText "\n"
+ } else {
+ set replaceText {}
+ }
+
+ dom createDocument "SOAP-ENV:Envelope" doc
+ $doc documentElement env
+ $env setAttribute \
+ "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \
+ "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" \
+ "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" \
+ "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" \
+ xmlns:$serviceName "http://$serviceData(-host)$serviceData(-prefix)"
+ if {[llength $serviceData(-outheaders)]} {
+ $env appendChild [$doc createElement "SOAP-ENV:Header" header]
+ foreach headerType $serviceData(-outheaders) {
+ #$header appendChild [$doc createElement ${serviceName}:${headerType} part]
+ #::WS::Utils::convertDictToType Server $serviceName $doc $part $results $headerType
+ ::WS::Utils::convertDictToType Server $serviceName $doc $header $results $headerType 0 $serviceData(-enforceRequired)
+ }
+ }
+ $env appendChild [$doc createElement "SOAP-ENV:Body" body]
+ $body appendChild [$doc createElement ${serviceName}:${operation}Results reply]
+
+ ::WS::Utils::convertDictToType Server $serviceName $doc $reply $results ${serviceName}:${operation}Results 0 $serviceData(-enforceRequired)
+
+ append output \
+ {} \
+ "\n" \
+ [$doc asXML -indent none -doctypeDeclaration 0]
+ #regsub "\]*>\n" [::dom::DOMImplementation serialize $doc] $replaceText xml
+ $doc delete
+ }
+ default {
+ error "Unsupported flavor"
+ }
+ }
+
+ ::log::log debug "Leaving ::WS::Server::generateReply $output"
+ return $output
}
###########################################################################
#
@@ -1915,26 +2233,31 @@
append msg "\n"
append msg [::html::h4 {Inputs}] "\n"
append msg [::html::openTag div {style="margin-left: 40px;"}]
- append msg [::html::openTag {table} {border="2"}]
- append msg [::html::hdrRow Name Type Description]
- foreach arg [dict get $procInfo $service op$oper argOrder] {
- ::log::log debug "\t\t\tDisplaying '$arg'"
- if {[dict exists $procInfo $service op$oper argList $arg comment]} {
- set comment [dict get $procInfo $service op$oper argList $arg comment]
- } else {
- set comment {}
- }
- append msg [::html::row \
- $arg \
- [displayType $service [dict get $procInfo $service op$oper argList $arg type]] \
- $comment \
- ]
- }
- append msg [::html::closeTag]
+
+ if {[llength [dict get $procInfo $service op$oper argOrder]]} {
+ append msg [::html::openTag {table} {border="2"}]
+ append msg [::html::hdrRow Name Type Description]
+ foreach arg [dict get $procInfo $service op$oper argOrder] {
+ ::log::log debug "\t\t\tDisplaying '$arg'"
+ if {[dict exists $procInfo $service op$oper argList $arg comment]} {
+ set comment [dict get $procInfo $service op$oper argList $arg comment]
+ } else {
+ set comment {}
+ }
+ append msg [::html::row \
+ $arg \
+ [displayType $service [dict get $procInfo $service op$oper argList $arg type]] \
+ $comment \
+ ]
+ }
+ append msg [::html::closeTag]
+ } else {
+ append msg "No inputs."
+ }
append msg [::html::closeTag]
::log::log debug "\t\tReturns"
append msg [::html::h4 {Returns}] "\n"
@@ -2018,20 +2341,27 @@
append msg [::html::h2 {Custom Types}]
set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $service]
foreach type [lsort -dictionary [dict keys $localTypeInfo]] {
::log::log debug "\t\tDisplaying '$type'"
+ set href_type [lindex [split $type :] end]
set typeOverloadArray($type) 1
- append msg [::html::h3 "$type"]
+ append msg [::html::h3 "$type"]
set typeDetails [dict get $localTypeInfo $type definition]
append msg [::html::openTag {table} {border="2"}]
- append msg [::html::hdrRow Field Type]
+ append msg [::html::hdrRow Field Type Comment]
foreach part [lsort -dictionary [dict keys $typeDetails]] {
::log::log debug "\t\t\tDisplaying '$part'"
+ if {[dict exists $typeDetails $part comment]} {
+ set comment [dict get $typeDetails $part comment]
+ } else {
+ set comment {}
+ }
append msg [::html::row \
$part \
- [displayType $service [dict get $typeDetails $part type]]
+ [displayType $service [dict get $typeDetails $part type]] \
+ $comment
]
}
append msg [::html::closeTag]
}
Index: Utilities.tcl
==================================================================
--- Utilities.tcl
+++ Utilities.tcl
@@ -57,11 +57,11 @@
package require log
package require tdom 0.8
package require struct::set
-package provide WS::Utils 2.3.10
+package provide WS::Utils 2.4.0
namespace eval ::WS {}
namespace eval ::WS::Utils {
set ::WS::Utils::typeInfo {}
@@ -70,10 +70,32 @@
set nsList {
w http://schemas.xmlsoap.org/wsdl/
d http://schemas.xmlsoap.org/wsdl/soap/
xs http://www.w3.org/2001/XMLSchema
}
+
+ # mapping of how the simple SOAP types should be serialized using YAJL into JSON.
+ array set ::WS::Utils::simpleTypesJson {
+ boolean "bool"
+ float "number"
+ double "double"
+ integer "integer"
+ int "integer"
+ long "integer"
+ short "integer"
+ byte "integer"
+ nonPositiveInteger "integer"
+ negativeInteger "integer"
+ nonNegativeInteger "integer"
+ unsignedLong "integer"
+ unsignedInt "integer"
+ unsignedShort "integer"
+ unsignedByte "integer"
+ positiveInteger "integer"
+ decimal "number"
+ }
+
array set ::WS::Utils::simpleTypes {
anyType 1
string 1
boolean 1
decimal 1
@@ -127,11 +149,11 @@
valueAttrCompatiblityMode 1
includeDirectory {}
suppressNS {}
useTypeNs 0
nsOnChangeOnly 0
- anyType string
+ anyType string
}
set ::WS::Utils::standardAttributes {
baseType
comment
@@ -217,11 +239,11 @@
array set crossreference {}
dict for {type typeDict} [dict get $typeInfo $mode $service] {
foreach {field fieldDict} [dict get $typeDict definition] {
- set fieldType [string trimright [dict get $fieldDict type] {()}]
+ set fieldType [string trimright [dict get $fieldDict type] {()?}]
incr crossreference($fieldType,count)
lappend crossreference($fieldType,usedBy) $type.$field
}
if {![info exists crossreference($type,count) ]} {
set crossreference($type,count) 0
@@ -563,11 +585,11 @@
###########################################################################
proc ::WS::Utils::GetServiceTypeDef {mode service {type {}}} {
variable typeInfo
variable simpleTypes
- set type [string trimright $type {()}]
+ set type [string trimright $type {()?}]
set results {}
if {[string equal $type {}]} {
::log::log debug "@1"
set results [dict get $typeInfo $mode $service]
} else {
@@ -653,11 +675,11 @@
#
###########################################################################
proc ::WS::Utils::GetServiceSimpleTypeDef {mode service {type {}}} {
variable simpleTypes
- set type [string trimright $type {()}]
+ set type [string trimright $type {()?}]
if {[string equal -nocase -length 3 $type {xs:}]} {
return [::WS::Utils::GetServiceTypeDef $mode $service $type]
}
if {[string equal $type {}]} {
set results {}
@@ -913,11 +935,11 @@
#>>BEGIN PUBLIC<<
#
# Procedure Name : ::WS::Utils::TypeInfo
#
# Description : Return a list indicating if the type is simple or complex
-# and if it is a scalar or an array.
+# and if it is a scalar or an array. Also if it is optional
#
# Arguments :
# type - the type name, possibly with a () to specify it is an array
#
# Returns : A list of two elements, as follows:
@@ -943,15 +965,20 @@
# 1 07/06/2006 G.Lester Initial version
# 2.3.0 10/16/2012 G. Lester Corrected detection of service specific simple type.
# 2.3.0 10/31/2012 G. Lester Corrected missing newline.
#
###########################################################################
-proc ::WS::Utils::TypeInfo {mode service type} {
+proc ::WS::Utils::TypeInfo {mode service type {findOptional 0}} {
variable simpleTypes
variable typeInfo
set type [string trim $type]
+ set isOptional 0
+ if {[string equal [string index $type end] {?}]} {
+ set isOptional 1
+ set type [string trimright $type {?}]
+ }
if {[string equal [string range $type end-1 end] {()}]} {
set isArray 1
set type [string range $type 0 end-2]
} elseif {[string equal $type {array}]} {
set isArray 1
@@ -960,10 +987,13 @@
}
#set isNotSimple [dict exists $typeInfo $mode $service $type]
#set isNotSimple [expr {$isNotSimple || [dict exists $typeInfo $mode $service $service:$type]}]
lassign [split $type {:}] tns baseType
set isNotSimple [expr {!([info exist simpleTypes($type)] || [info exist simpleTypes($baseType)] || [info exist simpleTypes($mode,$service,$type)] || [info exist simpleTypes($mode,$service,$baseType)] )}]
+ if {$findOptional} {
+ return [list $isNotSimple $isArray $isOptional]
+ }
return [list $isNotSimple $isArray]
}
###########################################################################
@@ -1272,19 +1302,22 @@
#
###########################################################################
proc ::WS::Utils::getTypeWSDLInfo {mode serviceName field type} {
set typeInfo {maxOccurs 1 minOccurs 1 name * type *}
dict set typeInfo name $field
- set typeList [TypeInfo $mode $serviceName $type]
+ set typeList [TypeInfo $mode $serviceName $type 1]
if {[lindex $typeList 0] == 0} {
- dict set typeInfo type xs:[string trimright $type {()}]
+ dict set typeInfo type xs:[string trimright $type {()?}]
} else {
- dict set typeInfo type $serviceName:[string trimright $type {()}]
+ dict set typeInfo type $serviceName:[string trimright $type {()?}]
}
if {[lindex $typeList 1]} {
dict set typeInfo maxOccurs unbounded
}
+ if {[lindex $typeList 2]} {
+ dict set typeInfo minOccurs 0
+ }
return $typeInfo
}
@@ -1382,10 +1415,11 @@
set partsList [dict keys [dict get $typeDefInfo definition]]
::log::log debug "\t partsList is {$partsList}"
set arrayOverride [expr {$isArray && ([llength $partsList] == 1)}]
foreach partName $partsList {
set partType [dict get $typeDefInfo definition $partName type]
+ set partType [string trimright $partType {?}]
if {[dict exists $typeDefInfo definition $partName allowAny] && [dict get $typeDefInfo definition $partName allowAny]} {
set allowAny 1
} else {
set allowAny 0
}
@@ -1467,15 +1501,15 @@
switch -exact -- $typeInfoList {
{0 0} {
##
## Simple non-array
##
- if {[dict exists $tmpTypeInfo base]} {
- set baseType [dict get $tmpTypeInfo base]
- } else {
- set baseType string
- }
+ if {[dict exists $tmpTypeInfo base]} {
+ set baseType [dict get $tmpTypeInfo base]
+ } else {
+ set baseType string
+ }
if {$options(parseInAttr)} {
foreach attrList [$item attributes] {
catch {
lassign $attrList attr nsAlias nsUrl
if {[string equal $nsUrl $xsiNsUrl]} {
@@ -1505,15 +1539,15 @@
}
{0 1} {
##
## Simple array
##
- if {[dict exists $tmpTypeInfo base]} {
- set baseType [dict get $tmpTypeInfo base]
- } else {
- set baseType string
- }
+ if {[dict exists $tmpTypeInfo base]} {
+ set baseType [dict get $tmpTypeInfo base]
+ } else {
+ set baseType string
+ }
set tmp {}
foreach row $item {
if {$options(parseInAttr)} {
set rowList {}
foreach attrList [$row attributes] {
@@ -1708,29 +1742,30 @@
# ------- ---------- ---------- -------------------------------------------
# 1 07/06/2006 G.Lester Initial version
#
#
###########################################################################
-proc ::WS::Utils::convertDictToType {mode service doc parent dict type {forceNs 0}} {
+proc ::WS::Utils::convertDictToType {mode service doc parent dict type {forceNs 0} {enforceRequired 0}} {
::log::log debug "Entering ::WS::Utils::convertDictToType $mode $service $doc $parent {$dict} $type"
# ::log::log debug " Parent xml: [$parent asXML]"
variable typeInfo
variable simpleTypes
variable options
variable standardAttributes
variable currentNs
if {!$options(UseNS)} {
- return [::WS::Utils::convertDictToTypeNoNs $mode $service $doc $parent $dict $type]
+ return [::WS::Utils::convertDictToTypeNoNs $mode $service $doc $parent $dict $type $enforceRequired]
}
if {$options(valueAttrCompatiblityMode)} {
set valueAttr {}
} else {
set valueAttr {::value}
}
set typeInfoList [TypeInfo $mode $service $type]
+ set type [string trimright $type {?}]
::log::log debug "\t typeInfoList = {$typeInfoList}"
if {[dict exists $typeInfo $mode $service $service:$type]} {
set typeName $service:$type
} else {
set typeName $type
@@ -1775,22 +1810,26 @@
foreach {itemName itemDef} $itemList {
set baseName [lindex [split $itemName {:}] end]
lappend fieldList $itemName
set itemType [dict get $itemDef type]
::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} itemType ={$itemType}"
- set typeInfoList [TypeInfo $mode $service $itemType]
+ set typeInfoList [TypeInfo $mode $service $itemType 1]
::log::log debug "Expr [list ![dict exists $dict $itemName] && ![dict exists $dict $baseName]]"
if {![dict exists $dict $itemName] && ![dict exists $dict $baseName]} {
::log::log debug "Neither {$itemName} nor {$baseName} are in dictionary {$dict}, skipping"
+ # If required parameters are being enforced and this field is not optional, throw an error
+ if {$enforceRequired && ![lindex $typeInfoList 2]} {
+ error "Required field $itemName is missing from response"
+ }
continue
} elseif {[dict exists $dict $baseName]} {
set useName $baseName
} else {
set useName $itemName
}
set itemXns $xns
- set tmpInfo [GetServiceTypeDef $mode $service [string trimright $itemType {()}]]
+ set tmpInfo [GetServiceTypeDef $mode $service [string trimright $itemType {()?}]]
if {$options(useTypeNs) && [dict exists $tmpInfo xns]} {
set itemXns [dict get $tmpInfo xns]
}
set attrList {}
if {$options(useTypeNs) && [string equal $itemXns xs]} {
@@ -1805,15 +1844,17 @@
::log::log debug "key = {$key} standardAttributes = {$standardAttributes}"
}
}
::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} itemXns = {$itemXns} tmpInfo = {$tmpInfo} attrList = {$attrList}"
set isAbstract false
- set baseType [string trimright $itemType ()]
+ set baseType [string trimright $itemType {()?}]
if {$options(genOutAttr) && [dict exists $typeInfo $mode $service $baseType abstract]} {
set isAbstract [dict get $typeInfo $mode $service $baseType abstract]
}
- ::log::log notice "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} isAbstract = {$isAbstract}"
+ ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} isAbstract = {$isAbstract}"
+ # Strip the optional flag off the typeInfoList
+ set typeInfoList [lrange $typeInfoList 0 1]
switch -exact -- $typeInfoList {
{0 0} {
##
## Simple non-array
##
@@ -1922,13 +1963,13 @@
set resultValue [dict get $dict $useName]
}
if {![string equal $currentNs $itemXns] && ![string equal $itemXns {}]} {
set tmpNs $currentNs
set currentNs $itemXns
- convertDictToType $mode $service $doc $retNode $resultValue $itemType
+ convertDictToType $mode $service $doc $retNode $resultValue $itemType $forceNs $enforceRequired
} else {
- convertDictToType $mode $service $doc $retNode $resultValue $itemType
+ convertDictToType $mode $service $doc $retNode $resultValue $itemType $forceNs $enforceRequired
}
if {[llength $attrList]} {
::WS::Utils::setAttr $retNode $attrList
}
}
@@ -1935,11 +1976,10 @@
{1 1} {
##
## Non-simple array
##
set dataList [dict get $dict $useName]
- set tmpType [string trimright $itemType ()]
#::log::log debug "\t\t [llength $dataList] rows {$dataList}"
foreach row $dataList {
if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} {
$parent appendChild [$doc createElement $itemName retNode]
} else {
@@ -1965,16 +2005,21 @@
}
}
} else {
set resultValue $row
}
+ if {[string index $itemType end] eq {?}} {
+ set tmpType "[string trimright $itemType {()?}]?"
+ } else {
+ set tmpType [string trimright $itemType {()}]
+ }
if {![string equal $currentNs $itemXns] && ![string equal $itemXns {}]} {
set tmpNs $currentNs
set currentNs $itemXns
- convertDictToType $mode $service $doc $retNode $resultValue $tmpType
+ convertDictToType $mode $service $doc $retNode $resultValue $tmpType $forceNs $enforceRequired
} else {
- convertDictToType $mode $service $doc $retNode $resultValue $tmpType
+ convertDictToType $mode $service $doc $retNode $resultValue $tmpType $forceNs $enforceRequired
}
if {[llength $attrList]} {
::WS::Utils::setAttr $retNode $attrList
}
}
@@ -1994,10 +2039,155 @@
}
set currentNs $entryNs
::log::log debug "Leaving ::WS::Utils::convertDictToType with xml: [$parent asXML]"
return;
}
+
+###########################################################################
+#
+# Private Procedure Header - as this procedure is modified, please be sure
+# that you update this header block. Thanks.
+#
+#>>BEGIN PRIVATE<<
+#
+# Procedure Name : ::WS::Utils::convertDictToJson
+#
+# Description : Convert a dictionary object into a JSON tree.
+#
+# Arguments :
+# mode - The mode, Client or Server
+# service - The service name the type is defined in
+# doc - The document (yajltcl)
+# dict - The dictionary to convert
+# type - The name of the type
+#
+# Returns : None
+#
+# Side-Effects : None
+#
+# Exception Conditions : None
+#
+# Pre-requisite Conditions : None
+#
+# Original Author : Jeff Lawson
+#
+#>>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
+# ------- ---------- ---------- -------------------------------------------
+# 1 03/23/2011 J.Lawson Initial version
+#
+#
+###########################################################################
+proc ::WS::Utils::convertDictToJson {mode service doc dict type {enforceRequired 0}} {
+ ::log::log debug "Entering ::WS::Utils::convertDictToJson $mode $service $doc {$dict} $type"
+ variable typeInfo
+ variable simpleTypes
+ variable simpleTypesJson
+ variable options
+ variable standardAttributes
+
+ set typeInfoList [TypeInfo $mode $service $type]
+ set type [string trimright $type {?}]
+ if {[dict exists $typeInfo $mode $service $service:$type]} {
+ set typeName $service:$type
+ } else {
+ set typeName $type
+ }
+ set itemList {}
+ if {[lindex $typeInfoList 0] && [dict exists $typeInfo $mode $service $typeName definition]} {
+ set itemList [dict get $typeInfo $mode $service $typeName definition]
+ set xns [dict get $typeInfo $mode $service $typeName xns]
+ } else {
+ set xns $simpleTypes($mode,$service,$typeName)
+ set itemList [list $typeName {type string}]
+ }
+ if {[info exists mutableTypeInfo([list $mode $service $typeName])]} {
+ set typeName [(*)[lindex mutableTypeInfo([list $mode $service $type]) 0] $mode $service $type $xns $dict]
+ set typeInfoList [TypeInfo $mode $service $typeName]
+ if {[lindex $typeInfoList 0]} {
+ set itemList [dict get $typeInfo $mode $service $typeName definition]
+ } else {
+ set itemList [list $type {type string}]
+ }
+ }
+ ::log::log debug "\titemList is {$itemList}"
+ set fieldList {}
+ foreach {itemName itemDef} $itemList {
+ lappend fieldList $itemName
+ set itemType [dict get $itemDef type]
+ ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} itemType = {$itemType}"
+ set typeInfoList [TypeInfo $mode $service $itemType 1]
+ if {![dict exists $dict $itemName]} {
+ if {$enforceRequired && ![lindex $typeInfoList 2]} {
+ error "Required field $itemName is missing from response"
+ }
+ continue
+ }
+
+ if {[info exists simpleTypesJson([string trimright $itemType {()?}])]} {
+ set yajlType $simpleTypesJson([string trimright $itemType {()?}])
+ } else {
+ set yajlType "string"
+ }
+
+ ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList}"
+ set typeInfoList [lrange $typeInfoList 0 1]
+ switch $typeInfoList {
+ {0 0} {
+ ##
+ ## Simple non-array
+ ##
+ set resultValue [dict get $dict $itemName]
+ $doc string $itemName $yajlType $resultValue
+ }
+ {0 1} {
+ ##
+ ## Simple array
+ ##
+ set dataList [dict get $dict $itemName]
+ $doc string $itemName array_open
+ foreach row $dataList {
+ $doc $yajlType $row
+ }
+ $doc array_close
+ }
+ {1 0} {
+ ##
+ ## Non-simple non-array
+ ##
+ $doc string $itemName map_open
+ set resultValue [dict get $dict $itemName]
+ convertDictToJson $mode $service $doc $resultValue $itemType $enforceRequired
+ $doc map_close
+ }
+ {1 1} {
+ ##
+ ## Non-simple array
+ ##
+ set dataList [dict get $dict $itemName]
+ $doc string $itemName array_open
+ if {[string index $itemType end] eq {?}} {
+ set tmpType "[string trimright $itemType {()?}]?"
+ } else {
+ set tmpType [string trimright $itemType {()}]
+ }
+ foreach row $dataList {
+ $doc map_open
+ convertDictToJson $mode $service $doc $row $tmpType $enforceRequired
+ $doc map_close
+ }
+ $doc array_close
+ }
+ }
+ }
+ return;
+}
###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
# that you update this header block. Thanks.
@@ -2035,11 +2225,11 @@
# ------- ---------- ---------- -------------------------------------------
# 1 07/06/2006 G.Lester Initial version
#
#
###########################################################################
-proc ::WS::Utils::convertDictToTypeNoNs {mode service doc parent dict type} {
+proc ::WS::Utils::convertDictToTypeNoNs {mode service doc parent dict type {enforceRequired 0}} {
::log::log debug "Entering ::WS::Utils::convertDictToTypeNoNs $mode $service $doc $parent {$dict} $type"
# ::log::log debug " Parent xml: [$parent asXML]"
variable typeInfo
variable simpleTypes
variable options
@@ -2067,16 +2257,19 @@
::log::log debug "\titemList is {$itemList}"
foreach {itemName itemDef} $itemList {
::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef}"
set itemType [dict get $itemDef type]
set isAbstract false
- set baseType [string trimright $itemType ()]
+ set baseType [string trimright $itemType {()?}]
if {$options(genOutAttr) && [dict exists $typeInfo $mode $service $baseType abstract]} {
set isAbstract [dict get $typeInfo $mode $service $baseType abstract]
}
- set typeInfoList [TypeInfo $mode $service $itemType]
+ set typeInfoList [TypeInfo $mode $service $itemType 1]
if {![dict exists $dict $itemName]} {
+ if {$enforceRequired && ![lindex $typeInfoList 2]} {
+ error "Required field $itemName is missing from response"
+ }
continue
}
set attrList {}
foreach key [dict keys $itemDef] {
if {[lsearch -exact $standardAttributes $key] == -1 && $key ne "isList" && $key ne "xns"} {
@@ -2083,10 +2276,11 @@
lappend attrList $key [dict get $itemDef $key]
::log::log debug "key = {$key} standardAttributes = {$standardAttributes}"
}
}
::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList}"
+ set typeInfoList [lrange $typeInfoList 0 1]
switch -exact -- $typeInfoList {
{0 0} {
##
## Simple non-array
##
@@ -2169,18 +2363,18 @@
set resultValue [dict get $dict $itemName]
}
if {[llength $attrList]} {
::WS::Utils::setAttr $retNode $attrList
}
- convertDictToTypeNoNs $mode $service $doc $retnode $resultValue $itemType
+ convertDictToTypeNoNs $mode $service $doc $retnode $resultValue $itemType $enforceRequired
}
{1 1} {
##
## Non-simple array
##
set dataList [dict get $dict $itemName]
- set tmpType [string trimright $itemType ()]
+ set tmpType [string trimright $itemType {()}]
foreach row $dataList {
$parent appendChild [$doc createElement $itemName retnode]
if {$options(genOutAttr)} {
set dictList [dict keys $row]
set resultValue {}
@@ -2202,11 +2396,11 @@
set resultValue $row
}
if {[llength $attrList]} {
::WS::Utils::setAttr $retNode $attrList
}
- convertDictToTypeNoNs $mode $service $doc $retnode $resultValue $tmpType
+ convertDictToTypeNoNs $mode $service $doc $retnode $resultValue $tmpType $enforceRequired
}
}
default {
##
## Placed here to shut up tclchecker
@@ -2265,10 +2459,11 @@
variable options
set typeInfoList [TypeInfo $mode $service $type]
::log::log debug "\t typeInfoList = {$typeInfoList}"
+ set type [string trimright $type {?}]
if {[lindex $typeInfoList 0]} {
set itemList [dict get $typeInfo $mode $service $type definition]
set xns [dict get $typeInfo $mode $service $type xns]
} else {
if {[info exists simpleTypes($mode,$service,$type)]} {
@@ -2293,11 +2488,11 @@
set itemList [list $type {type string}]
}
}
::log::log debug "\titemList is {$itemList} in $xns"
foreach {itemName itemDef} $itemList {
- set itemType [dict get $itemList $itemName type]
+ set itemType [string trimright [dict get $itemList $itemName type] {?}]
set typeInfoList [TypeInfo $mode $service $itemType]
::log::log debug "\t\t Looking for {$itemName} in {$dict}"
if {![dict exists $dict $itemName]} {
::log::log debug "\t\t Not found, skipping"
continue
@@ -2369,11 +2564,11 @@
if {![string match {*:*} $itemType]} {
set attrType $xns:$itemType
} else {
set attrType $itemType
}
- set attrType [string trim $attrType {()}]
+ set attrType [string trim $attrType {()?}]
$parent setAttribute xmlns:soapenc {http://schemas.xmlsoap.org/soap/encoding/}
$parent setAttribute soapenc:arrayType [format {%s[%d]} $attrType [llength $dataList]]
$parent setAttribute xsi:type soapenc:Array
#set itemName [$parent nodeName]
foreach item $dataList {
@@ -2671,11 +2866,10 @@
::log::log $options(StrictMode) "Found $lastUnknownRefCount forward type references: [join [array names unkownRef] {,}]"
}
error -
default {
set ::WS::Utils::targetNs $tmpTargetNs
- set ofd [open full.xsd w];puts $ofd [$schemaNode asXML];close $ofd
return \
-code error \
-errorcode [list WS $mode UNKREFS [list $lastUnknownRefCount]] \
"Found $lastUnknownRefCount forward type references: [join [array names unkownRef] {,}]"
}
@@ -2912,11 +3106,11 @@
"Missing Schema Location in '$baseUrl'"
}
}
set urlTail [$importNode getAttribute $attrName]
set url [::uri::resolve $baseUrl $urlTail]
- ::log::log info "Including $url"
+ ::log::log debug "Including $url"
set lastPos [string last / $url]
set testUrl [string range $url 0 [expr {$lastPos - 1}]]
if { [info exists ::WS::Utils::redirectArray($testUrl)] } {
set newUrl $::WS::Utils::redirectArray($testUrl)
@@ -3131,11 +3325,11 @@
-errorcode [list WS $mode UNKREF [list $typeName $partType]] \
"Unknown forward type reference {$partType} in {$typeName}"
}
} else {
set partName [$middleNode getAttribute name]
- set partType [getQualifiedType $results [$middleNode getAttribute type string:string] $tns]
+ set partType [string trimright [getQualifiedType $results [$middleNode getAttribute type string:string] $tns] {?}]
set partMax [$middleNode getAttribute maxOccurs 1]
if {$partMax <= 1} {
lappend partList $partName [list type $partType comment $comment]
} else {
lappend partList $partName [list type [string trimright ${partType} {()}]() comment $comment]
@@ -3198,11 +3392,11 @@
catch {set attrArr($name) [$element getAttribute $ref]}
}
set partName item
set partType [getQualifiedType $results $attrArr(arrayType) $tns]
set partType [string map {{[]} {()}} $partType]
- lappend partList $partName [list type [string trimright ${partType} {()}]() comment $comment allowAny 1]
+ lappend partList $partName [list type [string trimright ${partType} {()?}]() comment $comment allowAny 1]
set nodeFound 1
}
extension {
::log::log debug "Calling partList for $contentType of $typeName"
if {[catch {set tmp [partList $mode $child $serviceName results $tns]} msg]} {
@@ -3327,11 +3521,11 @@
##
}
element {
catch {
set partName [$node getAttribute name]
- set partType [getQualifiedType $results [$node getAttribute type string] $tns]
+ set partType [string trimright [getQualifiedType $results [$node getAttribute type string] $tns] {?}]
set partMax [$node getAttribute maxOccurs 1]
if {$partMax <= 1} {
set partList [list $partName [list type $partType comment {}]]
} else {
set partList [list $partName [list type [string trimright ${partType} {()}]() comment {}]]
@@ -3403,11 +3597,11 @@
}
set partName [$element getAttribute $attrName]
if {$isRef} {
set partType {}
set partTypeInfo {}
- set partType [getQualifiedType $results $partName $tns]
+ set partType [string trimright [getQualifiedType $results $partName $tns] {?}]
set partTypeInfo [::WS::Utils::GetServiceTypeDef $mode $serviceName $partType]
set partName [lindex [split $partName {:}] end]
::log::log debug "\t\t\t part name is {$partName} type is {$partTypeInfo}"
if {[dict exists $partTypeInfo definition $partName]} {
set partType [dict get $partTypeInfo definition $partName type]
@@ -3452,11 +3646,11 @@
set partMax [$element getAttribute maxOccurs 1]
}
if {$partMax <= 1} {
lappend partList $partName [concat [list type $partType comment $comment] $additional_defininition_elements]
} else {
- lappend partList $partName [concat [list type [string trimright ${partType} {()}]() comment $comment] $additional_defininition_elements]
+ lappend partList $partName [concat [list type [string trimright ${partType} {()?}]() comment $comment] $additional_defininition_elements]
}
} msg]} {
::log::log error "\tError processing {$msg} for [$element asXML]"
if {$isRef} {
::log::log error "\t\t Was a reference. Additionally information is:"
@@ -3488,11 +3682,11 @@
catch {set attrArr($name) [$element getAttribute $ref]}
}
set partName item
set partType [getQualifiedType $results $attrArr(arrayType) $tns]
set partType [string map {{[]} {()}} $partType]
- set partList [list $partName [list type [string trimright ${partType} {()}]() comment {} allowAny 1]]
+ set partList [list $partName [list type [string trimright ${partType} {()?}]() comment {} allowAny 1]]
}
extension {
set extension [$node selectNodes -namespaces $nsList xs:extension]
set partList [partList $mode $extension $serviceName results $tns]
}
@@ -3681,11 +3875,11 @@
set partMax [[$element parent] getAttribute maxOccurs -1]
}
if {$partMax <= 1} {
lappend partList $partName [list type $partType comment {}]
} else {
- lappend partList $partName [list type [string trimright ${partType} {()}]() comment {}]
+ lappend partList $partName [list type [string trimright ${partType} {()?}]() comment {}]
}
}
if {[llength $elements] == 0} {
#
# Validate this is not really a complex or simple type
@@ -3734,11 +3928,11 @@
return
} else {
lappend partList $typeName [list type $partType comment {}]
}
} else {
- lappend partList $typeName [list type [string trimright ${partType} {()}]() comment {}]
+ lappend partList $typeName [list type [string trimright ${partType} {()?}]() comment {}]
}
}
if {[llength $partList]} {
::WS::Utils::ServiceTypeDef $mode $serviceName $tns:$typeName $partList $tns $isAbstractType
} else {
@@ -3911,11 +4105,12 @@
##
## Get the type information
##
set typeInfoList [TypeInfo $mode $serviceName $typeName]
- set baseTypeName [string trimright $typeName {()}]
+ set baseTypeName [string trimright $typeName {()?}]
+ set typeName [string trimright $typeName {?}]
set typeInfo [GetServiceTypeDef $mode $serviceName $baseTypeName]
set isComplex [lindex $typeInfoList 0]
set isArray [lindex $typeInfoList 1]
if {$isComplex} {
@@ -4104,12 +4299,13 @@
upvar 1 $valueInfos values
##
## Get the type information
##
- set baseTypeName [string trimright $typeName {()}]
+ 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]
foreach {field fieldDef} [dict get $typeInfo definition] {
##
## Get info about this field and its type
@@ -4116,11 +4312,11 @@
##
array unset fieldInfoArr
set fieldInfoArr(minOccurs) 0
array set fieldInfoArr $fieldDef
set typeInfoList [TypeInfo $mode $serviceName $fieldInfoArr(type)]
- set fieldBaseType [string trimright $fieldInfoArr(type) {()}]
+ set fieldBaseType [string trimright $fieldInfoArr(type) {()?}]
set isComplex [lindex $typeInfoList 0]
set isArray [lindex $typeInfoList 1]
if {[dict exists $valueInfos $field]} {
if {$isArray} {
set valueList [dict get $valueInfos $field]
@@ -4374,10 +4570,11 @@
return $results
} else {
set generatedTypes([list $mode $serviceName $type]) 1
}
+ set type [string trimright $type {?}]
# set typeDefInfo [dict get $typeInfo $mode $serviceName $type]
set typeDefInfo [GetServiceTypeDef $mode $serviceName $type]
if {![llength $typeDefInfo]} {
## We failed to locate the type. try with the last known xns...
set typeDefInfo [GetServiceTypeDef $mode $serviceName ${xns}:$type]
@@ -4407,11 +4604,11 @@
set typeDefInfo [dict create definition [dict create $type $typeDefInfo]]
}
set partsList [dict keys [dict get $typeDefInfo definition]]
::log::log debug "\t partsList is {$partsList}"
foreach partName $partsList {
- set partType [dict get $typeDefInfo definition $partName type]
+ set partType [string trimright [dict get $typeDefInfo definition $partName type] {?}]
set partXns $xns
catch {set partXns [dict get $typeInfo $mode $serviceName $partType xns]}
set typeInfoList [TypeInfo $mode $serviceName $partType]
set isArray [lindex $typeInfoList end]
@@ -4596,10 +4793,12 @@
set lastPos [string last / $finalUrl]
set finalUrlDir [string range $finalUrl 0 [expr {$lastPos - 1}]]
::log::log debug "initialUrlDir = $initialUrlDir, finalUrlDir = $finalUrlDir"
set ::WS::Utils::redirectArray($initialUrlDir) $finalUrlDir
}
+ return $token
+ } elseif {![string match {20[1237]} $ncode]} {
return $token
}
# http code announces redirect (3xx)
array set meta [set ${token}(meta)]
if {![info exist meta(Location)]} {
Index: Wub.tcl
==================================================================
--- Wub.tcl
+++ Wub.tcl
@@ -46,11 +46,11 @@
}
package require uri
package require base64
package require html
-package provide WS::Wub 2.2.1
+package provide WS::Wub 2.4.0
namespace eval ::WS::Wub {
array set portInfo {}
Index: WubServer.tcl
==================================================================
--- WubServer.tcl
+++ WubServer.tcl
@@ -9,12 +9,12 @@
package require OO
package require Direct
package require Debug
Debug off wsdl 10
-package provide WS::Wub 2.0.0
-package provide Wsdl 1.0
+package provide WS::Wub 2.4.0
+package provide Wsdl 2.4.0
class create Wsdl {
method / {r args} {
return [Http Ok $r [::WS::Server::generateInfo $service 0] text/html]
}
Index: pkgIndex.tcl
==================================================================
--- pkgIndex.tcl
+++ pkgIndex.tcl
@@ -1,20 +1,18 @@
# Tcl package index file, version 1.1
-# This file is generated by the "pkg_mkIndex" command
+# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
-package ifneeded WS::Client 2.3.9 [list source [file join $dir ClientSide.tcl]]
-package ifneeded WS::Server 2.3.7 [list source [file join $dir ServerSide.tcl]]
-package ifneeded WS::Utils 2.3.10 [list source [file join $dir Utilities.tcl]]
-
-package ifneeded WS::Embeded 2.3.0 [list source [file join $dir Embedded.tcl]]
-package ifneeded WS::AOLserver 2.0.0 [list source [file join $dir AOLserver.tcl]]
-package ifneeded WS::Channel 2.0.0 [list source [file join $dir ChannelServer.tcl]]
-
-package ifneeded WS::Wub 2.2.1 [list source [file join $dir WubServer.tcl]]
-package ifneeded Wsdl 2.0.0 [list source [file join $dir WubServer.tcl]]
+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.4.0 [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.0 [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]]