tclws-3.5.0000075500000000000000000000000001471124032000121425ustar00nobodynobodytclws-3.5.0/AOLserver.tcl000064400000000000000000000047371471124032000146020ustar00nobodynobodypackage require Tcl 8.6- namespace eval ::WS::AOLserver { if {![info exists logVersion]} { variable logVersion [package require log] } if {![info exists wsVersion]} { variable wsVersion [package require WS::Server] } namespace import -force ::log::log } proc ::WS::AOLserver::ReturnData {sock type data code} { log debug "AOLserver::ReturnData returning $code $type $data" ns_return $code $type $data } proc ::WS::AOLserver::AddHandler {args} { log debug "AOLserver::AddHandler added '$args'" } proc ::WS::AOLserver::Init { } { uplevel 1 { set server [ns_info server] set nsset [ns_configsection "ns/server/$server/module/nssock"] set headerSet [ns_conn headers] set host [string tolower [ns_set iget $headerSet host]] set hostList [split $host :] set peeraddr [ns_conn peeraddr] if {[llength $hostList] == 1} { set port 80 } else { set port [lindex $hostList 1] } set url [lindex [split [lindex [ns_conn request] 1] ?] 0] set urlv [split $url /] switch -exact -- [lindex $urlv end] { "" { # get service description set requestType doc } "wsdl" { # return wsdl set requestType wsdl } "op" { set requestType op } default { set requestType [lindex $urlv end] } } set prefix [join [lrange $urlv 0 end-1] /] set service [lindex $urlv end-1] ::log::log debug "prefix = $prefix service = $service requestType = $requestType" } } proc ::WS::AOLserver::Return {} { uplevel 1 { set sock nosock switch -exact -- $requestType { doc { ::WS::Server::generateInfo $service $sock } wsdl { ::WS::Server::generateWsdl $service $sock } op { upvar #0 Httpd$sock data # Copy Headers/ip set headerLength [ns_set size $headerSet] for {set i 0} {$i < $headerLength} {incr i} { lappend headers [ns_set key $headerSet $i] [ns_set value $headerSet $i] } set data(ipaddr) $peeraddr set data(headerlist) $headers # Get POSTed data set length [ns_set iget $headerSet "Content-length"] set tmpFile [ns_tmpnam] ::log::log debug "Using tmpFile = $tmpFile" set fp [ns_openexcl $tmpFile] fconfigure $fp -translation binary ns_conn copy 0 $length $fp seek $fp 0 set data(query) [read $fp] close $fp # Run request ::WS::Server::callOperation $service $sock } default { ns_return 200 text/plain "prefix = $prefix service = $service requestType = $requestType" } } } } package provide WS::AOLserver 2.5.0 tclws-3.5.0/ChannelServer.tcl000064400000000000000000000267111471124032000154730ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2008, Gerald W. Lester ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require Tcl 8.6- # XXX WS::Utils usable here? (provide dict, lassign) if {![llength [info command dict]]} { package require dict } if {![llength [info command lassign]]} { proc lassign {inList args} { set numArgs [llength $args] set i -1 foreach var $args { incr i uplevel 1 [list set $var [lindex $inList $i]] } return [lrange $inList $numArgs end] } } package require uri package require base64 package require html package provide WS::Channel 2.5.0 namespace eval ::WS::Channel { array set portInfo {} array set dataArray {} } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Channel::AddHandler # # Description : Register a handler for a url on a port. # # Arguments : # ports -- The port to register the callback on # operation -- {} for WSDL callback, otherwise operation callback # callback -- The callback prefix, two additionally arguments are lappended # the callback: (1) the socket (2) the null string # # Returns : Nothing # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : ::WS::Channel::Listen must have been called for the port # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Channel::AddHandler {ports operation callback} { variable portInfo if {[llength $ports] == 2} { lassign $ports in out set portInfo(in) $in set portInfo(out) $out set portInfo(eof) [lindex [fconfigure $portInfo(out) -eofchar] end] } elseif {[llength $ports] == 1} { set portInfo(in) $ports set portInfo(out) $ports set portInfo(eof) [fconfigure $portInfo(out) -eofchar] } else { return -code error -errorcode [list ] "Invalid channel count {$ports}" } if {[string length $operation]} { set portInfo(op) $callback } else { set portInfo(wsdl) $callback } return; } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Channel::ReturnData # # Description : Store the information to be returned. # # Arguments : # socket -- Socket data is for # type -- Mime type of data # data -- Data # code -- Status code # # Returns : Nothing # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : A callback on the socket should be pending # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Channel::ReturnData {sock type data code} { variable dataArray foreach var {type data code} { dict set dataArray(reply) $var [set $var] } return; } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Channel::Start # # Description : Start listening on all ports (i.e. enter the event loop). # # Arguments : None # # Returns : Value that event loop was exited with. # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : # ::WS::Channel::Listen should have been called for one or more port. # # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Channel::Start {} { variable portInfo variable dataArray while {1} { array unset dataArray set xml [read $portInfo(in)] if {[string length $xml]} { ## ## Call for an operation ## handler op $xml } else { ## ## Call for a WSDL ## handler wsdl {} } } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Channel::respond # # Description : Send response back to user. # # Arguments : # sock -- Socket to send reply on # code -- Code to send # body -- HTML body to send # head -- HTML header to send # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Channel::respond {sock code body {head ""}} { puts -nonewline $sock "HTTP/1.0 $code ???\nContent-Type: text/html; charset=ISO-8859-1\nConnection: close\nContent-length: [string length $body]\n$head\n$body" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Channel::handler # # Description : Handle a request. # # Arguments : # type -- Request type # xml -- XML # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Channel::handler {type xml} { variable portInfo variable dataArray upvar #0 Httpd_Channel data set ::errorInfo {} set data(query) $xml set cmd $portInfo($type) lappend cmd _Channel {} puts "Calling {$cmd}" if {[catch {eval $cmd} msg]} { respond $portInfo(out) 404 Error $msg } else { set data [dict get $dataArray(reply) data] set reply "HTTP/1.0 [dict get $dataArray(reply) code] ???\n" append reply "Content-Type: [dict get $dataArray(reply) type]; charset=UTF-8\n" append reply "Connection: close\n" append reply "Content-length: [string length $data]\n" append reply "\n" append reply $data puts -nonewline $portInfo(out) $reply } puts -nonewline $portInfo(eof) return; } tclws-3.5.0/ClientSide.tcl000064400000000000000000004672711471124032000147710ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2016-2019, Harald Oehlmann ## ## Copyright (c) 2006-2013, Gerald W. Lester ## ## Copyright (c) 2008, Georgios Petasis ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## Copyright (c) 2006, Arnulf Wiedemann ## ## Copyright (c) 2006, Colin McCormack ## ## Copyright (c) 2006, Rolf Ade ## ## Copyright (c) 2001-2006, Pat Thoyts ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require Tcl 8.6- package require WS::Utils ; # logsubst package require tdom 0.8- package require http 2- package require log package require uri package provide WS::Client 3.1.0 namespace eval ::WS::Client { # 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 ::tls::socket } err]} { log::log warning "No TLS package: $err" if { [catch { package require twapi_crypto http::register https 443 ::twapi::tls_socket } err] } { log::log warning "No https support. No TWAPI package: $err" } } } else { # Ok, was registered - reregister http::register https {*}$lPortCmd } unset -nocomplain err lPortCmd ## ## serviceArr is indexed by service name and contains a dictionary that ## defines the service. The dictionary has the following structure: ## targetNamespace - the target namespace ## operList - list of operations ## objList - list of operations ## headers - list of http headers ## types - dictionary of types ## service - dictionary containing general information about the service, formatted: ## name -- the name of the service ## location -- the url ## style -- style of call (e.g. rpc/encoded, document/literal) ## ## For style of rpc/encoded, document/literal ## operations - dictionary with information about the operations. The key ## is the operations name and each with the following structure: ## soapRequestHeader -- list of SOAP Request Headers ## soapReplyHeader -- list of SOAP Reply Headers ## action -- SOAP Action Header ## inputs -- list of fields with type info ## outputs -- return type ## style -- style of call (e.g. rpc/encoded, document/literal) ## ## For style of rest ## object - dictionary with informat about objects. The key is the object ## name each with the following strucutre: ## operations -- dictionary with information about the operations. The key ## is the operations name and each with the following structure: ## inputs --- list of fields with type info ## outputs --- return type ## ## Note -- all type information is formated suitable to be passed ## to ::WS::Utils::ServiceTypeDef ## array set ::WS::Client::serviceArr {} set ::WS::Client::currentBaseUrl {} array set ::WS::Client::options { skipLevelWhenActionPresent 0 skipLevelOnReply 0 skipHeaderLevel 0 suppressTargetNS 0 allowOperOverloading 1 contentType {text/xml;charset=utf-8} UseNS {} parseInAttr {} genOutAttr {} valueAttrCompatiblityMode 1 suppressNS {} useTypeNs {} nsOnChangeOnly {} noTargetNs 0 errorOnRedefine 0 inlineElementNS 1 queryTimeout 60000 } ## ## List of options which are copied to the service array ## set ::WS::Client::serviceLocalOptionsList { skipLevelWhenActionPresent skipLevelOnReply skipHeaderLevel suppressTargetNS allowOperOverloading contentType UseNS parseInAttr genOutAttr valueAttrCompatiblityMode suppressNS useTypeNs nsOnChangeOnly noTargetNs queryTimeout } ## ## List of options which are set and restored in the Utilities module ## when we do a call into the module ## set ::WS::Client::utilsOptionsList { UseNS parseInAttr genOutAttr valueAttrCompatiblityMode suppressNS useTypeNs nsOnChangeOnly } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::SetOption # # Description : Set or get file global or default option. # Global option control the service creation process. # Default options are takren as defaults to new created services. # # Arguments : # -globalonly # - Return list of global options/values # -defaultonly # - Return list of default options/values # -- # option - Option to be set/retrieved # Return all option/values if omitted # args - Value to set the option to # Return the value if not given # # Returns : The value of the option # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 04/272009 G.Lester Initial version # 2.4.5 2017-12-04 H.Oehlmann Return all current options if no argument # given. Options -globalonly or -defaultonly # limit this to options which are (not) # copied to the service. # ########################################################################### proc ::WS::Client::SetOption {args} { variable options variable serviceLocalOptionsList if {0 == [llength $args]} { return [array get options] } set args [lassign $args option] switch -exact -- $option { -globalonly { ## ## Return list of global options ## # A list convertible to a dict is build for performance reasons: # - lappend does not test existence for each element # - if a list is needed, dict build burden is avoided set res {} foreach option [array names options] { if {$option ni $serviceLocalOptionsList} { lappend res $option $options($option) } } return $res } -defaultonly { ## ## Return list of default options ## set res {} foreach option [array names options] { if {$option in $serviceLocalOptionsList} { lappend res $option $options($option) } } return $res } -- { ## ## End of options ## set args [lassign $args option] } } ## ## Check if given option exists ## if {![info exists options($option)]} { return -code error \ -errorcode [list WS CLIENT UNKOPT $option] \ "Unknown option: '$option'" } ## ## Check if value is given ## switch -exact -- [llength $args] { 0 { return $options($option) } 1 { set value [lindex $args 0] set options($option) $value return $value } default { return -code error \ -errorcode [list WS CLIENT INVALDCNT $args] \ "To many parameters: '$args'" } } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::CreateService # # Description : Define a service # # Arguments : # serviceName - Service name to add namespace to # type - The type of service, currently only REST is supported # url - URL of namespace file to import # args - Optional arguments: # -header httpHeaderList # # Returns : The local alias (tns) # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 04/14/2009 G.Lester Initial version # 2.4.5 2017-12-04 H.Oehlmann Use distinct list of option items, which are # copied to the service array. Not all options # are used in the service array. # ########################################################################### proc ::WS::Client::CreateService {serviceName type url target args} { variable serviceArr variable options variable serviceLocalOptionsList if {$options(errorOnRedefine) && [info exists serviceArr($serviceName)]} { return -code error "Service '$serviceName' already exists" } elseif {[info exists serviceArr($serviceName)]} { unset serviceArr($serviceName) } dict set serviceArr($serviceName) types {} dict set serviceArr($serviceName) operList {} dict set serviceArr($serviceName) objList {} dict set serviceArr($serviceName) headers {} dict set serviceArr($serviceName) targetNamespace tns1 $target dict set serviceArr($serviceName) name $serviceName dict set serviceArr($serviceName) location $url dict set serviceArr($serviceName) style $type dict set serviceArr($serviceName) imports {} dict set serviceArr($serviceName) inTransform {} dict set serviceArr($serviceName) outTransform {} foreach item $serviceLocalOptionsList { dict set serviceArr($serviceName) $item $options($item) } foreach {name value} $args { set name [string trimleft $name {-}] dict set serviceArr($serviceName) $name $value } ::log::logsubst debug {Setting Target Namespace tns1 as $target} if {[dict exists $serviceArr($serviceName) xns]} { foreach xnsItem [dict get $serviceArr($serviceName) xns] { lassign $xnsItem tns xns ::log::logsubst debug {Setting targetNamespace $tns for $xns} dict set serviceArr($serviceName) targetNamespace $tns $xns } } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::Config # # Description : Configure a service information # # Arguments : # serviceName - Service name to add namespace to. # Return a list of items/values of default options if not # given. # item - The item to configure. Return a list of all items/values # if not given. # value - Optional, the new value. Return the value, if not given. # # Returns : The value of the option or a list of item/value pairs. # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 04/14/2009 G.Lester Initial version # 2.4.5 2017-12-04 H.Oehlmann Allow to set an option to the empty string. # Return all option/values, if called without # item. Return default items/values if no # service given. # ########################################################################### proc ::WS::Client::Config {args} { variable serviceArr variable options variable serviceLocalOptionsList set validOptionList $serviceLocalOptionsList lappend validOptionList location targetNamespace if {0 == [llength $args]} { # A list convertible to a dict is build for performance reasons: # - lappend does not test existence for each element # - if a list is needed, dict build burden is avoided set res {} foreach item $validOptionList { lappend res $item if {[info exists options($item)]} { lappend res $options($item) } else { lappend res {} } } return $res } set args [lassign $args serviceName] if {0 == [llength $args]} { set res {} foreach item $validOptionList { lappend res $item [dict get $serviceArr($serviceName) $item] } return $res } set args [lassign $args item] if { $item ni $validOptionList } { return -code error "Uknown option '$item' -- must be one of: [join $validOptionList {, }]" } switch -exact -- [llength $args] { 0 { return [dict get $serviceArr($serviceName) $item] } 1 { set value [lindex $args 0] dict set serviceArr($serviceName) $item $value return $value } default { ::log::log debug "To many arguments arguments {$args}" return \ -code error \ -errorcode [list WS CLIENT INVARGCNT $args] \ "To many arguments '$args'" } } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::SetServiceTransforms # # Description : Define a service's transforms # Transform signature is: # cmd serviceName operationName transformType xml {url {}} {argList {}} # where transformType is REQUEST or REPLY # and url and argList will only be present for transformType == REQUEST # # Arguments : # serviceName - Service name to add namespace to # inTransform - Input transform, defaults to {} # outTransform - Output transform, defaults to {} # # Returns : None # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 04/14/2009 G.Lester Initial version # # ########################################################################### proc ::WS::Client::SetServiceTransforms {serviceName {inTransform {}} {outTransform {}}} { variable serviceArr dict set serviceArr($serviceName) inTransform $inTransform dict set serviceArr($serviceName) outTransform $outTransform return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::GetServiceTransforms # # Description : Define a service's transforms # # Arguments : # serviceName - Service name to add namespace to # # Returns : List of two elements: inTransform outTransform # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 04/14/2009 G.Lester Initial version # # ########################################################################### proc ::WS::Client::GetServiceTransforms {serviceName} { variable serviceArr set inTransform [dict get serviceArr($serviceName) inTransform] set outTransform [dict get serviceArr($serviceName) outTransform] return [list $inTransform $outTransform] } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DefineRestMethod # # Description : Define a method # # Arguments : # serviceName - Service name to add namespace to # objectName - Name of the object # operationName - The name of the method to add # inputArgs - List of input argument definitions where each argument # definition is of the format: name typeInfo # returnType - The type, if any returned by the procedure. Format is: # xmlTag typeInfo # # where, typeInfo is of the format {type typeName comment commentString} # # Returns : The current service definition # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 04/14/2009 G.Lester Initial version # # ########################################################################### proc ::WS::Client::DefineRestMethod {serviceName objectName operationName inputArgs returnType {location {}}} { variable serviceArr if {[lsearch -exact [dict get $serviceArr($serviceName) objList] $objectName] == -1} { dict lappend serviceArr($serviceName) objList $objectName } if {![llength $location]} { set location [dict get $serviceArr($serviceName) location] } if {$inputArgs ne {}} { set inType $objectName.$operationName.Request ::WS::Utils::ServiceTypeDef Client $serviceName $inType $inputArgs } else { set inType {} } if {$returnType ne {}} { set outType $objectName.$operationName.Results ::WS::Utils::ServiceTypeDef Client $serviceName $outType $returnType } else { set outType {} } dict set serviceArr($serviceName) object $objectName location $location dict set serviceArr($serviceName) object $objectName operation $operationName inputs $inType dict set serviceArr($serviceName) object $objectName operation $operationName outputs $outType } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::ImportNamespace # # Description : Import and additional namespace into the service # # Arguments : # serviceName - Service name to add namespace to # url - URL of namespace file to import # # Returns : The local alias (tns) # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 01/30/2009 G.Lester Initial version # 2.4.1 2017-08-31 H.Oehlmann Use utility function # ::WS::Utils::geturl_fetchbody for http call # which also follows redirects. # 3.0.0 2020-10-26 H.Oehlmann Add geturl timeout # # ########################################################################### proc ::WS::Client::ImportNamespace {serviceName url} { variable serviceArr set serviceInfo $serviceArr($serviceName) switch -exact -- [dict get [::uri::split $url] scheme] { file { upvar #0 [::uri::geturl $url] token set xml $token(data) unset token } http - https { set xml [::WS::Utils::geturl_fetchbody $url\ -timeout [dict get $serviceInfo queryTimeout]] } default { return \ -code error \ -errorcode [list WS CLIENT UNKURLTYP $url] \ "Unknown URL type '$url'" } } set tnsCount [expr {[llength [dict get $serviceArr($serviceName) targetNamespace]]/2}] 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 {$target eq $url} { break } } return $result } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::GetOperationList # # Description : Import and additional namespace into the service # # Arguments : # serviceName - Service name to add namespace to # # Returns : A list of operations names. # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 01/30/2009 G.Lester Initial version # # ########################################################################### proc ::WS::Client::GetOperationList {serviceName {object {}}} { variable serviceArr 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]] } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::AddInputHeader # # Description : Import and additional namespace into the service # # Arguments : # serviceName - Service name to of the operation # operation - name of operation to add an input header to # headerType - the type name to add as a header # attrList - list of name value pairs of attributes and their # values to add to the XML # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 01/30/2009 G.Lester Initial version # # ########################################################################### proc ::WS::Client::AddInputHeader {serviceName operationName headerType {attrList {}}} { variable serviceArr set serviceInfo $serviceArr($serviceName) set soapRequestHeader [dict get $serviceInfo operation $operationName soapRequestHeader] lappend soapRequestHeader [list $headerType $attrList] dict set serviceInfo operation $operationName soapRequestHeader $soapRequestHeader set serviceArr($serviceName) $serviceInfo return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::AddOutputHeader # # Description : Import any additional namespace into the service # # Arguments : # serviceName - Service name to of the oepration # operation - name of operation to add an output header to # headerType - the type name to add as a header # attrList - list of name value pairs of attributes and their # values to add to the XML # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 01/30/2009 G.Lester Initial version # # ########################################################################### proc ::WS::Client::AddOutputHeader {serviceName operation headerType} { variable serviceArr set serviceInfo $serviceArr($serviceName) set soapReplyHeader [dict get $serviceInfo operation $operation soapReplyHeader] lappend soapReplyHeader $headerType dict set serviceInfo operation $operation soapReplyHeader $soapReplyHeader set serviceArr($serviceName) $serviceInfo return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::GetParsedWsdl # # Description : Get a service definition # # Arguments : # serviceName - Name of the service. # # Returns : The parsed service information # # Side-Effects : None # # Exception Conditions : UNKSERVICE # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::GetParsedWsdl {serviceName} { variable serviceArr if {![info exists serviceArr($serviceName)]} { return \ -code error "Unknown service '$serviceName'" \ -errorcode [list UNKSERVICE $serviceName] } return $serviceArr($serviceName) } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::LoadParsedWsdl # # Description : Load a saved service definition in # # Arguments : # serviceInfo - parsed service definition, as returned from # ::WS::Client::ParseWsdl or ::WS::Client::GetAndParseWsdl # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # serviceAlias - Alias (unique) name for service. # This is an optional argument and defaults to the name of the # service in serviceInfo. # # Returns : The name of the service loaded # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # 3.0.0 2020-10-30 H.Oehlmann Smooth option migration. # # ########################################################################### proc ::WS::Client::LoadParsedWsdl {serviceInfo {headers {}} {serviceAlias {}}} { variable serviceArr variable options variable serviceLocalOptionsList if {[string length $serviceAlias]} { set serviceName $serviceAlias } else { set serviceName [dict get $serviceInfo name] } if {$options(errorOnRedefine) && [info exists serviceArr($serviceName)]} { return -code error "Service '$serviceName' already exists" } elseif {[info exists serviceArr($serviceName)]} { unset serviceArr($serviceName) } if {[llength $headers]} { dict set serviceInfo headers $headers } set serviceArr($serviceName) $serviceInfo ## ## Copy any not present options from the default values ## This allows smooth migration, if a new version of the package define ## new options and the preparsed service of the old version was stored. ## foreach item $serviceLocalOptionsList { if {![dict exists $serviceArr($serviceName) $item]} { dict set serviceArr($serviceName) $item $options($item) } } 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 {[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 } } } if {[dict exists $serviceInfo simpletypes]} { foreach partList [dict get $serviceInfo simpletypes] { lassign $partList typeName definition 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 } } } return $serviceName } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::GetAndParseWsdl # # Description : # # Arguments : # url - The url of the WSDL # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # serviceAlias - Alias (unique) name for service. # This is an optional argument and defaults to the name # of the service in serviceInfo. # serviceNumber - Number of service within the WSDL to assign the # serviceAlias to. Only usable with a serviceAlias. # First service (default) is addressed by value "1". # # Returns : The parsed service definition # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # 2.4.1 2017-08-31 H.Oehlmann Use utility function # ::WS::Utils::geturl_fetchbody for http call # 2.4.6 2017-12-07 H.Oehlmann Added argument "serviceNumber". # 3.0.0 2020-10-26 H.Oehlmann Added query timeout # ########################################################################### proc ::WS::Client::GetAndParseWsdl {url {headers {}} {serviceAlias {}} {serviceNumber 1}} { variable currentBaseUrl variable options set currentBaseUrl $url switch -exact -- [dict get [::uri::split $url] scheme] { file { upvar #0 [::uri::geturl $url] token set wsdlInfo [ParseWsdl $token(data) -headers $headers -serviceAlias $serviceAlias -serviceNumber $serviceNumber] unset token } http - https { set largs {} if {[llength $headers]} { lappend largs -headers $headers } set body [::WS::Utils::geturl_fetchbody $url\ -timeout $options(queryTimeout) {*}$largs] set wsdlInfo [ParseWsdl $body -headers $headers -serviceAlias $serviceAlias -serviceNumber $serviceNumber] } default { return \ -code error \ -errorcode [list WS CLIENT UNKURLTYP $url] \ "Unknown URL type '$url'" } } set currentBaseUrl {} return $wsdlInfo } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::ParseWsdl # # Description : Parse a WSDL and create the service. Create stubs if specified. # # Arguments : # wsdlXML - XML of the WSDL # # Optional Arguments: # -createStubs 0|1 - create stub routines for the service # -headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # -serviceAlias - Alias (unique) name for service. # This is an optional argument and defaults to the # name of the service in serviceInfo. # -serviceNumber - Number of service within the WSDL to assign the # serviceAlias to. Only usable with a serviceAlias. # First service (default) is addressed by value "1". # # NOTE -- Arguments are position independent. # # Returns : The parsed service definition # # Side-Effects : None # # Exception Conditions :None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # 2.4.4 2017-11-03 H.Oehlmann Included ticket [dcce437d7a] with # solution by Wolfgang Winkler: # Search namespace prfix also in element # nodes and not only in definition node # of wsdl file. # 2.4.4 2017-11-06 H.Oehlmann Added check (for nested namespace prefix # case), that a namespace prefix is not # reused for another URI. # 2.4.5 2017-11-24 H.Oehlmann Added option "inlineElementNS" to activate # namespace definition search in element nodes # 2.4.6 2017-12-07 H.Oehlmann Added argument "-serviceNumber". # ########################################################################### proc ::WS::Client::ParseWsdl {wsdlXML args} { variable currentBaseUrl variable serviceArr variable options # Build the argument array with the following defaults array set argument { -createStubs 0 -headers {} -serviceAlias {} -serviceNumber 1 } array set argument $args set first [string first {<} $wsdlXML] if {$first > 0} { set wsdlXML [string range $wsdlXML $first end] } ::log::logsubst debug {Parsing WSDL: $wsdlXML} # save parsed document node to tmpdoc dom parse $wsdlXML tmpdoc # save transformed document handle in variable wsdlDoc $tmpdoc xslt $::WS::Utils::xsltSchemaDom wsdlDoc $tmpdoc delete # save top node in variable wsdlNode $wsdlDoc documentElement wsdlNode set nsCount 1 set targetNs [$wsdlNode getAttribute targetNamespace] set ::WS::Utils::targetNs $targetNs ## ## Build the namespace prefix dict ## # nsDict contains two tables: # 1) Lookup URI, get internal prefix # url # 2) Lookup wsdl namespace prefix, get internal namespace prefix # tns # : unique ID, mostly URL # : namespace prefix used in wsdl # internal namespace prefix which allows to use predefined prefixes # not to clash with the wsdl prefix in # Predefined: # - tns1 : targetNamespace # - w: http://schemas.xmlsoap.org/wsdl/ # - d: http://schemas.xmlsoap.org/wsdl/soap/ # - xs: http://www.w3.org/2001/XMLSchema # # The top node # # xmlns:wsdl="http://schemas.xmlsoap.org/wsdl/ ...> # contains the target namespace and all namespace definitions dict set nsDict url $targetNs tns$nsCount $wsdlDoc selectNodesNamespaces { w http://schemas.xmlsoap.org/wsdl/ d http://schemas.xmlsoap.org/wsdl/soap/ xs http://www.w3.org/2001/XMLSchema } ## ## build list of namespace definition nodes ## ## the top node is always used set NSDefinitionNodeList [list $wsdlNode] ## ## get namespace definitions in element nodes ## ## Element nodes may declare namespaces inline like: ## ## ticket [dcce437d7a] # This is only done, if option inlineElementNS is set in the default # options. Service dependent options may not be used at this stage, # as serviceArr is not created jet (Client::Config will fail) and the # service name is not known jet. if {$options(inlineElementNS)} { lappend NSDefinitionNodeList {*}[$wsdlDoc selectNodes {//xs:element}] } foreach elemNode $NSDefinitionNodeList { # Get list of xmlns attributes # This list looks for the example like: {{q1 q1 {}} ... } set xmlnsAttributes [$elemNode attributes xmlns:*] # Loop over found namespaces foreach itemList $xmlnsAttributes { set ns [lindex $itemList 0] set url [$elemNode getAttribute xmlns:$ns] if {[dict exists $nsDict url $url]} { set tns [dict get $nsDict url $url] } else { ## ## Check for hardcoded namespaces ## switch -exact -- $url { http://schemas.xmlsoap.org/wsdl/ { set tns w } http://schemas.xmlsoap.org/wsdl/soap/ { set tns d } http://www.w3.org/2001/XMLSchema { set tns xs } default { set tns tns[incr nsCount] } } dict set nsDict url $url $tns } ## ## Check if same namespace prefix was already assigned to a ## different URL ## # This may happen, if the element namespace prefix overwrites # a global one, like # # if { [dict exists $nsDict tns $ns] && $tns ne [dict get $nsDict tns $ns] } { ::log::logsubst debug {Namespace prefix '$ns' with different URI '$url': $nsDict} return \ -code error \ -errorcode [list WS CLIENT AMBIGNSPREFIX] \ "element namespace prefix '$ns' used again for different URI '$url'.\ Sorry, this is a current implementation limitation of TCLWS." } dict set nsDict tns $ns $tns } } if {[info exists currentBaseUrl]} { set url $currentBaseUrl } else { set url $targetNs } array unset ::WS::Utils::includeArr ::WS::Utils::ProcessIncludes $wsdlNode $url set serviceInfo {} foreach serviceInfo [buildServiceInfo $wsdlNode $nsDict $serviceInfo $argument(-serviceAlias) $argument(-serviceNumber)] { set serviceName [dict get $serviceInfo name] if {[llength $argument(-headers)]} { dict set serviceInfo headers $argument(-headers) } dict set serviceInfo types [::WS::Utils::GetServiceTypeDef Client $serviceName] dict set serviceInfo simpletypes [::WS::Utils::GetServiceSimpleTypeDef Client $serviceName] set serviceArr($serviceName) $serviceInfo if {$argument(-createStubs)} { catch {namespace delete $serviceName} namespace eval $serviceName {} CreateStubs $serviceName } } $wsdlDoc delete unset -nocomplain ::WS::Utils::targetNs return $serviceInfo } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::CreateStubs # # Description : Create stubs routines to make calls to Webservice Operations. # All routines will be create in a namespace that is the same # as the service name. The procedure name will be the same # as the operation name. # # NOTE -- Webservice arguments are position independent, thus # the proc arguments will be defined in alphabetical order. # # Arguments : # serviceName - The service to create stubs for # # Returns : A string describing the created procedures. # # Side-Effects : Existing namespace is deleted. # # Exception Conditions : None # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::CreateStubs {serviceName} { variable serviceArr namespace eval [format {::%s::} $serviceName] {} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) set procList {} foreach operationName [dict get $serviceInfo operList] { if {[dict get $serviceInfo operation $operationName cloned]} { continue } set procName [format {::%s::%s} $serviceName $operationName] set argList {} foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { set inputHeaderType [lindex $inputHeaderTypeItem 0] if {$inputHeaderType eq {}} { continue } set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] set headerFields [dict keys [dict get $headerTypeInfo definition]] 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 ## not add any arguments... set inputMsgTypeDefinition [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] if {[dict exists $inputMsgTypeDefinition definition]} { set inputFields [dict keys [dict get $inputMsgTypeDefinition definition]] } else { ::log::logsubst debug {no definition found for inputMsgType $inputMsgType} set inputFields {} } if {$inputFields ne {}} { lappend argList [lsort -dictionary $inputFields] } set argList [join $argList] set body { set procName [lindex [info level 0] 0] set serviceName [string trim [namespace qualifiers $procName] {:}] set operationName [string trim [namespace tail $procName] {:}] set argList {} foreach var [namespace eval ::${serviceName}:: [list info args $operationName]] { lappend argList $var [set $var] } ::log::logsubst debug {::WS::Client::DoCall $serviceName $operationName $argList} ::WS::Client::DoCall $serviceName $operationName $argList } proc $procName $argList $body append procList "\n\t[list $procName $argList]" } return "$procList\n" } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DoRawCall # # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call # argList - The arguments to the operation as a dictionary object. # This is for both the Soap Header and Body messages. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # # Returns : # The XML of the operation. # # Side-Effects : None # # Exception Conditions : # WS CLIENT HTTPERROR - if an HTTP error occurred # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # 2.4.1 2017-08-31 H.Oehlmann Use utility function # ::WS::Utils::geturl_fetchbody for http call # which also follows redirects. # 3.0.0 2020-10-26 H.Oehlmann Added query timeout # # ########################################################################### proc ::WS::Client::DoRawCall {serviceName operationName argList {headers {}}} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) if {![dict exists $serviceInfo operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $operationName]] \ "Unknown operation '$operationName' for service '$serviceName'" } ## ## build query ## set url [dict get $serviceInfo location] SaveAndSetOptions $serviceName if {[catch {set query [buildCallquery $serviceName $operationName $url $argList]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { RestoreSavedOptions $serviceName } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } if {[dict exists $serviceInfo operation $operationName action]} { lappend headers SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]] } ## ## do http call ## set largs {} if {[llength $headers]} { lappend largs -headers $headers } set body [::WS::Utils::geturl_fetchbody $url\ -query $query\ -type [dict get $serviceInfo contentType]\ -timeout [dict get $serviceInfo queryTimeout]\ {*}$largs] ::log::logsubst debug {Leaving ::WS::Client::DoRawCall with {$body}} return $body } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DoCall # # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call # argList - The arguments to the operation as a dictionary object # This is for both the Soap Header and Body messages. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # # Returns : # The return value of the operation as a dictionary object. # # Side-Effects : None # # Exception Conditions : # WS CLIENT HTTPERROR - if an HTTP error occurred # others - as raised by called Operation # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # 2.4.1 2017-08-30 H.Oehlmann Use ::WS::Utils::geturl_fetchbody to do # http call. This automates a lot and follows # redirects. # 3.0.0 2020-10-26 H.Oehlmann Added query timeout # # ########################################################################### proc ::WS::Client::DoCall {serviceName operationName argList {headers {}}} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) if {![dict exists $serviceInfo operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $operationName]] \ "Unknown operation '$operationName' for service '$serviceName'" } elseif {[dict get $serviceInfo operation $operationName cloned]} { return \ -code error \ -errorcode [list WS CLIENT MUSTCALLCLONE [list $serviceName $operationName]] \ "Operation '$operationName' for service '$serviceName' is overloaded, you must call one of its clones." } set url [dict get $serviceInfo location] SaveAndSetOptions $serviceName if {[catch {set query [buildCallquery $serviceName $operationName $url $argList]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo "buildCallquery error -- $err" } else { RestoreSavedOptions $serviceName } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } if {[dict exists $serviceInfo operation $operationName action]} { lappend headers SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]] } ## ## Do the http request ## # This will directly return with correct error # side effect: sets the variable httpCode set largs {} if {[llength $headers]} { lappend largs -headers $headers } set body [::WS::Utils::geturl_fetchbody -codeok {200 500} -codevar httpCode $url\ -query $query\ -type [dict get $serviceInfo contentType]\ -headers $headers\ {*}$largs] # numerical http code was saved in variable httpCode ## ## Process body ## set outTransform [dict get $serviceInfo outTransform] if {$httpCode == 500} { ## Code 500 treatment 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 {$mainError eq {WSCLIENT} && $subError eq {NOSOAP}} { ::log::logsubst debug {\tHTTP error $body} set results $body set errorCode [list WSCLIENT HTTPERROR $body] set errorInfo {} } else { ::log::logsubst debug {Reply was $body} set errorCode $::errorCode set errorInfo $::errorInfo } } } else { if {$outTransform ne {}} { SaveAndSetOptions $serviceName catch {set body [$outTransform $serviceName $operationName REPLY $body]} RestoreSavedOptions $serviceName } SaveAndSetOptions $serviceName set hadError [catch {parseResults $serviceName $operationName $body} results] RestoreSavedOptions $serviceName if {$hadError} { ::log::logsubst debug {Reply was $body} set errorCode $::errorCode set errorInfo $::errorInfo } } if {$hadError} { ::log::log debug "Leaving (error) ::WS::Client::DoCall" return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $results } else { ::log::logsubst debug {Leaving ::WS::Client::DoCall with {$results}} return $results } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::FormatHTTPError # # Description : Format error after a http::geturl failure. # A failure consists wether in the HTTP return code unequal to 200 # or in the status equal "error". Status "timeout" is untreated, as this # http feature is not used in the package. # # Arguments : # tolken - tolken of the http::geturl request # # Returns : # Error message # # Side-Effects : None # # Pre-requisite Conditions : HTTP failure must be present # # Original Author : Harald Oehlmann # #>>END PUBLIC<< # # 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 06/02/2015 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Client::FormatHTTPError {token} { if {[::http::status $token] eq {ok}} { if {[::http::size $token] == 0} { return "HTTP failure socket closed" } return "HTTP failure code [::http::ncode $token]" } else { return "HTTP error: [::http::error $token]" } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DoAsyncCall # # Description : Call an operation of a web service asynchronously # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call # argList - The arguments to the operation as a dictionary object # This is for both the Soap Header and Body messages. # succesCmd - A command prefix to be called if the operations # does not raise an error. The results, as a dictionary # object are concatenated to the prefix. # errorCmd - A command prefix to be called if the operations # raises an error. The error code and stack trace # are concatenated to the prefix. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # # Returns : # None. # # Side-Effects : None # # Exception Conditions : # WS CLIENT HTTPERROR - if an HTTP error occurred # others - as raised by called Operation # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # 3.1.0 2024-11-01 H.Oehlmann Set header "SOAPAction" as in the other # call methods. Ticket [b41fe0846b] # # ########################################################################### proc ::WS::Client::DoAsyncCall {serviceName operationName argList succesCmd errorCmd {headers {}}} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) if {![dict exists $serviceInfo operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $operationName]] \ "Unknown operation '$operationName' for service '$serviceName'" } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } if {[dict exists $serviceInfo operation $operationName action]} { lappend headers SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]] } set url [dict get $serviceInfo location] SaveAndSetOptions $serviceName if {[catch {set query [buildCallquery $serviceName $operationName $url $argList]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { RestoreSavedOptions $serviceName } set largs {} if {[llength $headers]} { lappend largs -headers $headers } ::log::logsubst info {::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd]\ -timeout [dict get $serviceInfo queryTimeout] \ {*}$largs} ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] \ -timeout [dict get $serviceInfo queryTimeout] \ {*}$largs ::log::logsubst debug {Leaving ::WS::Client::DoAsyncCall} return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::List # # Description : List a Webservice's Operations. # # NOTE -- Webservice arguments are position independent, thus # the proc arguments will be defined in alphabetical order. # # Arguments : # serviceName - The service to create stubs for # # Returns : A string describing the operations. # # Side-Effects : Existing namespace is deleted. # # Exception Conditions : None # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 10/11/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::List {serviceName} { variable serviceArr if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) set procList {} foreach operationName [lsort -dictionary [dict get $serviceInfo operList]] { if {[dict get $serviceInfo operation $operationName cloned]} { continue } set procName $operationName set argList {} foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { set inputHeaderType [lindex $inputHeaderTypeItem 0] if {$inputHeaderType eq {}} { continue } set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] set headerFields [dict keys [dict get $headerTypeInfo definition]] if {$headerFields ne {}} { lappend argList [lsort -dictionary $headerFields] } } set inputMsgType [dict get $serviceInfo operation $operationName inputs] 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 {$inputFields ne {}} { lappend argList [lsort -dictionary $inputFields] } } } set argList [join $argList] append procList "\n\t$procName $argList" } return "$procList\n" } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::ListRest # # Description : List a Webservice's Operations. # # NOTE -- Webservice arguments are position independent, thus # the proc arguments will be defined in alphabetical order. # # Arguments : # serviceName - The service to create stubs for # # Returns : A string describing the operations. # # Side-Effects : Existing namespace is deleted. # # Exception Conditions : None # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 10/11/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::ListRest {serviceName} { variable serviceArr if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) set procList {} foreach object [dict get $serviceInfo objList] { 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 {$inputHeaderType eq {}} { continue } set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] set headerFields [dict keys [dict get $headerTypeInfo definition]] 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 {$inputFields ne {}} { lappend argList [lsort -dictionary $inputFields] } set argList [join $argList] append procList "\n\t$object $procName $argList" } } return "$procList\n" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::asyncCallDone # # Description : Called when an asynchronous call is complete. This routine # will call either the success or error callback depending on # if the operation succeeded or failed -- assuming the callback # is defined. # # Arguments : # serviceName - the name of the service called # operationName - the name of the operation called # succesCmd - the command prefix to call if no error # errorCmd - the command prefix to call on an error # token - the token from the HTTP request # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::asyncCallDone {serviceName operationName succesCmd errorCmd token} { ::log::logsubst debug {Entering [info level 0]} ## ## Check for errors ## set body [::http::data $token] ::log::logsubst info {\nReceived: $body} set results {} if {[::http::status $token] ne {ok} || ( [::http::ncode $token] != 200 && $body eq {} )} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set hadError 1 set results [FormatHTTPError $token] set errorInfo "" } else { SaveAndSetOptions $serviceName set hadError [catch {parseResults $serviceName $operationName $body} results] RestoreSavedOptions $serviceName if {$hadError} { set errorCode $::errorCode set errorInfo $::errorInfo } } ::http::cleanup $token ## ## Call the appropriate callback ## if {$hadError} { set cmd $errorCmd lappend cmd $errorCode $errorInfo } else { set cmd $succesCmd } if {$cmd ne ""} { lappend cmd $results if {[catch $cmd cmdErr]} { ::log::log error "Error invoking callback '$cmd': $cmdErr" } } ## ## All done ## return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::parseResults # # Description : Convert the returned XML into a dictionary object # # Arguments : # serviceName - the name of the service called # operationName - the name of the operation called # inXML - the XML returned by the operation # # Returns : A dictionary object representing the results # # Side-Effects : None # # Exception Conditions : # WS CLIENT REMERR - The remote end raised an exception, the third element of # the error code is the remote fault code. # Error info is set to the remote fault details. # The error message is the remote fault string. # WS CLIENT BADREPLY - Badly formatted reply, the third element is a list of # what message type was received vs what was expected. # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2.4.2 2017-08-31 H.Oehlmann The response node name may also be the # output name and not only the output type. # (ticket [21f41e22bc]). # 2.4.3 2017-11-03 H.Oehlmann Extended upper commit also to search # for multiple child nodes. # 2.5.1 2018-05-14 H.Oehlmann Add support to translate namespace prefixes # in attribute values or text values. # Translation dict "xnsDistantToLocalDict" is # passed to ::WS::Utils::convertTypeToDict # to translate abstract types. # ########################################################################### proc ::WS::Client::parseResults {serviceName operationName inXML} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set expectedMsgType [dict get $serviceInfo operation $operationName outputs] set expectedMsgTypeBase [lindex [split $expectedMsgType {:}] end] set first [string first {<} $inXML] if {$first > 0} { set inXML [string range $inXML $first end] } # parse xml and save handle in variable doc and free it when out of scope dom parse $inXML doc # save top node handle in variable top and free it if out of scope $doc documentElement top set xns { ENV http://schemas.xmlsoap.org/soap/envelope/ xsi "http://www.w3.org/2001/XMLSchema-instance" xs "http://www.w3.org/2001/XMLSchema" } foreach {prefixCur URICur} [dict get $serviceInfo targetNamespace] { lappend xns $prefixCur $URICur } ::log::logsubst debug {Using namespaces {$xns}} $doc selectNodesNamespaces $xns ## ## When arguments with tags are passed (example: abstract types), ## the upper "selectNodesNamespaces translation must be executed manually. ## Thus, we need a list of server namespace prefixes to our client namespace ## prefixes. (bug 584bfb77) ## # Example xml: # set xnsDistantToLocalDict {} foreach attributeCur [$top attributes] { # attributeCur is a list of "prefix local URI", # which is for xmlns tags: "prefix prefix {}". set attributeCur [lindex $attributeCur 0] # Check if this is a namespace prefix if { ! [$top hasAttribute "xmlns:$attributeCur"] } {continue} set URIServer [$top getAttribute "xmlns:$attributeCur"] # Check if it is included in xns foreach {prefixCur URICur} $xns { if {$URIServer eq $URICur} { dict set xnsDistantToLocalDict $attributeCur $prefixCur break } } } ::log::logsubst debug {Server to Client prefix dict: $xnsDistantToLocalDict} ## ## Get body tag ## set body [$top selectNodes ENV:Body] if {![llength $body]} { return \ -code error \ -errorcode [list WS CLIENT BADREPLY $inXML] \ "Bad reply type, no SOAP envelope received in: \n$inXML" } ## ## Find the reply root node with the response. ## # # # <-- this one # # WSDL 1.0: http://xml.coverpages.org/wsdl20000929.html # Chapter 2.4.2 (name optional) and 2.4.5 (default name) # The node name could be: # 1) an error node "Fault" # 2) equal to the WSDL name property of the output node # 3) if no name tag, equal to Response # 4) the local output type name # # Possibility (2) "OutName" WSDL example: # # # This possibility is requested by ticket [21f41e22bc] # # Possibility (3) default name "{OperationName}Result" WSDL example: # # *** no name tag *** # # Possibility (4) was not found in wsdl 1.0 standard but was used as only # solution by TCLWS prior to 2.4.2. # The following sketch shows the location of the local output type name # "OutTypeName" in a WSDL file: # -> In WSDL portType output message name # # # -> then in message, use the element: # # # -> The element "OutTypeName" is also find in a type definition: # # # ... # # Build a list of possible names set nodeNameCandidateList [list Fault $expectedMsgTypeBase] # We check if the preparsed wsdl contains the name flag. # This is not the case, if it was parsed with tclws prior 2.4.2 # *** ToDo *** This security may be removed on a major release if {[dict exists $serviceInfo operation $operationName outputsname]} { lappend nodeNameCandidateList [dict get $serviceInfo operation $operationName outputsname] } set rootNodeList [$body childNodes] ::log::logsubst debug {Have [llength $rootNodeList] node under Body} foreach rootNodeCur $rootNodeList { set rootNameCur [$rootNodeCur localName] if {$rootNameCur eq {}} { set rootNameCur [$rootNodeCur nodeName] } if {$rootNameCur in $nodeNameCandidateList} { set rootNode $rootNodeCur set rootName $rootNameCur ::log::logsubst debug {Result root name is '$rootName'} break } ::log::logsubst debug {Result root name '$rootNameCur' not in candidates '$nodeNameCandidateList'} } ## ## Exit if there is no such node ## if {![info exists rootName]} { return \ -code error \ -errorcode [list WS CLIENT BADREPLY [list $rootNameCur $expectedMsgTypeBase]] \ "Bad reply type, received '$rootNameCur'; but expected '$expectedMsgTypeBase'." } ## ## See if it is a standard error packet ## if {$rootName eq {Fault}} { set faultcode {} set faultstring {} set detail {} foreach item {faultcode faultstring detail} { set tmpNode [$rootNode selectNodes ENV:$item] if {$tmpNode eq {}} { set tmpNode [$rootNode selectNodes $item] } if {$tmpNode ne {}} { if {[$tmpNode hasAttribute href]} { set tmpNode [GetReferenceNode $top [$tmpNode getAttribute href]] } set $item [$tmpNode asText] } } $doc delete return \ -code error \ -errorcode [list WS CLIENT REMERR $faultcode] \ -errorinfo $detail \ $faultstring } ## ## Convert the packet to a dictionary ## set results {} set headerRootNode [$top selectNodes ENV:Header] if {[llength $headerRootNode]} { foreach outHeaderType [dict get $serviceInfo operation $operationName soapReplyHeader] { if {$outHeaderType eq {}} { continue } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $outHeaderType] xns] set node [$headerRootNode selectNodes $outHeaderType] if {![llength $node]} { set node [$headerRootNode selectNodes $xns:$outHeaderType] if {![llength $node]} { continue } } #if {[llength $outHeaderAttrs]} { # ::WS::Utils::setAttr $node $outHeaderAttrs #} ::log::logsubst debug {Calling convertTypeToDict from header node type '$outHeaderType'} lappend results [::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode 0 $xnsDistantToLocalDict] } } ## ## Call Utility function to build result list ## if {$rootName ne {}} { ::log::log debug "Calling convertTypeToDict with root node" set bodyData [::WS::Utils::convertTypeToDict \ Client $serviceName $rootNode $expectedMsgType $body 0 $xnsDistantToLocalDict] if {![llength $bodyData] && ([dict get $serviceInfo skipLevelWhenActionPresent] || [dict get $serviceInfo skipLevelOnReply])} { ::log::log debug "Calling convertTypeToDict with skipped action level (skipLevelWhenActionPresent was set)" set bodyData [::WS::Utils::convertTypeToDict \ Client $serviceName $body $expectedMsgType $body 0 $xnsDistantToLocalDict] } lappend results $bodyData } set results [join $results] $doc delete set ::errorCode {} set ::errorInfo {} return $results } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::buildCallquery # # Description : Build the XML request message for the call # # Arguments : # serviceName - the name of the service called # operationName - the name of the operation called # url - the URL of the operation # argList - a dictionary object of the calling arguments # # Returns : The XML for the call # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::buildCallquery {serviceName operationName url argList} { variable serviceArr set serviceInfo $serviceArr($serviceName) set style [dict get $serviceInfo operation $operationName style] set suppressTargetNS [dict get $serviceInfo suppressTargetNS] set inSuppressNs [::WS::Utils::SetOption suppressNS] if {$suppressTargetNS} { ::WS::Utils::SetOption suppressNS tns1 } else { ::WS::Utils::SetOption suppressNS {} } switch -exact -- $style { document/literal { set xml [buildDocLiteralCallquery $serviceName $operationName $url $argList] } rpc/encoded { set xml [buildRpcEncodedCallquery $serviceName $operationName $url $argList] } default { return \ -code error \ "Unsupported Style '$style'" } } ::WS::Utils::SetOption suppressNS $inSuppressNs set inTransform [dict get $serviceInfo inTransform] if {$inTransform ne {}} { set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList] } ::log::logsubst debug {Leaving ::WS::Client::buildCallquery with {$xml}} return $xml } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::buildDocLiteralCallquery # # Description : Build the XML request message for the call # # Arguments : # serviceName - the name of the service called # operationName - the name of the operation called # url - the URL of the operation # argList - a dictionary object of the calling arguments # This is for both the Soap Header and Body messages. # # Returns : The XML for the call # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::buildDocLiteralCallquery {serviceName operationName url argList} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set msgType [dict get $serviceInfo operation $operationName inputs] set url [dict get $serviceInfo location] set xnsList [dict get $serviceInfo targetNamespace] # save the document in variable doc and free it if out of scope dom createDocument "SOAP-ENV:Envelope" doc $doc documentElement env $env setAttribute \ "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \ "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" \ "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance" \ "xmlns:xs" "http://www.w3.org/2001/XMLSchema" if {[dict exists $serviceInfo noTargetNs] && ![dict get $serviceInfo noTargetNs]} { $env setAttribute "xmlns" [dict get $xnsList tns1] } array unset tnsArray * array set tnsArray { "http://schemas.xmlsoap.org/soap/envelope/" "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/encoding/" "xmlns:SOAP-ENC" "http://www.w3.org/2001/XMLSchema-instance" "xmlns:xsi" "http://www.w3.org/2001/XMLSchema" "xmlns:xs" } foreach {tns target} $xnsList { #set tns [lindex $xns 0] #set target [lindex $xns 1] set tnsArray($target) $tns $env setAttribute \ xmlns:$tns $target } #parray tnsArray set firstHeader 1 foreach inputHeaderTypeItem [dict get $serviceInfo operation $operationName soapRequestHeader] { lassign $inputHeaderTypeItem inputHeaderType attrList if {$inputHeaderType eq {}} { continue } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] xns] if {[info exists tnsArray($xns)]} { set xns $tnsArray($xns) } if {$firstHeader} { # side effect: save new node handle in variable header $env appendChild [$doc createElement "SOAP-ENV:Header" header] set firstHeader 0 } if {[dict exists $serviceInfo skipHeaderLevel] && [dict get $serviceInfo skipHeaderLevel]} { set headerData $header } else { set typeInfo [split $inputHeaderType {:}] if {[llength $typeInfo] > 1} { set headerType $inputHeaderType } else { set headerType $xns:$inputHeaderType } $header appendChild [$doc createElement $headerType headerData] if {[llength $attrList]} { ::WS::Utils::setAttr $headerData $attrList } } ::WS::Utils::convertDictToType Client $serviceName $doc $headerData $argList $inputHeaderType } # side effect: save new element handle in variable bod $env appendChild [$doc createElement "SOAP-ENV:Body" bod] #puts "set xns \[dict get \[::WS::Utils::GetServiceTypeDef Client $serviceName $msgType\] xns\]" #puts "\t [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType]" set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType] xns] if {[info exists tnsArray($xns)]} { set xns $tnsArray($xns) } set typeInfo [split $msgType {:}] if {[llength $typeInfo] != 1} { set xns [lindex $typeInfo 0] set msgType [lindex $typeInfo 1] } if {[dict get $serviceInfo skipLevelWhenActionPresent] && [dict exists $serviceInfo operation $operationName action]} { set forceNs 1 set reply $bod } else { ::log::logsubst debug {$bod appendChild \[$doc createElement $xns:$msgType reply\]} $bod appendChild [$doc createElement $xns:$msgType reply] set forceNs 0 } ::WS::Utils::convertDictToType Client $serviceName $doc $reply $argList $xns:$msgType $forceNs set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {:}] end] {=}] end] set xml [format {} $encoding] append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] $doc delete ::log::logsubst debug {Leaving ::WS::Client::buildDocLiteralCallquery with {$xml}} return [encoding convertto $encoding $xml] } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::buildRpcEncodedCallquery # # Description : Build the XML request message for the call # # Arguments : # serviceName - the name of the service called # operationName - the name of the operation called # url - the URL of the operation # argList - a dictionary object of the calling arguments # This is for both the Soap Header and Body messages. # # Returns : The XML for the call # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::buildRpcEncodedCallquery {serviceName operationName url argList} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set msgType [dict get $serviceInfo operation $operationName inputs] set xnsList [dict get $serviceInfo targetNamespace] dom createDocument "SOAP-ENV:Envelope" doc $doc documentElement env $env setAttribute \ xmlns:SOAP-ENV "http://schemas.xmlsoap.org/soap/envelope/" \ xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance" \ xmlns:xs "http://www.w3.org/2001/XMLSchema" foreach {tns target} $xnsList { $env setAttribute xmlns:$tns $target } set firstHeader 1 foreach inputHeaderType [dict get $serviceInfo operation $operationName soapRequestHeader] { 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] set firstHeader 0 } $header appendChild [$doc createElement $xns:$inputHeaderType headerData] ::WS::Utils::convertDictToEncodedType Client $serviceName $doc $headerData $argList $inputHeaderType } $env appendChild [$doc createElement "SOAP-ENV:Body" bod] set baseName [dict get $serviceInfo operation $operationName name] set callXns [dict get $serviceInfo operation $operationName xns] # side effect: node handle is saved in variable reply if {![string is space $callXns]} { $bod appendChild [$doc createElement $callXns:$baseName reply] } else { $bod appendChild [$doc createElement $baseName reply] } $reply setAttribute \ SOAP-ENV:encodingStyle "http://schemas.xmlsoap.org/soap/encoding/" ::WS::Utils::convertDictToEncodedType Client $serviceName $doc $reply $argList $msgType set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {;}] end] {=}] end] set xml [format {} $encoding] append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] $doc delete ::log::logsubst debug {Leaving ::WS::Client::buildRpcEncodedCallquery with {$xml}} return [encoding convertto $encoding $xml] } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::buildServiceInfo # # Description : Parse the WSDL into our internal representation # # Arguments : # wsdlNode - The top node of the WSDL # results - Initial definition. This is optional and defaults to no definition. # serviceAlias - Alias (unique) name for service. # This is an optional argument and defaults to the name of the # service in serviceInfo. # serviceNumber - Number of service within the WSDL to assign the # serviceAlias to. Only usable with a serviceAlias. # First service (default) is addressed by value "1". # # Returns : The parsed WSDL # # Side-Effects : Defines Client mode types as specified by the WSDL # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2.4.6 2017-12-07 H.Oehlmann Added argument "serviceNumber" # # ########################################################################### proc ::WS::Client::buildServiceInfo {wsdlNode tnsDict {serviceInfo {}} {serviceAlias {}} {serviceNumber 1}} { ## ## Need to refactor to foreach service parseService ## Service drills down to ports, which drills down to bindings and messages ## ::log::logsubst debug {Entering [info level 0]} ## ## Parse Service information ## # WSDL snippet: # # # ... # # # ... # # # Without serviceAlias and serviceNumber, two services "service1" and # "service2" are created. # With serviceAlias = "SE" and serviceNumber=2, "service2" is created as # "SE". set serviceNameList [$wsdlNode selectNodes w:service] # Check for no service node if {[llength $serviceNameList] == 0} { return \ -code error \ -errorcode [list WS CLIENT NOSVC] \ "WSDL does not define any services" } if {"" ne $serviceAlias} { if {$serviceNumber < 1 || $serviceNumber > [llength $serviceNameList]} { return \ -code error \ -errorcode [list WS CLIENT INVALDCNT] \ "WSDL does not define service number $serviceNumber" } set serviceNameList [lrange $serviceNameList $serviceNumber-1 $serviceNumber-1] } foreach serviceNode $serviceNameList { lappend serviceInfo [parseService $wsdlNode $serviceNode $serviceAlias $tnsDict] } ::log::logsubst debug {Leaving ::WS::Client::buildServiceInfo with $serviceInfo} return $serviceInfo } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::parseService # # Description : Parse a service from a WSDL into our internal representation # # Arguments : # wsdlNode - The top node of the WSDL # serviceNode - The DOM node for the service. # serviceAlias - Alias (unique) name for service. # This is an optional argument and defaults to the name of the # service in serviceInfo. # tnsDict - Dictionary of URI to namespaces used # # Returns : The parsed service WSDL # # Side-Effects : Defines Client mode types for the service as specified by the WSDL # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 08/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::parseService {wsdlNode serviceNode serviceAlias tnsDict} { variable serviceArr variable options ::log::logsubst debug {Entering [info level 0]} if {[string length $serviceAlias]} { set serviceName $serviceAlias } else { set serviceName [$serviceNode getAttribute name] } set addressNodeList [$serviceNode getElementsByTagNameNS http://schemas.xmlsoap.org/wsdl/soap/ address] if {[llength $addressNodeList] == 1} { set addressNode [lindex $addressNodeList 0] set portNode [$addressNode parentNode] set location [$addressNode getAttribute location] } else { foreach addressNode $addressNodeList { set portNode [$addressNode parentNode] if {[$addressNode hasAttribute location]} { set location [$addressNode getAttribute location] break } } } if {![info exists location]} { return \ -code error \ -errorcode [list WS CLIENT NOSOAPADDR] \ "Malformed WSDL -- No SOAP address node found." } set xns {} foreach url [dict keys [dict get $tnsDict url]] { lappend xns [list [dict get $tnsDict url $url] $url] } if {[$wsdlNode hasAttribute targetNamespace]} { set target [$wsdlNode getAttribute targetNamespace] } else { set target $location } set tmpTargetNs $::WS::Utils::targetNs set ::WS::Utils::targetNs $target CreateService $serviceName WSDL $location $target xns $xns set serviceInfo $serviceArr($serviceName) dict set serviceInfo tnsList $tnsDict set bindingName [lindex [split [$portNode getAttribute binding] {:}] end] ## ## Parse types ## parseTypes $wsdlNode $serviceName serviceInfo ## ## Parse bindings ## parseBinding $wsdlNode $serviceName $bindingName serviceInfo ## ## All done, so return results ## #dict unset serviceInfo tnsList dict set serviceInfo suppressTargetNS $options(suppressTargetNS) foreach {key value} [dict get $serviceInfo tnsList url] { dict set serviceInfo targetNamespace $value $key } set serviceArr($serviceName) $serviceInfo set ::WS::Utils::targetNs $tmpTargetNs ::log::logsubst debug {Leaving [lindex [info level 0] 0] with $serviceInfo} return $serviceInfo } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::parseTypes # # Description : Parse the types for a service from a WSDL into # our internal representation # # Arguments : # wsdlNode - The top node of the WSDL # serviceNode - The DOM node for the service. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. # # Returns : Nothing # # Side-Effects : Defines Client mode types for the service as specified by the WSDL # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 08/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::parseTypes {wsdlNode serviceName serviceInfoVar} { ::log::log debug "Entering [info level 0]" upvar 1 $serviceInfoVar serviceInfo set tnsCount [llength [dict keys [dict get $serviceInfo tnsList url]]] set baseUrl [dict get $serviceInfo location] foreach schemaNode [$wsdlNode selectNodes w:types/xs:schema] { ::log::log debug "Parsing node $schemaNode" ::WS::Utils::parseScheme Client $baseUrl $schemaNode $serviceName serviceInfo tnsCount } ::log::log debug "Leaving [lindex [info level 0] 0]" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::parseBinding # # Description : Parse the bindings for a service from a WSDL into our # internal representation # # Arguments : # wsdlNode - The top node of the WSDL # serviceName - The name service. # bindingName - The name binding we are to parse. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. # # Returns : Nothing # # Side-Effects : Defines Client mode types for the service as specified by the WSDL # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 08/06/2006 G.Lester Initial version # 2.4.2 2017-08-31 H.Oehlmann Also set serviceArr operation members # inputsName and outputsName. # # ########################################################################### proc ::WS::Client::parseBinding {wsdlNode serviceName bindingName serviceInfoVar} { ::log::log debug "Entering [info level 0]" upvar 1 $serviceInfoVar serviceInfo variable options set bindQuery [format {w:binding[attribute::name='%s']} $bindingName] array set msgToOper {} foreach binding [$wsdlNode selectNodes $bindQuery] { array unset msgToOper * set portName [lindex [split [$binding getAttribute type] {:}] end] ::log::log debug "\t Processing binding '$bindingName' on port '$portName'" 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 {$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 } set style [$styleNode getAttribute style] #puts "Using style for first operation {$style}" } else { set style $tmpStyle #puts "Using style for first binding {$style}" } 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 {!($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" } } } set style $style/$use ## ## Process each operation ## foreach oper $operList { set operName [$oper getAttribute name] set baseName $operName ::log::log debug "\t Processing operation '$operName'" ## ## Check for overloading ## set inNode [$oper selectNodes w:input] if {[llength $inNode] == 1 && [$inNode hasAttribute name]} { set inName [$inNode getAttribute name] } else { set inName {} } if {[dict exists $serviceInfo operation $operName]} { if {!$options(allowOperOverloading)} { return -code error \ -errorcode [list WS CLIENT NOOVERLOAD $operName] } ## ## See if the existing operation needs to be cloned ## set origType [lindex [split [dict get $serviceInfo operation $operName inputs] {:}] end] set newName ${operName}_${origType} if {![dict exists $serviceInfo operation $newName]} { ## ## Clone it ## dict set serviceInfo operation $baseName cloned 1 dict lappend serviceInfo operList $newName dict set serviceInfo operation $newName [dict get $serviceInfo operation $operName] } # typNameList contains inType inName outType outName set typeNameList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style] set operName ${operName}_[lindex [split [lindex $typeNameList 0] {:}] end] set cloneList [dict get $serviceInfo operation $baseName cloneList] lappend cloneList $operName dict set serviceInfo operation $baseName cloneList $cloneList dict set serviceInfo operation $operName isClone 1 } else { set typeNameList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style] dict set serviceInfo operation $operName isClone 0 } #puts "Processing operation $operName" set actionNode [$oper selectNodes d:operation] 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 {} dict set serviceInfo operation $operName cloned 0 dict set serviceInfo operation $operName name $baseName dict set serviceInfo operation $operName style $style catch { set action [$actionNode getAttribute soapAction] dict set serviceInfo operation $operName action $action if {[dict exists $serviceInfo soapActions $action]} { set actionList [dict get $serviceInfo soapActions $action] } else { set actionList {} } lappend actionList $operName dict set serviceInfo soapActions $action $actionList } ## ## Get the input headers, if any ## set soapRequestHeaderList {{}} foreach inHeader [$oper selectNodes w:input/d:header] { ##set part [$inHeader getAttribute part] set tmp [$inHeader getAttribute 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 usage not supported!'" } set msgName [$inHeader getAttribute message] ::log::log debug [list messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] set type [messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] lappend soapRequestHeaderList $type } dict set serviceInfo operation $operName soapRequestHeader $soapRequestHeaderList if {![dict exists [dict get $serviceInfo operation $operName] action]} { dict set serviceInfo operation $operName action $serviceName } ## ## Get the output header, if one ## set soapReplyHeaderList {{}} foreach outHeader [$oper selectNodes w:output/d:header] { ##set part [$outHeader getAttribute part] set tmp [$outHeader getAttribute 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 usage not supported!'" } set messagePath [$outHeader getAttribute message] set msgName [lindex [split $messagePath {:}] end] ::log::log debug [list messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] set type [messageToType $wsdlNode $serviceName $baseName $msgName serviceInfo $style] lappend soapReplyHeaderList $type } dict set serviceInfo operation $operName soapReplyHeader $soapReplyHeaderList ## ## Validate that the input and output uses are the same ## 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 {$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 usage not supported!'" } } ::log::log debug "\t Input/Output types and names are {$typeNameList}" foreach {type name} $typeNameList mode {inputs outputs} { dict set serviceInfo operation $operName $mode $type # also set outputsname which is used to match it as alternate response node name dict set serviceInfo operation $operName ${mode}name $name } set inMessage [dict get $serviceInfo operation $operName inputs] if {[dict exists $serviceInfo inputMessages $inMessage] } { set operList [dict get $serviceInfo inputMessages $inMessage] } else { set operList {} } lappend operList $operName dict set serviceInfo inputMessages $inMessage $operList ## ## Handle target namespace defined at WSDL level for older RPC/Encoded ## if {![dict exists $serviceInfo targetNamespace]} { catch { #puts "attempting to get tragetNamespace" dict set serviceInfo targetNamespace tns1 [[$oper selectNodes w:input/d:body] getAttribute namespace] } } set xns tns1 dict set serviceInfo operation $operName xns $xns } } ::log::log debug "Leaving [lindex [info level 0] 0]" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::getTypesForPort # # Description : Get the types for a port. # # Arguments : # wsdlNode - The top node of the WSDL # serviceNode - The DOM node for the service. # operNode - The DOM node for the operation. # portName - The name of the port. # inName - The name of the input message. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. # style - style of call # # Returns : A list containing the input and output types and names # # Side-Effects : Defines Client mode types for the service as specified by the WSDL # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 08/06/2006 G.Lester Initial version # 2.4.2 2017-08-31 H.Oehlmann Extend return by names to verify this # as return output node name. # 2.4.3 2017-11-03 H.Oehlmann If name is not given, set the default # name of Request/Response given by the # WSDL 1.0 standard. # # ########################################################################### proc ::WS::Client::getTypesForPort {wsdlNode serviceName operName portName inName serviceInfoVar style} { ::log::log debug "Entering [info level 0]" upvar 1 $serviceInfoVar serviceInfo set inType {} set outType {} #set portQuery [format {w:portType[attribute::name='%s']} $portName] #set portNode [lindex [$wsdlNode selectNodes $portQuery] 0] 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 {$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 resList {} foreach sel {w:input w:output} defaultNameSuffix {Request Response} { set nodeList [$operNode selectNodes $sel] if {1 == [llength $nodeList]} { set nodeCur [lindex $nodeList 0] set msgPath [$nodeCur getAttribute message] set msgCur [lindex [split $msgPath {:}] end] # Append type lappend resList [messageToType $wsdlNode $serviceName $operName $msgCur serviceInfo $style] # Append name if {[$nodeCur hasAttribute name]} { lappend resList [$nodeCur getAttribute name] } else { # Build the default name according WSDL 1.0 as # Request/Response lappend resList ${operName}$defaultNameSuffix } } } ## ## Return the types ## ::log::log debug "Leaving [lindex [info level 0] 0] with $resList" return $resList } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::messageToType # # Description : Get a type name from a message # # Arguments : # wsdlNode - The top node of the WSDL # serviceName - The name of the service. # operName - The name of the operation. # msgName - The name of the message. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. # style - Style of call # # Returns : The requested type name # # Side-Effects : Defines Client mode types for the service as specified by the WSDL # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 08/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::messageToType {wsdlNode serviceName operName msgName serviceInfoVar style} { upvar 1 $serviceInfoVar serviceInfo ::log::log debug "Entering [info level 0]" #puts "Message to Type $serviceName $operName $msgName" set msgQuery [format {w:message[attribute::name='%s']} $msgName] set msg [$wsdlNode selectNodes $msgQuery] 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 {$msg eq {}} { return \ -code error \ -errorcode [list WS CLIENT BADMSGSEC $msgName] \ "Can not find message '$msgName'" } switch -exact -- $style { document/literal { set partNode [$msg selectNodes w:part] set partNodeCount [llength $partNode] ::log::log debug "partNodeCount = {$partNodeCount}" if {$partNodeCount == 1} { if {[$partNode hasAttribute element]} { set type [::WS::Utils::getQualifiedType $serviceInfo [$partNode getAttribute element] tns1] } } if {($partNodeCount > 1) || ![info exist type]} { set tmpType {} foreach part [$msg selectNodes w:part] { set partName [$part getAttribute name] if {[$part hasAttribute type]} { set partType [$part getAttribute type] } else { set partType [$part getAttribute element] } lappend tmpType $partName [list type [::WS::Utils::getQualifiedType $serviceInfo $partType tns1] comment {}] } set type tns1:$msgName dict set serviceInfo types $type $tmpType ::WS::Utils::ServiceTypeDef Client $serviceName $type $tmpType tns1 } elseif {!$partNodeCount} { return \ -code error \ -errorcode [list WS CLIENT BADMSGSEC $msgName] \ "Invalid format for message '$msgName'" } } rpc/encoded { set tmpType {} foreach part [$msg selectNodes w:part] { set partName [$part getAttribute name] if {[$part hasAttribute type]} { set partType [$part getAttribute type] } else { set partType [$part getAttribute element] } lappend tmpType $partName [list type [::WS::Utils::getQualifiedType $serviceInfo $partType tns1] comment {}] } set type tns1:$msgName dict set serviceInfo types $type $tmpType ::WS::Utils::ServiceTypeDef Client $serviceName $type $tmpType tns1 } default { return \ -code error \ -errorcode [list WS CLIENT UNKSTY $style] \ "Unknown style combination $style" } } ## ## Return the type name ## ::log::log debug "Leaving [lindex [info level 0] 0] with {$type}" return $type } #--------------------------------------- #--------------------------------------- ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DoRawRestCall # # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call # argList - The arguments to the operation as a dictionary object. # This is for both the Soap Header and Body messages. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # # Returns : # The XML of the operation. # # Side-Effects : None # # Exception Conditions : # WS CLIENT HTTPERROR - if an HTTP error occurred # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # 2.4.1 2017-08-31 H.Oehlmann Use utility function # ::WS::Utils::geturl_fetchbody for http call # which also follows redirects. # 3.0.0 2020-10-26 H.Oehlmann Added query timeout # # ########################################################################### proc ::WS::Client::DoRawRestCall {serviceName objectName operationName argList {headers {}} {location {}}} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) if {![dict exists $serviceInfo object $objectName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOBJ [list $serviceName $objectName]] \ "Unknown object '$objectName' for service '$serviceName'" } if {![dict exists $serviceInfo object $objectName operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \ "Unknown operation '$operationName' for object '$objectName' of service '$serviceName'" } ## ## build call query ## if {$location ne {}} { set url $location } else { set url [dict get $serviceInfo object $objectName location] } SaveAndSetOptions $serviceName if {[catch {set query [buildRestCallquery $serviceName $objectName $operationName $url $argList]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { RestoreSavedOptions $serviceName } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } ## ## do http call ## set largs {} if {[llength $headers]} { lappend largs -headers $headers } set body [::WS::Utils::geturl_fetchbody $url\ -query $query\ -type [dict get $serviceInfo contentType]\ -timeout [dict get $serviceInfo queryTimeout]\ {*}$largs] ::log::logsubst debug {Leaving ::WS::Client::DoRawRestCall with {$body}} return $body } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DoRestCall # # Description : Call an operation of a web service # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call # argList - The arguments to the operation as a dictionary object # This is for both the Soap Header and Body messages. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # # Returns : # The return value of the operation as a dictionary object. # # Side-Effects : None # # Exception Conditions : # WS CLIENT HTTPERROR - if an HTTP error occurred # others - as raised by called Operation # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # 2.4.1 2017-08-31 H.Oehlmann Use utility function # ::WS::Utils::geturl_fetchbody for http call # which also follows redirects. # 3.0.0 2020-10-26 H.Oehlmann Added query timeout # # ########################################################################### proc ::WS::Client::DoRestCall {serviceName objectName operationName argList {headers {}} {location {}}} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) if {![dict exists $serviceInfo object $objectName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOBJ [list $serviceName $objectName]] \ "Unknown object '$objectName' for service '$serviceName'" } if {![dict exists $serviceInfo object $objectName operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \ "Unknown operation '$operationName' for object '$objectName' of service '$serviceName'" } if {$location ne {}} { set url $location } else { set url [dict get $serviceInfo object $objectName location] } ## ## build call query ## SaveAndSetOptions $serviceName if {[catch {set query [buildRestCallquery $serviceName $objectName $operationName $url $argList]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } RestoreSavedOptions $serviceName ## ## Do http call ## if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } set largs {} if {[llength $headers]} { lappend largs -headers $headers } set body [::WS::Utils::geturl_fetchbody $url\ -query $query\ -type [dict get $serviceInfo contentType]\ -timeout [dict get $serviceInfo queryTimeout]\ {*}$largs] ## ## Parse results ## SaveAndSetOptions $serviceName if {[catch { parseRestResults $serviceName $objectName $operationName $body } results]} { RestoreSavedOptions $serviceName ::log::log debug "Leaving (error) ::WS::Client::DoRestCall" return -code error $results } RestoreSavedOptions $serviceName ::log::logsubst debug {Leaving ::WS::Client::DoRestCall with {$results}} return $results } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Client::DoARestsyncCall # # Description : Call an operation of a web service asynchronously # # Arguments : # serviceName - The name of the Webservice # operationName - The name of the Operation to call # argList - The arguments to the operation as a dictionary object # This is for both the Soap Header and Body messages. # succesCmd - A command prefix to be called if the operations # does not raise an error. The results, as a dictionary # object are concatenated to the prefix. # errorCmd - A command prefix to be called if the operations # raises an error. The error code and stack trace # are concatenated to the prefix. # headers - Extra headers to add to the HTTP request. This # is a key value list argument. It must be a list with # an even number of elements that alternate between # keys and values. The keys become header field names. # Newlines are stripped from the values so the header # cannot be corrupted. # This is an optional argument and defaults to {}. # # Returns : # None. # # Side-Effects : None # # Exception Conditions : # WS CLIENT HTTPERROR - if an HTTP error occurred # others - as raised by called Operation # # Pre-requisite Conditions : Service must have been defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::DoRestAsyncCall {serviceName objectName operationName argList succesCmd errorCmd {headers {}}} { variable serviceArr set svcHeaders [dict get $serviceArr($serviceName) headers] if {[llength $svcHeaders]} { set headers [concat $headers $svcHeaders] } ::log::logsubst debug {Entering [info level 0]} if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) if {![dict exists $serviceInfo object $objectName operation $operationName]} { return \ -code error \ -errorcode [list WS CLIENT UNKOPER [list $serviceName $objectName $operationName]] \ "Unknown operation '$operationName' for service '$serviceName'" } if {[dict exists $serviceInfo headers]} { set headers [concat $headers [dict get $serviceInfo headers]] } set url [dict get $serviceInfo object $objectName location] SaveAndSetOptions $serviceName if {[catch {set query [buildRestCallquery $serviceName $objectName $operationName $url $argList]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { RestoreSavedOptions $serviceName } set largs {} if {[llength $headers]} { lappend largs -headers $headers } ::log::logsubst info {::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] \ -timeout [dict get $serviceInfo queryTimeout]\ {*}$largs} ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -headers $headers \ -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] \ -timeout [dict get $serviceInfo queryTimeout]\ {*}$largs ::log::log debug "Leaving ::WS::Client::DoAsyncRestCall" return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::buildRestCallquery # # Description : Build the XML request message for the call # # Arguments : # serviceName - the name of the service called # operationName - the name of the operation called # url - the URL of the operation # argList - a dictionary object of the calling arguments # This is for both the Soap Header and Body messages. # # Returns : The XML for the call # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::buildRestCallquery {serviceName objectName operationName url argList} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} set serviceInfo $serviceArr($serviceName) set msgType [dict get $serviceInfo object $objectName operation $operationName inputs] set xnsList [dict get $serviceInfo targetNamespace] dom createDocument "request" doc $doc documentElement body $body setAttribute \ "method" $operationName foreach {tns target} $xnsList { #set tns [lindex $xns 0] #set target [lindex $xns 1] $body setAttribute \ xmlns:$tns $target } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $msgType] xns] ::log::logsubst debug {calling [list ::WS::Utils::convertDictToType Client $serviceName $doc $body $argList $msgType]} set options [::WS::Utils::SetOption] ::WS::Utils::SetOption UseNS 0 ::WS::Utils::SetOption genOutAttr 1 ::WS::Utils::SetOption valueAttr {} ::WS::Utils::convertDictToType Client $serviceName $doc $body $argList $msgType set encoding [lindex [split [lindex [split [dict get $serviceInfo contentType] {;}] end] {=}] end] foreach {option value} $options { ::WS::Utils::SetOption $option $value } set xml [format {} $encoding] append xml "\n" [$doc asXML -indent none -doctypeDeclaration 0] #regsub "\]*>\n" [::dom::DOMImplementation serialize $doc] {} xml $doc delete set xml [encoding convertto $encoding $xml] set inTransform [dict get $serviceInfo inTransform] if {$inTransform ne {}} { set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList] } ::log::logsubst debug {Leaving ::WS::Client::buildRestCallquery with {$xml}} return $xml } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::parseRestResults # # Description : Convert the returned XML into a dictionary object # # Arguments : # serviceName - the name of the service called # operationName - the name of the operation called # inXML - the XML returned by the operation # # Returns : A dictionary object representing the results # # Side-Effects : None # # Exception Conditions : # WS CLIENT REMERR - The remote end raised an exception, the third element of # the error code is the remote fault code. # Error info is set to the remote fault details. # The error message is the remote fault string. # WS CLIENT BADREPLY - Badly formatted reply, the third element is a list of # what message type was received vs what was expected. # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::parseRestResults {serviceName objectName operationName inXML} { variable serviceArr ::log::logsubst debug {Entering [info level 0]} set first [string first {<} $inXML] if {$first > 0} { set inXML [string range $inXML $first end] } set serviceInfo $serviceArr($serviceName) set outTransform [dict get $serviceInfo outTransform] if {$outTransform ne {}} { set inXML [$outTransform $serviceName $operationName REPLY $inXML] } set expectedMsgType [dict get $serviceInfo object $objectName operation $operationName outputs] # save parsed xml handle in variable doc dom parse $inXML doc # save top node handle in variable top $doc documentElement top set xns {} foreach tmp [dict get $serviceInfo targetNamespace] { lappend xns $tmp } ::log::logsubst debug {Using namespaces {$xns}} set body $top set status [$body getAttribute status] ## ## See if it is a standard error packet ## if {$status ne {ok}} { set faultstring {} if {[catch {set faultstring [[$body selectNodes error] asText]}]} { catch {set faultstring [[$body selectNodes error] asText]} } $doc delete return \ -code error \ -errorcode [list WS CLIENT REMERR $status] \ -errorinfo {} \ $faultstring } ## ## Convert the packet to a dictionary ## set results {} set options [::WS::Utils::SetOption] ::WS::Utils::SetOption UseNS 0 ::WS::Utils::SetOption parseInAttr 1 ::log::logsubst debug {Calling ::WS::Utils::convertTypeToDict Client $serviceName $body $expectedMsgType $body} if {$expectedMsgType ne {}} { set node [$body childNodes] set nodeName [$node nodeName] if {$objectName ne $nodeName} { return \ -code error \ -errorcode [list WS CLIENT BADRESPONSE [list $objectName $nodeName]] \ -errorinfo {} \ "Unexpected message type {$nodeName}, expected {$objectName}" } set results [::WS::Utils::convertTypeToDict \ Client $serviceName $node $expectedMsgType $body] } foreach {option value} $options { ::WS::Utils::SetOption $option $value } $doc delete return $results } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::asyncRestobCallDone # # Description : Called when an asynchronous call is complete. This routine # will call either the success or error callback depending on # if the operation succeeded or failed -- assuming the callback # is defined. # # Arguments : # serviceName - the name of the service called # operationName - the name of the operation called # succesCmd - the command prefix to call if no error # errorCmd - the command prefix to call on an error # token - the token from the HTTP request # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Client::asyncRestCallDone {serviceName objectName operationName succesCmd errorCmd token} { ::log::logsubst debug {Entering [info level 0]} ## ## Check for errors ## set body [::http::data $token] ::log::logsubst info {\nReceived: $body} if {[::http::status $token] ne {ok} || ( [::http::ncode $token] != 200 && $body eq {} )} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set hadError 1 set errorInfo [FormatHTTPError $token] } else { SaveAndSetOptions $serviceName if {[catch {set hadError [catch {parseRestResults $serviceName $objectName $operationName $body} results]} err]} { RestoreSavedOptions $serviceName return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err } else { RestoreSavedOptions $serviceName } if {$hadError} { set errorCode $::errorCode set errorInfo $::errorInfo } } ## ## Call the appropriate callback ## if {$hadError} { set cmd $errorCmd lappend cmd $errorCode $errorInfo } else { set cmd $succesCmd } lappend cmd $results catch $cmd ## ## All done ## ::http::cleanup $token return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::asyncRestobCallDone # # Description : Save the global options of the utilities package and # set them for how this service needs them. # # Arguments : # serviceName - the name of the service called # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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/06/2012 G.Lester Initial version # # ########################################################################### proc ::WS::Client::SaveAndSetOptions {serviceName} { variable serviceArr variable utilsOptionsList if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) set savedDict {} foreach item $utilsOptionsList { if {[dict exists $serviceInfo $item] && [string length [set value [dict get $serviceInfo $item]]]} { dict set savedDict $item [::WS::Utils::SetOption $item] ::WS::Utils::SetOption $item $value } } dict set serviceArr($serviceName) UtilsSavedOptions $savedDict return } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Client::RestoreSavedOptions # # Description : Restore the saved global options of the utilities package. # # Arguments : # serviceName - the name of the service called # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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/06/2012 G.Lester Initial version # # ########################################################################### proc ::WS::Client::RestoreSavedOptions {serviceName} { variable serviceArr if {![info exists serviceArr($serviceName)]} { return \ -code error \ -errorcode [list WS CLIENT UNKSRV $serviceName] \ "Unknown service '$serviceName'" } set serviceInfo $serviceArr($serviceName) set savedDict {} foreach {item value} [dict get $serviceInfo UtilsSavedOptions] { ::WS::Utils::SetOption $item $value } dict set serviceArr($serviceName) UtilsSavedOptions {} return } tclws-3.5.0/Embedded.tcl000064400000000000000000001256261471124032000144320ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2016-2020, Harald Oehlmann ## ## Copyright (c) 2008, Gerald W. Lester ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require Tcl 8.6- package require uri package require base64 package require html package require log # Emulate the log::logsubst command introduced in log 1.4 if {![llength [info command ::log::logsubst]]} { proc ::log::logsubst {level text} { if {[::log::lvIsSuppressed $level]} { return } ::log::log $level [uplevel 1 [list subst $text]] } } package provide WS::Embeded 3.4.0 namespace eval ::WS::Embeded { variable portInfo {} variable handlerInfoDict {} variable returnCodeText [dict create 200 OK 404 "Not Found" \ 500 "Internal Server Error" 501 "Not Implemented"] variable socketStateArray } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Embeded::AddHandler # # Description : Register a handler for a url on a port. # # Arguments : # port -- The port to register the callback on # urlPath -- The URL path to register the callback for # method -- HTTP method: GET or POST # callback -- The callback prefix, two additionally arguments are lappended # the callback: (1) the socket (2) the null string # # Returns : Nothing # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : ::WS::Embeded::Listen must have been called for the port # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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/28/2008 G.Lester Initial version # 3.2.0 2021-03-17 H.Oehlmann Also pass method. # 3.3.0 2021-03-19 H.Oehlmann Put handler info to own dict, so order of # Listen and AddHandler call is not important. # # ########################################################################### proc ::WS::Embeded::AddHandler {port urlPath method callback} { variable handlerInfoDict dict set handlerInfoDict $port $urlPath $method $callback return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Embeded::GetValue # # Description : Get a value found in this module # # Arguments : # index -- type of value to get. Possible values: # -- isHTTPS : true, if https protocol is used. # port -- concerned port. May be ommitted, if not relevant for value. # # Returns : the distinct value # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : ::WS::Embeded::Listen must have been called for the port # # Original Author : Harald Oehlmann # #>>END PUBLIC<< # # Maintenance History - as this file is modified, please be sure that you # update this segment of the file header block by # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 2.7.0 2020-10-26 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::GetValue {index {port ""}} { variable portInfo switch -exact -- $index { isHTTPS { return [dict get $portInfo $port $index] } default {return -code error "Unknown index '$index'"} } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Embeded::Listen # # Description : Instruct the module to listen on a Port, security information. # # Arguments : # port -- Port number to listen on # certfile -- Name of the certificate file or a pfx archive for twapi. # Defaults to {}. # keyfile -- Name of the key file. Defaults to {}. # To use twapi TLS, specify a list with the following elements: # -- "-twapi": Flag, that TWAPI TLS should be used # -- password: password of PFX file passed by # [::twapi::conceal]. The concealing makes sure that the # password is not readable in the error stack trace # -- ?subject?: optional search string in pfx file, if # multiple certificates are included. # userpwds -- A list of username:password. Defaults to {}. # realm -- The security realm. Defaults to {}. # timeout -- A time in ms the sender may use to send the request. # If a sender sends wrong data (Example: TLS if no TLS is # used), the process will just stand and a timeout is required # to clear the connection. Set to 0 to not use a timeout. # Default: 60000 (1 Minuit). # # Returns : socket handle # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : ::WS::Embeded::Listen must have been called for the port # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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/28/2008 G.Lester Initial version # 3.0.0 2020-10-30 H.Oehlmann Add twapi tls support # 3.3.0 2021-03-18 H.Oehlmann Add timeout option. Remove unused portList. # Call Close, if we use the port already. # Do not leave portInfo data, if open fails. # 3.3.1 2021-03-23 H.Oehlmann Fix bug: pfx subject had added ")". # # ########################################################################### proc ::WS::Embeded::Listen {port {certfile {}} {keyfile {}} {userpwds {}} {realm {}} {timeout 600000}} { variable portInfo ## ## Check if port already used by us. If yes, close it. ## if {[dict exists $portInfo $port]} { Close $port } ## ## Check if HTTPS protocol is used ## set isHTTPS [expr {$certfile ne ""}] if {$isHTTPS } { if { [string is list $keyfile] && [lindex $keyfile 0] eq "-twapi"} { ## ## Use TWAPI TLS ## package require twapi_crypto # Decode parameters # # certfile is the pfx file name # keyfile is a list of: # -twapi: fix element # password of the pfx file, passed by twapi::conceal # Optional Subject of the certificate, if there are multiple # certificates contained. # If not given, the first certificate is used. set pfxpassword [lindex $keyfile 1] set pfxsubject "" if {[llength $keyfile] > 2} { set pfxsubject [lindex $keyfile 2] } # Create certificate selection tring if {$pfxsubject eq ""} { set pfxselection any } else { set pfxselection [list subject_substring $pfxsubject] } set hFile [open $certfile rb] set PFXCur [read $hFile] close $hFile # Set up the store containing the certificates # Import the PFX file and search the certificate. set certstore [twapi::cert_temporary_store -pfx $PFXCur \ -password $pfxpassword] set servercert [twapi::cert_store_find_certificate $certstore \ {*}$pfxselection] if {"" eq $servercert} { # There was no certificate included in the pfx file catch {twapi::cert_store_release $certstore} return -code error "no certificate found in file '$certfile'" } # The following is catched to clean-up in case of any error if {![catch { # Start the TLS socket with the credentials set creds [twapi::sspi_schannel_credentials \ -certificates [list $servercert] \ -protocols [list ssl3 tls1.1 tls1.2]] set creds [twapi::sspi_acquire_credentials \ -credentials $creds -package unisp -role server] set handle [::twapi::tls_socket \ -server [list ::WS::Embeded::accept $port] \ -credentials $creds $port] } errormsg errordict]} { # All ok, clear error flag unset errormsg } # Clean up certificate and certificate store if {[info exists servercert]} { catch {twapi::cert_release $servercert} } catch {twapi::cert_store_release $certstore} # Return error if happened above if {[info exists errormsg]} { dict unset errordict -level return -options $errordict $errormsg } } else { ## ## Use TLS Package ## package require tls ::tls::init \ -certfile $certfile \ -keyfile $keyfile \ -require 0 \ -request 0 set handle [::tls::socket -server [list ::WS::Embeded::accept $port] $port] } } else { ## ## Use http protocol without encryption ## ::log::logsubst debug {socket -server [list ::WS::Embeded::accept $port] $port} set handle [socket -server [list ::WS::Embeded::accept $port] $port] } ## ## Prepare basic authentication ## set authlist {} foreach up $userpwds { lappend authlist [base64::encode $up] } ## ## Save the port information dict entry ## dict set portInfo $port [dict create\ port $port\ realm $realm\ timeout $timeout\ auths $authlist\ isHTTPS $isHTTPS\ handle $handle] return $handle } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Embeded::Close # # Description : End listening, close the port. # # Arguments : # port -- Port number to listen on # # Returns : none # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PUBLIC<< # # 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 # ------- ---------- ---------- ------------------------------------------- # 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::Close {port} { variable socketStateArray variable portInfo # Check, if port exists if {![dict exists $portInfo $port handle]} {return} ::log::log info "closing server socket for port $port" # close server port if {[catch {close [dict get $portInfo $port handle]} msg]} { ::log::log error "error closing server socket for port $port: $msg" } # close existing connections foreach sock [array names socketStateArray] { if {[dict get $socketStateArray($sock) port] eq $port} { cleanup $sock } } # remove registered data dict unset portInfo $port return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Embeded::CloseAll # # Description : End listening, close all ports. # # Arguments : # port -- Port number to listen on # # Returns : none # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PUBLIC<< # # 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 # ------- ---------- ---------- ------------------------------------------- # 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::CloseAll {} { variable portInfo foreach port [dict keys $portInfo] { Close $port } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::respond # # Description : Send response back to user. # # Arguments : # sock -- Socket to send reply on # code -- Code to send # body -- HTML body to send # head -- Additional HTML headers to send # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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/28/2008 G.Lester Initial version # 2.3.0 11/06/2012 H.Oehlmann Separate head and body, # correct Content-length # # ########################################################################### proc ::WS::Embeded::respond {sock code body {head ""}} { set body [encoding convertto iso8859-1 $body\r\n] if {[catch { chan configure $sock -translation crlf puts $sock "[httpreturncode $code]\nContent-Type: text/html; charset=ISO-8859-1\nConnection: close\nContent-length: [string length $body]" if {"" ne $head} { puts -nonewline $sock $head } # Separator head and body puts $sock "" chan configure $sock -translation binary puts -nonewline $sock $body close $sock } msg]} { log::log error "Error sending response: $msg" cleanup $sock } else { cleanup $sock 1 } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::httpreturncode # # Description : Format the first line of a http return including the status code # # Arguments : # code -- numerical http return code # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 10/05/2012 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::httpreturncode {code} { variable returnCodeText if {[dict exist $returnCodeText $code]} { set textCode [dict get $returnCodeText $code] } else { set textCode "???" } return "HTTP/1.0 $code $textCode" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::handler # # Description : Handle a request. # # Arguments : # sock -- Incoming socket # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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/28/2008 G.Lester Initial version # 2.3.0 10/31/2012 G.Lester bug fix for [68310fe3bd] -- correct encoding and data length # 2.6.1 2020-10-22 H.Oehlmann Do not pass parameter reqstring. # The corresponding value is found in global # array anyway. # Use charset handler of request decoding. # 2.7.0 2020-10-26 H.Oehlmann Pass additional port parameter to handle # functions. This helps to get isHTTPS # status for WSDL. # 3.1.0 2020-11-05 H.Oehlmann Pass additional port parameter with leading # -port specifier to avoid clash with # other parameters. # 3.2.0 2021-03-17 H.Oehlmann Return the result directly by the call. # Replace global parameter dict by parameter # url and dataDict (for POST method). # 3.3.0 2021-03-18 H.Oehlmann Use state array, move checks to Receive, # do query recode here. # ########################################################################### proc ::WS::Embeded::handler {sock} { variable socketStateArray set cmd [dict get $socketStateArray($sock) cmd] if {[dict get $socketStateArray($sock) method] eq "POST"} { # Recode the query data dict set socketStateArray($sock) query [encoding convertfrom\ [dict get $socketStateArray($sock) requestEncoding]\ [dict get $socketStateArray($sock) query]] # The following dict keys are attended: query, ipaddr, headers if {[catch { lassign [$cmd $sock -data $socketStateArray($sock)] type data code } msg]} { ::log::log error "Return 404 due to post eval error: $msg" tailcall respond $sock 404 "Error: $msg" } } else { if {[catch { lassign [$cmd $sock -port [dict get $socketStateArray($sock) port]] type data code } msg]} { ::log::log error "Return 404 due to get eval error: $msg" tailcall respond $sock 404 "Error: $msg" } } # This may modify the type variable, if encoding is not found set encoding [contentTypeParse 0 type] set data [encoding convertto $encoding $data] set reply "[httpreturncode $code]\n" append reply "Content-Type: $type\n" append reply "Connection: close\n" append reply "Content-length: [string length $data]\n" # Note: to avoid delay, full buffering is used on the channel. # In consequence, the data is sent in the background after the close. # Socket errors may not be detected, but the event queue is free. # This is specially important with the Edge browser, which sometimes delays # data reception. if {[catch { chan configure $sock -translation crlf puts $sock $reply chan configure $sock -translation binary puts -nonewline $sock $data close $sock } msg]} { ::log::log error "Error sending reply: $msg" tailcall cleanup $sock } ::log::log debug ok tailcall cleanup $sock 1 } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::accept # # Description : Accept an incoming connection and register callback. # # Arguments : # port -- Port number # sock -- Incoming socket # ip -- Requester's IP address # clientport -- Requester's port number # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # Maintenance History - as this file is modified, please be sure that you # update this segment of the file header block by # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::accept {port sock ip clientport} { variable portInfo variable socketStateArray ::log::logsubst info {Received request on $port for $ip:$clientport} # Setup events if {[catch { chan configure $sock -blocking 0 -translation crlf chan event $sock readable [list ::WS::Embeded::receive $sock] } msg]} { catch {chan close $sock} ::log::log error "Error installing accepted socket on ip '$ip': $msg" return } # Prepare socket state dict set stateDict [dict create port $port ip $ip phase request] # Install timeout if {0 < [dict get $portInfo $port timeout]} { dict set stateDict timeoutHandle [after\ [dict get $portInfo $port timeout]\ [list ::WS::Embeded::timeout $sock]] } # Save state dict set socketStateArray($sock) $stateDict } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::receive # # Description : handle a readable socket # # Arguments : # sock -- Incoming socket # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # Maintenance History - as this file is modified, please be sure that you # update this segment of the file header block by # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 3.3.0 2021-03-18 H.Oehlmann Initial version # 3.4.0 2024-11-01 H.Oehlmann replaced for byte lengths "scan %d" by # "%lld" to support larger than 2**32 # # ########################################################################### proc ::WS::Embeded::receive {sock} { variable socketStateArray variable portInfo variable handlerInfoDict ## ## Make data read attempts in this read loop. ## while 1 { ::log::logsubst debug {Top of loop with dict: $socketStateArray($sock)} ## ## Read data ## if {[catch { if {[dict get $socketStateArray($sock) phase] eq "body"} { # Read binary data set line [chan read $sock [dict get $socketStateArray($sock) readMax]] } else { # read line data set line [chan gets $sock] } } msg]} { ::log::log error "Data read error: $msg" tailcall cleanup $sock } ::log::logsubst debug {Read: len [string length $line] eof [eof $sock] block [chan blocked $sock] data '$line'} ## ## Check for early EOF ## if { [eof $sock] } { ::log::log warning {Connection closed from client} tailcall cleanup $sock } ## ## Check for no new data, so wait for next file event. ## ## For gets: ## This makes also the difference between empty data read (crlf ## terminated line) and no read (true). ## For read with limit: ## If not all characters could be read, block is flagged with data. ## So check the data length to 0 for this case. ## if {[string length $line] == 0 && [chan blocked $sock]} { return } ## ## Handle the received data ## switch -exact -- [dict get $socketStateArray($sock) phase] { request { ## ## Handle Request line ## if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} { ::log::logsubst warning {Wrong request: $line} tailcall cleanup $sock } if {$method ni {"GET" "POST"}} { ::log::logsubst warning {Unsupported method '$method'} tailcall respond $sock 501 "Method not implemented" } # Check if we have a handler for this method and URL path set urlPath "/[string trim [dict get [uri::split $url] path] /]" set port [dict get $socketStateArray($sock) port] if {![dict exists $handlerInfoDict $port $urlPath $method]} { ::log::log warning "404 Error: URL path '$urlPath' not found" tailcall respond $sock 404 "URL not found" } # Save data and pass to header phase dict set socketStateArray($sock) cmd [dict get $handlerInfoDict $port $urlPath $method] dict set socketStateArray($sock) phase header dict set socketStateArray($sock) method $method dict set socketStateArray($sock) header "" } header { ## ## Handle Header lines ## if {[string length $line] > 0} { if {[regexp {^([^:]*):(.*)$} $line -> key data]} { dict set socketStateArray($sock) header [string tolower $key] [string trim $data] } } else { # End of header by empty line ## ## Get authorization failure condition ## # Authorization is ok, if no authrization required # Authorization fails, if: # - no authentication in current request # - or current credentials incorrect set port [dict get $socketStateArray($sock) port] if { 0 != [llength [dict get $portInfo $port auths]] && ! ( [dict exists $socketStateArray($sock) header authorization] && [regexp -nocase {^basic +([^ ]+)$} \ [dict get $socketStateArray($sock) header authorization] -> auth] && $auth in [dict get $portInfo $port auths] ) } { set realm [dict get $portInfo $port realm] ::log::log warning {Unauthorized} tailcall respond $sock 401 "" "WWW-Authenticate: Basic realm=\"$realm\"\n" } # Within the GET method, we have all we need if {[dict get $socketStateArray($sock) method] eq "GET"} { tailcall handler $sock } # Post method requires content-encoding header if {![dict exists $socketStateArray($sock) header content-type]} { ::log::logsubst warning {Header missing: 'Content-Type'} tailcall cleanup $sock } set contentType [dict get $socketStateArray($sock) header content-type] dict set socketStateArray($sock) requestEncoding [contentTypeParse 1 contentType] # Post method requires query data dict set socketStateArray($sock) query "" set fChunked [expr { [dict exists $socketStateArray($sock) header transfer-encoding] && [dict get $socketStateArray($sock) header transfer-encoding] eq "chunked"}] dict set socketStateArray($sock) fChunked $fChunked if {$fChunked} { dict set socketStateArray($sock) phase chunk } else { # Check for content length if { ! [dict exists $socketStateArray($sock) header content-length] || 0 == [scan [dict get $socketStateArray($sock) header content-length] %lld contentLength] } { ::log::log warning "Header content-length missing" tailcall cleanup $sock } dict set socketStateArray($sock) readMax $contentLength dict set socketStateArray($sock) phase body # Switch to binary data if {[catch { chan configure $sock -translation binary } msg]} { ::log::log error "Channel config error: $msg" tailcall cleanup $sock } } } } body { ## ## Read body data ## set query [dict get $socketStateArray($sock) query] append query $line dict set socketStateArray($sock) query $query set readMax [expr { [dict get $socketStateArray($sock) readMax] - [string length $line] } ] if {$readMax > 0} { # Data missing, so loop dict set socketStateArray($sock) readMax $readMax } else { # We have all data if {[dict get $socketStateArray($sock) fChunked]} { # Chunk read # Switch to line mode if {[catch { chan configure $sock -translation crlf } msg]} { ::log::log error "Channel config error: $msg" tailcall cleanup $sock } dict set socketStateArray($sock) phase chunk } else { # no chunk -> all data -> call handler tailcall handler $sock } } } chunk { ## ## Handle chunk header ## if {[scan $line %llx length] != 1} { ::log::log warning "No chunk length in '$line'" tailcall cleanup $sock } if {$length > 0} { # Receive chunk data # Switch to binary data if {[catch { chan configure $sock -translation binary } msg]} { ::log::log error "Channel config error: $msg" tailcall cleanup $sock } dict set socketStateArray($sock) readMax $length dict set socketStateArray($sock) phase body } else { # We have all data tailcall handler $sock } } } } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::timeout # # Description : socket timeout fired # # Arguments : # sock -- Incoming socket # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # Maintenance History - as this file is modified, please be sure that you # update this segment of the file header block by # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::timeout {sock} { variable socketStateArray # The timeout fired, so the cancel handle is not required any more dict unset socketStateArray($sock) timeoutHandle ::log::log warning "Cancelling request due to timeout" tailcall cleanup $sock } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::cleanup # # Description : cleanup a socket # # Arguments : # sock -- Incoming socket # fClosed -- Socket already closed # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # Maintenance History - as this file is modified, please be sure that you # update this segment of the file header block by # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 3.3.0 2021-03-18 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::cleanup {sock {fClosed 0}} { variable socketStateArray if {!$fClosed} { catch { chan close $sock } } if {[dict exists $socketStateArray($sock) timeoutHandle]} { after cancel [dict get $socketStateArray($sock) timeoutHandle] } unset socketStateArray($sock) } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Embeded::contentTypeParse # # Description : Parse a content-type value and get the encoding. # When receiving, only the encoding is required. # When sending, we have to correct the encoding, if not known # by TCL. Thus, the content-type string is changed. # # Arguments : # fReceiving -- When receiving, we only need the extracted codepage. # If sending, the content-type string must be modified, # if the codepage is not found in tcl # contentTypeName -- The variable containing the content type string. # # Returns : # tcl encoding to apply # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # Maintenance History - as this file is modified, please be sure that you # update this segment of the file header block by # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 2.6.1 2020-10-22 H.Oehlmann Initial version # # ########################################################################### proc ::WS::Embeded::contentTypeParse {fReceiving contentTypeName} { upvar 1 $contentTypeName contentType ## ## Extract charset parameter from content-type header ## # content-type example content: text/xml;charset=utf-8 set paramList [lassign [split $contentType ";"] typeOnly] foreach parameterCur $paramList { set parameterCur [string trim $parameterCur] # Check for 'charset="', where data may contain '\"' if {[regexp -nocase {^charset\s*=\s*\"((?:[^""]|\\\")*)\"$} \ $parameterCur -> requestEncoding] } { set requestEncoding [string map {{\"} \"} $requestEncoding] break } else { # check for 'charset=' regexp -nocase {^charset\s*=\s*(\S+?)$} \ $parameterCur -> requestEncoding break } } ## ## Find the corresponding TCL encoding name ## if {[info exists requestEncoding]} { if {[llength [info commands ::http::CharsetToEncoding]]} { # Use private http package routine set requestEncoding [::http::CharsetToEncoding $requestEncoding] # Output is "binary" if not found if {$requestEncoding eq "binary"} { unset requestEncoding } } else { # Reduced version of the http package version only honoring ISO8859-x # and encoding names identical to tcl encoding names set requestEncoding [string tolower $requestEncoding] if {[regexp {iso-?8859-([0-9]+)} $requestEncoding -> num]} { set requestEncoding "iso8859-$num" } if {$requestEncoding ni [encoding names]} { unset requestEncoding } } } ## ## Output found encoding and eventually content type ## # If encoding was found, just return it if {[info exists requestEncoding]} { return $requestEncoding } # encoding was not found if {$fReceiving} { # This is the http default so use that ::log::logsubst info {Use default encoding as content type header has missing/unknown charset in '$contentType'} return iso8859-1 } # When sending, be sure to cover all characters, so use utf-8 # correct content-type string (upvar) ::log::logsubst info {Set send charset to utf-8 due missing/unknown charset in '$contentType'} if {[info exists typeOnly]} { set contentType "${typeOnly};charset=utf-8" } else { set contentType "text/xml;charset=utf-8" } return utf-8 } tclws-3.5.0/Examples000075500000000000000000000000001471124032000137205ustar00nobodynobodytclws-3.5.0/Examples/Echo000075500000000000000000000000001471124032000145765ustar00nobodynobodytclws-3.5.0/Examples/Echo/CallEchoWebService.tcl000064400000000000000000000110211471124032000210050ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]] package require WS::Utils package require WS::Client ## ## Get Definition of the offered services ## ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsEchoExample/wsdl set testString "This is a test" set inputs [list TestString $testString] ## ## Call synchronously ## puts stdout "Calling SimpleEcho via DoCalls!" set results [::WS::Client::DoCall wsEchoExample SimpleEcho $inputs] puts stdout "\t Received: {$results}" puts stdout "Calling ComplexEcho via DoCalls!" set results [::WS::Client::DoCall wsEchoExample ComplexEcho $inputs] puts stdout "\t Received: {$results}" ## ## Generate stubs and use them for the calls ## ::WS::Client::CreateStubs wsEchoExample puts stdout "Calling SimpleEcho via Stubs!" set results [::wsEchoExample::SimpleEcho $testString] puts stdout "\t Received: {$results}" puts stdout "Calling ComplexEcho via Stubs!" set results [::wsEchoExample::ComplexEcho $testString] puts stdout "\t Received: {$results}" ## ## Call asynchronously ## proc success {service operation result} { global waitVar puts stdout "A call to $operation of $service was successful and returned $result" set waitVar 1 } proc hadError {service operation errorCode errorInfo} { global waitVar puts stdout "A call to $operation of $service was failed with {$errorCode} {$errorInfo}" set waitVar 1 } set waitVar 0 puts stdout "Calling SimpleEcho via DoAsyncCall!" ::WS::Client::DoAsyncCall wsEchoExample SimpleEcho $inputs \ [list success wsEchoExample SimpleEcho] \ [list hadError wsEchoExample SimpleEcho] vwait waitVar puts stdout "Calling ComplexEcho via DoAsyncCall!" ::WS::Client::DoAsyncCall wsEchoExample ComplexEcho $inputs \ [list success wsEchoExample SimpleEcho] \ [list hadError wsEchoExample SimpleEcho] vwait waitVar exit tclws-3.5.0/Examples/Echo/EchoEmbeddedService.tcl000064400000000000000000000103541471124032000211750ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]] package require WS::Server package require WS::Utils package require WS::Embeded catch {console show} ## ## Define the service ## ::WS::Server::Service \ -service wsEchoExample \ -description {Echo Example - Tcl Web Services} \ -host localhost:8015 \ -mode embedded \ -ports [list 8015] ## ## Define any special types ## ::WS::Utils::ServiceTypeDef Server wsEchoExample echoReply { echoBack {type string} echoTS {type dateTime} } ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsEchoExample \ {SimpleEcho {type string comment {Requested Echo}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string back} { ::log::lvSuppressLE debug 0 return [list SimpleEchoResult $TestString] } ::WS::Server::ServiceProc \ wsEchoExample \ {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string and a timestamp back} { set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes] return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp] ] } set ::errorInfo {} set SocketHandle [::WS::Embeded::Listen 8015] set ::errorInfo {} proc x {} { close $::SocketHandle exit } puts stdout {Server started. Press x and Enter to stop} flush stdout fileevent stdin readable {set QuitNow 1} vwait QuitNow x tclws-3.5.0/Examples/Echo/EchoRivetService.rvt000064400000000000000000000056011471124032000206250ustar00nobodynobody tclws-3.5.0/Examples/Echo/EchoWebService.tcl000064400000000000000000000074321471124032000202240ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require WS::Server package require WS::Utils ## ## Define the service ## ::WS::Server::Service \ -service wsEchoExample \ -description {Echo Example - Tcl Web Services} \ -host $::Config(host):$::Config(port) ## ## Define any special types ## ::WS::Utils::ServiceTypeDef Server wsEchoExample echoReply { echoBack {type string} echoTS {type dateTime} } ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsEchoExample \ {SimpleEcho {type string comment {Requested Echo}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string back} { return [list SimpleEchoResult $TestString] } ::WS::Server::ServiceProc \ wsEchoExample \ {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string and a timestamp back} { set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes] return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp] ] } tclws-3.5.0/Examples/Echo/EchoWibbleService.tcl000064400000000000000000000074521471124032000207150ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require WS::Server package require WS::Utils ## ## Define the service ## ::WS::Server::Service \ -service wsEchoExample \ -description {Echo Example - Tcl Web Services} \ -mode wibble \ -host $::Config(host):$::Config(port) ## ## Define any special types ## ::WS::Utils::ServiceTypeDef Server wsEchoExample echoReply { echoBack {type string} echoTS {type dateTime} } ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsEchoExample \ {SimpleEcho {type string comment {Requested Echo}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string back} { return [list SimpleEchoResult $TestString] } ::WS::Server::ServiceProc \ wsEchoExample \ {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string and a timestamp back} { set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes] return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp] ] } tclws-3.5.0/Examples/Echo/EchoWibbleStart.tcl000064400000000000000000000013541471124032000204050ustar00nobodynobody############# tclws.tcl, start script for wibble 24 (not included) ######## # Adjust auto_path to your needs lappend auto_path [file dir [info script]] lib source wibble.tcl # Set the root directory. set root html set ::Config(host) 127.0.0.1 set ::Config(port) 8015 source EchoWebService.tcl # Define zone handlers. ::wibble::handle /vars vars ::wibble::handle / dirslash root $root ::wibble::handle / indexfile root $root indexfile index.html ::wibble::handle / static root $root ::wibble::handle / template root $root ::wibble::handle / script root $root ::wibble::handle / dirlist root $root ::wibble::handle / notfound # Start a server and enter the event loop. catch { ::wibble::listen 8015 vwait forever } tclws-3.5.0/Examples/Math000075500000000000000000000000001471124032000146115ustar00nobodynobodytclws-3.5.0/Examples/Math/CallMathWebService.tcl000064400000000000000000000113461471124032000210450ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require WS::Client ## ## Get Definition of the offered services ## ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsMathExample/wsdl ## ## Add two numbers ## puts stdout "Calling Add via DoCalls!" set inputs [list N1 12 N2 34] set results [::WS::Client::DoCall wsMathExample Add $inputs] puts stdout "\t Received: {$results}" ## ## Divide two numbers ## puts stdout "Calling Divide via DoCalls!" set inputs [list Dividend 34 Divisor 12] set results [::WS::Client::DoCall wsMathExample Divide $inputs] puts stdout "\t Received: {$results}" ## ## Multiply two numbers ## puts stdout "Calling Multiply via DoCalls!" set inputs [list N1 12.0 N2 34] set results [::WS::Client::DoCall wsMathExample Multiply $inputs] puts stdout "\t Received: {$results}" ## ## Subtract two numbers ## puts stdout "Calling Subtract via DoCalls!" set inputs [list Subtrahend 12 Minuend 34] set results [::WS::Client::DoCall wsMathExample Subtract $inputs] puts stdout "\t Received: {$results}" ## ## Sqrt a number ## puts stdout "Calling Sqrt via DoCalls!" set inputs [list X 12] set results [::WS::Client::DoCall wsMathExample Sqrt $inputs] puts stdout "\t Received: {$results}" ## ## Set up to evaluate a polynomial ## dict set term var X dict set term value 2.0 dict lappend varList $term dict set term var Y dict set term value 3.0 dict lappend varList $term set term {} set powerTerm {} dict set powerTerm coef 2.0 dict set term var X dict set term pow 2.0 dict lappend terms $term dict set term var Y dict set term pow 3.0 dict lappend terms $term dict set powerTerm powerTerms $terms dict set powerTerm coef -2.0 dict set term var X dict set term pow 3.0 dict lappend terms $term dict set term var Y dict set term pow 2.0 dict lappend terms $term dict set powerTerm powerTerms $terms dict lappend polynomial powerTerms $powerTerm dict set input varList $varList dict set input polynomial $polynomial ## ## Call service ## puts stdout "Calling EvaluatePolynomial with {$input}" set resultsDict [::WS::Client::DoCall wsMathExample EvaluatePolynomial $input] puts stdout "Results are {$resultsDict}" tclws-3.5.0/Examples/Math/MathWebService.tcl000064400000000000000000000147151471124032000202540ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require WS::Server package require WS::Utils ## ## Define the service ## ::WS::Server::Service \ -service wsMathExample \ -description {Math Example - Tcl Web Services} \ -host $::Config(host):$::Config(port) ## ## Define any special types ## ::WS::Utils::ServiceTypeDef Server wsMathExample Term { `coef {type float} powerTerms {type PowerTerm()} } ::WS::Utils::ServiceTypeDef Server wsMathExample PowerTerm { var {type string} exponet {type float} } ::WS::Utils::ServiceTypeDef Server wsMathExample Variables { var {type string} value {type float} } ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsMathExample \ {Add {type string comment {Sum of two number}}} \ { N1 {type double comment {First number to add}} N2 {type double comment {Second number to add}} } \ {Add two numbers} { return [list AddResult [expr {$N1 + $N2}]] } ::WS::Server::ServiceProc \ wsMathExample \ {Subtract {type string comment {Difference of two number}}} \ { Minuend {type double comment {Number to subtrack from}} Subtrahend {type double comment {Number to be subtracked}} } \ {Subtract one number from another} { return [list SubtractResult [expr {$Minuend - $Subtrahend}]] } ::WS::Server::ServiceProc \ wsMathExample \ {Multiply {type string comment {Product of two number}}} \ { N1 {type double comment {First number to multiply}} N2 {type double comment {Second number to multiply}} } \ {Multiply two numbers} { return [list MultiplyResult [expr {$N1 * $N2}]] } ::WS::Server::ServiceProc \ wsMathExample \ {Divide {type string comment {Quotient of two number}}} \ { Dividend {type double comment {Number that is being divided}} Divisor {type double comment {Number dividing}} } \ {Divide one number by another} { if {$Divisor == 0.0} { return \ -code error \ -errorcode [list MATH DIVBYZERO] \ "Can not divide by zero" } return [list DivideResult [expr {$Dividend / $Divisor}]] } ::WS::Server::ServiceProc \ wsMathExample \ {Sqrt {type string comment {Square root of a non-negative number}}} \ { X {type double comment {Number raised to the half power}} } \ {The the square root of a number} { if {$X < 0.0} { return \ -code error \ -errorcode [list MATH RANGERR] \ "Can not take the square root of a negative number, $X" } return [list SqrtResult [expr {sqrt($X)}]] } ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsMathExample \ {EvaluatePolynomial {type float comment {Result of evaluating a polynomial}}} \ { varList {type Variables() comment {The variables to be substitued into the polynomial}} polynomial {type Term() comment {The polynomial}} } \ {Evaluate a polynomial} { set equation {0 } foreach varDict $varList { set var dict get $varDict var set val dict get $varDict value set vars($var) $val } foreach term $polynomial { if {dict exists $term coef} { set coef dict get $term coef } else { set coef 1 } append equation "+ ($coef" foreach pow dict get $term powerTerms { if {dict exists $pow exponet} { set exp dict get $pow exponet } else { set exp 1 } append equation format { * pow($vars(%s),%s} [dict get $pow var $exp] } append equation ")" } set result expr $equation return list SimpleEchoResult $result } tclws-3.5.0/Examples/README.txt000064400000000000000000000022171471124032000154770ustar00nobodynobodyThe file EchoWebService.tcl defines a service and should be sourced in by the web services server. Normally this is done by placing it in the custom directory. The file CallEchoWebService.tcl is a Tcl script (i.e. non-GUI) designed to show how calls can be made. The file htdocs/service/index.tml should be copied to service/index.tml under the document root of the web server (normally htdocs). This page when displayed in a browser as http://localhost:8015/service/ will show a nice page listing what services you have available. The page will dynamically generate links to the info and wsdl pages that the server generates and also to status pages (located in http://localhost:8015/servicestatus/$serviceName.tml) and form pages (located in http://localhost:8015/serviceforms/$serviceName.tml). This would allow you to auto generate, or hand generate, forms to call your service operations and also status pages to monitor and control your services. Alternatively, the following could be done from the current directory (assuming that httpd.tcl is in the current PATH): httpd.tcl -docRoot ./tclhttpd/htdocs -port 8015 -library ./tclhttpd/custom/ tclws-3.5.0/Examples/aolserver000075500000000000000000000000001471124032000157225ustar00nobodynobodytclws-3.5.0/Examples/aolserver/lib000075500000000000000000000000001471124032000164705ustar00nobodynobodytclws-3.5.0/Examples/aolserver/lib/aolserver-log000075500000000000000000000000001471124032000212515ustar00nobodynobodytclws-3.5.0/Examples/aolserver/lib/aolserver-log/log.tcl000064400000000000000000000002421471124032000226130ustar00nobodynobodynamespace eval ::log { proc log {level args} { ::ns_log [string totitle $level] [join $args " "] } namespace export * } package provide log 2.4.0 tclws-3.5.0/Examples/aolserver/lib/aolserver-log/pkgIndex.tcl000064400000000000000000000001531471124032000236040ustar00nobodynobodypackage ifneeded log 2.4.0 [list source [file normalize [file join [file dirname [info script]] log.tcl]]] tclws-3.5.0/Examples/aolserver/servers000075500000000000000000000000001471124032000174135ustar00nobodynobodytclws-3.5.0/Examples/aolserver/servers/tclws000075500000000000000000000000001471124032000205475ustar00nobodynobodytclws-3.5.0/Examples/aolserver/servers/tclws/modules000075500000000000000000000000001471124032000222175ustar00nobodynobodytclws-3.5.0/Examples/aolserver/servers/tclws/modules/tcl000075500000000000000000000000001471124032000230015ustar00nobodynobodytclws-3.5.0/Examples/aolserver/servers/tclws/modules/tcl/tclws000075500000000000000000000000001471124032000241355ustar00nobodynobodytclws-3.5.0/Examples/aolserver/servers/tclws/modules/tcl/tclws/init.tcl000064400000000000000000000013311471124032000256610ustar00nobodynobody# Require WS::AOLserver and record version # Note: All required packages must be in a lib directory. namespace eval ::WS::AOLserver { variable logVersion [ns_ictl package require log] variable wsVersion [ns_ictl package require WS::Server] variable version [ns_ictl package require WS::AOLserver] } ns_register_filter preauth GET /*/wsdl ::ws_aolserver_redirect wsdl ns_register_filter preauth POST /*/op ::ws_aolserver_redirect op proc ::ws_aolserver_redirect { why } { set urlv [split [ns_conn url] /] set new_url "[join [lrange $urlv 0 end-1] /]/index.tcl" ns_log Notice "WS::AOLserver::Redirect: from [lindex $urlv end] to '$new_url'" ns_rewriteurl $new_url return filter_ok } tclws-3.5.0/Examples/aolserver/servers/tclws/pages000075500000000000000000000000001471124032000216465ustar00nobodynobodytclws-3.5.0/Examples/aolserver/servers/tclws/pages/favicon.ico000064400000000000000000000004761471124032000240550ustar00nobodynobody(( €E¡ÿ„ """"""""#2#2 3 3 3 3#2#2"""""""" 0 !0!!0! 0 """"""""#2#2 3 3 3 3#2#2""""""""2LI’I’2LI’2L2LI’2LI’I’2Ltclws-3.5.0/Examples/aolserver/servers/tclws/pages/global000075500000000000000000000000001471124032000231065ustar00nobodynobodytclws-3.5.0/Examples/aolserver/servers/tclws/pages/global/file-not-found.tcl000064400000000000000000000005611471124032000265210ustar00nobodynobody# Directory Listing File. set request [ns_conn request] set url [lindex [split $request] 1] set path $url set full_path [ns_url2file $url] ns_log Notice "Running file-not-found.tcl for $request" if {![string equal "/" "$path"] && [file isdirectory "$full_path"]} { css_dirlist $full_path $path } else { ns_returnnotice 404 "Not Found" "File $path Not Found" } tclws-3.5.0/Examples/aolserver/servers/tclws/pages/global/server-error.tcl000064400000000000000000000001111471124032000263170ustar00nobodynobodyglobal errorInfo ns_return 500 text/plain "Oops screwed up: $errorInfo" tclws-3.5.0/Examples/aolserver/servers/tclws/pages/index.adp000064400000000000000000000113761471124032000235320ustar00nobodynobody<% set uptime [ns_info uptime] if {$uptime < 60} { set uptime [format %.2d $uptime] } elseif {$uptime < 3600} { set mins [expr $uptime / 60] set secs [expr $uptime - ($mins * 60)] set uptime "[format %.2d $mins]:[format %.2d $secs]" } else { set hours [expr $uptime / 3600] set mins [expr ($uptime - ($hours * 3600)) / 60] set secs [expr $uptime - (($hours * 3600) + ($mins * 60))] set uptime "${hours}:[format %.2d $mins]:[format %.2d $secs]" } set config "" lappend config "Build Date" [ns_info builddate] lappend config "Build Label" [ns_info label] lappend config "Build Platform" [ns_info platform] lappend config "Build Version" [ns_info version] lappend config "Build Patch Level" [ns_info patchlevel] lappend config " " " " lappend config "Binary" [ns_info nsd] lappend config "Process ID" [ns_info pid] lappend config "Uptime" $uptime lappend config "Host Name" [ns_info hostname] lappend config "Address" [ns_info address] lappend config "Server Config" [ns_info config] lappend config "Server Log" [ns_info log] lappend config "Access Log" [ns_accesslog file] lappend config " " " " lappend config "Tcl Version" [info tclversion] lappend config "Tcl Patch Level" [info patchlevel] lappend config " " " " lappend config "Home Directory" [ns_info home] lappend config "Page Root" [ns_info pageroot] lappend config "Tcl Library" [ns_info tcllib] %> Welcome to AOLserver

AOLserver <%=[ns_info version]%>

Congratulations, you have successfully installed AOLserver <%=[ns_info version]%>!

Configuration

<% foreach {key value} $config { ns_adp_puts "" } %>
Key Value
$key$value

Loaded AOLserver Modules

<% set server [ns_info server] set modSection [ns_configsection ns/server/$server/modules] set tclDir [ns_info tcllib] set binDir "[ns_info home]/bin" foreach {name binary} [ns_set array $modSection] { if {[string match "tcl" $binary]} { set type "Tcl" set location "$tclDir/$name" } else { set type "C" set location "$binDir/$binary" } ns_adp_puts "" } %>
Type Name Location
$type$name$location
<% set modules [info loaded] if {[string length $modules]} { ns_adp_puts "\

Loaded Tcl Modules

" foreach module [info loaded] { foreach {binary name} $module { ns_adp_puts "" } } ns_adp_puts "
Name Location
$name$binary
" } %> tclws-3.5.0/Examples/aolserver/servers/tclws/pages/ws000075500000000000000000000000001471124032000222775ustar00nobodynobodytclws-3.5.0/Examples/aolserver/servers/tclws/pages/ws/echoexample000075500000000000000000000000001471124032000245715ustar00nobodynobodytclws-3.5.0/Examples/aolserver/servers/tclws/pages/ws/echoexample/index.tcl000064400000000000000000000021561471124032000264670ustar00nobodynobody package require WS::AOLserver ::WS::AOLserver::Init ::WS::Server::Service \ -mode aolserver \ -prefix $prefix \ -service $service \ -description {Tcl Example Web Services} \ -host $host \ -ports $port ## ## Define any special types ## ::WS::Utils::ServiceTypeDef Server $service echoReply { echoBack {type string} echoTS {type dateTime} } ## ## Define the operations available ## ::WS::Server::ServiceProc \ $service \ {SimpleEcho {type string comment {Requested Echo}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string back} { return [list SimpleEchoResult $TestString] } ::WS::Server::ServiceProc \ $service \ {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string and a timestamp back} { set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes] return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp] ] } ::WS::AOLserver::Returntclws-3.5.0/Examples/aolserver/servers/tclws/pages/ws/mathexample000075500000000000000000000000001471124032000246045ustar00nobodynobodytclws-3.5.0/Examples/aolserver/servers/tclws/pages/ws/mathexample/index.tcl000064400000000000000000000044451471124032000265050ustar00nobodynobodypackage require WS::AOLserver ::WS::AOLserver::Init ## ## Define the service ## ::WS::Server::Service \ -service $service \ -mode aolserver \ -prefix $prefix \ -description {Math Example - Tcl Web Services} \ -host $host \ -ports $port ## ## Define the operations available ## ::WS::Server::ServiceProc \ $service \ {Add {type string comment {Sum of two number}}} \ { N1 {type double comment {First number to add}} N2 {type double comment {Second number to add}} } \ {Add two numbers} { return [list AddResult [expr {$N1 + $N2}]] } ::WS::Server::ServiceProc \ $service \ {Subtract {type string comment {Difference of two number}}} \ { Minuend {type double comment {Number to subtrack from}} Subtrahend {type double comment {Number to be subtracked}} } \ {Subtract one number from another} { return [list SubtractResult [expr {$Minuend - $Subtrahend}]] } ::WS::Server::ServiceProc \ $service \ {Multiply {type string comment {Product of two number}}} \ { N1 {type double comment {First number to multiply}} N2 {type double comment {Second number to multiply}} } \ {Multiply two numbers} { return [list MultiplyResult [expr {$N1 * $N2}]] } ::WS::Server::ServiceProc \ $service \ {Divide {type string comment {Quotient of two number}}} \ { Dividend {type double comment {Number that is being divided}} Divisor {type double comment {Number dividing}} } \ {Divide one number by another} { if {$Divisor == 0.0} { return \ -code error \ -errorcode [list MATH DIVBYZERO] \ "Can not divide by zero" } return [list DivideResult [expr {$Dividend + $Divisor}]] } ::WS::Server::ServiceProc \ $service \ {Sqrt {type string comment {Square root of a non-negative number}}} \ { X {type double comment {Number raised to the half power}} } \ {The the square root of a number} { if {$X < 0.0} { return \ -code error \ -errorcode [list MATH RANGERR] \ "Can not take the square root of a negative number, $X" } return [list SqrtResult [expr {sqrt($X)}]] } ::WS::AOLserver::Returntclws-3.5.0/Examples/aolserver/tclws.tcl000064400000000000000000000055621471124032000176510ustar00nobodynobody# # $Header: /cvsroot/aolserver/aolserver/examples/config/base.tcl,v 1.4 2007/08/01 21:35:26 michael_andrews Exp $ # $Name: $ # # base.tcl -- # # A simple example of a Tcl based AOLserver configuration file. # # Results: # # HTTP (nssock): # # http://
:8000/ # # Server Page Root: # # $AOLSERVER/servers/server1/pages # # Server Access Log: # # $AOLSERVER/servers/server1/modules/nslog/access.log # # Notes: # # To start AOLserver, make sure you are in the AOLserver # installation directory, usually /usr/local/aolserver, and # execute the following command: # # % bin/nsd -ft sample-config.tcl # set server tclws set home [file dirname [ns_info config]] set pageRoot $home/servers/$server/pages ns_section "ns/parameters" ns_param home $home ns_param logdebug true ns_param logusec true ns_section "ns/mimetypes" ns_param default "*/*" ns_param .adp "text/html; charset=iso-8859-1" ns_section "ns/encodings" ns_param adp "iso8859-1" ns_section "ns/threads" ns_param stacksize [expr 128 * 1024] ns_section "ns/servers" ns_param $server "$server" ns_section "ns/server/$server" ns_param directoryfile "index.tcl,index.htm,index.html,index.adp" ns_param pageroot $pageRoot ns_param maxthreads 20 ns_param minthreads 5 ns_param maxconnections 20 ns_param urlcharset "utf-8" ns_param outputcharset "utf-8" ns_param inputcharset "utf-8" ns_param enabletclpages true ns_param chunked true ns_param nsvbuckets 8 ns_param errorminsize 514 ns_section "ns/server/$server/adp" ns_param map "/*.adp" ns_param defaultparser fancy ; # adp ns_param cachesize 40 ns_section ns/server/${server}/adp/parsers ns_param fancy ".adp" ns_section ns/server/${server}/tcl ns_param autoclose "on" ns_param debug "true" ;# false ns_param nsvbuckets "8" ns_section "ns/server/$server/modules" ns_param nssock nssock.so ns_param nslog nslog.so ns_param nscp nscp.so ns_param nsrewrite nsrewrite.so ns_param tclws tcl ns_section "ns/server/$server/module/nssock" ns_param location http://127.0.0.1:8080 ns_param hostname 127.0.0.1:8080 ns_param address 127.0.0.1 ns_param port 8080 ns_section "ns/server/$server/module/nslog" ns_param rolllog true ns_param rollonsignal true ns_param rollhour 0 ns_param maxbackup 2 ns_section "ns/server/$server/module/nscp" ns_param address "127.0.0.1" ns_param port 8081 ns_param cpcmdlogging "false" ns_section "ns/server/$server/module/nscp/users" ns_param user ":" ns_param user "tom:1.7MASVQIxdCA" # Testing # Server url, Proxy & Redirects ns_section "ns/server/${server}/redirects" ns_param 404 "global/file-not-found.tcl" #ns_param 403 "global/forbidden.html" ns_param 500 "global/server-error.tcl" tclws-3.5.0/Examples/redirect_test000075500000000000000000000000001471124032000165605ustar00nobodynobodytclws-3.5.0/Examples/redirect_test/redirect_call.tcl000064400000000000000000000006031471124032000221360ustar00nobodynobody# Call redirect server # 2015-11-09 Harald Oehlmann # Start the redirect_server.tcl and the embedded echo sample to test. set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]] package require WS::Utils package require WS::Client catch {console show} ::log::lvSuppressLE debug 0 ::WS::Client::GetAndParseWsdl http://localhost:8014/service/wsEchoExample/wsdl tclws-3.5.0/Examples/redirect_test/redirect_server.tcl000064400000000000000000000030001471124032000225230ustar00nobodynobody# Test tclws redirection # 2015-11-09 by Harald Oehlmann # # If (set loop 1), infinite redirect is tested, otherwise one redirect. # Start the embedded test server and use redirect_call to call. # set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]] catch {console show} package require uri proc ::Listen {port} { return [socket -server ::Accept $port] } proc ::Accept {sock ip clientport} { if {1 == [catch { gets $sock line set request {} while {[gets $sock temp] > 0 && ![eof $sock]} { if {[regexp {^([^:]*):(.*)$} $temp -> key data]} { dict set request header [string tolower $key] [string trim $data] } } if {[eof $sock]} { puts "Connection closed from $ip" return } if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} { puts "Wrong request: $line" return } array set uri [::uri::split $url] if {[info exists ::loop]} { set uri(host) "localhost:8014" } else { set uri(host) "localhost:8015" } set url [eval ::uri::join [array get uri]] puts "Redirecting to $url" puts $sock "HTTP/1.1 301 Moved Permanently" puts $sock "Location: $url" puts $sock "Content-Type: text/html" puts $sock "Content-Length: 0\n\n" close $sock } Err]} { puts "Socket Error: $Err" return } } Listen 8014 tclws-3.5.0/Examples/tclhttpd000075500000000000000000000000001471124032000155465ustar00nobodynobodytclws-3.5.0/Examples/tclhttpd/custom000075500000000000000000000000001471124032000170605ustar00nobodynobodytclws-3.5.0/Examples/tclhttpd/custom/EchoWebService.tcl000064400000000000000000000074321471124032000225060ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require WS::Server package require WS::Utils ## ## Define the service ## ::WS::Server::Service \ -service wsEchoExample \ -description {Echo Example - Tcl Web Services} \ -host $::Config(host):$::Config(port) ## ## Define any special types ## ::WS::Utils::ServiceTypeDef Server wsEchoExample echoReply { echoBack {type string} echoTS {type dateTime} } ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsEchoExample \ {SimpleEcho {type string comment {Requested Echo}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string back} { return [list SimpleEchoResult $TestString] } ::WS::Server::ServiceProc \ wsEchoExample \ {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string and a timestamp back} { set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes] return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp] ] } tclws-3.5.0/Examples/tclhttpd/custom/MathWebService.tcl000064400000000000000000000116401471124032000225150ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require WS::Server package require WS::Utils ## ## Define the service ## ::WS::Server::Service \ -service wsMathExample \ -description {Math Example - Tcl Web Services} \ -host $::Config(host):$::Config(port) ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsMathExample \ {Add {type string comment {Sum of two number}}} \ { N1 {type double comment {First number to add}} N2 {type double comment {Second number to add}} } \ {Add two numbers} { return [list AddResult [expr {$N1 + $N2}]] } ::WS::Server::ServiceProc \ wsMathExample \ {Subtract {type string comment {Difference of two number}}} \ { Minuend {type double comment {Number to subtrack from}} Subtrahend {type double comment {Number to be subtracked}} } \ {Subtract one number from another} { return [list SubtractResult [expr {$Minuend - $Subtrahend}]] } ::WS::Server::ServiceProc \ wsMathExample \ {Multiply {type string comment {Product of two number}}} \ { N1 {type double comment {First number to multiply}} N2 {type double comment {Second number to multiply}} } \ {Multiply two numbers} { return [list MultiplyResult [expr {$N1 * $N2}]] } ::WS::Server::ServiceProc \ wsMathExample \ {Divide {type string comment {Quotient of two number}}} \ { Dividend {type double comment {Number that is being divided}} Divisor {type double comment {Number dividing}} } \ {Divide one number by another} { if {$Divisor == 0.0} { return \ -code error \ -errorcode [list MATH DIVBYZERO] \ "Can not divide by zero" } return [list DivideResult [expr {$Dividend + $Divisor}]] } ::WS::Server::ServiceProc \ wsMathExample \ {Sqrt {type string comment {Square root of a non-negative number}}} \ { X {type double comment {Number raised to the half power}} } \ {The the square root of a number} { if {$X < 0.0} { return \ -code error \ -errorcode [list MATH RANGERR] \ "Can not take the square root of a negative number, $X" } return [list SqrtResult [expr {sqrt($X)}]] } tclws-3.5.0/Examples/tclhttpd/custom/dodirs.tcl000064400000000000000000000007541471124032000211350ustar00nobodynobody# code to start tclhttpd modules contained in subdirs of custom/ set here [file dirname [info script]] foreach dir [glob -nocomplain [file join [file normalize $here] *]] { if {[file isdirectory $dir] && [file exists [file join $dir startup.tcl]]} { if {$Config(debug)} { Stderr "Loading code from module $dir" } if {[catch {source [file join $dir startup.tcl]} err]} { Stderr "$dir: $err" } elseif {$Config(debug)} { Stderr "Loaded [file tail $dir]: $err" } } } tclws-3.5.0/Examples/tclhttpd/custom/faq.tcl000064400000000000000000000073261471124032000204220ustar00nobodynobody# # Faq generation tool # (for use in .tml->.html files) # # Laurent Demailly # # SCCS: @(#) faq.tcl 1.5 97/12/23 21:13:33 # package provide faq 1.2 global FAQ proc FAQinit {{title ""}} { global FAQ if {[info exists FAQ]} { unset FAQ } set FAQ(section) 0 set FAQ(question) 0 set FAQ(currentSection) S0 set FAQ(sections) [list S0] set result {} if {[string length $title]} { append result [FAQ_H1 $title] } append result "\n" return $result } proc FAQsection {section {ref ""}} { global FAQ if {$FAQ(section) == 0} { # Reset the section list, we have a FAQ with actual sections: set FAQ(sections) {} } incr FAQ(section) set label $FAQ(section) if {[string compare $ref ""] == 0} { set ref "S$label" } if {[info exists FAQ(label$ref)]} { error "ref \"$ref\" not unique!" } lappend FAQ(sections) $ref $section set FAQ(currentSection) $ref set FAQ($ref) {} set FAQ(label$ref) $label set FAQ(question) 0 return $ref } proc FAQ {question answer {ref ""}} { global FAQ set sectionRef $FAQ(currentSection) incr FAQ(question) if {$FAQ(section)} { set label "$FAQ(section).$FAQ(question)" } else { set label "$FAQ(question)" } if {[string compare $ref ""] == 0} { set ref "Q$label" } if {[info exists FAQ(label$ref)]} { error "ref \"$ref\" not unique!" } lappend FAQ($sectionRef) $ref $question $answer set FAQ(label$ref) $label return $ref } proc FAQlink {ref {label ""}} { global FAQ if {[string compare $label ""] == 0} { set label %%FAQ$ref%% } return "$label" } # Quotes chars that are special to regsub : To be implemented proc FAQregQuote {str} { return $str } proc FAQlinkResolve {text} { global FAQ while {[regexp {%%FAQ(.+)%%} $text all ref]} { regsub "%%FAQ[FAQregQuote $ref]%%" $text [FAQregQuote $FAQ(label$ref)] text } return $text } proc FAQgenSec {ref section} { global FAQ page set result {} if {[info exists page(opendl)]} { append result "\n" } append result [FAQ_H2 "$FAQ(label$ref). $section"] append result "
\n" set page(opendl) 1 return $result } proc FAQgenQ {ref question answer} { global FAQ set result {} append result "

$FAQ(label$ref). $question\n" append result "
[FAQlinkResolve $answer]\n" return $result } proc FAQgen {} { global FAQ page set result {} set hasSections $FAQ(section) # Table of content append result [FAQ_H2 "FAQ Index"] append result "\n" foreach {secRef section} $FAQ(sections) { if {$hasSections} { append result "
  • $FAQ(label$secRef).\ $section\n" append result "\n" } foreach {qref question answer} $FAQ($secRef) { append result "
  • $FAQ(label$qref).\ $question\n" } if {$hasSections} { append result "
    • \n" } } append result "
    • " # Actual content foreach {secRef section} $FAQ(sections) { if {$hasSections} { append result [FAQgenSec $secRef $section] } else { append result [FAQ_H2 "Questions and Answers"] append result "
    \n" set page(opendl) 1 } foreach {qref question answer} $FAQ($secRef) { append result [FAQgenQ $qref $question $answer] } } if {[info exists page(opendl)]} { append result "
    \n" } return $result } proc FAQ_H1 {title} { return "

    $title

    \n" } proc FAQ_H2 {title} { return "

    $title

    \n" } tclws-3.5.0/Examples/tclhttpd/custom/hello.tcl000064400000000000000000000007531471124032000207530ustar00nobodynobody# Trivial application-direct URL for "/hello" # The URLs under /hello are implemented by procedures that begin with "::hello::" Direct_Url /hello ::hello:: namespace eval ::hello { variable x [clock format [clock seconds]] } # ::hello::/ -- # # This implements /hello/ proc ::hello::/ {args} { return "Hello, World!" } # ::hello::/there -- # # This implements /hello/there proc ::hello::/there {args} { variable x return "Hello, World!
    \nThe server started at $x" } tclws-3.5.0/Examples/tclhttpd/custom/mypage.tcl000064400000000000000000000054401471124032000211300ustar00nobodynobody# # Tcl Httpd local site templates # # SCCS: @(#) mypage.tcl 1.5 97/12/23 21:11:10 # package provide mypage 1.0 namespace eval mypage { namespace export * } # mypage::contents # # Define the site contents # # Arguments: # list List of URL, labels for each page in the site # # Side Effects: # Records the site structure proc mypage::contents {list} { variable contents $list } # mypage::header # # Generate HTML for the standard page header # # Arguments: # title The page title # # Results: # HTML for the page header. proc mypage::header {title} { mypage::SetLevels $title set html [html::head $title]\n append html [html::bodyTag]\n append html "\n" append html " \ [html::cell align=left "\"Home\""] \ [html::cell "" "

    $title

    "] \ " append html [mypage::thinrule] append html "
    " append html [html::font]\n return $html } # mypage::thinrule # # Generate a thin horizontal rule, expect to be in full width table. # # Arguments: # bgcolor (optional) color # # Results: # HTML for the table row containing the rule. proc mypage::thinrule {{param {colspan=2}}} { set color [html::default thinrule.bgcolor $param] append html "[html::cell "$param $color" \ ""]\n" return $html } # mypage::SetLevels # # Map the page title to a hierarchy location in the site for the page. # # Arguments: # title The page title # # Side Effects: # Sets the level namespace variables proc mypage::SetLevels {title} { variable level } # mypage::footer # # Generate HTML for the standard page footer # # Arguments: # none # # Results: # HTML for the page footer. proc mypage::footer {} { variable contents if {![info exists contents]} { set contents {} } append html "\n" append html "\n" append html [thinrule colspan=[expr {[llength $contents]/2}]] append html [html::cell "" [html::minorMenu $contents \n append html
    [html::font]]]
    \n append html "\n\n" return $html } # mypage::README_links # # Generate optional links to distribution README files. # # Arguments: # none # # Results: # HTML for some links proc mypage::README_links {} { set html "" foreach f [lsort [glob -nocomplain [file join [Doc_Root] links/*]]] { if {[file tail $f] == "CVS"} { continue } if {[file exists $f]} { # Symlink is not broken set t [file tail $f] append html "
  • $t\n" } } if {[string length $html]} { set html
      $html
    } return $html } tclws-3.5.0/Examples/tclhttpd/htdocs000075500000000000000000000000001471124032000170325ustar00nobodynobodytclws-3.5.0/Examples/tclhttpd/htdocs/hacks.tml000064400000000000000000000043471471124032000207300ustar00nobodynobody[mypage::header "Tcl Server Info"]

    Status

    [StatusMenu]

    Debugging

    This server has the interesting ability to reload parts of its implementation dynamically. This lets you add features and fix bugs without ever restarting. It is even possible to setup a debug session with TclPro. This is made possible with the help of the /debug URL. The debug module has e.g. several useful URLs that let you examine variable values and other internal state.

    The /debug URLs are:

    /debug/source?source=<value>&thread=<value>

    /debug/package?package=<value>

    /debug/pvalue?aname=<value>

    /debug/parray?aname=<value>

    /debug/raise?args

    /debug/after

    /debug/echo?title=<value>&args

    /debug/errorInfo?title=<value>&errorInfo=<value>&no=<value>

    /debug/dbg?host=<value>&port=<value>

    /debug/showproc?showproc=<value>

    /debug/disable

    For more specific information about the calls see the debug module.

    Some examples:

    TclPro

    It is also possible to debug tclhttpd with TclPro. Briefly you have to perform following steps:
    Enable the tclhttpd server for debugging (see httpdthread.tcl).
    Setup a Project in TclPro with Debugging Type "Remote Debugging"; define the portnumber; start TclPro by calling

    http://yourserver:port/debug/dbg?host=<hostname>&port=<portnumber>

    The tclhttpd server will connect to a TclPro Session running on host <hostname> listening for remote connections on port number <portnumber>
    In case TclPro is running on the "localhost" listening for the default portnumber "2576" it is enough to call

    http://yourserver:port/debug/dbg [mypage::footer] tclws-3.5.0/Examples/tclhttpd/htdocs/index.tml000064400000000000000000000071761471124032000207510ustar00nobodynobody[html::description "TclHttpd, the Tcl Web Server, is an extensible platform for web application development."] [html::keywords Tcl TclHttpd Tcl/Tk "Tcl Web Server" "Web Server"] [html::author "Brent Welch"] [mypage::header "TclHttpd Home Page"] [Doc_Dynamic]
    [clock format [clock seconds] -format "%B %d, %Y %H:%M:%S"] [if {[Url_PrefixExists /tclpro]} { set _ "
    TclPro Documentation
    " }]

    The TclHttpd is a pure Tcl implementation of a Web server. It runs as a Tcl script on top of Tcl. This server is running Tcl $tcl_patchLevel. There is more TclHttpd version information about using other versions of Tcl and the Standard Tcl Library (tcllib).

    While this server works fine as a stand alone web server, the intent is to embed the server in other applications in order to "web enable" them. A Tcl-based web server is ideal for embedding because Tcl was designed from the start to support embedding into other applications. The interpreted nature of Tcl allows dynamic reconfiguration of the server. Once the core interface between the web server and the hosting application is defined, it is possible to manage the web server, upload Safe-Tcl control scripts, download logging information, and otherwise debug the Tcl part of the application without restarting the hosting application.

    [html::if {[file exists [file join $Doc(root) license.terms]]} { The server is distributed under a copyright that allows free use. }]

    The tclhttpd-users@lists.sourceforge.net mailing list is the best source of current information about TclHttpd.

    Related Articles

    [mypage::README_links] The main TclHttpd Information Page.

    A Tcl Httpd Book Chapter from the 3rd Edition of Practical Programming in Tcl and Tk by Brent Welch.

    The white paper presents a case for an embedded web server from more of a business angle.

    Control/Status Pages

    Documentation

    Test Pages

    [mypage::footer] tclws-3.5.0/Examples/tclhttpd/htdocs/register.tml000064400000000000000000000031051471124032000214520ustar00nobodynobody[mypage::header "Tcl Web Server Registration"]

    If you are unable to post the registration form, an informal note to [html::mailto welch@acm.org "Register WebServer"] would be appreciated.

    Ahem, this form is all great and everything, but I don't have a good "email this form data" handler running, so the mail will go into the bit bucket. The best thing to do is introduce yourself on the tclhttpd mailing list.

    User Registration

    [html::textInputRow "Name" name] [html::textInputRow "Email" emailaddr] [html::cell colspan=2 [html::checkSet noemail {} { "Do not contact me about new releases" 1 }]] [html::textInputRow "Title" title] [html::textInputRow "Company" company]

    How do you plan to use the server?

    For more general comments, please send email to welch@acm.org. There is also a mailing list for users of the Tcl Web Server. You can join this list by visiting http://lists.sourceforge.net/mailman/listinfo/tclhttpd-users. Send mail to the list at [html::mailto tclhttpd-users@lists.sourceforge.net]

    [html::submit "Register (test)"]

    [mypage::footer] tclws-3.5.0/Examples/tclhttpd/htdocs/service000075500000000000000000000000001471124032000204725ustar00nobodynobodytclws-3.5.0/Examples/tclhttpd/htdocs/service/index.tml000064400000000000000000000026631471124032000224050ustar00nobodynobody[Doc_Dynamic] [::html::init] [::html::head {Web Services for Tcl - Available Services}] [::html::bodyTag] [mypage::contents {}] [::html::h1 {Web Services for Tcl - Available Services}] [::html::openTag TABLE border=10 ] [::html::hdrRow {Service} {Description} {Info Link} {WSDL Link} {Status} {Forms}] [ set data {} foreach serviceName [array names ::WS::Server::serviceArr] { set statusFile [file normalize [file join $Config(docRoot) servicestatus $serviceName.tml]] if {[file exist $statusFile]} { set statusLink "Status" } else { set statusLink {None} } set formsFile [file normalize [file join $Config(docRoot) serviceforms $serviceName.tml]] if {[file exist $formsFile]} { set formsLink "Forms" } else { set formsLink {None} } append data [::html::row $serviceName \ [dict get $::WS::Server::serviceArr($serviceName) -description] \ [format {Infomation} $serviceName]\ [format {WSDL} $serviceName] \ $statusLink \ $formsLink] } set data ] [mypage::footer] [::html::end] tclws-3.5.0/Examples/tclhttpd/htdocs/templates000075500000000000000000000000001471124032000210305ustar00nobodynobodytclws-3.5.0/Examples/tclhttpd/htdocs/templates/faqfaq.tml000064400000000000000000000035511471124032000230700ustar00nobodynobody[html::description "tclhttpd FAQ generator FAQ"] [html::keywords ] [html::author "Colin McCormack"] [mypage::header "tclhttpd FAQ generator FAQ"] [FAQinit "tclhttpd FAQ FAQ"] [FAQgen] [mypage::footer] tclws-3.5.0/Examples/tclhttpd/htdocs/templates/form.tml000064400000000000000000000021151471124032000225670ustar00nobodynobody[html::author "Brent Welch"] [mypage::header "Templates and State"] Sample Form

    [html::row "General Info" ""] [html::row "Exclusive Choice" \ [html::radioSet somevariable { } { orange Orange blue Blue green Green "violet red" "Violet Red" }]] [html::row "Selection" \ [html::select mutli 1 { "" "Please Select" orange Orange blue Blue green Green "violet red" "Violet Red" }]] [html::row "Multiple Choice " \ [html::checkSet check " " { orange Orange blue Blue green Green "violet red" "Violet Red" }]]
    Hit this page with form data:

    When a template is processed, information about the CGI values is available via the ncgi module, and the html module used to create the above form automatically initializes the form elements to match the CGI values.

    CGI Values
    [html::tableFromList [ncgi::nvlist] "border=1"]

    Environment
    [html::tableFromArray ::env "border=1" *] [mypage::footer] tclws-3.5.0/Examples/tclhttpd/htdocs/templates/index.tml000064400000000000000000000057641471124032000227500ustar00nobodynobody[mypage::header "HTML/Tcl Templates"]

    A Tcl template works by mixing Tcl code into normal HTML pages. The server uses the Tcl subst command to replace the Tcl code and variable references with their results and values. Here are a few examples: [html::foreach {code} { {[Httpd_Version]} {[clock format [clock seconds]]} {$Doc(root)} {[expr 7 * 826]} } { }]
    Tcl fragmentResult
    $code[subst $code]

    There are two template systems provided by the Doc module: tml and subst templates. They both work in a similar way to replace in-line Tcl, but they differ in the setup done before a page is processed.

    Simple "subst" Templates

    If you have a file that ends with ".subst", then it is processed every time the page is fetched. There is relatively little setup done before processing the page.

    tml Templates

    The ".tml" template system is similar to the ".subst" system, but it provides caching and additional setup before pages are processed.

    Caching Template Results

    The ".tml" template system provides caching of template results in static ".html" files. This saves the cost of re-processing the template each time you access the file. By default, the file page.html contains the cached results of processing the file page.tml. If the page.tml page is modified, the cached copy is regenerated. To get the cache, you have to ask for the page.html file. The server automatically checks to see if there is a corresponding page.tml file, processes the template, caches the result in page.html, and returns the result.

    However, you don't want to cache if the page must be processed on each access. If you don't want your templates cached, put a call to 

    \[Doc_Dynamic\]
    into your page. That surpresses the caching of the template results.

    Per-directory .tml files

    Before processing a page.tml page, the server loads any file named ".tml" (no prefix) in the same directory. This allows you to put procedure and variable definitions in the ".tml" file that are shared among the pages in that directory.

    The server looks up the directory hierarchy to the document root for additional ".tml" files. These are all loaded in order from the root down towards the directory containing the template file page.tml. If you look at the sample htdocs tree that comes with the server, you can see how these .tml files are used.

    More Examples

    • A self modifying page lets you try out a few things yourself.
    • FAQ Generator example that illustrates how to use the faq module in the sample custom directory.
    • Templates with Form Data If you want to process query data, it is available via the ncgi interface, and indirectly via the html interface used to create form elements.
    [mypage::footer] tclws-3.5.0/Examples/tclhttpd/htdocs/templates/self.tml000064400000000000000000000031711471124032000225600ustar00nobodynobody[::learn::header "Tcl in your Page"] [Doc_Dynamic] This page shows what you can do with a little bit of Tcl code in a page. Right below the <hr> horizontal line we'll display the result of the Example1 procedure:

    [if {[catch {interp eval learn Example1} result]} { set _ "Error

    \n$result\n
    " } else { set _ $result }]

    The body of the Example1 procedure is shown here.

    Hint if there is no procedure, try
    return "<b>\[clock format \[clock seconds\]\]</b>"
    Understand that this code runs with all the powers of the web server application. If you want to halt the server, try this. 
    exit
    Ha! tried it, huh? This page runs Example1 in a Safe-Tcl interpreter, although the TML template system normally runs the templates in the main interpreter of your application. [mypage::footer] tclws-3.5.0/Examples/tclhttpd/htdocs/templates/simple.subst000064400000000000000000000013471471124032000234670ustar00nobodynobody Tcl-based Templates

    Tcl-based Templates

    This page shows the very simple processing done for page.subst pages. These pages process Tcl embedded in pages, but don't have the more sophisticated support developed for the page.tml pages.

    The time is [clock format [clock seconds]]

    Here is a look inside the httpd server module. This is generated with the html::tableFromArray command applied to the Httpd array variable in the server.
    [html::tableFromArray Httpd] tclws-3.5.0/Examples/tclhttpd/htdocs/test.tml000064400000000000000000000010061471124032000206030ustar00nobodynobody[mypage::header "Test Page"]

    Namespaces: [namespace children ::]

    mypage: [info vars mypage::*]

    Contents: [set ::mypage::contents]

    This is some text. The image is generated a CGI script so we can hopefully see two threads dispatched to do work as the CGI script blocks.
    [mypage::footer] tclws-3.5.0/Examples/tclhttpd/htdocs/version_history.tml000064400000000000000000000022001471124032000230670ustar00nobodynobody[html::author "Brent Welch"] [mypage::header "TclHttpd Version History"]

    Current versions running in this server:
    TclHttpd $Httpd(version)
    Tcl $tcl_patchLevel

    TclHttpd has been tested on Tcl 8.3, Tcl 8.4, and early versions of Tcl 8.5. For information about Tcl distributions, visit www.tcl.tk.

    The server also depends on the Standard Tcl Library. The server should work with tcllib version >= 1.2. The current tcllib version is 1.5. For the latest tcllib, see the tcllib SourceForge project.

    Using older verions:

      TclHttpd was originally written using Tcl 7.5, and you can probably get it to run on any post 8.0 Tcl release, but you may need to fix a few dependencies on newer, more convenient Tcl apis. If you install the Standard Tcl Library with your Tcl 8.0 or later release you can probably get by, and if you grab a 2.3.* version of TclHttpd you can run with Tcl 7.5 or later.

    FTP site

    ftp://ftp.tcl.tk/pub/tcl/httpd

    [mypage::footer] tclws-3.5.0/Examples/wub000075500000000000000000000000001471124032000145155ustar00nobodynobodytclws-3.5.0/Examples/wub/WubApp.tcl000064400000000000000000000033411471124032000164770ustar00nobodynobody#! /usr/bin/env tclsh lappend ::auto_path [file dirname [info script]] lappend ::auto_path ../Wub/Wub/ ;# add Wub's directory to auto_path package require WS::Server ## ## Define the service ## ::WS::Server::Service -mode wub \ -htmlhead {Wub Based Web Services} \ -service wsEchoExample \ -description {Echo Example - Tcl Web Services} \ -ports 8080 ## ## Define any special types ## ::WS::Utils::ServiceTypeDef Server wsEchoExample echoReply { echoBack {type string} echoTS {type dateTime} } ## ## Define the operations available ## ::WS::Server::ServiceProc \ wsEchoExample \ {SimpleEcho {type string comment {Requested Echo}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string back} { return [list SimpleEchoResult $TestString] } ::WS::Server::ServiceProc \ wsEchoExample \ {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \ { TestString {type string comment {The text to echo back}} } \ {Echo a string and a timestamp back} { set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes] return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp] ] } #### Wub specific application start package require Site ;# load up the site # Initialize Site Site init home [file normalize [file dirname [info script]]] ini site.ini debug 10 # this defines the mapping from URL to Wsdl interface objects package require Nub package require WS::Wub Nub domain /service/wsEchoExample Wsdl -service wsEchoExample Nub domain /service/wsEchoExample2 Wsdl -service wsEchoExample ;# you can have multiple Wsdl instances # Start Site Server(s) Site start tclws-3.5.0/License.txt000064400000000000000000000031631471124032000143470ustar00nobodynobody Copyright (c) 2006-2013, Gerald W. Lester Copyright (c) 2006, Visiprise Software, Inc Copyright (c) 2006, Colin McCormack Copyright (c) 2006, Rolf Ade Copyright (c) 2001-2006, Pat Thoyts All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the Visiprise Software, Inc nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. tclws-3.5.0/Makefile000064400000000000000000000003461471124032000136640ustar00nobodynobody# # "make install" to copy all the stuff into a dir where Tcl can find it # # $Id$ # TARGETDIR=/usr/local/lib/tclws all: @echo "Use \"make install\" to deploy files." install: mkdir -p $(TARGETDIR) cp -v *.tcl $(TARGETDIR) tclws-3.5.0/ServerSide.tcl000064400000000000000000003265771471124032000150240ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2016-2021, Harald Oehlmann ## ## Copyright (c) 2006-2013, Gerald W. Lester ## ## Copyright (c) 2008, Georgios Petasis ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## Copyright (c) 2006, Colin McCormack ## ## Copyright (c) 2006, Rolf Ade ## ## Copyright (c) 2001-2006, Pat Thoyts ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require Tcl 8.6- package require WS::Utils package require html package require log package require tdom 0.8- package provide WS::Server 3.5.0 namespace eval ::WS::Server { array set ::WS::Server::serviceArr {} set ::WS::Server::procInfo {} set ::WS::Server::mode {} } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Server::Service # # Description : Declare a Web Service, the following URLs will exist # /service/ # Displays an HTML page describing the service # /service//wsdl # Returns a WSDL describing the service # /service//op # Invoke an operation # # Arguments : this procedure uses position independent arguments, they are: # -hostcompatibility32 bool - Activate version 3.2.0 compatibility # mode for -host parameter. # Defaults to true. # -host - The host specification within XML namespaces # of the transmitted XML files. # This should be unique. # Defaults to localhost. # If 3.2 compatibility is activated, the default # value is changed to ip:port in embedded mode. # -hostlocation - The host name, which is promoted within the # generated WSDL file. Defaults to localhost. # If 3.2 compatibility is activated, the # default value is equal to the -host parameter. # -hostlocationserver bool - If true, the host location is set by # the current server settings. # In case of httpd server, this value is imported. # For other servers or if this fails, the value # is the current ip:port. # The default value is true. # In case of 3.2 compatibility, the default # value is true for tclhttpd, false otherwise. # -hostprotocol - Define the host protocol (http, https) for the # WSDL location URL. The special value "server" # (default) follows the TCP/IP server specification. # This is implemented for Embedded server and tclhttpd. # Remark that the protocol for XML namespaces # is always "http". # -description - The HTML description for this service # -service - The service name (this will also be used for # the Tcl namespace of the procedures that implement # the operations. # -premonitor - This is a command prefix to be called before # an operation is called. The following arguments are # added to the command prefix: # PRE serviceName operationName operArgList # -postmonitor - This is a command prefix to be called after # an operation is called. The following arguments are # added to the command prefix: # POST serviceName operationName OK|ERROR results # -inheaders - List of input header types. # -outheaders - List of output header types. # -intransform - Inbound (request) transform procedure. # -outtransform - Outbound (reply) transform procedure. # -checkheader - Command prefix to check headers. # If the call is not to be allowed, this command # should raise an error. # The signature of the command must be: # cmd \ # service \ # operation \ # caller_ipaddr \ # http_header_list \ # soap_header_list # -mode - Mode that service is running in. Must be one of: # tclhttpd -- running inside of tclhttpd or an # environment that supplies a # compatible Url_PrefixInstall # and Httpd_ReturnData commands # embedded -- using the ::WS::Embedded package # aolserver -- using the ::WS::AolServer package # wub -- using the ::WS::Wub package # wibble -- running inside of wibble # rivet -- running inside Apache Rivet (mod_rivet) # channel -- use a channel pair, WSDL is return if no XML # otherwise an operation is called # -ports - List of ports. Only valid for embedded and channel mode # For chanel mode. Defaults to {stdin stdout} # NOTE -- a call should be to # ::WS::Channel::Start to process data # For embedded mode. Default: 80 # NOTE -- a call should be to # ::WS::Embedded::Listen # for each port in this # list prior to this call # -prefix - Path prefix used for the namespace and endpoint # Defaults to "/service/" plus the service name # -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 # # Exception Conditions : # MISSREQARG -- Missing required arguments # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # 2.7.0 2020-10-26 H.Oehlmann Embedded server: Do not add port 443 to default url # 3.0.0 2020-10-30 H.Oehlmann New option -hostProtocol # 3.2.0 2021-03-17 H.Oehlmann Add HTTP method to embedded registration. # Change default of -checkheader from # ::WS::Server::ok to the empty string. # 3.4.0 2021-10-15 H.Oehlmann Rename option -hostProtocol to -hostprotocol. # Still accept -hostProtocol. # The logic on .hostprotocol=server is changed # to default to http and set an update flag. # The default value of -host in embedded mode # is :port. This is critial, if # the IP changes and thus the XML namespace. # If the old WSDL with old IP is used, there # are no input parameters recognized, as the # XML namespace has changed. # In consequence, a new parameter set including # options -host, -hostlocation, -hostlocationserver # and -hostcompatibility32 is defined as # described above. # ########################################################################### proc ::WS::Server::Service {args} { variable serviceArr variable procInfo variable mode ::log::logsubst debug {Defining Service as $args} set defaults [dict create\ -checkheader {}\ -inheaders {}\ -outheaders {}\ -intransform {}\ -outtransform {}\ -htmlhead {TclHttpd Based Web Services}\ -author {}\ -description {}\ -mode {tclhttpd}\ -ports {80}\ -traceEnabled {Y}\ -docFormat {text}\ -stylesheet {}\ -beautifyJson {N}\ -errorCallback {}\ -verifyUserArgs {N}\ -enforceRequired {N}\ -hostcompatibility32 1] set defaults [dict merge $defaults $args] # Set default -ports value if mode equal channel if { [dict get $defaults -mode] eq "channel" && ! [dict exists $args -ports] } { dict set defaults -ports {stdin stdout} } set requiredList {-service} set missingList {} foreach opt $requiredList { if {![dict exists $defaults $opt]} { lappend missingList $opt } } if {[llength $missingList]} { return \ -code error \ -errorcode [list WSSERVER MISSREQARG $missingList] \ "Missing required arguments '[join $missingList {,}]'" } set service [dict get $defaults -service] if {![dict exists $defaults -prefix]} { dict set defaults -prefix /service/$service } # find default host/host location if {[dict get $defaults -hostcompatibility32]} { ## ## Version 3.2.x compatibility mode: ## -host: default value is changed to ip:port in embedded mode. ## -hostlocation : default value is equal to the -host parameter. ## -hostlocationserver: default true for tclhttpd, false otherwise. ## if { ! [dict exists $defaults -hostlocationserver]} { dict set defaults -hostlocationserver [expr { [dict get $defaults -mode] eq "tclhttpd" }] } if {![dict exists $defaults -host]} { if { [dict get $defaults -mode] eq "embedded" } { set myHostLocation [MyHostLocationGet [dict get $defaults -ports]] dict set defaults -host $myHostLocation # Note: myHostLocation may be reused below } else { dict set defaults -host localhost } } if { ! [dict exists $defaults -hostlocation]} { dict set defaults -hostlocation [dict get $defaults -host] } } else { ## ## No Version 3.2.x compatibility mode: ## -host: defaults to localhost. ## -hostlocation : defaults to localhost. ## -hostlocationserver bool: defaults to true. ## set defaults [dict merge \ [dict create \ -hostlocation "localhost" \ -hostlocationserver 1 \ -host "localhost"] \ $defaults] } # Compatibility has done its work, remove it: dict unset defaults -hostcompatibility32 ## ## Update host location server to current value if specified ## if { [dict get $defaults -hostlocationserver] } { if {![info exists myHostLocation]} { set myHostLocation [MyHostLocationGet [dict get $defaults -ports]] } dict set defaults -hostlocation $myHostLocation } ## ## Resolve -hostprotocol setting. ## Also accept -hostProtocol ## if {![dict exists $defaults -hostprotocol]} { if {[dict exists $defaults -hostProtocol]} { dict set defaults -hostprotocol [dict get $defaults -hostProtocol] } else { dict set defaults -hostprotocol server } } dict unset defaults -hostProtocol ## ## Resolve server protocol to http and set flag for server protocol. ## If the flag is set, the protocol is corrected when required ## dict set defaults hostProtocolServer [expr { [dict get $defaults -hostprotocol] eq "server"}] if {[dict get $defaults hostProtocolServer]} { dict set defaults -hostprotocol http } dict set defaults -uri $service namespace eval ::$service {} set serviceArr($service) $defaults if {![dict exists $procInfo $service operationList]} { dict set procInfo $service operationList {} } set mode [dict get $defaults -mode] ## ## Install wsdl doc ## interp alias {} ::WS::Server::generateInfo_${service} \ {} ::WS::Server::generateInfo ${service} ::log::logsubst debug {Installing Generate info for $service at [dict get $defaults -prefix]} switch -exact -- $mode { embedded { package require WS::Embeded foreach port [dict get $defaults -ports] { ::WS::Embeded::AddHandler $port [dict get $defaults -prefix] GET ::WS::Server::generateInfo_${service} } } tclhttpd { ::Url_PrefixInstall [dict get $defaults -prefix] ::WS::Server::generateInfo_${service} \ -thread 0 } wub { package require WS::Wub } aolserver { package require WS::AOLserver } rivet { package require Rivet } wibble { ## ## Define zone handler - get code from andy ## proc ::wibble::webservice {state} { dict with state options {} switch -exact -- $suffix { "" - / { ::WS::Server::generateInfo $name 0 response sendresponse $response } /op { ::WS::Server::callOperation $name 0 [dict get $state request] response sendresponse $response } /wsdl { ::WS::Server::generateWsdl $name 0 -responsename response sendresponse $response } default { ## Do nothing } } } if {[package present Wibble] eq "0.1"} { proc ::WS::Wibble::ReturnData {responseDictVar type text status} { upvar 1 $responseDictVar responseDict dict set responseDict header content-type $type dict set responseDict content $text dict set responseDict status $status } } else { proc ::WS::Wibble::ReturnData {responseDictVar type text status} { upvar 1 $responseDictVar responseDict dict set responseDict header content-type "" $type dict set responseDict content $text dict set responseDict status $status } } ::wibble::handle [dict get $defaults -prefix] webservice name $service } default { return \ -code error \ -errorcode [list WSSERVER UNSUPMODE $mode] \ "-mode '$mode' not supported" } } ## ## Install wsdl ## interp alias {} ::WS::Server::generateWsdl_${service} \ {} ::WS::Server::generateWsdl ${service} ::log::logsubst debug {Installing GenerateWsdl info for $service at [dict get $defaults -prefix]/wsdl} switch -exact -- $mode { embedded { foreach port [dict get $defaults -ports] { ::WS::Embeded::AddHandler $port [dict get $defaults -prefix]/wsdl GET ::WS::Server::generateWsdl_${service} } } channel { package require WS::Channel ::WS::Channel::AddHandler [dict get $defaults -ports] {} ::WS::Server::generateWsdl_${service} } tclhttpd { ::Url_PrefixInstall [dict get $defaults -prefix]/wsdl ::WS::Server::generateWsdl_${service} \ -thread 0 } default { ## Do nothing } } ## ## Install operations ## interp alias {} ::WS::Server::callOperation_${service} \ {} ::WS::Server::callOperation ${service} ::log::logsubst debug {Installing callOperation info for $service at [dict get $defaults -prefix]/op} switch -exact -- $mode { embedded { foreach port [dict get $defaults -ports] { ::WS::Embeded::AddHandler $port [dict get $defaults -prefix]/op POST ::WS::Server::callOperation_${service} } } channel { package require WS::Channel ::WS::Channel::AddHandler [dict get $defaults -ports] {op} ::WS::Server::callOperation_${service} } tclhttpd { ::Url_PrefixInstall [dict get $defaults -prefix]/op ::WS::Server::callOperation_${service} \ -thread 1 } default { ## Do nothing } } return } # Get my computers IP address proc ::WS::Server::MyHostLocationGet {ports} { if {[catch { set me [socket -server garbage_word -myaddr [info hostname] 0] set myHostLocation [lindex [fconfigure $me -sockname] 0] close $me } errorMessage]} { ::log::logsubst error {Error '$errorMessage' when querying my own IP\ address. Use 'localhost' instead.} set myHostLocation "localhost" } if { 0 !=[llength $ports] && [lindex $ports 0] ni {80 433} } { append myHostLocation ":[lindex $ports 0]" } return $myHostLocation } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Server::ServiceProc # # Description : Register an operation for a service and declare the procedure to handle # the operations. # # Arguments : # ServiceName -- Name of the service this operation is for # NameInfo -- List of four elements: # 1) OperationName -- the name of the operation # 2) ReturnType -- the type of the procedure return, # this can be a simple or complex type # 3) Description -- description of the return method # 4) Version -- optional version for the service # if ommitted then available in all versions # Arglist -- List of argument definitions, # each list element must be of the form: # 1) ArgumentName -- the name of the argument # 2) ArgumentTypeInfo -- A list of: # {type typeName comment commentString version versionCode} # typeName can be any simple or defined type. # commentString is a quoted string describing the field. # versionCode is the version which this argument is available for # Documentation -- HTML describing what this operation does # Body -- The tcl code to be called when the operation is invoked. . This # code should return a dictionary with Result as a # key and the operation's result as the value. # # Returns : Nothing # # Side-Effects : # A procedure named "::" defined # A type name with the name Result is defined. # # Exception Conditions : None # # Pre-requisite Conditions : ::WS::Server::Server must have been called for the ServiceName # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Server::ServiceProc {service nameInfo arglist documentation body} { variable procInfo set name [lindex $nameInfo 0] set version [expr {[llength $nameInfo] > 3 ? [lindex $nameInfo 3] : {}}] ::log::logsubst debug {Defining operation $name for $service} set argOrder {} ::log::logsubst debug {\targs are {$arglist}} foreach {arg data} $arglist { lappend argOrder $arg } if {![dict exists $procInfo $service op$name argList]} { set tmpList [dict get $procInfo $service operationList] lappend tmpList $name dict set procInfo $service operationList $tmpList } dict set procInfo $service op$name argList $arglist dict set procInfo $service op$name argOrder $argOrder dict set procInfo $service op$name docs $documentation dict set procInfo $service op$name returnInfo [lindex $nameInfo 1] set typeInfo [dict get $procInfo $service op$name returnInfo] dict set procInfo $service op$name version $version ::WS::Utils::ServiceTypeDef Server $service ${name}Results [list ${name}Result $typeInfo] {} {} $version ::WS::Utils::ServiceTypeDef Server $service ${name}Request $arglist {} {} $version set tclArgList [list] foreach {arg typeinfo} $arglist { lappend tclArgList [list [lindex $arg 0] ""] } lappend tclArgList [list tclws_op_version ""] proc ::${service}::${name} $tclArgList $body } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::GetWsdl # # Description : Generates a WSDL for a registered service. # # Arguments : # serviceName - The name of the service # urlPrefix - (optional) Prefix to use for location; defaults to http:// # version - (optional) specific version of service to generate. If ommitted # then returns the lastest # # Returns : # XML for the WSDL # # Side-Effects : None # # Exception Conditions : # WS SERVER UNKSERV - Unknown service name # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2 12/12/2009 W.Kocjan Support for services over SSL in Tclhttpd # 3 11/13/2018 J.Cone Version support # 2.7.0 2020-10-26 H.Oehlmann urlPrefix is a mandatory parameter. # The caller has to think about it. # 3.3.0 2021-10-15 H.Oehlmann Build default location from options # -hostprotocol and -hostlocation replacing # http and option -host. # # ########################################################################### proc ::WS::Server::GetWsdl {serviceName {urlPrefix ""} {version {}}} { variable serviceArr variable procInfo set serviceData $serviceArr($serviceName) set operList {} foreach oper [lsort -dictionary [dict get $procInfo $serviceName operationList]] { if {$version ne {} && [dict exists $procInfo $serviceName op$oper version] && ![::WS::Utils::check_version [dict get $procInfo $serviceName op$oper version] $version]} { continue } lappend operList $oper } ::log::logsubst debug {Generating WSDL for $serviceName} if {![info exists serviceArr($serviceName)]} { set msg "Unknown service '$serviceName'" ::return \ -code error \ -errorCode [list WS SERVER UNKSERV $serviceName] \ $msg } set msg {} set reply [::dom createDocument wsdl:definitions] $reply documentElement definition $definition setAttribute \ xmlns:wsdl "http://schemas.xmlsoap.org/wsdl/" \ xmlns:http "http://schemas.xmlsoap.org/wsdl/http/" \ xmlns:mime "http://schemas.xmlsoap.org/wsdl/mime/" \ xmlns:xs "http://www.w3.org/2001/XMLSchema" \ xmlns:soap "http://schemas.xmlsoap.org/wsdl/soap/" \ xmlns:soapenc "http://schemas.xmlsoap.org/soap/encoding/" \ xmlns:${serviceName} "http://[dict get $serviceData -host][dict get $serviceData -prefix]" \ targetNamespace "http://[dict get $serviceData -host][dict get $serviceData -prefix]" foreach topLevel {types} { $definition appendChild [$reply createElement wsdl:$topLevel $topLevel] } ## ## Messages ## ## Operations foreach oper $operList { $definition appendChild [$reply createElement wsdl:message input] $input setAttribute name ${oper}In $input appendChild [$reply createElement wsdl:part part] $part setAttribute \ name parameters \ element ${serviceName}:${oper}Request $definition appendChild [$reply createElement wsdl:message output] $output setAttribute name ${oper}Out $output appendChild [$reply createElement wsdl:part part] $part setAttribute \ name parameters \ element ${serviceName}:${oper}Results } ## Input headers foreach headerType [dict get $serviceData -inheaders] { $definition appendChild [$reply createElement wsdl:message header] $header setAttribute name $headerType $header appendChild [$reply createElement wsdl:part part] $part setAttribute \ name parameters \ element ${serviceName}:${headerType} } ## Output headers foreach headerType [dict get $serviceData -outheaders] { $definition appendChild [$reply createElement wsdl:message header] $header setAttribute name $headerType $header appendChild [$reply createElement wsdl:part part] $part setAttribute \ name parameters \ element ${serviceName}:${headerType} } ## ## Add the rest of the toplevels in ## foreach topLevel {portType binding service} { $definition appendChild [$reply createElement wsdl:$topLevel $topLevel] } ## ## Service ## $service setAttribute name $serviceName $service appendChild [$reply createElement wsdl:documentation documentation] $documentation appendChild [$reply createTextNode [dict get $serviceData -description]] $service appendChild [$reply createElement wsdl:port port] $port setAttribute \ name ${serviceName}Soap \ binding ${serviceName}:${serviceName}Soap $port appendChild [$reply createElement soap:address address] if {$urlPrefix == ""} { set urlPrefix "[dict get $serviceData -hostprotocol]://[dict get $serviceData -hostlocation]" } $address setAttribute \ location "$urlPrefix[dict get $serviceData -prefix]/op" ## ## Bindings ## $binding setAttribute \ name ${serviceName}Soap \ type ${serviceName}:${serviceName}Soap $binding appendChild [$reply createElement soap:binding b2] $b2 setAttribute \ style document \ transport "http://schemas.xmlsoap.org/soap/http" foreach oper $operList { $binding appendChild [$reply createElement wsdl:operation operNode] $operNode setAttribute name $oper $operNode appendChild [$reply createElement soap:operation o2] $o2 setAttribute \ soapAction $serviceName:$oper \ style document ## Input message $operNode appendChild [$reply createElement wsdl:input input] $input appendChild [$reply createElement soap:body tmp] $tmp setAttribute use literal foreach headerType [dict get $serviceData -inheaders] { $operNode appendChild [$reply createElement wsdl:header header] $header appendChild [$reply createElement soap:header tmp] $tmp setAttribute \ use literal \ message ${serviceName}:${headerType} \ part $headerType } ## Output message $operNode appendChild [$reply createElement wsdl:output output] $output appendChild [$reply createElement soap:body tmp] $tmp setAttribute use literal foreach headerType [dict get $serviceData -outheaders] { $operNode appendChild [$reply createElement wsdl:header header] $header appendChild [$reply createElement soap:header tmp] $tmp setAttribute \ use literal \ message ${serviceName}:${headerType} \ part $headerType } } ## ## Ports ## $portType setAttribute name ${serviceName}Soap foreach oper $operList { $portType appendChild [$reply createElement wsdl:operation operNode] $operNode setAttribute name $oper $operNode appendChild [$reply createElement wsdl:input input] $input setAttribute message ${serviceName}:${oper}In $operNode appendChild [$reply createElement wsdl:output output] $output setAttribute message ${serviceName}:${oper}Out } ## ## Types ## GenerateScheme Server $serviceName $reply $types $version append msg \ {} \ "\n" \ [$reply asXML \ -indent 4 \ -escapeNonASCII \ -doctypeDeclaration 0 \ ] $reply delete return $msg } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateWsdl # # Description : Generates a WSDL for a registered service. # # Arguments : # serviceName - The name of the service # sock - The socket to return the WSDL on # args - Multi-function depending on server: # embedded: -port number: embedded server port number # unknown server: -version number: version # wibble: -responsename name: response variable name # # Returns : # Embedded mode: return list of contentType, message, httpcode # Other modes: 1 - On error, 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2 12/12/2009 W.Kocjan Support for services over SSL in Tclhttpd # 3 11/13/2018 J.Cone Version support # 2.7.0 2020-10-26 H.Oehlmann Support https for embedded server. # 3.1.0 2020-11-06 H.Oehlmann Pass port parameter from embedded server # with prefix "-port" to be compatible with # the -version parameter. # Pass wibble responsename also with prefix # "-responsename". # 3.2.0 2021-03-17 H.Oehlmann In embedded mode, directly return the data # 3.3.0 2021-10-15 H.Oehlmann Change the setting/update of the host location # by using the new parameter -hostlocationserver # and -hostlocation. # ########################################################################### proc ::WS::Server::generateWsdl {serviceName sock args} { variable serviceArr variable procInfo variable mode set operList [lsort -dictionary [dict get $procInfo $serviceName operationList]] ::log::logsubst debug {Generating WSDL for $serviceName on $sock with {$args}} # ToDo HaO 2020-11-06: if confirmed, args may be interpreted as a dict # and the code may be simplified. It is not clear, if any server does not # pass any unused data not being a dict. set version "" set argsIdx [lsearch -exact $args "-version"] if {$argsIdx != -1} { set version [lindex $args [expr {$argsIdx + 1}]] } if {![info exists serviceArr($serviceName)]} { set msg "Unknown service '$serviceName'" switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData \ $sock \ "text/html; charset=UTF-8" \ "Webservice Error

    $msg

    " \ 404 } embedded { return [list\ "text/html; charset=UTF-8" \ "Webservice Error

    $msg

    " \ 404] } channel { ::WS::Channel::ReturnData \ $sock \ "text/xml; charset=UTF-8" \ "Webservice Error

    $msg

    " \ 404 } rivet { headers type "text/html; charset=UTF-8" headers numeric 404 puts "Webservice Error

    $msg

    " } aolserver { ::WS::AOLserver::ReturnData \ $sock \ text/html \ "Webservice Error

    $msg

    " \ 404 } wibble { upvar 1 [lindex $args 0] responseDict ::WS::Wibble::ReturnData responseDict text/html "Webservice Error

    $msg

    " 404 } default { ## Do nothing } } return 1 } set serviceData $serviceArr($serviceName) ## ## Check if the server protocol (and host) should be used ## ## ## Prepare default URL prefix ## set urlPrefix "[dict get $serviceData -hostprotocol]://[dict get $serviceData -hostlocation]" ## ## Return the WSDL ## switch -exact -- $mode { tclhttpd { upvar #0 ::Httpd$sock s # Get protocol and host location from server if configured if { [dict get $serviceData hostProtocolServer] } { catch { dict set serviceData -hostprotocol [lindex $s(self) 0] } } if { [dict get $serviceData -hostlocationserver] } { catch { dict set serviceData -hostprotocol $s(mime,host) } } set urlPrefix [dict get $serviceData -hostprotocol]://[dict get $serviceData -hostlocation] set xml [GetWsdl $serviceName $urlPrefix $version] ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } channel { set xml [GetWsdl $serviceName $urlPrefix $version] ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } embedded { if {[dict get $serviceData hostProtocolServer]} { ## ## For https, change the URL prefix ## set argsIdx [lsearch -exact $args "-port"] if {$argsIdx == -1} { ::log::logsubst error {Parameter '-port' missing from\ embedded server in arguments '$args'} } elseif { [::WS::Embeded::GetValue isHTTPS\ [lindex $args [expr {$argsIdx + 1}]]] } { dict set serviceData -hostprotocol https } else { dict set serviceData -hostprotocol http } set urlPrefix "[dict get $serviceData -hostprotocol]://[dict get $serviceData -hostlocation]" } set xml [GetWsdl $serviceName $urlPrefix $version] return [list "text/xml; charset=UTF-8" $xml 200] } rivet { set xml [GetWsdl $serviceName $urlPrefix $version] headers type "text/xml; charset=UTF-8" headers numeric 200 puts $xml } aolserver { set xml [GetWsdl $serviceName $urlPrefix $version] ::WS::AOLserver::ReturnData $sock text/xml $xml 200 } wibble { set xml [GetWsdl $serviceName $urlPrefix $version] set argsIdx [lsearch -exact $args "-responsename"] if {$argsIdx == -1} { ::log::logsubst error {Parameter '-responsename' missing from\ wibble server in arguments '$args'} } else { upvar 1 [lindex $args [expr {$argsIdx + 1}]] responseDict ::WS::Wibble::ReturnData responseDict text/xml $xml 200 } } default { ## Do nothing } } return 0 } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Server::GenerateScheme # # Description : Generate a scheme # # Arguments : # mode - Client/Server # serviceName - The service name # doc - The document to add the scheme to # parent - The parent node of the scheme # version - Service version # # Returns : nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 02/15/2008 G.Lester Made Scheme generation a utility # 2 02/03/2008 G.Lester Moved scheme generation into WS::Utils namespace # 3 11/13/2018 J.Cone Version support # ########################################################################### proc ::WS::Server::GenerateScheme {mode serviceName doc parent {version {}}} { variable serviceArr set serviceData $serviceArr($serviceName) set targetNamespace "http://[dict get $serviceData -host][dict get $serviceData -prefix]" return [::WS::Utils::GenerateScheme $mode $serviceName $doc $parent $targetNamespace $version] } ########################################################################### # # 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 - supports passing service version info. # Eg: -version 3 # # 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 # 2 09/04/2018 A.Brooks Send an 'example' field # 3 11/13/2018 J.Cone Version support # # ########################################################################### # NOTE: This proc only works with Rivet # TODO: Update to handle jsonp? proc ::WS::Server::generateJsonInfo { serviceName sock args } { variable serviceArr variable procInfo ::log::logsubst debug {Generating JSON Documentation for $serviceName on $sock with {$args}} set version {} set versionIdx [lsearch -exact $args "-version"] if {$versionIdx != -1} { set version [lindex $args [expr {$versionIdx + 1}]] } set serviceData $serviceArr($serviceName) set doc [yajl create #auto -beautify [dict get $serviceData -beautifyJson]] $doc map_open $doc string operations array_open ::log::log debug "\tDisplay Operations (json)" foreach oper [lsort -dictionary [dict get $procInfo $serviceName operationList]] { # version check if {$version ne {} && [dict exists $procInfo $serviceName op$oper version] && ![::WS::Utils::check_version [dict get $procInfo $serviceName op$oper version] $version]} { continue } $doc map_open # operation name $doc string name string $oper # description set description [dict get $procInfo $serviceName op$oper docs] $doc string description string $description # parameters if {[llength [dict get $procInfo $serviceName op$oper argOrder]]} { $doc string inputs array_open foreach arg [dict get $procInfo $serviceName op$oper argOrder] { # version check if {$version ne {} && [dict exists $procInfo $serviceName op$oper argList $arg version] && ![::WS::Utils::check_version [dict get $procInfo $serviceName op$oper argList $arg version] $version]} { continue } ::log::logsubst debug {\t\t\tDisplaying '$arg'} set comment {} if {[dict exists $procInfo $serviceName op$oper argList $arg comment]} { set comment [dict get $procInfo $serviceName op$oper argList $arg comment] } set example {} if {[dict exists $procInfo $serviceName op$oper argList $arg example]} { set example [dict get $procInfo $serviceName op$oper argList $arg example] } set type [dict get $procInfo $serviceName op$oper argList $arg type] $doc map_open \ string name string $arg \ string type string $type \ string comment string $comment \ string example string $example \ map_close } $doc array_close } else { $doc string inputs array_open array_close } $doc string returns map_open set comment {} if {[dict exists $procInfo $serviceName op$oper returnInfo comment]} { set comment [dict get $procInfo $serviceName op$oper returnInfo comment] } set example {} if {[dict exists $procInfo $serviceName op$oper returnInfo example]} { set example [dict get $procInfo $serviceName op$oper returnInfo example] } set type [dict get $procInfo $serviceName op$oper returnInfo type] $doc string comment string $comment string type string $type string example string $example $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 $serviceName] foreach type [lsort -dictionary [dict keys $localTypeInfo]] { # version check if {$version ne {} && [dict exists $localTypeInfo $type version] && ![::WS::Utils::check_version [dict get $localTypeInfo $type version] $version]} { continue } ::log::logsubst 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]] { # version check if {$version ne {} && [dict exists $typeDetails $part version] && ![::WS::Utils::check_version [dict get $typeDetails $part version] $version]} { continue } ::log::logsubst 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] } set example {} if {[dict exists $typeDetails $part example]} { set example [dict get $typeDetails $part example] } $doc map_open \ string field string $part \ string type string $subType \ string comment string $comment \ string example string $example \ 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. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML 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 - Supports passing a wibble dictionary ref or a # service version. Eg: -version 3 # # Returns : # Embedded mode: return list of contentType, message, httpcode # Other modes: 1 - On error, 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2 11/13/2018 J.Cone Version support # 3.2.0 2021-03-17 H.Oehlmann In embedded mode, directly return the data # # ########################################################################### proc ::WS::Server::generateInfo {serviceName sock args} { variable serviceArr variable procInfo variable mode ::log::logsubst debug {Generating HTML Documentation for $serviceName on $sock with {$args}} set version {} if {$args ne {}} { if {[lindex $args 0] eq {-version}} { set version [lindex $args 1] } } if {![info exists serviceArr($serviceName)]} { set msg "Unknown service '$serviceName'" switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData \ $sock \ "text/html; charset=UTF-8" \ "Webservice Error

    $msg

    " \ 404 } embedded { return [list\ "text/html; charset=UTF-8" \ "Webservice Error

    $msg

    " \ 404] } channel { ::WS::Channel::ReturnData \ $sock \ text/html \ "Webservice Error

    $msg

    " \ 404 } rivet { headers type "text/html; charset=UTF-8" headers numeric 404 puts "Webservice Error

    $msg

    " } aolserver { ::WS::AOLserver::ReturnData \ $sock \ text/html \ "Webservice Error

    $msg

    " \ 404 } wibble { upvar 1 [lindex $args 0] responseDict ::WS::Wibble::ReturnData responseDict \ text/html \ "Webservice Error

    $msg

    " \ 404 } default { ## Do nothing } } return 1 } set menuList { {List of Operations} {#TOC} {Operation Details} {#OperDetails} {Simple Types} {#SimpleTypeDetails} {Custom Types} {#CustomTypeDetails} } ## ## Display Service General Information ## append msg [generateGeneralInfo $serviceArr($serviceName) $menuList] ## ## Display TOC ## append msg [generateTocInfo $serviceArr($serviceName) $menuList $version] ## ## Display Operations ## ::log::log debug "\tDisplay Operations" append msg [generateOperationInfo $serviceArr($serviceName) $menuList $version] ## ## Display custom types ## ::log::log debug "\tDisplay custom types" append msg [generateCustomTypeInfo $serviceArr($serviceName) $menuList $version] ## ## Display list of simple types ## ::log::log debug "\tDisplay list of simply types" append msg [generateSimpleTypeInfo $serviceArr($serviceName) $menuList] ## ## All Done ## append msg [::html::end] switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData $sock "text/html; charset=UTF-8" $msg 200 } embedded { return [list "text/html; charset=UTF-8" $msg 200] } channel { ::WS::Channel::ReturnData $sock "text/html; charset=UTF-8" $msg 200 } rivet { headers numeric 200 headers type "text/html; charset=UTF-8" puts $msg } aolserver { ::WS::AOLserver::ReturnData $sock text/html $msg 200 } wibble { upvar 1 [lindex $args 0] responseDict ::WS::Wibble::ReturnData responseDict text/html $msg 200 } default { ## Do nothing } } return 0 } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::displayType # # Description : Formats the type, including a link to a complex type. # # Arguments : # serviceName - The name of the service # type - The type # # Returns : Formatted type information. # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Server::displayType {serviceName 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] } return $result } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::callOperation # # Description : Process the call to an operation. If an error occurs, a standard # error packet is sent, otherwise the appropriate message type # is sent. # # Arguments : # serviceName - The name of the service # sock - The socket to return the WSDL on # -rest - Use Rest flavor call instead of SOAP # -version - specify service version # args - additional arguments and flags: # -rest: choose rest flavor instead soap # -version num: choose a version number # -data dict: data dict in embedded mode. # Used keys are: query, ipaddr, headers. # first element: response dict name in wibble mode # # Returns : # Embedded mode: return list of contentType, message, httpcode # Other modes: 1 - On error, 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2 11/13/2018 J.Cone Version support # 3.1.0 2020-11-06 H.Oehlmann Get global validHttpStatusCodes in this # module, was deleted in Utilities.tcl. # 3.2.0 2021-03-17 H.Oehlmann Embedded mode: directly return data. # Embedded mode: directly receive data via # argument -data dict. # The result return is not protected any more # by a catch to allow direct return. # # ########################################################################### proc ::WS::Server::callOperation {serviceName sock args} { variable procInfo variable serviceArr variable mode switch -exact -- $mode { embedded { # Get the data dict as argument behind call flag "-data" set embeddedServerDataDict [lindex $args\ [lsearch -exact $args "-data"]+1] set inXML [dict get $embeddedServerDataDict query] } wibble { set requestDict [lindex $args 0] upvar 1 [lindex $args 1] responseDict set inXML [dict get $requestDict post xml ""] } 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" } # check if a version number was passed set version {} set versionIdx [lsearch -exact $args "-version"] if {$versionIdx != -1} { set version [lindex $args [expr {$versionIdx + 1}]] } ::log::logsubst debug {In ::WS::Server::callOperation {$serviceName $sock $args}} set serviceData $serviceArr($serviceName) ::log::logsubst debug {\tDocument is {$inXML}} set ::errorInfo {} set ::errorCode {} set ns $serviceName set inTransform [dict get $serviceData -intransform] set outTransform [dict get $serviceData -outtransform] if {$inTransform ne {}} { set inXML [$inTransform REQUEST $inXML] } # Get a reference to the error callback set errorCallback [dict get $serviceData -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) JsonpCallback } set contentType "text/javascript" } } soap { # skip any XML header set first [string first {<} $inXML] if {$first > 0} { set inXML [string range $inXML $first end] } # parse the XML request dom parse $inXML doc $doc documentElement top ::log::logsubst debug {$doc selectNodesNamespaces \ [list ENV http://schemas.xmlsoap.org/soap/envelope/ \ $serviceName http://[dict get $serviceData -host][dict get $serviceData -prefix]]} $doc selectNodesNamespaces \ [list ENV http://schemas.xmlsoap.org/soap/envelope/ \ $serviceName http://[dict get $serviceData -host][dict get $serviceData -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::logsubst debug {requestMessage = {$requestMessage} legacyRpcMode=$legacyRpcMode} 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 } ::log::logsubst debug {operation = '$operation' legacyRpcMode=$legacyRpcMode} set contentType "text/xml" } default { if {$errorCallback ne {}} { $errorCallback "BAD_FLAVOR No supported protocol" {} "UnknownMethod" $flavor } error "bad flavor" } } ## ## Check that the method exists and version checks out. ## if {![dict exists $procInfo $serviceName op$operation argList] || ([dict exists $procInfo $serviceName op$operation version] && ![::WS::Utils::check_version [dict get $procInfo $serviceName op$operation version] $version])} { set msg "Method $operation not found" ::log::log error $msg set ::errorInfo {} set ::errorCode [list Server UNKNOWN_METHOD $operation] set response [generateError \ [dict get $serviceData -traceEnabled] \ CLIENT \ $msg \ [list "errorCode" $::errorCode "stackTrace" $::errorInfo] \ $flavor] catch {$doc delete} set httpStatus 404 if {$errorCallback ne {}} { $errorCallback "UNKNOWN_METHOD $msg" httpStatus $operation $flavor } ::log::logsubst 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 "$contentType; charset=UTF-8" $response $httpStatus } embedded { return [list "$contentType; charset=UTF-8" $response $httpStatus] } rivet { headers type "$contentType; charset=UTF-8" headers numeric $httpStatus puts $response } aolserver { ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } wibble { ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus } default { ## Do nothing } } return 1 } set baseName $operation set cmdName op$baseName set methodName "${ns}::$baseName" ## ## Parse the arguments for the method. ## set argInfo [dict get $procInfo $ns $cmdName argList] if {[catch { # Check that all supplied arguments are valid set methodArgs {} foreach arg [dict get $procInfo $ns $cmdName argOrder] { lappend methodArgs $arg } if {$flavor eq "rest"} { lappend methodArgs jsonp_callback "_" } if {[dict get $serviceData -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 { if {$argName eq "jsonp_callback" || $argName eq "_"} { continue } set argType [string trim [dict get $argInfo $argName type]] set typeInfoList [::WS::Utils::TypeInfo Server $serviceName $argType] if {[dict exists $procInfo $ns $cmdName argList $argName version] && ![::WS::Utils::check_version [dict get $procInfo $ns $cmdName argList $argName version] $version]} { ::log::log debug "user supplied argument not supported in the requested version" lappend tclArgList {} continue } if {![info exists rawargs($argName)]} { ::log::logsubst 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 $serviceName $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 $serviceName $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 $serviceName $argType] if {$pass == 1} { # access arguments by name using full namespace set path $serviceName:$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 {[dict exists $procInfo $ns $cmdName argList $argName version] && ![::WS::Utils::check_version [dict get $procInfo $ns $cmdName argList $argName version] $version]} { ::log::log debug "user supplied argument not supported in the requested version" lappend tclArgList {} continue } if {[string equal $node {}]} { ::log::logsubst debug {did not find argument for $argName using $path, leaving blank (pass $pass)} lappend tclArgList {} continue } ::log::logsubst 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 $serviceName $node $argType $top] } {1 1} { ## Non-simple array set tmp {} set argType [string trimright $argType {()?}] foreach row $node { lappend tmp [::WS::Utils::convertTypeToDict Server $serviceName $row $argType $top] } lappend tclArgList $tmp } default { ## Do nothing } } } ::log::logsubst debug {gotAnyArgs $gotAnyArgs, legacyRpcMode $legacyRpcMode} if {$gotAnyArgs || !$legacyRpcMode} break } } default { if {$errorCallback ne {}} { $errorCallback "BAD_FLAVOR No supported protocol" {} $operation $flavor } error "invalid flavor" } } # If the user passed a version, pass that along if {$version ne {}} { lappend tclArgList $version } ::log::logsubst debug {finalargs $tclArgList} } errMsg]} { ::log::log error $errMsg set localerrorCode $::errorCode set localerrorInfo $::errorInfo set response [generateError \ [dict get $serviceData -traceEnabled] \ CLIENT \ "Error Parsing Arguments -- $errMsg" \ [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \ $flavor] catch {$doc delete} set httpStatus 400 if {$errorCallback ne {}} { $errorCallback "INVALID_ARGUMENT $errMsg" httpStatus $operation $flavor } ::log::logsubst 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 "$contentType; charset=UTF-8" $response $httpStatus } embedded { return [list "$contentType; charset=UTF-8" $response $httpStatus] } channel { ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } rivet { headers type "$contentType; charset=UTF-8" headers numeric $httpStatus puts $response } aolserver { ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } wibble { ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus } default { ## Do nothing } } return 1 } ## ## Run the premonitor hook, if necessary. ## if {[dict exists $serviceData -premonitor] && "" ne [dict get $serviceData -premonitor]} { set precmd [dict get $serviceData -premonitor] lappend precmd PRE $serviceName $operation $tclArgList catch $precmd } ## ## Convert the HTTP request headers. ## set headerList {} foreach headerType [dict get $serviceData -inheaders] { if {[string equal $headerType {}]} { continue } foreach node [$top selectNodes data:$headerType] { lappend headerList [::WS::Utils::convertTypeToDict Server $serviceName $node $headerType $top] } } ## ## Actually execute the method. ## if {[catch { set cmd [dict get $serviceData -checkheader] if {$cmd ne ""} { switch -exact -- $mode { wibble { lappend cmd \ $ns \ $baseName \ [dict get $requestDict peerhost] \ [dict keys [dict get $requestDict header]] \ $headerList } embedded { lappend cmd $ns $baseName [dict get $embeddedServerDataDict ipaddr] [dict get $embeddedServerDataDict headers] $headerList } default { lappend cmd $ns $baseName $data(ipaddr) $data(headerlist) $headerList } } # This will return with error, if the header is not ok eval $cmd } set results [eval \$methodName $tclArgList] # generate a reply packet 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} if {![string equal $outTransform {}]} { set response [$outTransform REPLY $response $operation $results] } if {[dict exists $serviceData -postmonitor] && "" ne [dict get $serviceData -postmonitor]} { set precmd [dict get $serviceData -postmonitor] lappend precmd POST $serviceName $operation OK $results catch $precmd } } msg]} { ## ## Handle errors ## set localerrorCode $::errorCode set localerrorInfo $::errorInfo if {[dict exists $serviceData -postmonitor] && "" ne [dict get $serviceData -postmonitor]} { set precmd [dict get $serviceData -postmonitor] lappend precmd POST $serviceName $operation ERROR $msg catch $precmd } catch {$doc delete} set httpStatus 500 if {$errorCallback ne {}} { $errorCallback $msg httpStatus $operation $flavor } set response [generateError \ [dict get $serviceData -traceEnabled] \ CLIENT \ $msg \ [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo] \ $flavor] ::log::logsubst debug {Leaving @ error 2::WS::Server::callOperation $response} # Check if the localerrorCode is a valid http status code set validHttpStatusCodes {100 101 102 200 201 202 203 204 205 206 207 208 226 300 301 302 303 304 305 306 307 308 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 421 422 423 424 425 426 427 428 429 430 431 451 500 501 502 503 504 505 506 507 508 509 510 511 } if {[lsearch -exact $validHttpStatusCodes $localerrorCode] > -1} { set httpStatus $localerrorCode } # wrap in JSONP if {$flavor == "rest" && [info exists rawargs(jsonp_callback)]} { set response "$rawargs(jsonp_callback)($response)" } switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } embedded { return [list "$contentType; charset=UTF-8" $response $httpStatus] } channel { ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response $httpStatus } rivet { 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 $contentType $response $httpStatus } wibble { ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response $httpStatus } default { ## Do nothing } } return 1 } ## ## Return result ## ::log::logsubst debug {Leaving ::WS::Server::callOperation $response} switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData $sock "$contentType; charset=UTF-8" $response 200 } embedded { return [list "$contentType; charset=UTF-8" $response 200] } channel { ::WS::Channel::ReturnData $sock "$contentType; charset=UTF-8" $response 200 } rivet { headers type "$contentType; charset=UTF-8" headers numeric 200 puts $response } aolserver { ::WS::AOLserver::ReturnData $sock "$contentType; charset=UTF-8" $response 200 } wibble { ::WS::Wibble::ReturnData responseDict "$contentType; charset=UTF-8" $response 200 } default { ## Do nothing } } return 0 } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateError # # Description : Generate a standard error packet # # 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 # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Server::generateError {includeTrace faultcode faultstring detail flavor} { ::log::logsubst debug {Entering ::WS::Server::generateError $faultcode $faultstring {$detail}} set code [lindex $detail 1] switch -exact -- $code { "VersionMismatch" { set code "SOAP-ENV:VersionMismatch" } "MustUnderstand" { set code "SOAP-ENV:MustUnderstand" } "Client" { set code "SOAP-ENV:Client" } "Server" { set code "SOAP-ENV:Server" } default { ## Do nothing } } 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::logsubst debug {Leaving (error) ::WS::Server::generateError $response} return $response } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : :WS::Server::generateReply # # Description : Generate the reply packet for an operation # # 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" # version - Requested service version # # # Returns : The results as an XML formatted packet. # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Server::generateReply {serviceName operation results flavor {version {}}} { ::log::logsubst debug {Entering ::WS::Server::generateReply $serviceName $operation {$results}} variable serviceArr set serviceData $serviceArr($serviceName) switch -exact -- $flavor { rest { set doc [yajl create #auto -beautify [dict get $serviceData -beautifyJson]] $doc map_open ::WS::Utils::convertDictToJson Server $serviceName $doc $results ${serviceName}:${operation}Results [dict get $serviceData -enforceRequired] $version $doc map_close set output [$doc get] $doc delete } soap { if {[info exists ::Config(docRoot)] && [file exists [file join $::Config(docRoot) $serviceName $operation.css]]} { # *** Bug: the -hostprotocol in -hostprotocol=server is not # *** corrected, if no WSDL is required before this call. set replaceText [format {}\ [dict get $serviceData -hostprotocol] \ [dict get $serviceData -hostlocation] \ $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://[dict get $serviceData -host][dict get $serviceData -prefix]" if {0 != [llength [dict get $serviceData -outheaders]]} { $env appendChild [$doc createElement "SOAP-ENV:Header" header] foreach headerType [dict get $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 [dict get $serviceData -enforceRequired] $version } } $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 [dict get $serviceData -enforceRequired] $version append output \ {} \ "\n" \ [$doc asXML -indent none -doctypeDeclaration 0] #regsub "\]*>\n" [::dom::DOMImplementation serialize $doc] $replaceText xml $doc delete } default { error "Unsupported flavor" } } ::log::logsubst debug {Leaving ::WS::Server::generateReply $output} return $output } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : # serviceData -- Service information dict # menuList -- html menu # args - not used # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Server::generateGeneralInfo {serviceData menuList} { variable procInfo ::log::log debug "\tDisplay Service General Information" set service [dict get $serviceData -service] ::html::init ::html::author [dict get $serviceData -author] if {"" eq [dict get $serviceData -description]} { ::html::description "Automatically generated human readable documentation for '$service'" } else { ::html::description [dict get $serviceData -description] } if {[dict get $serviceData -stylesheet] ne ""} { ::html::headTag "link rel=\"stylesheet\" type=\"text/css\" href=\"[dict get $serviceData -stylesheet]\"" } set head [dict get $serviceData -htmlhead] set msg [::html::head $head] append msg [::html::bodyTag] dict unset serviceData -service if {[dict exists $serviceData -description]} { dict set serviceData -description [::html::nl2br [dict get $serviceData -description]] } set wsdl [format {WSDL(xml)} [dict get $serviceData -prefix] wsdl] append msg [::html::openTag center] [::html::h1 "$head -- $wsdl"] [::html::closeTag] \ [::html::openTag table {border="2"}] foreach key [lsort -dictionary [dict keys $serviceData]] { if {"" eq [dict get $serviceData $key]} { append msg [::html::row [string range $key 1 end] {N/A}] } else { append msg [::html::row [string range $key 1 end] [dict get $serviceData $key]] } } append msg [::html::closeTag] \ "\n
    \n" return $msg } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : # serviceData -- Service option dict # menuList -- html menu # version - Requested service version # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Server::generateTocInfo {serviceData menuList version} { variable procInfo ## ## Display TOC ## ::log::log debug "\tTOC" set service [dict get $serviceData -service] append msg [::html::h2 {List of Operations}] set operList {} foreach oper [lsort -dictionary [dict get $procInfo $service operationList]] { if {$version ne {} && [dict exists $procInfo $service op$oper version]} { if {![::WS::Utils::check_version [dict get $procInfo $service op$oper version] $version]} { ::log::log debug "Skipping operation '$oper' because version is incompatible" continue } } lappend operList $oper "#op_$oper" } append msg [::html::minorList $operList] append msg "\n
    \n
    " [::html::minorMenu $menuList] "
    " append msg "\n
    \n" return $msg } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : # serviceData -- Service option dict # menuList -- html menu # version - Requested service version # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Server::generateOperationInfo {serviceData menuList version} { variable procInfo ## ## Display Operations ## ::log::log debug "\tDisplay Operations" set service [dict get $serviceData -service] set operList {} foreach oper [lsort -dictionary [dict get $procInfo $service operationList]] { lappend operList $oper "#op_$oper" } append msg [::html::h2 {Operation Details}] set docFormat [dict get $serviceData -docFormat] set opCount 0 foreach {oper anchor} $operList { if {$version ne {} && [dict exists $procInfo $service op$oper version]} { if {![::WS::Utils::check_version [dict get $procInfo $service op$oper version] $version]} { ::log::log debug "Skipping operation '$oper' because version is incompatible" continue } } ::log::logsubst debug {\t\tDisplaying '$oper'} incr opCount append msg [::html::h3 "$oper"] append msg [::html::h4 {Description}] "\n" append msg [::html::openTag div {style="margin-left: 40px;"}] switch -exact -- $docFormat { "html" { append msg [dict get $procInfo $service op$oper docs] } "text" - default { append msg [::html::nl2br [::html::html_entities [dict get $procInfo $service op$oper docs]]] } } append msg [::html::closeTag] append msg "\n" append msg [::html::h4 {Inputs}] "\n" append msg [::html::openTag div {style="margin-left: 40px;"}] set inputCount 0 if {[llength [dict get $procInfo $service op$oper argOrder]]} { foreach arg [dict get $procInfo $service op$oper argOrder] { if {$version ne {} && [dict exists $procInfo $service op$oper argList $arg version]} { if {![::WS::Utils::check_version [dict get $procInfo $service op$oper argList $arg version] $version]} { ::log::log debug "Skipping field '$arg' because version is incompatible" continue } } ::log::logsubst debug {\t\t\tDisplaying '$arg'} if {!$inputCount} { append msg [::html::openTag {table} {border="2"}] append msg [::html::hdrRow Name Type Description] } incr inputCount 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 \ ] } if {$inputCount} { append msg [::html::closeTag] } } if {!$inputCount} { append msg "No inputs." } append msg [::html::closeTag] ::log::log debug "\t\tReturns" append msg [::html::h4 {Returns}] "\n" append msg [::html::openTag div {style="margin-left: 40px;"}] append msg [::html::openTag {table} {border="2"}] append msg [::html::hdrRow Type Description] if {[dict exists $procInfo $service op$oper returnInfo comment]} { set comment [dict get $procInfo $service op$oper returnInfo comment] } else { set comment {} } append msg [::html::row \ [displayType $service [dict get $procInfo $service op$oper returnInfo type]] \ $comment \ ] append msg [::html::closeTag] append msg [::html::closeTag] append msg "\n
    \n
    " [::html::minorMenu $menuList] "
    " append msg "\n
    \n" } if {!$opCount} { append msg "\n
    \n
    " [::html::minorMenu $menuList] "
    " append msg "\n
    \n" } return $msg } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : # serviceData -- Service option dict # menuList -- html menu # version - Requested service version # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Server::generateCustomTypeInfo {serviceData menuList version} { variable procInfo ## ## Display custom types ## ::log::log debug "\tDisplay custom types" set service [dict get $serviceData -service] append msg [::html::h2 {Custom Types}] set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $service] foreach type [lsort -dictionary [dict keys $localTypeInfo]] { if {$version ne {} && [dict exists $localTypeInfo $type version]} { set typeVersion [dict get $localTypeInfo $type version] if {![::WS::Utils::check_version $typeVersion $version]} { ::log::log debug "Skipping type '$type' because version is incompatible" continue } } ::log::logsubst debug {\t\tDisplaying '$type'} set href_type [lindex [split $type :] end] set typeOverloadArray($type) 1 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 Comment] foreach part [lsort -dictionary [dict keys $typeDetails]] { if {$version ne {} && [dict exists $typeDetails $part version]} { if {![::WS::Utils::check_version [dict get $typeDetails $part version] $version]} { ::log::log debug "Skipping field '$part' because version is incompatible" continue } } ::log::logsubst 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]] \ $comment \ ] } append msg [::html::closeTag] } append msg "\n
    \n
    " [::html::minorMenu $menuList] "
    " append msg "\n
    \n" return $msg } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::generateSimpleTypeInfo # # Description : Generate an HTML description of the service, the operations # and all applicable type definitions. # # Arguments : # serviceData -- Service option dict # menuList -- html menu # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Server::generateSimpleTypeInfo {serviceData menuList} { variable procInfo ## ## Display list of simple types ## ::log::log debug "\tDisplay list of simply types" set service [dict get $serviceData -service] append msg [::html::h2 {Simple Types}] append msg "\n
    \n
    " [::html::minorMenu $menuList] "
    " set localTypeInfo [::WS::Utils::GetServiceSimpleTypeDef Server $service] foreach typeDetails [lsort -dictionary -index 0 $localTypeInfo] { set type [lindex $typeDetails 0] ::log::logsubst debug {\t\tDisplaying '$type'} set typeOverloadArray($type) 1 append msg [::html::h3 "$type"] append msg [::html::openTag {table} {border="2"}] append msg [::html::hdrRow Attribute Value] foreach part [lsort -dictionary [dict keys [lindex $typeDetails 1]]] { ::log::logsubst debug {\t\t\tDisplaying '$part'} append msg [::html::row \ $part \ [dict get [lindex $typeDetails 1] $part] \ ] } append msg [::html::closeTag] } append msg "\n
    \n" return $msg } tclws-3.5.0/Utilities.tcl000064400000000000000000006303331471124032000147100ustar00nobodynobody############################################################################### ## ## ## Copyright (c) 2006-2013, Gerald W. Lester ## ## Copyright (c) 2008, Georgios Petasis ## ## Copyright (c) 2006, Visiprise Software, Inc ## ## Copyright (c) 2006, Arnulf Wiedemann ## ## Copyright (c) 2006, Colin McCormack ## ## Copyright (c) 2006, Rolf Ade ## ## Copyright (c) 2001-2006, Pat Thoyts ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require Tcl 8.6- package require log # Emulate the log::logsubst command introduced in log 1.4 if {![llength [info command ::log::logsubst]]} { proc ::log::logsubst {level text} { if {[::log::lvIsSuppressed $level]} { return } ::log::log $level [uplevel 1 [list subst $text]] } } package require tdom 0.8- package require struct::set package provide WS::Utils 3.2.0 namespace eval ::WS {} namespace eval ::WS::Utils { set ::WS::Utils::typeInfo {} set ::WS::Utils::currentSchema {} array set ::WS::Utils::importedXref {} variable redirectArray array set redirectArray {} 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 float 1 double 1 duration 1 dateTime 1 time 1 date 1 gYearMonth 1 gYear 1 gMonthDay 1 gDay 1 gMonth 1 hexBinary 1 base64Binary 1 anyURI 1 QName 1 NOTATION 1 normalizedString 1 token 1 language 1 NMTOKEN 1 NMTOKENS 1 Name 1 NCName 1 ID 1 IDREF 1 IDREFS 1 ENTITY 1 ENTITIES 1 integer 1 nonPositiveInteger 1 negativeInteger 1 long 1 int 1 short 1 byte 1 nonNegativeInteger 1 unsignedLong 1 unsignedInt 1 unsignedShort 1 unsignedByte 1 positiveInteger 1 } array set ::WS::Utils::options { UseNS 1 StrictMode error parseInAttr 0 genOutAttr 0 valueAttrCompatiblityMode 1 includeDirectory {} suppressNS {} useTypeNs 0 nsOnChangeOnly 0 anyType string queryTimeout 60000 } set ::WS::Utils::standardAttributes { baseType comment example pattern length fixed maxLength minLength minInclusive maxInclusive enumeration type } dom parse { } ::WS::Utils::xsltSchemaDom set currentNs {} } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::GetCrossreference # # Description : Get the type cross reference information for a service. # # Arguments : # mode - Client|Server # service - The name of the service # # Returns : A dictionary of cross reference information # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::GetCrossreference {mode service} { variable typeInfo 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] {()?}] incr crossreference($fieldType,count) lappend crossreference($fieldType,usedBy) $type.$field } if {![info exists crossreference($type,count) ]} { set crossreference($type,count) 0 set crossreference($type,usedBy) {} } } return [array get crossreference] } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::SetOption # # Description : Define a type for a service. # # Arguments : # option - option # value - value (optional) # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::SetOption {args} { variable options if {[llength $args] == 0} { ::log::log debug {Return all options} return [array get options] } elseif {[llength $args] == 1} { set opt [lindex $args 0] ::log::logsubst debug {One Option {$opt}} if {[info exists options($opt)]} { return $options($opt) } else { ::log::logsubst debug {Unknown option {$opt}} return \ -code error \ -errorcode [list WS CLIENT UNKOPTION $opt] \ "Unknown option'$opt'" } } elseif {([llength $args] % 2) == 0} { ::log::log debug {Multiple option pairs} foreach {opt value} $args { if {[info exists options($opt)]} { ::log::logsubst debug {Setting Option {$opt} to {$value}} set options($opt) $value } else { ::log::logsubst debug {Unknown option {$opt}} return \ -code error \ -errorcode [list WS CLIENT UNKOPTION $opt] \ "Unknown option'$opt'" } } } else { ::log::logsubst debug {Bad number of arguments {$args}} return \ -code error \ -errorcode [list WS CLIENT INVARGCNT $args] \ "Invalid argument count'$args'" } return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::ServiceTypeDef # # Description : Define a type for a service. # # Arguments : # mode - Client|Server # service - The name of the service this type definition is for # type - The type to be defined/redefined # definition - The definition of the type's fields. This consist of one # or more occurence of a field definition. Each field definition # consist of: fieldName fieldInfo # Where field info is: {type typeName comment commentString} # typeName can be any simple or defined type. # commentString is a quoted string describing the field. # xns - The namespace # abstract - Boolean indicating if this is an abstract, and hence mutable type # version - Version code for the custom type # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # 2 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Utils::ServiceTypeDef {mode service type definition {xns {}} {abstract {false}} {version {}}} { ::log::logsubst debug {Entering [info level 0]} variable typeInfo if {![string length $xns]} { set xns $service } if {[llength [split $type {:}]] == 1} { set type $xns:$type } dict set typeInfo $mode $service $type definition $definition dict set typeInfo $mode $service $type xns $xns dict set typeInfo $mode $service $type abstract $abstract if {$version ne {}} { dict set typeInfo $mode $service $type version $version } return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::MutableTypeDef # # Description : Define a mutable type for a service. # # Arguments : # mode - Client|Server # service - The name of the service this type definition is for # type - The type to be defined/redefined # fromSwitchCmd - The cmd to determine the actaul type when converting # from DOM to a dictionary. The actual call will have # the following arguments appended to the command: # mode service type xns DOMnode # toSwitchCmd - The cmd to determine the actual type when converting # from a dictionary to a DOM. The actual call will have # the following arguments appended to the command: # mode service type xns remainingDictionaryTree # xns - The namespace # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 02/15/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::MutableTypeDef {mode service type fromSwitchCmd toSwitchCmd {xns {}}} { variable mutableTypeInfo if {![string length $xns]} { set xns $service } set mutableTypeInfo([list $mode $service $type]) \ [list $fromSwitchCmd $toSwitchCmd] return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::ServiceSimpleTypeDef # # Description : Define a type for a service. # # Arguments : # mode - Client|Server # service - The name of the service this type definition is for # type - The type to be defined/redefined # definition - The definition of the type's fields. This consist of one # or more occurance of a field definition. Each field definition # consist of: fieldName fieldInfo # Where field info is list of name value: # basetype typeName - any simple or defined type. # comment commentString - a quoted string describing the field. # pattern value # length value # fixed "true"|"false" # maxLength value # minLength value # minInclusive value # maxInclusive value # enumeration value # # xns - The namespace # # Returns : Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::ServiceSimpleTypeDef {mode service type definition {xns {tns1}}} { variable simpleTypes variable typeInfo ::log::logsubst debug {Entering [info level 0]} if {![dict exists $definition xns]} { set simpleTypes($mode,$service,$type) [concat $definition xns $xns] } else { set simpleTypes($mode,$service,$type) $definition } if {[dict exists $typeInfo $mode $service $type]} { ::log::logsubst debug {\t Unsetting typeInfo $mode $service $type} ::log::logsubst debug {\t Was [dict get $typeInfo $mode $service $type]} dict unset typeInfo $mode $service $type } return } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::GetServiceTypeDef # # Description : Query for type definitions. # # Arguments : # mode - Client|Server # service - The name of the service this query is for # type - The type to be retrieved (optional) # # Returns : # If type not provided, a dictionary object describing all of the complex types # for the service. # If type provided, a dictionary object describing the type. # A definition consist of a dictionary object with the following key/values: # xns - The namespace for this type. # definition - The definition of the type's fields. This consist of one # or more occurance of a field definition. Each field definition # consist of: fieldName fieldInfo # Where field info is: {type typeName comment commentString} # Where field info is list of name value: # basetype typeName - any simple or defined type. # comment commentString - a quoted string describing the field. # pattern value # length value # fixed "true"|"false" # maxLength value # minLength value # minInclusive value # maxInclusive value # enumeration value # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : The service must be defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::GetServiceTypeDef {mode service {type {}}} { variable typeInfo variable simpleTypes set type [string trimright $type {()?}] set results {} if {[string equal $type {}]} { ::log::log debug "@1" set results [dict get $typeInfo $mode $service] } else { set typeInfoList [TypeInfo $mode $service $type] if {[string equal -nocase -length 3 $type {xs:}]} { set type [string range $type 3 end] } ::log::logsubst debug {Type = {$type} typeInfoList = {$typeInfoList}} if {[info exists simpleTypes($mode,$service,$type)]} { ::log::log debug "@2" set results $simpleTypes($mode,$service,$type) } elseif {[info exists simpleTypes($type)]} { ::log::log debug "@3" set results [list type xs:$type xns xs] } elseif {[dict exists $typeInfo $mode $service $service:$type]} { ::log::log debug "@5" set results [dict get $typeInfo $mode $service $service:$type] } elseif {[dict exists $typeInfo $mode $service $type]} { ::log::log debug "@6" set results [dict get $typeInfo $mode $service $type] } } return $results } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::GetServiceSimpleTypeDef # # Description : Query for type definitions. # # Arguments : # mode - Client|Server # service - The name of the service this query is for # type - The type to be retrieved (optional) # # Returns : # If type not provided, a dictionary object describing all of the simple types # for the service. # If type provided, a dictionary object describing the type. # A definition consist of a dictionary object with the following key/values: # xns - The namespace for this type. # definition - The definition of the type's fields. This consist of one # or more occurance of a field definition. Each field definition # consist of: fieldName fieldInfo # Where field info is: {type typeName comment commentString} # Where field info is list of name value and any restrictions: # basetype typeName - any simple or defined type. # comment commentString - a quoted string describing the field. # pattern value # length value # fixed "true"|"false" # maxLength value # minLength value # minInclusive value # maxInclusive value # enumeration value # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : The service must be defined. # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::GetServiceSimpleTypeDef {mode service {type {}}} { variable simpleTypes 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 {} foreach {key value} [array get simpleTypes $mode,$service,*] { lappend results [list [lindex [split $key {,}] end] $simpleTypes($key)] } } else { if {[info exists simpleTypes($mode,$service,$type)]} { set results $simpleTypes($mode,$service,$type) } elseif {[info exists simpleTypes($type)]} { set results [list type $type xns xs] } else { return \ -code error \ -errorcode [list WS CLIENT UNKSMPTYP $type] \ "Unknown simple type '$type'" } } return $results } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::ProcessImportXml # # Description : Parse the bindings for a service from a WSDL into our # internal representation # # Arguments : # mode - The mode, Client or Server # baseUrl - The URL we are processing # xml - The XML string to parse # serviceName - The name service. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. # tnsCountVar - The name of the variable containing the count of the # namespace. # # Returns : Nothing # # Side-Effects : Defines Client mode types for the service as specified by the WSDL # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 08/06/2006 G.Lester Initial version # 2.6.1 07/20/2018 A.Goth Correct variable access problems. Ticket [7bb1cd7b43] # Corrected access of right document. Ticket [61fd346dc3] # Bugs introduced 2015-05-24 Checkin [9c7e118edb] # 2018-09-03 H.Oehlmann Replaced stderr error print by error log. # ########################################################################### proc ::WS::Utils::ProcessImportXml {mode baseUrl xml serviceName serviceInfoVar tnsCountVar} { ::log::logsubst debug {Entering [info level 0]} upvar 1 $serviceInfoVar serviceInfo upvar 1 $tnsCountVar tnsCount variable currentSchema variable nsList variable xsltSchemaDom set first [string first {<} $xml] if {$first > 0} { set xml [string range $xml $first end] } if {[catch {dom parse $xml tmpdoc}]} { set first [string first {?>} $xml] incr first 2 set xml [string range $xml $first end] dom parse $xml tmpdoc } $tmpdoc xslt $xsltSchemaDom doc $tmpdoc delete $doc selectNodesNamespaces { w http://schemas.xmlsoap.org/wsdl/ d http://schemas.xmlsoap.org/wsdl/soap/ xs http://www.w3.org/2001/XMLSchema } $doc documentElement schema if {[catch {ProcessIncludes $schema $baseUrl} errMsg]} { ::log::log error "Error processing include $schema $baseUrl: $errMsg" } set prevSchema $currentSchema set nodeList [$doc selectNodes -namespaces $nsList descendant::xs:schema] foreach node $nodeList { set currentSchema $node parseScheme $mode $baseUrl $node $serviceName serviceInfo tnsCount } set currentSchema $prevSchema $doc delete } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::ProcessIncludes # # Description : Replace all include nodes with the contents of the included url. # # Arguments : # rootNode - the root node of the document # baseUrl - The URL being processed # # Returns : nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 25/05/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::ProcessIncludes {rootNode baseUrl {includePath {}}} { variable xsltSchemaDom variable nsList variable options variable includeArr ::log::logsubst debug {Entering [info level 0]} set includeNodeList [concat \ [$rootNode selectNodes -namespaces $nsList descendant::xs:include] \ [$rootNode selectNodes -namespaces $nsList descendant::w:include] \ [$rootNode selectNodes -namespaces $nsList descendant::w:import] \ ] set inXml [$rootNode asXML] set included 0 foreach includeNode $includeNodeList { ::log::logsubst debug {\t Processing Include [$includeNode asXML]} if {[$includeNode hasAttribute schemaLocation]} { set urlTail [$includeNode getAttribute schemaLocation] set url [::uri::resolve $baseUrl $urlTail] } elseif {[$includeNode hasAttribute location]} { set url [$includeNode getAttribute location] set urlTail [file tail [dict get [::uri::split $url] path]] } else { continue } if {[lsearch -exact $includePath $url] != -1} { log::logsubst warning {Include loop detected: [join $includePath { -> }]} continue } elseif {[info exists includeArr($url)]} { continue } else { set includeArr($url) 1 } incr included ::log::logsubst info {\t Including {$url} from base {$baseUrl}} switch -exact -- [dict get [::uri::split $url] scheme] { file { upvar #0 [::uri::geturl $url] token set xml $token(data) unset token } https - http { set ncode -1 catch { ::log::logsubst info {[list ::http::geturl $url\ -timeout $options(queryTimeout)]} set token [::http::geturl $url -timeout $options(queryTimeout)] set ncode [::http::ncode $token] set xml [::http::data $token] ::log::logsubst info {Received Ncode = ($ncode), $xml} ::http::cleanup $token } if {($ncode != 200) && [string equal $options(includeDirectory) {}]} { return \ -code error \ -errorcode [list WS CLIENT HTTPFAIL $url $ncode] \ "HTTP get of import file failed '$url'" } elseif {($ncode != 200) && ![string equal $options(includeDirectory) {}]} { set fn [file join $options(includeDirectory) $urlTail] set ifd [open $fn r] set xml [read $ifd] close $ifd } } default { return \ -code error \ -errorcode [list WS CLIENT UNKURLTYP $url] \ "Unknown URL type '$url'" } } set parentNode [$includeNode parentNode] set nextSibling [$includeNode nextSibling] set first [string first {<} $xml] if {$first > 0} { set xml [string range $xml $first end] } dom parse $xml tmpdoc $tmpdoc xslt $xsltSchemaDom doc $tmpdoc delete set children 0 set top [$doc documentElement] ::WS::Utils::ProcessIncludes $top $url [concat $includePath $baseUrl] foreach childNode [$top childNodes] { if {[catch { #set newNode [$parentNode appendXML [$childNode asXML]] #$parentNode removeChild $newNode #$parentNode insertBefore $newNode $includeNode $parentNode insertBefore $childNode $includeNode }]} { continue } incr children } $doc delete $includeNode delete } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>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. 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: # 0|1 - 0 means a simple type, 1 means a complex type # 0|1 - 0 means a scalar, 1 means an array # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 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 {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 } else { set isArray 0 } #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] } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::CheckAndBuild::ValidateRequest # # Description : Given a schema validate a XML string given as parameter # using a XML schema description (in WS:: form) for # validation # # Arguments : # mode - Client/Server # serviceName - The service name # xmlString - The XML string to validate # tagName - The name of the starting tag # typeName - The type for the tag # # Returns : 1 if validation ok, 0 if not # # Side-Effects : # ::errorCode - cleared if validation ok # - contains validation failure information if validation # failed. # # Exception Conditions : # WS CHECK START_NODE_DIFFERS - Start node not what was expected # # Pre-requisite Conditions : None # # Original Author : Arnulf Wiedemann # #>>END PUBLIC<< # # 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 08/14/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to handle qualified XML # # ########################################################################### proc ::WS::Utils::Validate {mode serviceName xmlString tagName typeName} { set first [string first {<} $xmlString] if {$first > 0} { set xmlString [string range $xmlString $first end] } dom parse $xmlString resultTree $resultTree documentElement currNode set nodeName [$currNode localName] if {![string equal $nodeName $tagName]} { return \ -code error \ -errorcode [list WS CHECK START_NODE_DIFFERS [list $tagName $nodeName]] \ "start node differs expected: $tagName found: $nodeName" } set ::errorCode {} set result [checkTags $mode $serviceName $currNode $typeName] $resultTree delete return $result } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::BuildRequest # # Description : Given a schema check the body of a request handed in # as a XML string using a XML schema description (in WS:: form) # for validation # # Arguments : # mode - Client/Server # serviceName - The service name # tagName - The name of the starting tag # typeName - The type for the tag # valueInfos - The dictionary of the values # # Returns : The body of the request as xml # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Arnulf Wiedemann # #>>END PUBLIC<< # # 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 08/13/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to generate qualified XML # ########################################################################### proc ::WS::Utils::BuildRequest {mode serviceName tagName typeName valueInfos} { upvar 1 $valueInfos values variable resultTree variable currNode set resultTree [::dom createDocument $tagName] set typeInfo [GetServiceTypeDef $mode $serviceName $typeName] $resultTree documentElement currNode if {[catch {buildTags $mode $serviceName $typeName $valueInfos $resultTree $currNode} msg]} { set tmpErrorCode $::errorCode set tmpErrorInfo $::errorInfo $resultTree delete return \ -code error \ -errorcode $tmpErrorCode \ -errorinfo $tmpErrorInfo \ $msg } set xml [$resultTree asXML] $resultTree delete return $xml } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Server::GenerateXsd # # Description : Generate a XSD. NOTE -- does not write a file # # Arguments : # mode - Client/Server # serviceName - The service name # targetNamespace - Target namespace # # Returns : XML of XSD # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : Service must exists # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 02/03/2008 G.Lester Initial Version # ########################################################################### proc ::WS::Utils::GenerateXsd {mode serviceName targetNamespace} { set reply [::dom createDocument definitions] $reply documentElement definition GenerateScheme $mode $serviceName $reply {} $targetNamespace append msg \ {} \ "\n" \ [$reply asXML -indent 4 -escapeNonASCII -doctypeDeclaration 0] $reply delete return $msg } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Utils::GenerateScheme # # Description : Generate a scheme # # Arguments : # mode - Client/Server # serviceName - The service name # doc - The document to add the scheme to # parent - The parent node of the scheme # targetNamespace - Target namespace # version - Requested service version # # Returns : nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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 02/15/2008 G.Lester Made Scheme generation a utility # 2 02/03/2008 G.Lester Moved scheme generation into WS::Utils namespace # 3 11/13/2018 J.Cone Version support # ########################################################################### proc ::WS::Utils::GenerateScheme {mode serviceName doc parent targetNamespace {version {}}} { set localTypeInfo [GetServiceTypeDef $mode $serviceName] array set typeArr {} foreach type [dict keys $localTypeInfo] { set typeArr($type) 1 } if {[string equal $parent {}]} { $doc documentElement schema $schema setAttribute \ xmlns:xs "http://www.w3.org/2001/XMLSchema" } else { $parent appendChild [$doc createElement xs:schema schema] } $schema setAttribute \ elementFormDefault qualified \ targetNamespace $targetNamespace foreach baseType [lsort -dictionary [array names typeArr]] { if {$version ne {} && [dict exists $localTypeInfo $baseType version]} { if {![check_version [dict get $localTypeInfo $baseType version] $version]} { continue } } ::log::logsubst debug {Outputing $baseType} $schema appendChild [$doc createElement xs:element elem] set name [lindex [split $baseType {:}] end] $elem setAttribute name $name $elem setAttribute type $baseType $schema appendChild [$doc createElement xs:complexType comp] $comp setAttribute name $name $comp appendChild [$doc createElement xs:sequence seq] set baseTypeInfo [dict get $localTypeInfo $baseType definition] ::log::logsubst debug {\t parts {$baseTypeInfo}} foreach {field tmpTypeInfo} $baseTypeInfo { if {$version ne {} && [dict exists $tmpTypeInfo version]} { if {![check_version [dict get $tmpTypeInfo version] $version]} { continue } } $seq appendChild [$doc createElement xs:element tmp] set tmpType [dict get $tmpTypeInfo type] ::log::logsubst debug {Field $field of $tmpType} foreach {name value} [getTypeWSDLInfo $mode $serviceName $field $tmpType] { $tmp setAttribute $name $value } } } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::getTypeWSDLInfo # # Description : Return full type information usable for a WSDL # # Arguments : # mode - Client/Server # serviceName - The name of the service # field - The field name # type - The data type # # Returns : The type definition as a dictionary object # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2 02/03/2008 G.Lester Moved into WS::Utils namespace # ########################################################################### 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 1] if {[lindex $typeList 0] == 0} { dict set typeInfo type xs:[string trimright $type {()?}] } else { 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 } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::convertTypeToDict # # Description : Convert the XML, in DOM representation, to a dictionary object for # a given type. # # Arguments : # mode - The mode, Client or Server # serviceName - The service name the type is defined in # node - The base node for the type. # type - The name of the type # root - The root node of the document # isArray - We are looking for array elements # # Returns : A dictionary object for a given type. # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # 2.4.2 2018-05-14 H.Oehlmann Add support to translate namespace prefixes # in attribute values or text values. # New parameter "xnsDistantToLocalDict". # ########################################################################### proc ::WS::Utils::convertTypeToDict { mode serviceName node type root {isArray 0} {xnsDistantToLocalDict {}} } { variable typeInfo variable mutableTypeInfo variable options if {$options(valueAttrCompatiblityMode)} { set valueAttr {} } else { set valueAttr {::value} } set xsiNsUrl {http://www.w3.org/2001/XMLSchema-instance} ::log::logsubst debug {Entering [info level 0]} if {[dict exists $typeInfo $mode $serviceName $type]} { set typeName $type } elseif {[dict exists $typeInfo $mode $serviceName $serviceName:$type]} { set typeName $serviceName:$type } else { ## ## Assume this is a simple type ## set baseType [::WS::Utils::GetServiceTypeDef $mode $serviceName $type] if {[string equal $baseType {XML}]} { set results [$node asXML] } else { set results [$node asText] } return $results } set typeDefInfo [dict get $typeInfo $mode $serviceName $typeName] ::log::logsubst debug {\t type def = {$typeDefInfo}} set xns [dict get $typeDefInfo xns] if {[$node hasAttribute href]} { set node [GetReferenceNode $root [$node getAttribute href]] } ::log::logsubst debug {\t XML of node is [$node asXML]} if {[info exists mutableTypeInfo([list $mode $serviceName $typeName])]} { set type [(*)[lindex mutableTypeInfo([list $mode $serviceName $type]) 0] $mode $serviceName $typeName $xns $node] set typeDefInfo [dict get $typeInfo $mode $serviceName $typeName] ::log::logsubst debug {\t type def replaced with = {$typeDefInfo}} } set results {} #if {$options(parseInAttr)} { # foreach attr [$node attributes] { # if {[llength $attr] == 1} { # dict set results $attr [$node getAttribute $attr] # } # } #} set partsList [dict keys [dict get $typeDefInfo definition]] ::log::logsubst 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 } if {[string equal $partName *] && [string equal $partType *]} { ## ## Type infomation being handled dynamically for this part ## set savedTypeInfo $typeInfo parseDynamicType $mode $serviceName $node $type set tmp [convertTypeToDict $mode $serviceName $node $type $root 0 $xnsDistantToLocalDict] foreach partName [dict keys $tmp] { dict set results $partName [dict get $tmp $partName] } set typeInfo $savedTypeInfo continue } set partXns $xns catch {set partXns [dict get $typeInfo $mode $serviceName $partType xns]} set typeInfoList [TypeInfo $mode $serviceName $partType] set tmpTypeInfo [::WS::Utils::GetServiceTypeDef $mode $serviceName $partType] ::log::logsubst debug {\tpartName $partName partType $partType xns $xns typeInfoList $typeInfoList} ## ## Try for fully qualified name ## ::log::logsubst debug {Trying #1 [list $node selectNodes $partXns:$partName]} if {[catch {llength [set item [$node selectNodes $partXns:$partName]]} len] || ($len == 0)} { ::log::logsubst debug {Trying #2 [list $node selectNodes $xns:$partName]} if {[catch {llength [set item [$node selectNodes $xns:$partName]]} len] || ($len == 0)} { ## ## Try for unqualified name ## ::log::logsubst debug {Trying #3 [list $node selectNodes $partName]} if {[catch {llength [set item [$node selectNodes $partName]]} len] || ($len == 0)} { ::log::log debug "Trying #4 -- search of children" set item {} set matchList [list $partXns:$partName $xns:$partName $partName] foreach childNode [$node childNodes] { set nodeType [$childNode nodeType] ::log::logsubst debug {\t\t Looking at {[$childNode localName],[$childNode nodeName]} ($allowAny,$isArray,$nodeType,$partName)} # From SOAP1.1 Spec: # Within an array value, element names are not significant # for distinguishing accessors. Elements may have any name. # Here we don't need check the element name, just simple check # it's a element node if {$allowAny || ($arrayOverride && [string equal $nodeType "ELEMENT_NODE"])} { ::log::logsubst debug {\t\t Found $partName [$childNode asXML]} lappend item $childNode } } if {![string length $item]} { ::log::log debug "\tSkipping" continue } } else { ::log::logsubst debug {\t\t Found [llength $item] $partName} } } else { ::log::logsubst debug {\t\t Found [llength $item] $partName} } } else { ::log::logsubst debug {\t\t Found [llength $item] $partName} } set origItemList $item set newItemList {} foreach item $origItemList { if {[$item hasAttribute href]} { set oldXML [$item asXML] ::log::logsubst debug {\t\t Replacing: $oldXML} set item [GetReferenceNode $root [$item getAttribute href]] ::log::logsubst debug {\t\t With: [$item asXML]} } lappend newItemList $item } set item $newItemList set isAbstract false if {[dict exists $typeInfo $mode $serviceName $partType abstract]} { set isAbstract [dict get $typeInfo $mode $serviceName $partType abstract] } switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## 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]} { set attrValue [$item getAttribute ${nsAlias}:$attr] dict set results $partName ::$attr $attrValue } elseif {![string equal $nsAlias {}]} { set attrValue [$item getAttribute ${nsAlias}:$attr] dict set results $partName $attr $attrValue } else { set attrValue [$item getAttribute $attr] dict set results $partName $attr $attrValue } } } if {[string equal $baseType {XML}]} { dict set results $partName $valueAttr [$item asXML] } else { dict set results $partName $valueAttr [$item asText] } } else { if {[string equal $baseType {XML}]} { dict set results $partName [$item asXML] } else { dict set results $partName [$item asText] } } } {0 1} { ## ## Simple array ## 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] { catch { lassign $attrList attr nsAlias nsUrl if {[string equal $nsUrl $xsiNsUrl]} { set attrValue [$row getAttribute ${nsAlias}:$attr] lappend rowList ::$attr $attrValue } elseif {![string equal $nsAlias {}]} { set attrValue [$row getAttribute ${nsAlias}:$attr] lappend rowList $attr $attrValue } else { set attrValue [$row getAttribute $attr] lappend rowList $attr $attrValue } } } if {[string equal $baseType {XML}]} { lappend rowList $valueAttr [$row asXML] } else { lappend rowList $valueAttr [$row asText] } lappend tmp $rowList } else { if {[string equal $baseType {XML}]} { lappend tmp [$row asXML] } else { lappend tmp [$row asText] } } } dict set results $partName $tmp } {1 0} { ## ## Non-simple non-array ## if {$options(parseInAttr)} { ## Translate an abstract type from the WSDL to a type given ## in the response ## Example xml response from bug 584bfb772: ## ## ## ## ## Layers ## ## ## ## The element FullExtend gets type "tns:EnvelopeN". ## ## xnsDistantToLocalDict if {$isAbstract && [$item hasAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type]} { # partType is now tns::EnvelopeN set partType [XNSDistantToLocal $xnsDistantToLocalDict \ [$item getAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type]] # Remove this type attribute from the snippet. # So, it is not handled in the loop below. $item removeAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type } foreach attrList [$item attributes] { catch { lassign $attrList attr nsAlias nsUrl if {[string equal $nsUrl $xsiNsUrl]} { set attrValue [$item getAttribute ${nsAlias}:$attr] dict set results $partName ::$attr $attrValue } elseif {![string equal $nsAlias {}]} { set attrValue [$item getAttribute ${nsAlias}:$attr] dict set results $partName $attr $attrValue } else { set attrValue [$item getAttribute $attr] dict set results $partName $attr $attrValue } } } dict set results $partName $valueAttr [convertTypeToDict $mode $serviceName $item $partType $root 0 $xnsDistantToLocalDict] } else { dict set results $partName [convertTypeToDict $mode $serviceName $item $partType $root 0 $xnsDistantToLocalDict] } } {1 1} { ## ## Non-simple array ## set partType [string trimright $partType {()}] set tmp [list] foreach row $item { if {$options(parseInAttr)} { set rowList {} if {$isAbstract && [$row hasAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type]} { set partType [$row getAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type] $row removeAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type } foreach attrList [$row attributes] { catch { lassign $attrList attr nsAlias nsUrl if {[string equal $nsUrl $xsiNsUrl]} { set attrValue [$row getAttribute ${nsAlias}:$attr] lappend rowList ::$attr $attrValue } elseif {![string equal $nsAlias {}]} { set attrValue [$row getAttribute ${nsAlias}:$attr] lappend rowList $attr $attrValue } else { set attrValue [$row getAttribute $attr] lappend rowList $attr $attrValue } } } lappend rowList $valueAttr [convertTypeToDict $mode $serviceName $row $partType $root 1 $xnsDistantToLocalDict] lappend tmp $rowList } else { lappend tmp [convertTypeToDict $mode $serviceName $row $partType $root 1 $xnsDistantToLocalDict] } } dict set results $partName $tmp } default { ## ## Placed here to shut up tclchecker ## } } } ::log::logsubst debug {Leaving ::WS::Utils::convertTypeToDict with result '$results'} return $results } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::XNSDistantToLocal # # Description : Get a reference node. # # Arguments : # xnsDistantToLocalDict - Dict to translate distant to local NS prefixes # typeDistant - Type string with possible distant namespace prefix # # Returns : type with local namespace prefix # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # Maintenance History - as this file is modified, please be sure that you # update this segment of the file header block by # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 2.4.2 2017-11-03 H.Oehlmann Initial version # ########################################################################### proc ::WS::Utils::XNSDistantToLocal {xnsDistantToLocalDict type} { set collonPos [string first ":" $type] # check for namespace prefix present if {-1 < $collonPos} { set prefixDistant [string range $type 0 $collonPos-1] if {[dict exists $xnsDistantToLocalDict $prefixDistant]} { set type [dict get $xnsDistantToLocalDict $prefixDistant][string range $type $collonPos end] log::logsubst debug {Mapped distant namespace prefix '$prefixDistant' to type '$type'} } else { log::logsubst warning {Distant type '$type' does not have a known namespace prefix ([dict keys $xnsDistantToLocalDict])} } } return $type } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::GetReferenceNode # # Description : Get a reference node. # # Arguments : # root - The root node of the document # root - The root node of the document # # Returns : A node object. # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 08/19/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::GetReferenceNode {root id} { set id [string trimleft $id {#}] set node [$root selectNodes -cache yes [format {//*[@id="%s"]} $id]] if {[$node hasAttribute href]} { set node [GetReferenceNode $root [$node getAttribute href]] } return $node } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::convertDictToType # # Description : Convert a dictionary object into a XML DOM tree. # # Arguments : # mode - The mode, Client or Server # service - The service name the type is defined in # parent - The parent node of the type. # doc - The document # dict - The dictionary to convert # type - The name of the type # forceNs - Force the response to use a namespace # enforceRequired - Boolean setting for enforcing required vars be set # version - Requested service version # # Returns : None # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Utils::convertDictToType {mode service doc parent dict type {forceNs 0} {enforceRequired 0} {version {}}} { ::log::logsubst debug {Entering [info level 0]} # ::log::logsubst 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 $enforceRequired $version] } if {$options(valueAttrCompatiblityMode)} { set valueAttr {} } else { set valueAttr {::value} } set typeInfoList [TypeInfo $mode $service $type] set type [string trimright $type {?}] ::log::logsubst debug {\t typeInfoList = {$typeInfoList}} if {[dict exists $typeInfo $mode $service $service:$type]} { set typeName $service:$type } else { set typeName $type } if {$version ne {} && [dict exists $typeInfo $mode $service $typeName version]} { if {![check_version [dict get $typeInfo $mode $service $typeName version] $version]} { return } } 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 { if {[info exists simpleTypes($mode,$service,$typeName)]} { set xns [dict get $simpleTypes($mode,$service,$typeName) xns] } elseif {[info exists simpleTypes($mode,$service,$currentNs:$typeName)]} { set xns [dict get $simpleTypes($mode,$service,$currentNs:$typeName) xns] } else { error "Simple type cannot be found: $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] set xns [dict get $typeInfo $mode $service $typeName xns] } else { if {[info exists simpleTypes($mode,$service,$typeName)]} { set xns [dict get $simpleTypes($mode,$service,$typeName) xns] } elseif {[info exists simpleTypes($mode,$service,$currentNs:$typeName)]} { set xns [dict get $simpleTypes($mode,$service,$currentNs:$typeName) xns] } else { error "Simple type cannot be found: $typeName" } set itemList [list $type {type string}] } } ::log::logsubst debug {\titemList is {$itemList} in $xns} set entryNs $currentNs if {!$forceNs} { set currentNs $xns } set fieldList {} foreach {itemName itemDef} $itemList { if {[dict exists $itemDef version] && ![check_version [dict get $itemDef version] $version]} { continue } set baseName [lindex [split $itemName {:}] end] lappend fieldList $itemName set itemType [dict get $itemDef type] ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} itemType ={$itemType}} set typeInfoList [TypeInfo $mode $service $itemType 1] ::log::logsubst debug {Expr [list ![dict exists $dict $itemName] && ![dict exists $dict $baseName]]} if {![dict exists $dict $itemName] && ![dict exists $dict $baseName]} { ::log::logsubst 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 {()?}]] if {$options(useTypeNs) && [dict exists $tmpInfo xns]} { set itemXns [dict get $tmpInfo xns] } set attrList {} if {$options(useTypeNs) && [string equal $itemXns xs]} { set itemXns $xns } if {$options(nsOnChangeOnly) && [string equal $itemXns $currentNs]} { set itemXns {} } foreach key [dict keys $itemDef] { if {[lsearch -exact $standardAttributes $key] == -1 && $key ne "isList" && $key ne "xns"} { lappend attrList $key [dict get $itemDef $key] ::log::logsubst debug {key = {$key} standardAttributes = {$standardAttributes}} } } ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} itemXns = {$itemXns} tmpInfo = {$tmpInfo} attrList = {$attrList}} set isAbstract false 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::logsubst 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 ## if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $itemXns:$itemName retNode] } if {$options(genOutAttr)} { set resultValue {} set dictList [dict keys [dict get $dict $useName]] #::log::log debug "$useName <$dict> '$dictList'" foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {[string equal $attr $valueAttr]} { set resultValue [dict get $dict $useName $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $dict $useName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $dict $useName $attr] } } } else { set resultValue [dict get $dict $useName] } if {[dict exists $tmpInfo base] && [string equal [dict get $tmpInfo base] {XML}]} { $retNode appendXML $resultValue } else { $retNode appendChild [$doc createTextNode $resultValue] } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } {0 1} { ## ## Simple array ## set dataList [dict get $dict $useName] #::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 { $parent appendChild [$doc createElement $itemXns:$itemName retNode] } if {$options(genOutAttr)} { set dictList [dict keys $row] ::log::logsubst debug {<$row> '$dictList'} set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {[string equal $attr $valueAttr]} { set resultValue [dict get $row $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $row $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $row $attr] } } } else { set resultValue $row } if {[dict exists $tmpInfo base] && [string equal [dict get $tmpInfo base] {XML}]} { $retNode appendXML $resultValue } else { $retNode appendChild [$doc createTextNode $resultValue] } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } } {1 0} { ## ## Non-simple non-array ## if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $itemXns:$itemName retNode] } if {$options(genOutAttr)} { #::log::log debug "Before 150 useName {$useName} dict {$dict}" set dictList [dict keys [dict get $dict $useName]] #::log::log debug "$useName <$dict> '$dictList'" set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {$isAbstract && [string equal $attr {::type}]} { set itemType [dict get $dict $useName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $itemType set itemType $itemXns:$itemType } elseif {[string equal $attr $valueAttr]} { set resultValue [dict get $dict $useName $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $dict $useName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $dict $useName $attr] } } } else { 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 $forceNs $enforceRequired $version } else { convertDictToType $mode $service $doc $retNode $resultValue $itemType $forceNs $enforceRequired $version } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } {1 1} { ## ## Non-simple array ## set dataList [dict get $dict $useName] #::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 { $parent appendChild [$doc createElement $itemXns:$itemName retNode] } if {$options(genOutAttr)} { set dictList [dict keys $row] set resultValue {} #::log::log debug "<$row> '$dictList'" foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {$isAbstract && [string equal $attr {::type}]} { set tmpType [dict get $row $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $tmpType set tmpType $itemXns:$tmpType } elseif {[string equal $attr $valueAttr]} { set resultValue [dict get $row $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $row $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $row $attr] } } } 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 $forceNs $enforceRequired $version } else { convertDictToType $mode $service $doc $retNode $resultValue $tmpType $forceNs $enforceRequired $version } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } } default { ## ## Placed here to shut up tclchecker ## } } #if {$options(genOutAttr)} { # set dictList [dict keys $dict] # foreach attr [lindex [::struct::set intersect3 $fieldList $dictList] end] { # $parent setAttribute $attr [dict get $dict $attr] # } #} } set currentNs $entryNs ::log::logsubst 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 # enforceRequired - Boolean setting for enforcing required vars be set # version - The requested service version # # 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 # 2 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Utils::convertDictToJson {mode service doc dict type {enforceRequired 0} {version {}}} { ::log::logsubst debug {Entering [info level 0]} 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 } if {$version ne {} && [dict exists $typeInfo $mode $service $typeName version]} { if {![check_version [dict get $typeInfo $mode $service $typeName version] $version]} { return } } 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::logsubst debug {\titemList is {$itemList}} set fieldList {} foreach {itemName itemDef} $itemList { if {[dict exists $itemDef version] && ![check_version [dict get $itemDef version] $version]} { continue } lappend fieldList $itemName set itemType [dict get $itemDef type] ::log::logsubst 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::logsubst 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 $version $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 $version $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. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::convertDictToTypeNoNs # # Description : Convert a dictionary object into a XML DOM tree. # # Arguments : # mode - The mode, Client or Server # service - The service name the type is defined in # parent - The parent node of the type. # dict - The dictionary to convert # type - The name of the type # enforceRequired - Boolean setting for enforcing required vars be set # version - The requested service version # # Returns : None # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 2 11/13/2018 J.Cone Version support # # ########################################################################### proc ::WS::Utils::convertDictToTypeNoNs {mode service doc parent dict type {enforceRequired 0} {version {}}} { ::log::logsubst debug {Entering [info level 0]} # ::log::log debug " Parent xml: [$parent asXML]" variable typeInfo variable simpleTypes variable options variable standardAttributes variable currentNs if {$version ne {} && [dict exists $typeInfo $mode $service $type version]} { if {![check_version [dict get $typeInfo $mode $service $type version] $version]} { return } } if {$options(valueAttrCompatiblityMode)} { set valueAttr {} } else { set valueAttr {::value} } set typeInfoList [TypeInfo $mode $service $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)]} { set xns [dict get $simpleTypes($mode,$service,$type) xns] } elseif {[info exists simpleTypes($mode,$service,$currentNs:$type)]} { set xns [dict get $simpleTypes($mode,$service,$currentNs:$type) xns] } else { error "Simple type cannot be found: $type" } set itemList [list $type {type string}] } ::log::logsubst debug {\titemList is {$itemList}} foreach {itemName itemDef} $itemList { if {[dict exists $itemDef version] && ![check_version [dict get $itemDef version] $version]} { continue } ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef}} set itemType [dict get $itemDef type] set isAbstract false 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 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"} { lappend attrList $key [dict get $itemDef $key] ::log::logsubst debug {key = {$key} standardAttributes = {$standardAttributes}} } } ::log::logsubst debug {\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList}} set typeInfoList [lrange $typeInfoList 0 1] switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys [dict get $dict $itemName]] set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {[string equal $attr $valueAttr]} { set resultValue [dict get $dict $itemName $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $dict $itemName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $dict $itemName $attr] } } } else { set resultValue [dict get $dict $itemName] } $retNode appendChild [$doc createTextNode $resultValue] if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } {0 1} { ## ## Simple array ## set dataList [dict get $dict $itemName] foreach row $dataList { $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys $row] set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {[string equal $attr $valueAttr]} { set resultValue [dict get $row $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $row $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $row $attr] } } } else { set resultValue $row } $retNode appendChild [$doc createTextNode $resultValue] if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } } {1 0} { ## ## Non-simple non-array ## $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys [dict get $dict $itemName]] set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {$isAbstract && [string equal $attr {::type}]} { # *** HaO: useName is never defined set itemType [dict get $dict $useName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $itemType } elseif {[string equal $attr $valueAttr]} { set resultValue [dict get $dict $itemName $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $dict $itemName $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $dict $itemName $attr] } } } else { set resultValue [dict get $dict $itemName] } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } convertDictToTypeNoNs $mode $service $doc $retNode $resultValue $itemType $enforceRequired $version } {1 1} { ## ## Non-simple array ## set dataList [dict get $dict $itemName] set tmpType [string trimright $itemType {()}] foreach row $dataList { $parent appendChild [$doc createElement $itemName retNode] if {$options(genOutAttr)} { set dictList [dict keys $row] set resultValue {} foreach attr [lindex [::struct::set intersect3 $standardAttributes $dictList] end] { if {$isAbstract && [string equal $attr {::type}]} { set tmpType [dict get $row $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:type $tmpType } elseif {[string equal $attr $valueAttr]} { set resultValue [dict get $row $attr] } elseif {[string match {::*} $attr]} { set baseAttr [string range $attr 2 end] set attrValue [dict get $row $attr] $retNode setAttributeNS "http://www.w3.org/2001/XMLSchema-instance" xsi:$baseAttr $attrValue } else { lappend attrList $attr [dict get $row $attr] } } } else { set resultValue $row } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } convertDictToTypeNoNs $mode $service $doc $retNode $resultValue $tmpType $enforceRequired $version } } default { ## ## Placed here to shut up tclchecker ## } } } # ::log::log debug "Leaving ::WS::Utils::convertDictToTypeNoNs 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::convertDictToEncodedType # # Description : Convert a dictionary object into a XML DOM tree with type # encoding. # # Arguments : # mode - The mode, Client or Server # service - The service name the type is defined in # parent - The parent node of the type. # 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 : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 3.2.0 2024-11-01 H.Oehlmann Replaced "format %d" by "%lld" for array # index larger than 2**32. # # ########################################################################### proc ::WS::Utils::convertDictToEncodedType {mode service doc parent dict type} { ::log::logsubst debug {Entering [info level 0]} variable typeInfo variable options set typeInfoList [TypeInfo $mode $service $type] ::log::logsubst 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)]} { set xns [dict get $simpleTypes($mode,$service,$type) xns] } else { error "Simple type cannot be found: $type" } set itemList [list $type {type string}] } if {[info exists mutableTypeInfo([list $mode $service $type])]} { set type [(*)[lindex mutableTypeInfo([list $mode $service $type]) 0] $mode $service $type $xns $dict] set typeInfoList [TypeInfo $mode $service $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)]} { set xns [dict get $simpleTypes($mode,$service,$type) xns] } else { error "Simple type cannot be found: $type" } set itemList [list $type {type string}] } } ::log::logsubst debug {\titemList is {$itemList} in $xns} foreach {itemName itemDef} $itemList { set itemType [string trimright [dict get $itemList $itemName type] {?}] set typeInfoList [TypeInfo $mode $service $itemType] ::log::logsubst debug {\t\t Looking for {$itemName} in {$dict}} if {![dict exists $dict $itemName]} { ::log::log debug "\t\t Not found, skipping" continue } ::log::logsubst debug {\t\t Type info is {$typeInfoList}} switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## if {[string equal $xns $options(suppressNS)]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $xns:$itemName retNode] } if {![string match {*:*} $itemType]} { set attrType $xns:$itemType } else { set attrType $itemType } $retNode setAttribute xsi:type $attrType set resultValue [dict get $dict $itemName] $retNode appendChild [$doc createTextNode $resultValue] } {0 1} { ## ## Simple array ## set dataList [dict get $dict $itemName] set tmpType [string trimright $itemType {()}] if {![string match {*:*} $itemType]} { set attrType $xns:$itemType } else { set attrType $itemType } foreach resultValue $dataList { if {[string equal $xns $options(suppressNS)]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $xns:$itemName retNode] } $retNode setAttribute xsi:type $attrType $retNode appendChild [$doc createTextNode $resultValue] } } {1 0} { ## ## Non-simple non-array ## if {[string equal $xns $options(suppressNS)]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $xns:$itemName retNode] } if {![string match {*:*} $itemType]} { set attrType $xns:$itemType } else { set attrType $itemType } $retNode setAttribute xsi:type $attrType convertDictToEncodedType $mode $service $doc $retNode [dict get $dict $itemName] $itemType } {1 1} { ## ## Non-simple array ## set dataList [dict get $dict $itemName] set tmpType [string trimright $itemType {()}] if {![string match {*:*} $itemType]} { set attrType $xns:$itemType } else { set attrType $itemType } set attrType [string trim $attrType {()?}] $parent setAttribute xmlns:soapenc {http://schemas.xmlsoap.org/soap/encoding/} $parent setAttribute soapenc:arrayType [format {%s[%lld]} $attrType [llength $dataList]] $parent setAttribute xsi:type soapenc:Array #set itemName [$parent nodeName] foreach item $dataList { if {[string equal $xns $options(suppressNS)]} { $parent appendChild [$doc createElement $itemName retNode] } else { $parent appendChild [$doc createElement $xns:$itemName retNode] } $retNode setAttribute xsi:type $attrType convertDictToEncodedType $mode $service $doc $retNode $item $tmpType } } default { ## ## Placed here to shut up tclchecker ## } } } 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::parseDynamicType # # Description : Parse the schema for a dynamically typed part. # # Arguments : # mode - The mode, Client or Server # serviceName - The service name the type is defined in # node - The base node for the type. # type - The name of the type # # Returns : A dictionary object for a given type. # # Side-Effects : Type definitions added # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseDynamicType {mode serviceName node type} { variable typeInfo variable nsList ::log::logsubst debug {Entering [info level 0]} foreach child [$node childNodes] { ::log::logsubst debug {\t Child $child is [$child nodeName]} } ## ## Get type being defined ## set schemeNode [$node selectNodes -namespaces $nsList xs:schema] set newTypeNode [$node selectNodes -namespaces $nsList xs:schema/xs:element] set newTypeName [lindex [split [$newTypeNode getAttribute name] :] end] ## ## Get sibling node to scheme and add tempory type definitions ## ## type == sibing of temp type ## temp_type == newType of newType ## set tnsCountVar [llength [dict get $::WS::Client::serviceArr($serviceName) targetNamespace]] set tns tns$tnsCountVar set dataNode {} $schemeNode nextSibling dataNode if {![info exists dataNode] || ![string length $dataNode]} { $schemeNode previousSibling dataNode } set dataNodeNameList [split [$dataNode nodeName] :] set dataTnsName [lindex $dataNodeNameList 0] set dataNodeName [lindex $dataNodeNameList end] set tempTypeName 1_temp_type dict set typeInfo $mode $serviceName $tempTypeName [list xns $tns definition [list $newTypeName [list type $newTypeName comment {}]]] dict set typeInfo $mode $serviceName $type [list xns $dataTnsName definition [list $dataNodeName [list type $tempTypeName comment {}]]] ## ## Parse the Scheme --gwl ## parseScheme $mode {} $schemeNode $serviceName typeInfo tnsCountVar ## ## All done ## 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::parseScheme # # Description : Parse the types for a service from a Schema into # our internal representation # # Arguments : # mode - The mode, Client or Server # SchemaNode - The top node of the Schema # serviceNode - The DOM node for the service. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. # tnsCountVar -- variable name holding count of tns so far # # Returns : Nothing # # Side-Effects : Defines mode types for the service as specified by the Schema # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 08/06/2006 G.Lester Initial version # 3.2.0 2024-11-01 H.Oehlmann Replaced "format %d" by "%lld" for tns # count larger 2**32 # # ########################################################################### proc ::WS::Utils::parseScheme {mode baseUrl schemaNode serviceName serviceInfoVar tnsCountVar} { ::log::logsubst debug {Entering [info level 0]} upvar 1 $tnsCountVar tnsCount upvar 1 $serviceInfoVar serviceInfo variable currentSchema variable nsList variable options variable unknownRef set currentSchema $schemaNode set tmpTargetNs $::WS::Utils::targetNs foreach attr [$schemaNode attributes] { set value {?} catch {set value [$schemaNode getAttribute $attr]} ::log::logsubst debug {Attribute $attr = $value} } if {[$schemaNode hasAttribute targetNamespace]} { set xns [$schemaNode getAttribute targetNamespace] ::log::logsubst debug {In Parse Scheme, found targetNamespace attribute with {$xns}} set ::WS::Utils::targetNs $xns } else { set xns $::WS::Utils::targetNs } ::log::logsubst debug {@3a {$xns} {[dict get $serviceInfo tnsList url]}} if {![dict exists $serviceInfo tnsList url $xns]} { set tns [format {tns%lld} [incr tnsCount]] dict set serviceInfo targetNamespace $tns $xns dict set serviceInfo tnsList url $xns $tns dict set serviceInfo tnsList tns $tns $tns } else { set tns [dict get $serviceInfo tnsList url $xns] } ::log::logsubst debug {@3 TNS count for $xns is $tnsCount {$tns}} set prevTnsDict [dict get $serviceInfo tnsList tns] dict set serviceInfo tns {} foreach itemList [$schemaNode attributes xmlns:*] { set ns [lindex $itemList 0] set url [$schemaNode getAttribute xmlns:$ns] if {[dict exists $serviceInfo tnsList url $url]} { set tmptns [dict get $serviceInfo tnsList url $url] } else { ## ## Check for hardcoded namespaces ## switch -exact -- $url { http://schemas.xmlsoap.org/wsdl/ { set tmptns w } http://schemas.xmlsoap.org/wsdl/soap/ { set tmptns d } http://www.w3.org/2001/XMLSchema { set tmptns xs } default { set tmptns tns[incr tnsCount] } } dict set serviceInfo tnsList url $url $tmptns } dict set serviceInfo tnsList tns $ns $tmptns } ## ## Process the scheme in multiple passes to handle forward references and extensions ## set pass 1 set lastUnknownRefCount 0 array unset unknownRef while {($pass == 1) || ($lastUnknownRefCount != [array size unknownRef])} { ::log::logsubst debug {Pass $pass over schema} incr pass set lastUnknownRefCount [array size unknownRef] array unset unknownRef foreach element [$schemaNode selectNodes -namespaces $nsList xs:import] { if {[catch {processImport $mode $baseUrl $element $serviceName serviceInfo tnsCount} msg]} { ::log::logsubst notice {Import failed due to: {$msg}. Trace: $::errorInfo} } } foreach element [$schemaNode selectNodes -namespaces $nsList w:import] { if {[catch {processImport $mode $baseUrl $element $serviceName serviceInfo tnsCount} msg]} { ::log::logsubst notice {Import failed due to: {$msg}. Trace: $::errorInfo} } } ::log::logsubst debug {Parsing Element types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:element] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { ::log::logsubst notice {Unhandled error: {$msg}. Trace: $::errorInfo} } } ::log::logsubst debug {Parsing Attribute types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:attribute] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { ::log::logsubst notice {Unhandled error: {$msg}. Trace: $::errorInfo} } } ::log::logsubst debug {Parsing Simple types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:simpleType] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseSimpleType $mode serviceInfo $serviceName $element $tns} msg]} { ::log::logsubst notice {Unhandled error: {$msg}. Trace: $::errorInfo} } } ::log::logsubst debug {Parsing Complex types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:complexType] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseComplexType $mode serviceInfo $serviceName $element $tns} msg]} { ::log::logsubst notice {Unhandled error: {$msg}. Trace: $::errorInfo} } } } set lastUnknownRefCount [array size unknownRef] foreach {unkRef usedByTypeList} [array get unknownRef] { foreach usedByType $usedByTypeList { switch -exact -- $options(StrictMode) { debug - warning { ::log::logsubst $options(StrictMode) {Unknown type reference $unkRef in type $usedByType} } error - default { ::log::logsubst error {Unknown type reference $unkRef in type $usedByType} } } } } if {$lastUnknownRefCount} { switch -exact -- $options(StrictMode) { debug - warning { set ::WS::Utils::targetNs $tmpTargetNs ::log::logsubst $options(StrictMode) {Found $lastUnknownRefCount forward type references: [join [array names unknownRef] {,}]} } error - default { set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode [list WS $mode UNKREFS [list $lastUnknownRefCount]] \ "Found $lastUnknownRefCount forward type references: [join [array names unknownRef] {,}]" } } } ## ## Ok, one more pass to report errors ## set importNodeList [concat \ [$schemaNode selectNodes -namespaces $nsList xs:import] \ [$schemaNode selectNodes -namespaces $nsList w:import] \ ] foreach element $importNodeList { if {[catch {processImport $mode $baseUrl $element $serviceName serviceInfo tnsCount} msg]} { switch -exact -- $options(StrictMode) { debug - warning { ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} ::log::logsubst $options(StrictMode) {\t error was: $msg} } error - default { set errorCode $::errorCode set errorInfo $::errorInfo ::log::logsubst error {Could not parse:\n [$element asXML]} ::log::logsubst error {\t error was: $msg} ::log::logsubst error {\t error info: $errorInfo} ::log::logsubst error {\t error in: [lindex [info level 0] 0]} ::log::logsubst error {\t error code: $errorCode} set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } ::log::logsubst debug {Parsing Element types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:element] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { switch -exact -- $options(StrictMode) { debug - warning { ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} ::log::logsubst $options(StrictMode) {\t error was: $msg} } error - default { set errorCode $::errorCode set errorInfo $::errorInfo ::log::logsubst error {Could not parse:\n [$element asXML]} ::log::logsubst error {\t error was: $msg} ::log::logsubst error {\t error info: $errorInfo} ::log::logsubst error {\t last element: $::elementName} ::log::logsubst error {\t error in: [lindex [info level 0] 0]} ::log::logsubst error {\t error code: $errorCode} set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } ::log::logsubst debug {Parsing Attribute types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:attribute] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { switch -exact -- $options(StrictMode) { debug - warning { ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} ::log::logsubst $options(StrictMode) {\t error was: $msg} } error - default { set errorCode $::errorCode set errorInfo $::errorInfo ::log::logsubst error {Could not parse:\n [$element asXML]} ::log::logsubst error {\t error was: $msg} ::log::logsubst error {\t error info: $errorInfo} ::log::logsubst error {\t error in: [lindex [info level 0] 0]} ::log::logsubst error {\t error code: $errorCode} ::log::logsubst error {\t last element: $::elementName} set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } ::log::logsubst debug {Parsing Simple types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:simpleType] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseSimpleType $mode serviceInfo $serviceName $element $tns} msg]} { switch -exact -- $options(StrictMode) { debug - warning { ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} ::log::logsubst $options(StrictMode) {\t error was: $msg} } error - default { set errorCode $::errorCode set errorInfo $::errorInfo ::log::logsubst error {Could not parse:\n [$element asXML]} ::log::logsubst error {\t error was: $msg} ::log::logsubst error {\t error info: $errorInfo} ::log::logsubst error {\t error in: [lindex [info level 0] 0]} ::log::logsubst error {\t error code: $errorCode} set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } ::log::logsubst debug {Parsing Complex types for $xns as $tns} foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:complexType] { ::log::logsubst debug {\tprocessing $element} if {[catch {parseComplexType $mode serviceInfo $serviceName $element $tns} msg]} { switch -exact -- $options(StrictMode) { debug - warning { ::log::logsubst $options(StrictMode) {Could not parse:\n [$element asXML]} ::log::logsubst $options(StrictMode) {\t error was: $msg} } error - default { set errorCode $::errorCode set errorInfo $::errorInfo ::log::logsubst error {Could not parse:\n [$element asXML]} ::log::logsubst error {\t error was: $msg} ::log::logsubst error {\t error info: $errorInfo} ::log::logsubst error {\t error in: [lindex [info level 0] 0]} ::log::logsubst error {\t error code: $errorCode} set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } set ::WS::Utils::targetNs $tmpTargetNs ::log::logsubst debug {Leaving :WS::Utils::parseScheme $mode $baseUrl $schemaNode $serviceName $serviceInfoVar $tnsCountVar} ::log::logsubst debug {Target NS is now: $::WS::Utils::targetNs} dict set serviceInfo tnsList tns $prevTnsDict } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::processImport # # Description : Parse the bindings for a service from a Schema into our # internal representation # # Arguments : # baseUrl - The url of the importing node # importNode - The node to import # serviceName - The name service. # serviceInfoVar - The name of the dictionary containing the partially # parsed service. # tnsCountVar - The name of the variable containing the count of the # namespace. # # Returns : Nothing # # Side-Effects : Defines mode types for the service as specified by the Schema # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 08/06/2006 G.Lester Initial version # 3.0.0 2020-10-26 H.Oehlmann Added query timeout # 3.1.0 2020-11-06 H.Oehlmann Access namespace variable redirectArray # via variable command # # ########################################################################### proc ::WS::Utils::processImport {mode baseUrl importNode serviceName serviceInfoVar tnsCountVar} { upvar 1 $serviceInfoVar serviceInfo upvar 1 $tnsCountVar tnsCount variable currentSchema variable importedXref variable options variable redirectArray ::log::logsubst debug {Entering [info level 0]} ## ## Get the xml ## set attrName schemaLocation if {![$importNode hasAttribute $attrName]} { set attrName namespace if {![$importNode hasAttribute $attrName]} { ::log::log debug "\t No schema location, existing" return \ -code error \ -errorcode [list WS CLIENT MISSCHLOC $baseUrl] \ "Missing Schema Location in '$baseUrl'" } } set urlTail [$importNode getAttribute $attrName] set url [::uri::resolve $baseUrl $urlTail] ::log::logsubst debug {Including $url} set lastPos [string last / $url] set testUrl [string range $url 0 [expr {$lastPos - 1}]] if { [info exists redirectArray($testUrl)] } { set newUrl $redirectArray($testUrl) append newUrl [string range $url $lastPos end] ::log::logsubst debug {newUrl = $newUrl} set url $newUrl } ::log::logsubst debug {\t Importing {$url}} ## ## Skip "known" namespace ## switch -exact -- $url { http://schemas.xmlsoap.org/wsdl/ - http://schemas.xmlsoap.org/wsdl/soap/ - http://www.w3.org/2001/XMLSchema { return } default { ## ## Do nothing ## } } ## ## Short-circuit infinite loop on inports ## if { [info exists importedXref($mode,$serviceName,$url)] } { ::log::logsubst debug {$mode,$serviceName,$url was already imported: $importedXref($mode,$serviceName,$url)} return } dict lappend serviceInfo imports $url set importedXref($mode,$serviceName,$url) [list $mode $serviceName $tnsCount] set urlScheme [dict get [::uri::split $url] scheme] ::log::logsubst debug {URL Scheme of {$url} is {$urlScheme}} switch -exact -- $urlScheme { file { ::log::logsubst debug {In file processor -- {$urlTail}} set fn [file join $options(includeDirectory) [string range $urlTail 8 end]] set ifd [open $fn r] set xml [read $ifd] close $ifd ProcessImportXml $mode $baseUrl $xml $serviceName $serviceInfoVar $tnsCountVar } https - http { ::log::log debug "In http/https processor" set ncode -1 set token [geturl_followRedirects $url -timeout $options(queryTimeout)] set ncode [::http::ncode $token] ::log::log debug "returned code {$ncode}" set xml [::http::data $token] ::http::cleanup $token if {($ncode != 200) && [string equal $options(includeDirectory) {}]} { return \ -code error \ -errorcode [list WS CLIENT HTTPFAIL $url $ncode] \ "HTTP get of import file failed '$url'" } elseif {($ncode == 200) && ![string equal $options(includeDirectory) {}]} { set fn [file join $options(includeDirectory) [file tail $urlTail]] ::log::logsubst info {Could not access $url -- using $fn} set ifd [open $fn r] set xml [read $ifd] close $ifd } if {[catch {ProcessImportXml $mode $baseUrl $xml $serviceName $serviceInfoVar $tnsCountVar} err]} { ::log::logsubst info {Error during processing of XML: $err} #puts stderr "error Info: $::errorInfo" } else { #puts stderr "import successful" } } default { return \ -code error \ -errorcode [list WS CLIENT UNKURLTYP $url] \ "Unknown URL type '$url'" } } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::parseComplexType # # Description : Parse a complex type declaration from the Schema into our # internal representation # # Arguments : # dictVar - The name of the results dictionary # serviceName - The service name this type belongs to # node - The root node of the type definition # tns - Namespace for this type # # Returns : Nothing # # Side-Effects : Defines mode type as specified by the Schema # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseComplexType {mode dictVar serviceName node tns} { upvar 1 $dictVar results variable currentSchema variable nsList variable unknownRef variable defaultType ::log::logsubst debug {Entering [info level 0]} set isAbstractType false set defaultType string set typeName $tns:[$node getAttribute name] ::log::logsubst debug {Complex Type is $typeName} if {[$node hasAttribute abstract]} { set isAbstractType [$node getAttribute abstract] ::log::logsubst debug {\t Abstract type = $isAbstractType} } #if {[string length [::WS::Utils::GetServiceTypeDef $mode $serviceName $typeName]]} { # ::log::log debug "\t Type $typeName is already defined -- leaving" # return #} set partList {} set nodeFound 0 array set attrArr {} set comment {} set middleNodeList [$node childNodes] foreach middleNode $middleNodeList { set commentNodeList [$middleNode selectNodes -namespaces $nsList xs:annotation] if {[llength $commentNodeList]} { set commentNode [lindex $commentNodeList 0] set comment [string trim [$commentNode asText]] } set middle [$middleNode localName] ::log::logsubst debug {Complex Type is $typeName, middle is $middle} #if {$isAbstractType && [string equal $middle attribute]} { # ## # ## Abstract type, so treat like an element # ## # set middle element #} switch -exact -- $middle { attribute - annotation { ## ## Do nothing ## continue } element { set nodeFound 1 if {[$middleNode hasAttribute ref]} { set partType [$middleNode getAttribute ref] ::log::logsubst debug {\t\t has a ref of {$partType}} if {[catch { set refTypeInfo [split $partType {:}] set partName [lindex $refTypeInfo end] set refNS [lindex $refTypeInfo 0] if {[string equal $refNS {}]} { set partType $tns:$partType } ## ## Convert the reference to the local tns space ## set partType [getQualifiedType $results $partType $tns $middleNode] set refTypeInfo [GetServiceTypeDef $mode $serviceName $partType] set refTypeInfo [dict get $refTypeInfo definition] set tmpList [dict keys $refTypeInfo] if {[llength $tmpList] == 1} { ## ## See if the reference is to an element or a type ## if {![dict exists $results elements $partType]} { ## ## To at type, so redefine the name ## set partName [lindex [dict keys $refTypeInfo] 0] } set partType [getQualifiedType $results [dict get $refTypeInfo $partName type] $tns $middleNode] } lappend partList $partName [list type $partType] }]} { lappend unknownRef($partType) $typeName return \ -code error \ -errorcode [list WS $mode UNKREF [list $typeName $partType]] \ "Unknown forward type reference {$partType} in {$typeName}" } } else { set partName [$middleNode getAttribute name] set partType [string trimright \ [getQualifiedType $results [$middleNode getAttribute type string:string] $tns $middleNode] {?}] 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] } } } extension { #set baseName [lindex [split [$middleNode getAttribute base] {:}] end] set tmp [partList $mode $middleNode $serviceName results $tns] if {[llength $tmp]} { set nodeFound 1 set partList [concat $partList $tmp] } } choice - sequence - all { # set elementList [$middleNode selectNodes -namespaces $nsList xs:element] set partMax [$middleNode getAttribute maxOccurs 1] set tmp [partList $mode $middleNode $serviceName results $tns $partMax] if {[llength $tmp]} { ::log::logsubst debug {\tadding {$tmp} to partslist} set nodeFound 1 set partList [concat $partList $tmp] } elseif {!$nodeFound} { ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $typeName [list base string comment $comment] $tns return } # simpleType { # $middleNode setAttribute name [$node getAttribute name] # parseSimpleType $mode results $serviceName $middleNode $tns # return # } } complexType { $middleNode setAttribute name $typeName parseComplexType $mode results $serviceName $middleNode $tns } simpleContent - complexContent { ## ## Save simple or complex content for abstract types, which ## may have content type with no fields. [Bug 584bfb77] ## Example xml type snippet: ## ## ## ## ## ## ## ... ## ## ## set isComplexContent [expr {$middle eq "complexContent"}] ::log::logsubst debug {isComplexContent = $isComplexContent} ## ## Loop over the components of the type ## foreach child [$middleNode childNodes] { set parent [$child parent] set contentType [$child localName] ::log::logsubst debug {Content Type is {$contentType}} switch -exact -- $contentType { restriction { set nodeFound 1 set restriction $child set element [$child selectNodes -namespaces $nsList xs:attribute] set typeInfoList [list baseType [$restriction getAttribute base]] array unset attrArr foreach attr [$element attributes] { if {[llength $attr] > 1} { set name [lindex $attr 0] set ref [lindex $attr 1]:[lindex $attr 0] } else { set name $attr set ref $attr } 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] set nodeFound 1 } extension { ::log::logsubst debug {Calling partList for $contentType of $typeName} if {[catch {set tmp [partList $mode $child $serviceName results $tns]} msg]} { ::log::logsubst debug {Error in partList {$msg}, errorInfo: $errorInfo} } ::log::logsubst debug {partList for $contentType of $typeName is {$tmp}} if {[llength $tmp] && ![string equal [lindex $tmp 0] {}]} { set nodeFound 1 set partList [concat $partList $tmp] } elseif {[llength $tmp]} { ## ## Found extension, but it is an empty type ## } else { ::log::log debug "Unknown extension!" return } } default { ## ## Placed here to shut up tclchecker ## } } } } restriction { if {!$nodeFound} { parseSimpleType $mode results $serviceName $node $tns return } } default { if {!$nodeFound} { parseElementalType $mode results $serviceName $node $tns return } } } } ::log::logsubst debug {at end of foreach {$typeName} with {$partList}} if {[llength $partList] || $isAbstractType} { #dict set results types $tns:$typeName $partList dict set results types $typeName $partList ::log::logsubst debug {Defining $typeName as '$partList'} ## ## Add complex type definition, if: ## * there is a part list ## * or it is an abstract type announced as complex ## (see xml snipped above about [Bug 584bfb77]) ## -> will set dict typeInfo client $service tns1:envelope { ## definition {} xns tns1 abstract true} ## if { ([llength $partList] && ![string equal [lindex $partList 0] {}]) || ($isAbstractType && [info exists isComplexContent] && $isComplexContent) } { ::WS::Utils::ServiceTypeDef $mode $serviceName $typeName $partList $tns $isAbstractType } else { ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $typeName [list base $defaultType comment {}] $tns } } elseif {!$nodeFound} { #puts "Defined $typeName as simple type" #::WS::Utils::ServiceTypeDef $mode $serviceName $typeName $partList $tns $isAbstractType ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $typeName [list base $defaultType comment {}] $tns } else { set xml [string trim [$node asXML]] return \ -code error \ -errorcode [list WS $mode BADCPXTYPDEF [list $typeName $xml]] \ "Bad complex type definition for '$typeName' :: '$xml'" } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::partList # # Description : Parse the list of parts of a type definition from the Schema into our # internal representation # # Arguments : # dictVar - The name of the results dictionary # servcieName - The service name this type belongs to # node - The root node of the type definition # tns - Namespace for this type # # Returns : Nothing # # Side-Effects : Defines mode type as specified by the Schema # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::partList {mode node serviceName dictVar tns {occurs {}}} { variable currentSchema variable unknownRef variable nsList variable defaultType variable options variable simpleTypes upvar 1 $dictVar results set partList {} set middle [$node localName] ::log::logsubst debug {Entering [info level 0] -- for $middle} switch -exact -- $middle { anyAttribute - attribute { ## ## Do Nothing ## } element { catch { set partName [$node getAttribute name] set partType [string trimright [getQualifiedType $results [$node getAttribute type string] $tns $node] {?}] 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 {}]] } } } extension { set baseName [getQualifiedType $results [$node getAttribute base string] $tns $node] set baseTypeInfo [TypeInfo Client $serviceName $baseName] ::log::logsubst debug {\t base name of extension is {$baseName} with typeinfo {$baseTypeInfo}} if {[lindex $baseTypeInfo 0]} { if {[catch {::WS::Utils::GetServiceTypeDef Client $serviceName $baseName}]} { set baseQuery [format {child::*[attribute::name='%s']} $baseName] set baseNode [$currentSchema selectNodes $baseQuery] #puts "$baseQuery gave {$baseNode}" set baseNodeType [$baseNode localName] switch -exact -- $baseNodeType { complexType { parseComplexType $mode results $serviceName $baseNode $tns } element { parseElementalType $mode results $serviceName $baseNode $tns } simpleType { parseSimpleType $mode results $serviceName $baseNode $tns } default { ## ## Placed here to shut up tclchecker ## } } } set baseInfo [GetServiceTypeDef $mode $serviceName $baseName] ::log::logsubst debug {\t baseInfo is {$baseInfo}} if {[llength $baseInfo] == 0} { ::log::logsubst debug {\t Unknown reference '$baseName'} set unknownRef($baseName) 1 return } catch {set partList [concat $partList [dict get $baseInfo definition]]} } else { ::log::logsubst debug {\t Simple type} } foreach elementNode [$node childNodes] { set tmp [partList $mode $elementNode $serviceName results $tns] if {[llength $tmp]} { set partList [concat $partList $tmp] } } } choice - sequence - all { set elementList [$node selectNodes -namespaces $nsList xs:element] set elementsFound 0 ::log::logsubst debug {\telement list is {$elementList}} foreach element $elementList { ::log::logsubst debug {\t\tprocessing $element ([$element nodeName])} set comment {} set additional_defininition_elements {} if {[catch { set elementsFound 1 set attrName name set isRef 0 if {![$element hasAttribute name]} { set attrName ref set isRef 1 } set partName [$element getAttribute $attrName] if {$isRef} { set partType {} set partTypeInfo {} set partType [string trimright [getQualifiedType $results $partName $tns] {?}] set partTypeInfo [::WS::Utils::GetServiceTypeDef $mode $serviceName $partType] set partName [lindex [split $partName {:}] end] ::log::logsubst 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] } ::log::logsubst debug {\t\t\t part name is {$partName} type is {$partType}} } else { ## ## See if really a complex definition ## if {[$element hasChildNodes]} { set isComplex 0; set isSimple 0 foreach child [$element childNodes] { switch -exact -- [$child localName] { annotation {set comment [string trim [$child asText]]} simpleType {set isSimple 1} default {set isComplex 1} } } if {$isComplex} { set partType $partName parseComplexType $mode results $serviceName $element $tns } elseif {$isSimple} { set partType $partName parseComplexType $mode results $serviceName $element $tns if {[info exists simpleTypes($mode,$serviceName,$tns:$partName)]} { set additional_defininition_elements $simpleTypes($mode,$serviceName,$tns:$partName) set partType [dict get $additional_defininition_elements baseType] } } else { set partType [getQualifiedType $results [$element getAttribute type string] $tns $element] } } else { set partType [getQualifiedType $results [$element getAttribute type string] $tns $element] } } if {[string length $occurs]} { set partMax [$element getAttribute maxOccurs 1] if {$partMax < $occurs} { set partMax $occurs } } else { 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] } } msg]} { ::log::logsubst error {\tError processing {$msg} for [$element asXML]} if {$isRef} { ::log::log error "\t\t Was a reference. Additionally information is:" ::log::logsubst error {\t\t\t part name is {$partName} type is {$partType} with {$partTypeInfo}} } } } if {!$elementsFound} { set defaultType $options(anyType) return } } complexContent { set contentType [[$node childNodes] localName] switch -exact -- $contentType { restriction { set restriction [$node selectNodes -namespaces $nsList xs:restriction] set element [$node selectNodes -namespaces $nsList xs:restriction/xs:attribute] set typeInfoList [list baseType [$restriction getAttribute base]] array unset attrArr foreach attr [$element attributes] { if {[llength $attr] > 1} { set name [lindex $attr 0] set ref [lindex $attr 1]:[lindex $attr 0] } else { set name $attr set ref $attr } 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]] } extension { set extension [$node selectNodes -namespaces $nsList xs:extension] set partList [partList $mode $extension $serviceName results $tns] } default { ## ## Placed here to shut up tclchecker ## } } } simpleContent { foreach elementNode [$node childNodes] { set tmp [partList $mode $elementNode $serviceName results $tns] if {[llength $tmp]} { set partList [concat $partList $tmp] } } } restriction { parseSimpleType $mode results $serviceName $node $tns return } default { parseElementalType $mode results $serviceName $node $tns return } } if {[llength $partList] == 0} { set partList {{}} } return $partList } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::parseElementalType # # Description : Parse an elemental type declaration from the Schema into our # internal representation # # Arguments : # dictVar - The name of the results dictionary # servcieName - The service name this type belongs to # node - The root node of the type definition # tns - Namespace for this type # # Returns : Nothing # # Side-Effects : Defines mode type as specified by the Schema # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseElementalType {mode dictVar serviceName node tns} { upvar 1 $dictVar results variable importedXref variable nsList variable unknownRef ::log::logsubst debug {Entering [info level 0]} set attributeName name if {![$node hasAttribute $attributeName]} { set attributeName ref } set typeName [$node getAttribute $attributeName] if {[string length [::WS::Utils::GetServiceTypeDef $mode $serviceName $tns:$typeName]]} { ::log::logsubst debug {\t Type $tns:$typeName is already defined -- leaving} return } set typeType "" if {[$node hasAttribute type]} { set typeType [getQualifiedType $results [$node getAttribute type string] $tns $node] } ::log::logsubst debug {Elemental Type is $typeName} set partList {} set partType {} set isAbstractType false if {[$node hasAttribute abstract]} { set isAbstractType [$node getAttribute abstract] ::log::logsubst debug {\t Abstract type = $isAbstractType} } set elements [$node selectNodes -namespaces $nsList xs:complexType/xs:sequence/xs:element] ::log::logsubst debug {\t element list is {$elements} partList {$partList}} foreach element $elements { set ::elementName [$element asXML] ::log::logsubst debug {\t\t Processing element {[$element nodeName]}} set elementsFound 1 set typeAttribute "" if {[$element hasAttribute ref]} { set partType [$element getAttribute ref] ::log::logsubst debug {\t\t has a ref of {$partType}} if {[catch { set refTypeInfo [split $partType {:}] set partName [lindex $refTypeInfo end] set refNS [lindex $refTypeInfo 0] if {[string equal $refNS {}]} { set partType $tns:$partType } ## ## Convert the reference to the local tns space ## set partType [getQualifiedType $results $partType $tns] set refTypeInfo [GetServiceTypeDef $mode $serviceName $partType] log::logsubst debug {looking up ref {$partType} got {$refTypeInfo}} if {![llength $refTypeInfo]} { error "lookup failed" } if {[dict exists $refTypeInfo definition]} { set refTypeInfo [dict get $refTypeInfo definition] } set tmpList [dict keys $refTypeInfo] if {[llength $tmpList] == 1} { ## ## See if the reference is to an element or a type ## if {![dict exists $results elements $partType]} { ## ## To at type, so redefine the name ## set partName [lindex [dict keys $refTypeInfo] 0] } if {[dict exists $refTypeInfo $partName type]} { set partType [getQualifiedType $results [dict get $refTypeInfo $partName type] $tns] } else { ## ## Not a simple element, so point type to type of same name as element ## set partType [getQualifiedType $results $partName $tns] } } } msg]} { lappend unknownRef($partType) $typeName log::logsubst debug {Unknown ref {$partType,$typeName} error: {$msg} trace: $::errorInfo} return \ -code error \ -errorcode [list WS $mode UNKREF [list $typeName $partType]] \ "Unknown forward type reference {$partType} in {$typeName}" } } else { ::log::logsubst debug {\t\t\t has no ref has {[$element attributes]}} set childList [$element selectNodes -namespaces $nsList xs:complexType/xs:sequence/xs:element] ::log::logsubst debug {\t\t\ has no ref has [llength $childList]} if {[llength $childList]} { ## ## Element defines another element layer ## set partName [$element getAttribute name] set partType [getQualifiedType $results $partName $tns $element] parseElementalType $mode results $serviceName $element $tns } else { set partName [$element getAttribute name] if {[$element hasAttribute type]} { set partType [getQualifiedType $results [$element getAttribute type] $tns $element] } else { set partType xs:string } } } set partMax [$element getAttribute maxOccurs -1] ::log::logsubst debug {\t\t\t part is {$partName} {$partType} {$partMax}} if {[string equal $partMax -1]} { 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 {}] } } if {[llength $elements] == 0} { # # Validate this is not really a complex or simple type # set childList [$node childNodes] foreach childNode $childList { if {[catch {$childNode setAttribute name $typeName}]} { continue } set childNodeType [$childNode localName] switch -exact -- $childNodeType { complexType { parseComplexType $mode results $serviceName $childNode $tns return } element { parseElementalType $mode results $serviceName $childNode $tns return } simpleType { parseSimpleType $mode results $serviceName $childNode $tns return } default { ## ## Placed here to shut up tclchecker ## } } } # have an element with a type only, so do the work here if {[$node hasAttribute type]} { set partType [getQualifiedType $results [$node getAttribute type] $tns $node] } elseif {[$node hasAttribute base]} { set partType [getQualifiedType $results [$node getAttribute base] $tns $node] } else { set partType xs:string } set partMax [$node getAttribute maxOccurs 1] if {$partMax <= 1} { ## ## See if this is just a restriction on a simple type ## if {([lindex [TypeInfo $mode $serviceName $partType] 0] == 0) && [string equal $tns:$typeName $partType]} { return } else { lappend partList $typeName [list type $partType comment {}] } } else { lappend partList $typeName [list type [string trimright ${partType} {()?}]() comment {}] } } if {[llength $partList]} { ::WS::Utils::ServiceTypeDef $mode $serviceName $tns:$typeName $partList $tns $isAbstractType } else { if {![dict exists $results types $tns:$typeName]} { set partList [list base string comment {} xns $tns] ::WS::Utils::ServiceSimpleTypeDef $mode $serviceName $tns:$typeName $partList $tns dict set results simpletypes $tns:$typeName $partList } } dict set results elements $tns:$typeName 1 ::log::log debug "\t returning" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::parseSimpleType # # Description : Parse a simple type declaration from the Schema into our # internal representation # # Arguments : # dictVar - The name of the results dictionary # servcieName - The service name this type belongs to # node - The root node of the type definition # tns - Namespace for this type # # Returns : Nothing # # Side-Effects : Defines mode type as specified by the Schema # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::parseSimpleType {mode dictVar serviceName node tns} { upvar 1 $dictVar results variable nsList ::log::logsubst debug {Entering [info level 0]} set typeName [$node getAttribute name] if {$typeName in {SAP_VALID_FROM}} { set foo 1 } set isList no ::log::logsubst debug {Simple Type is $typeName} if {[string length [::WS::Utils::GetServiceTypeDef $mode $serviceName $tns:$typeName]]} { ::log::logsubst debug {\t Type $tns:$typeName is already defined -- leaving} return } #puts "Simple Type is $typeName" set restrictionNode [$node selectNodes -namespaces $nsList xs:restriction] if {[string equal $restrictionNode {}]} { set restrictionNode [$node selectNodes -namespaces $nsList xs:simpleType/xs:restriction] } if {[string equal $restrictionNode {}]} { set restrictionNode [$node selectNodes -namespaces $nsList xs:list/xs:simpleType/xs:restriction] } if {[string equal $restrictionNode {}]} { set restrictionNode [$node selectNodes -namespaces $nsList xs:list] set isList yes } if {[string equal $restrictionNode {}]} { set xml [string trim [$node asXML]] return \ -code error \ -errorcode [list WS $mode BADSMPTYPDEF [list $typeName $xml]] \ "Bad simple type definition for '$typeName' :: \n'$xml'" } if {$isList} { set baseType [lindex [split [$restrictionNode getAttribute itemType] {:}] end] } else { set baseType [lindex [split [$restrictionNode getAttribute base] {:}] end] } set partList [list baseType $baseType xns $tns isList $isList] set enumList {} foreach item [$restrictionNode childNodes] { set itemName [$item localName] set value [$item getAttribute value] #puts "\t Item {$itemName} = {$value}" if {[string equal $itemName {enumeration}]} { lappend enumList $value } else { lappend partList $itemName $value } if {[$item hasAttribute fixed]} { lappend partList fixed [$item getAttribute fixed] } } if {[llength $enumList]} { lappend partList enumeration $enumList } if {![dict exists $results types $tns:$typeName]} { ServiceSimpleTypeDef $mode $serviceName $tns:$typeName $partList $tns dict set results simpletypes $tns:$typeName $partList } else { ::log::logsubst debug {\t type already exists as $tns:$typeName} } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::checkTags # # Description : Recursivly check the tags and values inside the tags # # Arguments : # mode - Client/Server # serviceName - The service name # currNode - The node to process # typeName - The type name of the node # # Returns : 1 if ok, 0 otherwise # # Side-Effects : # ::errorCode - contains validation failure information if validation # failed. # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Arnulf Wiedemann # #>>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 08/13/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to handle qualified XML # 3.2.0 2024-11-01 H.Oehlmann Fixed numeric check of # fieldInfoArr(maxOccurs) # ########################################################################### proc ::WS::Utils::checkTags {mode serviceName currNode typeName} { ## ## Assume success ## set result 1 ## ## Get the type information ## set typeInfoList [TypeInfo $mode $serviceName $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} { ## ## Is complex ## array set fieldInfoArr {} ## ## Build array of what is present ## foreach node [$currNode childNodes] { set localName [$node localName] lappend fieldInfoArr($localName) $node } ## ## Walk through each field and validate the information ## foreach {field fieldDef} [dict get $typeInfo definition] { array unset fieldInfoArr set fieldInfoArr(minOccurs) 0 array set fieldInfoArr $fieldDef if {$fieldInfoArr(minOccurs) && ![info exists fieldInfoArr($field)]} { ## ## Fields was required but is missing ## set ::errorCode [list WS CHECK MISSREQFLD [list $typeName $field]] set result 0 } elseif {$fieldInfoArr(minOccurs) && ($fieldInfoArr(minOccurs) > [llength $fieldInfoArr($field)])} { ## ## Fields was required and present, but not enough times ## set ::errorCode [list WS CHECK MINOCCUR [list $type $field]] set result 0 } elseif {[info exists fieldInfoArr(maxOccurs)] && [string is entier $fieldInfoArr(maxOccurs)] && ($fieldInfoArr(maxOccurs) < [llength $fieldInfoArr($field)])} { ## ## Fields was required and present, but too many times ## set ::errorCode [list WS CHECK MAXOCCUR [list $typeName $field]] set result 0 } elseif {[info exists fieldInfoArr($field)]} { foreach node $fieldInfoArr($field) { set result [checkTags $mode $serviceName $node $fieldInfoArr(type)] if {!$result} { break } } } if {!$result} { break } } } else { ## ## Get the value ## set value [$currNode asText] set result [checkValue $mode $serviceName $baseTypeName $value] } return $result } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::checkValue # # Description : Check a Value between tags of a XML document against the # type in the XML schema description # # Arguments : # mode - Client/Server # serviceName - The name of the service # type - The type to check # value - The value to check # # Returns : 1 if ok or 0 if checking not ok # # Side-Effects : # ::errorCode - contains validation failure information if validation # failed. # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Arnulf Wiedemann # #>>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 08/14/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to handle qualified XML # ########################################################################### proc ::WS::Utils::checkValue {mode serviceName type value} { set result 0 array set typeInfos { minLength 0 maxLength -1 fixed false } # returns indexes type, xns, ... array set typeInfos [GetServiceTypeDef $mode $serviceName $type] foreach {var value} [array get typeInfos] { set $var $value } set result 1 if {$minLength >= 0 && [string length $value] < $minLength} { set ::errorCode [list WS CHECK VALUE_TO_SHORT [list $type $value $minLength $typeInfo]] set result 0 } elseif {$maxLength >= 0 && [string length $value] > $maxLength} { set ::errorCode [list WS CHECK VALUE_TO_LONG [list $type $value $maxLength $typeInfo]] set result 0 } elseif {[info exists enumeration] && ([lsearch -exact $enumeration $value] == -1)} { set errorCode [list WS CHECK VALUE_NOT_IN_ENUMERATION [list $type $value $enumeration $typeInfo]] set result 0 } elseif {[info exists pattern] && (![regexp -- $pattern $value])} { set errorCode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $type $value $pattern $typeInfo]] set result 0 } return $result } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::buildTags # # Description : Recursivly build the tags by checking the values to put # inside the tags and append to the dom tree resultTree # # Arguments : # mode - Client/Server # serviceName - The service name # typeName - The type for the tag # valueInfos - The dictionary of the values # doc - The DOM Document # currentNode - Node to append values to # # Returns : nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Arnulf Wiedemann # #>>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 08/13/2006 A.Wiedemann Initial version # 2 08/18/2006 G.Lester Generalized to generate qualified XML # 3.2.0 2024-11-01 H.Oehlmann Fixed numeric check of # fieldInfoArr(maxOccurs) # ########################################################################### proc ::WS::Utils::buildTags {mode serviceName typeName valueInfos doc currentNode} { upvar 1 $valueInfos values ## ## Get the type information ## set baseTypeName [string trimright $typeName {()?}] set typeInfo [GetServiceTypeDef $mode $serviceName $baseTypeName] set typeName [string trimright $typeName {?}] set xns [dict get $typeInfo $mode $serviceName $typeName xns] foreach {field fieldDef} [dict get $typeInfo definition] { ## ## Get info about this field and its type ## 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 isComplex [lindex $typeInfoList 0] set isArray [lindex $typeInfoList 1] if {[dict exists $valueInfos $field]} { if {$isArray} { set valueList [dict get $valueInfos $field] } else { set valueList [list [dict get $valueInfos $field]] } set valueListLenght [llength $valueList] } else { set valueListLenght -1 } if {$fieldInfoArr(minOccurs) && ![dict exists $valueInfos $field]} { ## ## Fields was required but is missing ## return \ -errorcode [list WS CHECK MISSREQFLD [list $type $field]] \ "Field '$field' of type '$typeName' was required but is missing" } elseif {$fieldInfoArr(minOccurs) && ($fieldInfoArr(minOccurs) > $valueListLenght)} { ## ## Fields was required and present, but not enough times ## set minOccurs $fieldInfoArr(minOccurs) return \ -errorcode [list WS CHECK MINOCCUR [list $type $field $minOccurs $valueListLenght]] \ "Field '$field' of type '$typeName' was required to occur $minOccurs time(s) but only occured $valueListLenght time(s)" } elseif {[info exists fieldInfoArr(maxOccurs)] && [string is entier $fieldInfoArr(maxOccurs)] && ($fieldInfoArr(maxOccurs) < $valueListLenght)} { ## ## Fields was required and present, but too many times ## set minOccurs $fieldInfoArr(maxOccurs) return \ -errorcode [list WS CHECK MAXOCCUR [list $typeName $field]] \ "Field '$field' of type '$typeName' could only occur $minOccurs time(s) but occured $valueListLenght time(s)" } elseif {[dict exists $valueInfos $field]} { foreach value $valueList { $currentNode appendChild [$doc createElement $xns:$field retNode] if {$isComplex} { buildTags $mode $serviceName $fieldBaseType $value $doc $retNode } else { if {[info exists fieldInfoArr(enumeration)] && [info exists fieldInfoArr(fixed)] && $fieldInfoArr(fixed)} { set value [lindex $fieldInfoArr(enumeration) 0] } if {[checkValue $mode $serviceName $fieldBaseType $value]} { $retNode appendChild [$doc createTextNode $value] } else { set msg "Field '$field' of type '$typeName' " switch -exact -- [lindex $::errorCode 2] { VALUE_TO_SHORT { append msg "value required to be $fieldInfoArr(minLength) long but is only [string length $value] long" } VALUE_TO_LONG { append msg "value allowed to be only $fieldInfoArr(minLength) long but is [string length $value] long" } VALUE_NOT_IN_ENUMERATION { append msg "value '$value' not in ([join $fieldInfoArr(enumeration) {, }])" } VALUE_NOT_MATCHES_PATTERN { append msg "value '$value' does not match pattern: $fieldInfoArr(pattern)" } default { ## ## Placed here to shut up tclchecker ## } } return \ -errorcode $::errorCode \ $msg } } } } } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::getQualifiedType # # Description : Get a qualified type name from a local reference. # Thus return : which is in the global type list. # The is adjusted to point to the global type list. # # Arguments : # serviceInfo - service information dictionary # type - type to get local qualified type on # tns - current namespace # node - optional XML item to search for xmlns:* attribute # # Returns : nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald Lester # #>>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 02/24/2011 G. Lester Initial version # 2.6.2 2018-09-22 C. Werner Added parameter "node" to first search a # namespace attribute "xmlns:yprefix>" in the # current node. # ########################################################################### proc ::WS::Utils::getQualifiedType {serviceInfo type tns {node {}}} { set typePartsList [split $type {:}] if {[llength $typePartsList] == 1} { # No namespace prefix given - use current prefix set result $tns:$type } else { lassign $typePartsList tmpTns tmpType # Search the namespace attribute in the current node for a node-local prefix. # Aim is to translate the node-local prefix to a global namespace prefix. # Example: # # # Variable setup: # - type: x1:ArrayOfSomething # - tmpTns: x1 # - tmpType: ArrayOfSomething # Return value: # - # - plus ":ArrayOfSomething" if {$node ne {}} { set attr xmlns:$tmpTns if {[$node hasAttribute $attr]} { # There is a node-local attribute (Example: xmlns:x1) giving the node namespace set xmlns [$node getAttribute $attr] if {[dict exists $serviceInfo tnsList url $xmlns]} { set result [dict get $serviceInfo tnsList url $xmlns]:$tmpType ::log::logsubst debug {Got global qualified type '$result' from node-local qualified namespace '$xmlns'} return $result } else { # The node namespace (Ex: http://foo.org/bar) was not found as global prefix. # Thus, the type is refused. # HaO 2018-11-05 Opinion: # Continuing here is IMHO not an option, as the prefix (Ex: x1) might have a # different namespace on the global level which would lead to a misassignment. # # One day, we may support cascading namespace prefixes. Then, we may define # the namespace here set errMsg "Node local namespace URI '$xmlns' not found for type: '$type'" ::log::log error $errMsg return -code error $errMsg } # fail later if namespace not found } } if {[dict exists $serviceInfo tnsList tns $tmpTns]} { set result [dict get $serviceInfo tnsList tns $tmpTns]:$tmpType } elseif {[dict exists $serviceInfo types $type]} { set result $type } else { ::log::log error $serviceInfo ::log::logsubst error {Could not find tns '$tmpTns' in '[dict get $serviceInfo tnsList tns]' for type {$type}} return -code error "Namespace prefix of type '$type' not found." } } return $result } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::GenerateTemplateDict # # Description : Generate a template dictionary object for # a given type. # # Arguments : # mode - The mode, Client or Server # serviceName - The service name the type is defined in # type - The name of the type # arraySize - Number of elements to generate in an array. Default is 2 # # Returns : A dictionary object for a given type. If any circular references # exist, they will have the value of <** Circular Reference **> # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # # ########################################################################### proc ::WS::Utils::GenerateTemplateDict {mode serviceName type {arraySize 2}} { variable generatedTypes ::log::logsubst debug {Entering [info level 0]} unset -nocomplain -- generatedTypes set result [_generateTemplateDict $mode $serviceName $type $arraySize] unset -nocomplain -- generatedTypes ::log::logsubst debug {Leaving [info level 0] with {$result}} return $result } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::_generateTemplateDict # # Description : Private procedure to generate a template dictionary. This needs # setup work done by ::WS::Utils::GnerateTemplateDict # # Arguments : # mode - The mode, Client or Server # serviceName - The service name the type is defined in # type - The name of the type # arraySize - Number of elements to generate in an array. # # Returns : A dictionary object for a given type. If any circular references # exist, they will have the value of <** Circular Reference **> # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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 07/06/2006 G.Lester Initial version # 3.2.0 2024-11-01 H.Oehlmann Replaced "format %d" by "%lld" for array # element log larger 2**32 # # ########################################################################### proc ::WS::Utils::_generateTemplateDict {mode serviceName type arraySize {xns {}}} { variable typeInfo variable mutableTypeInfo variable options variable generatedTypes ::log::logsubst debug {Entering [info level 0]} set results {} ## ## Check for circular reference ## if {[info exists generatedTypes([list $mode $serviceName $type])]} { set results {<** Circular Reference **>} ::log::logsubst debug {Leaving [info level 0] with {$results}} 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] } ::log::logsubst debug {\t type def = {$typeDefInfo}} set xns [dict get $typeDefInfo xns] ## ## Check for mutable type ## if {[info exists mutableTypeInfo([list $mode $serviceName $type])]} { set results {<** Mutable Type **>} ::log::logsubst debug {Leaving [info level 0] with {$results}} return $results } if {![dict exists $typeDefInfo definition]} { ## This is a simple type, simulate a type definition... if {![dict exists $typeDefInfo type]} { if {[dict exists $typeDefInfo baseType]} { dict set typeDefInfo type [dict get $typeDefInfo baseType] } else { dict set typeDefInfo type xs:string } } set typeDefInfo [dict create definition [dict create $type $typeDefInfo]] } set partsList [dict keys [dict get $typeDefInfo definition]] ::log::logsubst debug {\t partsList is {$partsList}} foreach partName $partsList { 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] ::log::logsubst debug {\tpartName $partName partType $partType xns $xns typeInfoList $typeInfoList} switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## set msg {Simple non-array} ## Is there an enumenration? foreach attr {enumeration type comment} { if {[dict exists $typeDefInfo definition $partName $attr]} { set value [dict get $typeDefInfo definition $partName $attr] set value [string map {\{ ( \} ) \" '} $value] append msg ", $attr=\{$value\}" } } dict set results $partName $msg } {0 1} { ## ## Simple array ## set tmp {} for {set row 1} {$row <= $arraySize} {incr row} { lappend tmp [format {Simple array element #%lld} $row] } dict set results $partName $tmp } {1 0} { ## ## Non-simple non-array ## dict set results $partName [_generateTemplateDict $mode $serviceName $partType $arraySize $xns] } {1 1} { ## ## Non-simple array ## set partType [string trimright $partType {()}] set tmp [list] set isRecursive [info exists generatedTypes([list $mode $serviceName $partType])] for {set row 1} {$row <= $arraySize} {incr row} { if {$isRecursive} { lappend tmp $partName {<** Circular Reference **>} } else { unset -nocomplain -- generatedTypes([list $mode $serviceName $partType]) lappend tmp [_generateTemplateDict $mode $serviceName $partType $arraySize $xns] } } dict set results $partName $tmp } default { ## ## Placed here to shut up tclchecker ## } } } ::log::logsubst debug {Leaving [info level 0] with {$results}} return $results } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::setAttr # # Description : Set attributes on a DOM node # # Arguments : # node - node to set attributes on # attrList - List of attribute name value pairs # # Returns : nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald Lester # #>>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 02/24/2011 G. Lester Initial version # ########################################################################### proc ::WS::Utils::setAttr {node attrList} { $node setAttribute {*}$attrList } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::geturl_followRedirects # # Description : fetch via http following redirects. # May not be used as asynchronous call with -command option. # # Arguments : # url - target document url # args - additional argument list to http::geturl call # # Returns : http package token of received data # # Side-Effects : Save final url in redirectArray to forward info to # procedure "processImport". # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald Lester # #>>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 02/24/2011 G. Lester Initial version # 2.3.10 11/09/2015 H. Oehlmann Allow only 5 redirects (loop protection) # 3.1.0 2020-11-06 H.Oehlmann Access namespace variable redirectArray # via variable command # ########################################################################### proc ::WS::Utils::geturl_followRedirects {url args} { variable redirectArray ::log::logsubst debug {[info level 0]} set initialUrl $url set finalUrl $url array set URI [::uri::split $url] ;# Need host info from here for {set loop 1} {$loop <=5} {incr loop} { ::log::logsubst info {[concat [list ::http::geturl $url] $args]} set token [http::geturl $url {*}$args] set ncode [::http::ncode $token] ::log::logsubst info {ncode = $ncode} if {![string match {30[12378]} $ncode]} { ::log::logsubst debug {initialUrl = $initialUrl, finalUrl = $finalUrl} if {![string equal $finalUrl {}]} { ::log::log debug "Getting initial URL directory" set lastPos [string last / $initialUrl] set initialUrlDir [string range $initialUrl 0 [expr {$lastPos - 1}]] set lastPos [string last / $finalUrl] set finalUrlDir [string range $finalUrl 0 [expr {$lastPos - 1}]] ::log::logsubst debug {initialUrlDir = $initialUrlDir, finalUrlDir = $finalUrlDir} set 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)]} { ::log::log debug "Redirect http code without Location" return $token } array set uri [::uri::split $meta(Location)] unset meta array unset meta ::http::cleanup $token if { $uri(host) eq "" } { set uri(host) $URI(host) } # problem w/ relative versus absolute paths set url [eval ::uri::join [array get uri]] ::log::logsubst debug {url = $url} set finalUrl $url } # > 5 redirects reached -> exit with error return -errorcode [list WS CLIENT REDIRECTLIMIT $url] \ -code error "http redirect limit exceeded for $url" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::geturl_fetchbody # # Description : fetch via http following redirects and return data or error # # Arguments : # ?-codeok list? - list of acceptable http codes. # If not given, 200 is used # ?-codevar varname ? - Uplevel variable name to return current code # value. # ?-bodyalwaysok bool? - If a body is delivered any ncode is ok # url - target document url # args - additional argument list to http::geturl call # # Returns : fetched data # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Harald Oehlmann # #>>END PRIVATE<< # # Maintenance History - as this file is modified, please be sure that you # update this segment of the file header block by # adding a complete entry at the bottom of the list. # # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 11/08/2015 H.Oehlmann Initial version # 3.0.0 2020-10-26 H.Oehlmann Honor timeout and eof status # ########################################################################### proc ::WS::Utils::geturl_fetchbody {args} { set codeOkList {200} set codeVar "" set bodyAlwaysOk 0 ::log::logsubst info {Entering [info level 0]} if {[lindex $args 0] eq "-codeok"} { set codeOkList [lindex $args 1] set args [lrange $args 2 end] } if {[lindex $args 0] eq "-codevar"} { set codeVar [lindex $args 1] set args [lrange $args 2 end] } if {[lindex $args 0] eq "-bodyalwaysok"} { set bodyAlwaysOk [lindex $args 1] set args [lrange $args 2 end] } set token [eval ::WS::Utils::geturl_followRedirects $args] switch -exact -- [::http::status $token] { ok { if {[::http::size $token] == 0} { ::log::log debug "\tHTTP error: no data" ::http::cleanup $token return -errorcode [list WS CLIENT NODATA [lindex $args 0]]\ -code error "HTTP failure socket closed" } if {$codeVar ne ""} { upvar 1 $codeVar ncode } set ncode [::http::ncode $token] set body [::http::data $token] ::http::cleanup $token if {$bodyAlwaysOk && $body ne "" || $ncode in $codeOkList } { # >> Fetch ok ::log::logsubst debug {\tReceived: $body} return $body } ::log::logsubst debug {\tHTTP error: Wrong code $ncode or no data} return -code error -errorcode [list WS CLIENT HTTPERROR $ncode]\ "HTTP failure code $ncode" } eof { set error "socket closed by server" } error { set error [::http::error $token] } timeout { set error "timeout" } default { set error "unknown http::status: [::http::status $token]" } } ::log::logsubst debug {\tHTTP error [array get $token]} ::http::cleanup $token return -errorcode [list WS CLIENT HTTPERROR $error]\ -code error "HTTP error: $error" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::check_version # # Description : for a particular version code, check if the requested version # is allowd # # Arguments : # version - The specified version for the type, proc, etc # requestedVersion - The version being requested by the user # # Returns : boolean - true if allowed, false if not # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Jonathan Cone # #>>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 10/23/2018 J. Cone Initial version # ########################################################################### proc ::WS::Utils::check_version {version requestedVersion} { if {$version eq {} || $requestedVersion eq {}} { return 1 } if {[regexp {^(\d+)([+-])?(\d+)?$} $version _ start modifier end]} { if {$start ne {} && $end ne {}} { return [expr {$requestedVersion >= $start && $requestedVersion <= $end}] } elseif {$start ne {}} { switch -- $modifier { "+" { return [expr {$requestedVersion >= $start}] } "-" { return [expr {$requestedVersion <= $start}] } "" { return [expr {$requestedVersion == $start}] } } } } return 0 } tclws-3.5.0/Wub.tcl000064400000000000000000000510051471124032000134630ustar00nobodynobody##***************************************************************************## ## ## ## This is a stub and needs to be filled in!!!! ## ## ## ##***************************************************************************## ############################################################################### ## ## ## Copyright (c) 2008, Gerald W. Lester ## ## All rights reserved. ## ## ## ## Redistribution and use in source and binary forms, with or without ## ## modification, are permitted provided that the following conditions ## ## are met: ## ## ## ## * Redistributions of source code must retain the above copyright ## ## notice, this list of conditions and the following disclaimer. ## ## * Redistributions in binary form must reproduce the above ## ## copyright notice, this list of conditions and the following ## ## disclaimer in the documentation and/or other materials provided ## ## with the distribution. ## ## * Neither the name of the Visiprise Software, Inc nor the names ## ## of its contributors may be used to endorse or promote products ## ## derived from this software without specific prior written ## ## permission. ## ## ## ## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ## ## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ## ## COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ## ## INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ## ## BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; ## ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ## ## CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ## ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ## ## ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ## ## POSSIBILITY OF SUCH DAMAGE. ## ## ## ############################################################################### package require Tcl 8.4- # WS::Utils usable here for dict? if {![llength [info command dict]]} { package require dict } package require uri package require base64 package require html package provide WS::Wub 2.5.0 namespace eval ::WS::Wub { array set portInfo {} set portList [list] set forever {} } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Wub::AddHandler # # Description : Register a handler for a url on a port. # # Arguments : # port -- The port to register the callback on # url -- The URL to register the callback for # callback -- The callback prefix, two additionally arguments are lappended # the callback: (1) the socket (2) the null string # # Returns : Nothing # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : ::WS::Wub::Listen must have been called for the port # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Wub::AddHandler {port url callback} { variable portInfo dict set portInfo($port,handlers) $url $callback return; } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Wub::AddHandlerAllPorts # # Description : Register a handler for a url on all "defined" ports. # # Arguments : # url -- List of three elements: # callback -- The callback prefix, two additionally argumens are lappended # the callback: (1) the socket (2) the null string # # Returns : Nothing # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : ::WS::Wub::Listen must have been called for the port # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Wub::AddHandlerAllPorts {url callback} { variable portList foreach port $portList { AddHandler $port $url $callback } return; } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Wub::Listen # # Description : Instruct the module to listen on a Port, security information. # # Arguments : # port -- Port number to listen on # certfile -- Name of the certificate file # keyfile -- Name of the key file # userpwds -- A list of username and passwords # realm -- The security realm # logger -- A logging routines for errors # # Returns : Nothing # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : ::WS::Wub::Listen must have been called for the port # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Wub::Listen {port {certfile {}} {keyfile {}} {userpwds {}} {realm {}} {logger {::WS::Wub::logger}}} { variable portInfo variable portList lappend portList $port foreach key {port certfile keyfile userpwds realm logger} { set portInfo($port,$key) [set $key] } set portInfo($port,$handlers) {} foreach up $userpwds { lappend portInfo($port,auths) [base64::encode $up] } if {$certfile ne ""} { package require tls ::tls::init \ -certfile $certfile \ -keyfile $keyfile \ -ssl2 1 \ -ssl3 1 \ -tls1 0 \ -require 0 \ -request 0 ::tls::socket -server [list ::WS::Wub::accept $port] $port } else { socket -server [list ::WS::Wub::accept $port] $port } } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Wub::ReturnData # # Description : Store the information to be returned. # # Arguments : # socket -- Socket data is for # type -- Mime type of data # data -- Data # code -- Status code # # Returns : Nothing # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : A callback on the socket should be pending # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Wub::ReturnData {socket type data code} { upvar #0 ::WS::Wub::Httpd$sock data foreach var {type data code} { dict set $data(reply) $var [set $var] } return; } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Wub::Start # # Description : Start listening on all ports (i.e. enter the event loop). # # Arguments : None # # Returns : Value that event loop was exited with. # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : # ::WS::Wub::Listen should have been called for one or more port. # # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Wub::Start {} { vairable forever set forever 0 vwait ::WS::Wub::forever return $forever } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::Wub::Stop # # Description : Exit dispatching request. # # Arguments : # value -- Value that ::WS::Embedded::Start should return, # # Returns : Nothing # # Side-Effects : # None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>END PUBLIC<< # # 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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Wub::Stop {{value 1}} { vairable forever set forever $value vwait ::WS::Wub::forever return $forever } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Wub::logger # # Description : Stub for a logger. # # Arguments : # args - not used # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Wub::logger {args} { } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Wub::respond # # Description : Send response back to user. # # Arguments : # sock -- Socket to send reply on # code -- Code to send # body -- HTML body to send # head -- HTML header to send # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Wub::respond {sock code body {head ""}} { puts -nonewline $sock "HTTP/1.0 $code ???\nContent-Type: text/html; charset=ISO-8859-1\nConnection: close\nContent-length: [string length $body]\n$head\n$body" } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Wub::checkauth # # Description : Check to see if the user is allowed. # # Arguments : # port -- Port number # sock -- Incoming socket # ip -- Requester's IP address # auth -- Authentication information # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Wub::checkauth {port sock ip auth} { variable portInfo if {[llength portInfo($port,auths)] && [lsearch -exact $portInfo($port,auths) $auth]==-1} { set realm $portInfo($port,realm) respond $sock 401 Unauthorized "WWW-Authenticate: Basic realm=\"$realm\"\n" $portInfo($port,logger) "Unauthorized from $ip" return -code error } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Wub::handler # # Description : Handle a request. # # Arguments : # port -- Port number # sock -- Incoming socket # ip -- Requester's IP address # reqstring -- Requester's message # auth -- Authentication information # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Wub::handler {port sock ip reqstring auth} { variable portInfo upvar #0 ::WS::Wub::Httpd$sock req if {[catch {checkauth $port $sock $ip $auth}]} { return; } array set req $reqstring foreach var {type data code} { dict set $req(reply) $var [set $var] } set path $req(path) if {[dict exists $portInfo($port,handlers) $path]} { set cmd [dict get $portInfo($port,handlers) $path] lappend $cmd sock {} } else { respond $port $sock 404 "Error" } if {[catch {eval $cmd} msg]} { respond $port $sock 404 $msg } else { set data [dict get $req(reply) data] set reply "HTTP/1.0 [dict get $req(reply) code] ???\n" append reply "Content-Type: [dict get $req(reply) type]; charset=UTF-8\n" append reply "Connection: close\n" append reply "Content-length: [string length $data]\n" append reply "\n" append reply $data puts -nonewline $sock $reply } return; } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Wub::accept # # Description : Accept an incoming connection. # # Arguments : # port -- Port number # sock -- Incoming socket # ip -- Requester's IP address # clientport -- Requester's port number # # Returns : # Nothing # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : Gerald W. Lester # #>>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/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Wub::accept {port sock ip clientport} { variable portInfo if {[catch { gets $sock line set auth "" for {set c 0} {[gets $sock temp]>=0 && $temp ne "\r" && $temp ne ""} {incr c} { regexp {Authorization: Basic ([^\r\n]+)} $temp -- auth if {$c == 30} { $portInfo($port,logger) "Too many lines from $ip" } } if {[eof $sock]} { $portInfo($port,logger) "Connection closed from $ip" } foreach {method url version} $line { break } switch -exact $method { GET { handler $port $sock $ip [uri::split $url] $auth } default { $portInfo($port,logger) "Unsupported method '$method' from $ip" } } } msg]} { $portInfo($port,logger) "Error: $msg" } catch {flush $sock} catch {close $sock} return; } tclws-3.5.0/WubServer.tcl000064400000000000000000000020271471124032000146520ustar00nobodynobody# WSWub - Wub interface to WebServices package require Tcl 8.4- # WS::Utils usable here for dict? if {![llength [info command dict]]} { package require dict } package require WS::Server package require OO package require Direct package require Debug Debug off wsdl 10 package provide WS::Wub 2.5.0 package provide Wsdl 2.4.0 class create Wsdl { method / {r args} { return [Http Ok $r [::WS::Server::generateInfo $service 0] text/html] } method /op {r args} { if {[catch {::WS::Server::callOp $service 0 [dict get $r -entity]} result]} { return [Http Ok $r $result] } else { dict set r -code 500 dict set r content-type text/xml dict set r -content $result return [NoCache $r] } } method /wsdl {r args} { return [Http Ok $r [::WS::Server::GetWsdl $service] text/xml] } mixin Direct ;# Direct mixin maps the URL to invocations of the above methods variable service constructor {args} { set service [dict get $args -service] ;# we need to remember the service name } } tclws-3.5.0/docs000075500000000000000000000000001471124032000130725ustar00nobodynobodytclws-3.5.0/docs/Calling_a_Web_Service.html000064400000000000000000000677121471124032000202020ustar00nobodynobody Calling a Web Service from Tcl

    Calling a Web Service from Tcl

    Contents

    Overview

    The Webservices Client package provides a several ways to define what operations a remote Web Services Server provides and how to call those operations. It also includes several ways to call an operation.

    The following ways are provided to define remote operations:

    • Loading a pre-parsed WSDL
    • Quering a remote Web Services Server for its WSDL and parsing it
    • Parsing a saved WSDL
    • Defining a REST based service by hand

    The parsed format is much more compact than the XML of a WSDL.

    The following ways are provided to directly call an operation of a Web Service Server:

    • Synchronous Call returning a dictionary object
    • Synchronous Call returning the raw XML
    • Asynchronous Call with separate success and error callbacks
    • Creation of stub Tcl procedures to make synchronous calls

    This package makes use of the log package from TclLib. In particular the following levels are used:

    • error/warning -- errors encountered when parsing a WSDL. Actual level depends on options that are set in the ::WS::Utils package.
    • info -- HTTP calls, including the XML, made to invoke operations and the replies received. Introduced in 2.2.8.
    • debug -- detailed internal information. This should only be used if you want to code dive into the TclWs package internals.

    Loading the Webservices Client Package

    To load the webservices server package, do: 

     package require WS::Client

    This command will only load the utilities the first time it is used, so it causes no ill effects to put this in each file using the utilties.

    Quering a remote Web Services Server for its WSDL and parsing it

    Procedure Name : ::WS::Client::GetAndParseWsdl

    Description : Fetch the WSDL file from the given URL, aprse it and create the service.

    Arguments : 

         url     - The url of the WSDL
     headers - Extra headers to add to the HTTP request. This
               is a key value list argument. It must be a list with
               an even number of elements that alternate between
               keys and values. The keys become header field names.
               Newlines are stripped from the values so the header
               cannot be corrupted.
               This is an optional argument and defaults to {}.
     serviceAlias - Alias (unique) name for service.
                    This is an optional argument and defaults to the name of the
                    service in serviceInfo.
     serviceNumber - Number of service within the WSDL to assign the
                     serviceAlias to. Only recognized with a serviceAlias.
                     First service (default) is addressed by value "1".

    The following example WSDL snipped defines two services:

      >definitions ...<
    >service name="service1"<
      ...
    >/service<
    >service name="service1"<
      ...
    >/service<
  >/definitions<

    Using an empty or no serviceAlias would result in the creation of the services "service1" and "service2".

    Using serviceAlias="SE" and serviceNumber=2 would result in the creation of the service "SE" containing the "service2" of the WSDL.

    Returns : The parsed service definition

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : None

    Parsing a saved WSDL

    Procedure Name : ::WS::Client::ParseWsdl

    Description : Parse a WSDL and create the service. Create also the stubs if specified.

    Arguments : 

         wsdlXML - XML of the WSDL

    Optional Arguments: 

         -createStubs 0|1 - create stub routines for the service
     -headers         - Extra headers to add to the HTTP request. This
                        is a key value list argument. It must be a list with
                        an even number of elements that alternate between
                        keys and values. The keys become header field names.
                        Newlines are stripped from the values so the header
                        cannot be corrupted.
                        This is an optional argument and defaults to {}.
     -serviceAlias    - Alias (unique) name for service.
                        This is an optional argument and defaults to the name of the
                        service in serviceInfo.
     serviceNumber - Number of service within the WSDL to assign the
                     serviceAlias to. Only recognized with a serviceAlias.
                     First service (default) is addressed by value "1".

    The arguments are position independent.

    For an example use of serviceAlias and serviceNumber, see the chapter above.

    Returns : The parsed service definition

    Side-Effects : None

    Exception Conditions :None

    Pre-requisite Conditions : None

    Loading a pre-parsed WSDL

    Procedure Name : ::WS::Client::LoadParsedWsdl

    Description : Load a saved service definition in

    Arguments : 

         serviceInfo - parsed service definition, as returned from
                   ::WS::Client::ParseWsdl or ::WS::Client::GetAndParseWsdl
     headers     - Extra headers to add to the HTTP request. This
                     is a key value list argument. It must be a list with
                     an even number of elements that alternate between
                     keys and values. The keys become header field names.
                     Newlines are stripped from the values so the header
                     cannot be corrupted.
                     This is an optional argument and defaults to {}.
     serviceAlias - Alias (unique) name for service.
                     This is an optional argument and defaults to the name of the
                     service in serviceInfo.

    Returns : The name of the service loaded

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : None

    Defining a REST based service by hand


    Service Definition

    Procedure Name : ::WS::Client::CreateService

    Description : Define a REST service

    Arguments : 

         serviceName - Service name to add namespace to
     type        - The type of service, currently only REST is supported.
     url          - URL of namespace.
     args         - Optional arguments:
                            This is an optional argument and defaults to the name of the
                                -header httpHeaderList.

    Returns : The local alias (tns)

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : None

    Method Definition

    Procedure Name : ::WS::Client::DefineRestMethod

    Description : Define a method on a REST service

    Arguments : 

         serviceName - Service name to add namespace to
     methodName  - The name of the method to add.
     returnType  - The type, if any returned by the procedure.  Format is:
                           xmlTag typeInfo.
     inputArgs   - List of input argument definitions where each argument
                           definition is of the format: name typeInfo.

    where, typeInfo is of the format {type typeName comment commentString}

    Returns : The current service definition

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : None

    Defining Transforms

    Procedure Name : ::WS::Client::SetServiceTransforms

    Description : Define a service's transforms 

                   Transform signature is:
                   cmd serviceName operationName transformType xml {url {}} {argList {}}
               where transformType is REQUEST or REPLY
               and url and argList will only be present for transformType == REQUEST

    Arguments : 

         serviceName  - The name of the Webservice
     inTransform  - Input transform cmd, defaults to {}.
     The inTransform is the proc which allows to transform the SOAP output message, which will be input in the server.
     outTransform - Output transformcmd, defaults to {}.
     The outTransform is the proc which allows to transform the SOAP input message, which is the answer of the server.

    Returns : None

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : Service must have been defined.

    Synchronous Call returning a dictionary object

    Procedure Name : ::WS::Client::DoCall

    Description : Call an operation of a web service

    Arguments : 

         serviceName     - The name of the Webservice
     operationName   - The name of the Operation to call
     argList         - The arguements to the operation as a dictionary object
                       This is for both the Soap Header and Body messages.
     headers         - Extra headers to add to the HTTP request. This
                       is a key value list argument. It must be a list with
                       an even number of elements that alternate between
                       keys and values. The keys become header field names.
                       Newlines are stripped from the values so the header
                       cannot be corrupted.
                       This is an optional argument and defaults to {}.

    Returns : 

         The return value of the operation as a dictionary object.
       This includes both the return result and any return headers.

    Side-Effects : None

    Exception Conditions : 

         WSCLIENT HTTPERROR      - if an HTTP error occured
     others                  - as raised by called Operation

    Pre-requisite Conditions : Service must have been defined.

    Asynchronous Call with separate success and error callbacks

    Procedure Name : ::WS::Client::DoAsyncCall

    Description : Call an operation of a web service asynchronously

    Arguments : 

         serviceName     - The name of the Webservice
     operationName   - The name of the Operation to call
     argList         - The arguements to the operation as a dictionary object
                       This is for both the Soap Header and Body messages.
     succesCmd       - A command prefix to be called if the operations
                       does not raise an error.  The results, as a dictionary
                       object are concatinated to the prefix. This includes
                       both the return result and any return headers.  Leave
                       empty to not call any function.

     errorCmd        - A command prefix to be called if the operations
                       raises an error.  The error code, stack trace and
                       error message are concatinated to the prefix.  Leave
                       empty to not call any function.
     headers         - Extra headers to add to the HTTP request. This
                       is a key value list argument. It must be a list with
                       an even number of elements that alternate between
                       keys and values. The keys become header field names.
                       Newlines are stripped from the values so the header
                       cannot be corrupted.
                       This is an optional argument and defaults to {}.

    Returns : Nothing.

    Side-Effects : None

    Exception Conditions : 

         WSCLIENT HTTPERROR      - if an HTTP error occured
     others                  - as raised by called Operation

    Pre-requisite Conditions : Service must have been defined.

    Creation of stub Tcl procedures to make synchronous calls

    Procedure Name : ::WS::Client::CreateStubs

    Description : Create stubs routines to make calls to Webservice Operations. 

                 All routines will be create in a namespace that is the same
             as the service name.  The procedure name will be the same
             as the operation name.

                 NOTE -- Webservice arguments are position independent, thus
                     the proc arguments will be defined in alphabetical order.

    Arguments : 

         serviceName     - The service to create stubs for

    Returns : A string describing the created procedures.

    Side-Effects : Existing namespace is deleted.

    Exception Conditions : None

    Pre-requisite Conditions : Service must have been defined.

    Synchronous Call returning the raw XML

    Procedure Name : ::WS::Client::DoRawCall

    Description : Call an operation of a web service

    Arguments : 

         serviceName     - The name of the Webservice
     operationName   - The name of the Operation to call
     argList         - The arguements to the operation as a dictionary object
                       This is for both the Soap Header and Body messages.
     headers         - Extra headers to add to the HTTP request. This
                       is a key value list argument. It must be a list with
                       an even number of elements that alternate between
                       keys and values. The keys become header field names.
                       Newlines are stripped from the values so the header
                       cannot be corrupted.
                       This is an optional argument and defaults to {}.

    Returns : 

         The XML of the operation.

    Side-Effects : None

    Exception Conditions : 

         WSCLIENT HTTPERROR      - if an HTTP error occured

    Pre-requisite Conditions : Service must have been defined.

    Generating a Template Dictionary

    Procedure Name : ::WS::Utils::GenerateTemplateDict

    Description : Generate a template dictionary object for a given type.

    Arguments : 

         mode            - The mode, Client or Server
     serviceName     - The name of the Webservice
     type            - The name of the type
     arraySize       - Number of elements to generate in an array.  Default is 2

    Returns : 

    A dictionary object for a given type.  If any circular references exist, they will have the value of <** Circular Reference **>

    Side-Effects : None 
    

    Exception Conditions  : None 
    

    Pre-requisite Conditions : Service must have been defined.

    Configuring a Service

    There are two procedures to configure a service:
    • ::WS::Client::SetOption
    • ::WS::Client::Config

    The first procedure contains the default options of the package. The default options are used on service creation and are then copied to the service.

    The second procedure contains the options of each service. They are copied on service creation from the default options.

    Most option items may be accessed by both functions. Some options are only used on service creation phase, which do not exist as service option. Other options do not exist as default option, as they are initialized from the WSDL file.

    In the following, first the two access routines are described. Then, a list of options for both functions are given, with remarks, if they are only valid for one of the two procedures.

    Procedure Name : ::WS::Client::SetOption

    Description : Get or set the default options of the package

    Arguments : 

         -globalonly   - Return a list of global-only options and their values.
                     Global-only options are not copied to the service.
     -defaultonly  - Return a list of default-only options and their values.
                     default-only options are copied to the service.
     --            - End of options
     item          - The option item to get or configure.
                     Return a list of all item/value pairs if ommitted. 
     value         - The value to set the option item to.
                     Return current value if omitted.

    Procedure Name : ::WS::Client::Config

    Description : Get or set the options local to a service definition

    Arguments : 

         serviceName - The name of the Webservice.
                   Return a list of default items/values paires if not given.
     item        - The option item to get or configure.
                   Return a list of all item/value pairs, if not given. 
     value       - The value to set the option item to.
                   Return current value if omitted.

    Option List: 

    • allowOperOverloading

      An overloaded operation is an operation with the same name but different may exist with different input parameter sets.

      This option throws an error, if a WSDL is parsed with an overloaded operation.

      Default: 1
    • contentType
      The http content type of the http request sent to call the web service.
      Default: "text/xml;charset=utf-8"
    • errorOnRedefine

      Throw an error, if a service is created (CreateService etc) for an already existing service.

      Default value: 0

      This item may not be used with ::WS::Client::Config.

    • genOutAttr
      generate attributes on outbound tags, see here for details
    • inlineElementNS

      Namespace prefixes for types may be defined within the WSDL root element.

      This item may not be used with ::WS::Client::Config.

      Activate this option, to also search namespace prefixes in the type definition. As those are seen as global prefixes, there might be a double-used prefix which will cause a processing error, if different URI's are assigned.

      The error would be caused by a WSDL as follows

      	<wsdl:definitions targetNamespace="http://www.webserviceX.NET/"
        xmlns:wsdl="http://schemas.xmlsoap.org/wsdl/
		xmlns:q1="myURI1"
		...>
	    ...
	    <xs:element xmlns:q1="myURI2" type="q1:MessageQ1"/>
	
    • location

      The URL of the service. This is initialized on the value in the WSDL file, when the WSDL file is parsed. The value may be overwritten setting this option.

      This item may not be used with ::WS::Client::SetOption.

    • noTargetNs
      The target namespace URI is normally included twice in the envelope of the webservice call:
      <SOAP-ENV:Envelope
	...
	xmlns="http://targeturi.org/"
	xmlns:tns1="http://targeturi.org/"
	...>
      Setting this option to 1 suppresses the line with "xmlns=".
      This option was set to call a service published by SAP.
      Default value: 0
    • nsOnChangeOnly
      only put namespace prefix when namespaces change
    • parseInAttr
      parse attributes on inbound tags, see here for details
    • queryTimeout
      Timeout to any network query in ms. Default value: 60000 (1 minuite). The utility package has an option with the same functionality, which is used, when there is no call option context. 
    • skipHeaderLevel
      boolean indicating the first level of the XML in a request header shall be skipped. Derived from options. Default is 0 (do not skip). (Introduced in 2.2.8)
    • skipLevelOnReply
      boolean indicating the first level of the XML in a reply may be skipped. Derived from options. Default is 0 (do not skip). (Introduced in 2.2.8)
    • skipLevelWhenActionPresent
      boolean indicating if the first level of the XML is to be skipped. Derived from options. Default is 0 (do not skip).
    • suppressNS (default: empty string)
      do not put a particular namespace prefix
    • suppressTargetNS

      Do not add the Target Namespace URI prefix "tns1" to all parameters in the webservice call XML.

      As an example, the XML is modified from (option not set): 

      <SOAP-ENV:Envelope ...
    xmlns:tns1="http://targeturi.org/"
    ... >
  <SOAP-ENV:Body>
    <tns1:CalledMethod>
      <tns1:Parameter1>Value;/tns1:Parameter1>
    </tns1:CalledMethod>
  </SOAP-ENV:Body>
</SOAP-ENV:Envelope>
      to (option set) 
      <SOAP-ENV:Envelope ...
    xmlns:tns1="http://targeturi.org/"
    ... >
<SOAP-ENV:Envelope ...
  <SOAP-ENV:Body>
    <tns1:CalledMethod>
      <Parameter1>Value;/Parameter1>
    </tns1:CalledMethod>
  </SOAP-ENV:Body>
</SOAP-ENV:Envelope>

      Derived from options.
      Internally, this option sets the option "suppressNS" to "tns1".
      This option was set to call a service published by SAP.
      This option made a call to a certain MS Web Service fail with the error message: "Input parameter 'Parameter1' can not be NULL or Empty.".
      Default is 0 (do not suppress). 
    • targetNamespace (default: empty string)

      the target namespace of the service, derived from the WSDL.

      This item may not be used with ::WS::Client::SetOption.

    • UseNS (default: empty string)
      See here 
    • useTypeNS (default: empty string)
      use type's namespace prefix as prefix of elements
    • valueAttrCompatiblityMode (default: 1)
      If this and genOutAttr/parseInAttr are set, then values are specified in the dictionary as {}. Otherwise if genOutAttr/parseInAttr is set this is not set, then the values are specified in the dictionary as ::value.
         value         - Optional, the new value.

    Returns : 

         The value of the item.

    Side-Effects : None 
    

    Exception Conditions  : None 
    

    Pre-requisite Conditions : Service must have been defined.

    Dealing With Casting Abstract Types to Concrete Types

    If you turn on parseInAttr and genOutAttr, the system will semi-automatically deal with casting of elements declared as a being of a type that is an abstract type to/from the concrete type actually to be used in a message. On an element that is decleared to be a type which is an abstract type, the value of the ::type key in the dictionary will specify the concrete type to be actually used (or for a reply message the concrete type that was actually used).

    NOTE: While in the WSDL the concreate type must be an extention of the abstract type, the package does not enforce this restriction, so caution must be taken.

    tclws-3.5.0/docs/Creating_a_Tcl_Web_Service.html000064400000000000000000000325661471124032000211660ustar00nobodynobody Creating a Tcl Web Service

    Creating a Tcl Web Service

    Contents

    Loading the Webservices Server Package

    To load the webservices server package, do: 

     package require WS::Server

    This command will only load the server the first time it is used, so it causes no ill effects to put this in each file declaring a service or service procedure.

    Using as part of TclHttpd

    The Web Services package, WS::Server, is not a standalone application, but rather is designed to be a "module" of TclHttpd. The following command is normally placed in httpdthread.tcl:

    Embedding in a Standalone Application

    To embed a Web Service into an application, the application needs to be event driven and you also need to use the WS::Embeded package. You also must define the service with the -mode=embedded option.

    See also Embedding a Web Service into an application.

    Using with Apache Rivet

    Apache Rivet is a module (mod_rivet) that can be loaded by Apache httpd server to allow web pages to run embedded Tcl commands in a way similar to PHP. To create a Web Service in Rivet, use the example EchoRivetService.rvt as a starting point by simply copying it into any directory served by your Apache instance. You should be able to immediately access that new location at the following URLs: 

                   /path/to/EchoRivetService.rvt/doc
                     Displays an HTML page describing the service
               /path/to/EchoRivetService.rvt/wsdl
                     Returns a WSDL describing the service
               /path/to/EchoRivetService.rvt/op
                     Invoke an operation

    If you would prefer to expose the published URLs of your service differently, you can use the standard Apache mod_rewrite or mod_alias modules to transparently map any other URL to those locations.

    Defining a Service

    The code that defines a service is normally placed in one or more files in the custom directory.

    Procedure Name : ::WS::Server::Service

    Description : Declare a Web Service, the following URLs will exist 

                   /service/<ServiceName>
                     Displays an HTML page describing the service
               /service/<ServiceName>/wsdl
                     Returns a WSDL describing the service
               /service/<ServiceName>/op
                     Invoke an operation

    Arguments : this procedure uses position independent arguments, they are: 

                 -hostcompatibility32 bool - Activate version 3.2.0 compatibility
                               mode for -host parameter.
                               Defaults to true.
             -host           - The host specification within XML namespaces
                               of the transmitted XML files.
                               This should be unique.
                               Defaults to localhost.
                               If 3.2 compatibility is activated, the default
                               value is changed to ip:port in embedded mode.
             -hostlocation   - The host name, which is promoted within the
                               generated WSDL file. Defaults to localhost.
                               If 3.2 compatibility is activated, the
                               default value is equal to the -host parameter.
             -hostlocationserver bool - If true, the host location is set by
                               the current server settings.
                               In case of httpd server, this value is imported.
                               For other servers or if this fails, the value
                               is the current ip:port.
                               The default value is true.
                               In case of 3.2 compatibility, the default
                               value is true for tclhttpd, false otherwise.
             -hostProtocol   - Define the host protocol (http, https) for the
                               WSDL location URL. The special value "server"
                               (default) follows the TCP/IP server specification.
                               This is implemented for Embedded server and tclhttpd.
                               Remark that the protocol for XML namespaces
                               is always "http".
             -description    - The HTML description for this service
             -htmlhead       - The title string of the service description
             -author         - The author property in the service description
             -xmlnamespace   - Extra XML namespaces used by the service
             -service        - The service name (this will also be used for
                                 the Tcl namespace of the procedures that implement
                                 the operations.
             -premonitor     - This is a command prefix to be called before
                                 an operation is called.  The following arguments are
                                 added to the command prefix:
                                    PRE serviceName operationName operArgList
             -postmonitor    - This is a command prefix to be called after
                                 an operation is called.  The following arguments are
                                 added to the command prefix:
                                    POST serviceName operationName OK|ERROR results
             -inheaders      - List of input header types.
             -outheaders     - List of output header types.
             -intransform    - Inbound (request) transform procedure (2.0.3 and later).
                                The signature of the command must be:
                                     cmd \
                                         mode (REQUEST) \
                                         xml \
                                         notUsed_1 \
                                         notUsed_2
             -outtransform   - Outbound (reply) transform procedure (2.0.3 and later).
                                The signature of the command must be:
                                     cmd \
                                         mode (REPLY) \
                                         xml \
                                         operation \
                                         resultDict
             -checkheader    - Command prefix to check headers.
                                   If the call is not to be allowed, this command
                                   should raise an error.
                                   The signature of the command must be:
                                     cmd \
                                         service \
                                         operation \
                                         caller_ipaddr \
                                         http_header_list \
                                         soap_header_list
            -mode           - Mode that service is running in.  Must be one of:
                                   tclhttpd  -- running inside of tclhttpd or an
                                                environment that supplies a
                                                compatible Url_PrefixInstall
                                                and Httpd_ReturnData commands
                                   embedded  -- using the ::WS::Embedded package
                                   aolserver -- using the ::WS::AolServer package
                                   wub       -- using the ::WS::Wub package
                                   wibble    -- running inside wibble
                                   rivet     -- running inside Apache Rivet (mod_rivet)
            -ports          - List of ports for embedded mode. Default: 80
                                    NOTE -- a call should be to
                                            ::WS::Embedded::Listen for each port
                                            in this list prior to calling ::WS::Embeded::Start
            -prefix         - Path prefix used for the namespace and endpoint
                              Defaults to "/service/" plus the service name
            -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

    Exception Conditions : 

         MISSREQARG -- Missing required arguments

    Pre-requisite Conditions : None

    Defining an Operation (aka a Service Procedure)

    Procedure Name : ::WS::Server::ServiceProc

    Description : Register an operation for a service and declare the procedure to handle the operations.

    Arguments : 

         ServiceName     -- Name of the service this operation is for
     NameInfo        -- List of two elements:
                             1) OperationName -- the name of the operation
                             2) ReturnType    -- the type of the procedure return,
                                                 this can be a simple or complex type
     Arglist         -- List of argument definitions,
                         each list element must be of the form:
                             1) ArgumentName -- the name of the argument
                             2) ArgumentTypeInfo -- -- A list of:
                                    {type typeName comment commentString}
                                         typeName can be any simple or defined type.
                                         commentString is a quoted string describing the field
     Documentation   -- HTML describing what this operation does
     Body            -- The tcl code to be called when the operation is invoked. This
                            code should return a dictionary with <OperationName>Result as a
                            key and the operation's result as the value.
    Available simple types are:
    • anyType, string, boolean, decimal, float, double, duration, dateTime, time, date, gYearMonth, gYear, gMonthDay, gDay, gMonth, hexBinary, base64Binary, anyURI, QName, NOTATION, normalizedString, token, language, NMTOKEN, NMTOKENS, Name, NCName, ID, IDREF, IDREFS, ENTITY, ENTITIES, integer, nonPositiveInteger, negativeInteger, long, int, short, byte, nonNegativeInteger, unsignedLong, unsignedInt, unsignedShort, unsignedByte, positiveInteger
    The typeName may contain the following suffixes:
    • () : type is an array
    • ? : type is an optional parameter

    Returns : Nothing

    Side-Effects : 

       A procedure named "<ServiceName>::<OperationName>" defined
   A type name with the name <OperationName>Result is defined.

    Exception Conditions : None

    Pre-requisite Conditions : ::WS::Server::Server must have been called for the ServiceName

    Declaring Complex Types

    See: Creating a Web Service Type from Tcl

    tclws-3.5.0/docs/Creating_a_Web_Service_Type.html000064400000000000000000000166611471124032000213630ustar00nobodynobody Creating a Web Service Type from Tcl

    Creating a Web Service Type from Tcl

    Contents

    Overview

    Webservice Type declaration is part of the Webservices Utility package.

    When writing a web service it is often requried to write a complex type definition for an argument containing structured data.

    When calling an operation on a web service it is sometimes convient to define a complex type to return structured data as an XML fragment even though the sevice may state that it is only expecting a string.

    Loading the Webservices Utility Package

    To load the webservices server package, do: 

     package require WS::Utils

    This command will only load the utilities the first time it is used, so it causes no ill effects to put this in each file using the utilties.

    Defining a type

    Procedure Name : ::WS::Utils::ServiceTypeDef

    Description : Define a type for a service.

    Arguments : 

         mode            - Client or Server
     service         - The name of the service this type definition is for
     type            - The type to be defined/redefined
     definition      - The definition of the type's fields.  This consist of one
                           or more occurance of a field definition.  Each field definition
                           consist of:  fieldName fieldInfo
                           Where field info is: {type typeName comment commentString}
                              typeName can be any simple or defined type.
                              commentString is a quoted string describing the field.

    Returns : Nothing

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : None

    Defining a derived type

    Procedure Name : ::WS::Utils::ServiceSimpleTypeDef

    Description : Define a derived type for a service.

    Arguments : 

         mode            - Client or Server
     service         - The name of the service this type definition is for
     type            - The type to be defined/redefined
     definition      - The definition of the type's fields.  This consist of one
                           or more occurance of a field definition.  Each field definition
                           consist of:  fieldName fieldInfo
                           Where: {type typeName comment commentString}
                              baseType typeName - any simple or defined type.
                              comment commentString - a quoted string describing the field.
                              pattern value
                              length value
                              fixed "true"|"false"
                              maxLength value
                              minLength value
                              minInclusive value
                              maxInclusive value
                              enumeration value

    Returns : Nothing

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : None

    Getting a type definition

    Procedure Name : ::WS::Utils::GetServiceTypeDef

    Description : Query for type definitions.

    Arguments : 

         mode            - Client or Server
     service         - The name of the service this query is for
     type            - The type to be retrieved (optional)

    Returns : 

         If type not provided, a dictionary object describing all of the types
     for the service.
     If type provided, a dictionary object describing the type.
       A definition consist of a dictionary object with the following key/values:
         xns         - The namespace for this type.
         definition  - The definition of the type's fields.  This consist of one
                       or more occurance of a field definition.  Each field definition
                       consist of:  fieldName fieldInfo
                       Where field info is: {type typeName comment commentString}
                         typeName can be any simple or defined type.
                         commentString is a quoted string describing the field.

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : The service must be defined.

    Generating a template dictionary for a type definition

    Procedure Name : ::WS::Utils::GenerateTemplateDict

    Description : Generate a template dictionary object for a given type.

    Arguments : 

         mode            - Client or Server
     serviceName     - The service name the type is defined in
     type            - The name of the type
     arraySize       - Number of elements to generate in an array.  Default is 2.

    Returns : 

          A dictionary object for a given type.  If any circular references exist, they will have the value of <** Circular Reference **>

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : The type and service must be defined.

    tclws-3.5.0/docs/Defining_Types.html000064400000000000000000000165611471124032000167570ustar00nobodynobody Web Services for Tcl (aka tclws): Defining Types

    Contents

    Overview

    Webservice Type declaration is part of the Webservices Utility package.

    When writing a web service it is often requried to write a complex type definition for an argument containing structured data.

    When calling an operation on a web service it is sometimes convient to define a complex type to return structured data as an XML fragment even though the sevice may state that it is only expecting a string.

    Loading the Webservices Utility Package

    To load the webservices server package, do: 

     package require WS::Utils

    This command will only load the utilities the first time it is used, so it causes no ill effects to put this in each file using the utilties.

    Defining a type

    Procedure Name : ::WS::Utils::ServiceTypeDef

    Description : Define a type for a service.

    Arguments : 

         mode            - Client or Server
     service         - The name of the service this type definition is for
     type            - The type to be defined/redefined
     definition      - The definition of the type's fields.  This consist of one
                           or more occurance of a field definition.  Each field definition
                           consist of:  fieldName fieldInfo
                           Where field info is: {type typeName comment commentString}
                              typeName can be any simple or defined type.
                              commentString is a quoted string describing the field.

    Returns : Nothing

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : None

    Defining a derived type

    Procedure Name : ::WS::Utils::ServiceSimpleTypeDef

    Description : Define a derived type for a service.

    Arguments : 

         mode            - Client or Server
     service         - The name of the service this type definition is for
     type            - The type to be defined/redefined
     definition      - The definition of the type's fields.  This consist of one
                           or more occurance of a field definition.  Each field definition
                           consist of:  fieldName fieldInfo
                           Where: {type typeName comment commentString}
                              baseType typeName - any simple or defined type.
                              comment commentString - a quoted string describing the field.
                              pattern value
                              length value
                              fixed "true"|"false"
                              maxLength value
                              minLength value
                              minInclusive value
                              maxInclusive value
                              enumeration value

    Returns : Nothing

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : None

    Getting a type definition

    Procedure Name : ::WS::Utils::GetServiceTypeDef

    Description : Query for type definitions.

    Arguments : 

         mode            - Client or Server
     service         - The name of the service this query is for
     type            - The type to be retrieved (optional)

    Returns : 

         If type not provided, a dictionary object describing all of the types
     for the service.
     If type provided, a dictionary object describing the type.
       A definition consist of a dictionary object with the following key/values:
         xns         - The namespace for this type.
         definition  - The definition of the type's fields.  This consist of one
                       or more occurance of a field definition.  Each field definition
                       consist of:  fieldName fieldInfo
                       Where field info is: {type typeName comment commentString}
                         typeName can be any simple or defined type.
                         commentString is a quoted string describing the field.

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : The service must be defined.

    Generating a template dictionary for a type definition

    Procedure Name : ::WS::Utils::GenerateTemplateDict

    Description : Generate a template dictionary object for a given type.

    Arguments : 

         mode            - Client or Server
     serviceName     - The service name the type is defined in
     type            - The name of the type
     arraySize       - Number of elements to generate in an array.  Default is 2.

    Returns : 

          A dictionary object for a given type.  If any circular references exist, they will have the value of <** Circular Reference **>

    Side-Effects : None

    Exception Conditions : None

    Pre-requisite Conditions : The type and service must be defined.

    tclws-3.5.0/docs/Dictionary_Representation_of_XML_Arrays.html000064400000000000000000000044371471124032000237630ustar00nobodynobody Web Services for Tcl (aka tclws): Dictionary Representation of XML Arrays

    XML arrays are represented in dictionary format as a list of values. Lets consider what this looks like for a simple type and for a complex type;.

    Array of Simple Type

    Lets assume we have an element with the following definition: 

        <xs:element minOccurs="0" maxOccurs="unbounded" name="Primes" type="xs:integer" />
    Lets also assume that we will have that element in our dictionary with the first four prime numbers, thus the dictionary representation for that element would look like: 
        Primes {2 3 5 7}
    Or, if we have are using attributes (i.e. parseInAttr and/or genOutAttr are set), it would look like: 
        Primes {{} {2 3 5 7}}

    Array of Complex Type

    Lets assume we have the type definition: 

    <xs:element name="Person">
  <xs:complexType>
    <xs:sequence>
      <xs:element name="FristName" type="xs:string"/>
      <xs:element name="LastName" type="xs:integer"/>
    </xs:sequence>
  </xs:complexType>
</xs:element>
    Lets assume we have the following definition: 
        <xs:element minOccurs="0" maxOccurs="unbounded" name="Attendees" type="Person" />
    Now lets assume the following people are are attending:
    • John Doe
    • Jane Doe
    Thus the dictionary representation for that element would look like: 
        Attendees {
        {FirstName {John} LastName {Doe}}
        {FirstName {Jane} LastName {Doe}}
    }
    Or, if we have are using attributes (i.e. parseInAttr and/or genOutAttr are set), it would look like: 
        Attendees {
        {{} {FirstName {{} {John}} LastName {{} {Doe}}}}
        {{} {FirstName {{} {Jane}} LastName {{} {Doe}}}}
    }

    tclws-3.5.0/docs/Embedded_Web_Service.html000064400000000000000000000115231471124032000200070ustar00nobodynobody Embeding a Web Service

    Embeding a Web Service

    Contents

    Loading the Webservices Server Package

    To load the webservices server package, do: 

     package require WS::Embeded

    This command will only load the server the first time it is used, so it causes no ill effects to put this in each file declaring a service or service procedure.

    Specify a Port to Receive Request on

    The following command opens a listener socket in the specified port. The webservice functionality may be added by a call to ::WS::Server::Service with the -mode parameter set to embedded.

    Procedure Name : ::WS::Embeded::Listen

    Description : Instruct the module to listen on a Port, security information.

    Arguments : this procedure uses position dependent arguments, they are: 

         port     -- Port number to listen on.
     certfile -- Name of the certificate file or a pfx archive for twapi.
                 Defaults to {}.
     keyfile  -- Name of the key file. Defaults to {}.
                 To use twapi TLS, specify a list with the following elements:
                 -- "-twapi": Flag, that TWAPI TLS should be used
                 -- password: password of PFX file passed by
                    [::twapi::conceal]. The concealing makes sure that the
                    password is not readable in the error stack trace
                 -- ?subject?: optional search string in pfx file, if
                    multiple certificates are included.
     userpwds -- A list of username:password. Defaults to {}.
     realm    -- The seucrity realm. Defaults to {}.
     timeout  -- A time in ms the sender may use to send the request.
                 If a sender sends wrong data (Example: TLS if no TLS is
                 used), the process will just stand and a timeout is required
                 to clear the connection. Set to 0 to not use a timeout.
                 Default: 60000 (1 Minuit).

    Returns : Handle of socket

    Side-Effects : None

    Exception Conditions :  : None

    Pre-requisite Conditions : None

    Run the event queue

    To serve any requests, the interpreter must run the event queue using. If this is not anyway the case (Tk present etc.), one may call:

         vwait waitVariable

    To stop the event queue after server shutdown, one may execute:

         set waitVariable 1

    Close a port

    Procedure Name : ::WS::Embeded::Close

    Description : Close a formerly opened listener port and stop all running requests on this port.

    Arguments : this procedure uses position dependent arguments, they are: 

         port     -- Port number to close.

    Returns : None

    Side-Effects : None

    Exception Conditions :  : None

    Pre-requisite Conditions : None

    Close all ports

    Procedure Name : ::WS::Embeded::CloseAll

    Description : Close all formerly opened listener port and stop all running requests.

    Arguments : this procedure uses no arguments

    Returns : None

    Side-Effects : None

    Exception Conditions :  : None

    Pre-requisite Conditions : None

    tclws-3.5.0/docs/Rest_flavor_service_response.html000064400000000000000000000042531471124032000217670ustar00nobodynobody Rest-flavor service reply

    Rest-flavor service reply

    Contents

    Overview

    Since TCLWS 2.4, it is possible to return a response in REST style. This means, that a JSON reply is returned instead of an XML document.

    Our use case has only required us to accept FORM arguments and return JSON responses for everything, so we haven't implemented logic to parse any input arguments that are passed in as JSON serialized data, but this might be an area of future exploration for someone.

    Rivet Example

    Here's a bit of code showing how we initially start up this mode in Apache Rivet, which is actually pretty similar to how you'd use tclws in SOAP mode from Apache Rivet:

            # Capture the info from the request into an array.
        load_headers hdrArray
        set sock [pid];         # an arbitrary value
        array unset ::Httpd$sock

        # Prepare the CGI style arguments into a list
        load_response formArray
        set opname $formArray(call)
        unset formArray(call)
        set queryarg [list $opname [array get formArray]]

        # Invoke the the method
        array set ::Httpd$sock [list query $queryarg ipaddr [env REMOTE_ADDR] headerlist [array get hdrArray]]

        # Invoke the method in REST mode.
        set result [catch {::WS::Server::callOperation $svcname $sock -rest} error]
        array unset ::Httpd$sock
        if {$result} {
                headers numeric 500
                puts "Operation failed: $error"
                abort_page
        }
    tclws-3.5.0/docs/Tcl_Web_Service_Example.html000064400000000000000000000077351471124032000205250ustar00nobodynobody Tcl Web Service Example

    Tcl Web Service Example

    Server Side

    The following is placed in the httpdthread.tcl: 

       package require WS::Server
   package require WS::Utils

    The following is placed in the a file in the custom directory: 

       ##
   ## Define the service
   ##
   ::WS::Server::Service \
       -service wsExamples \
       -description  {Tcl Example Web Services} \
       -host         $::Config(host):$::Config(port)

       ##
   ## Define any special types
   ##
   ::WS::Utils::ServiceTypeDef Server wsExamples echoReply {
       echoBack     {type string}
       echoTS       {type dateTime}
   }

       ##
   ## Define the operations available
   ##
   ::WS::Server::ServiceProc \
       wsExamples \
       {SimpleEcho {type string comment {Requested Echo}}} \
       {
           TestString      {type string comment {The text to echo back}}
       } \
       {Echo a string back} {

           return [list SimpleEchoResult $TestString]
   }



       ::WS::Server::ServiceProc \
       wsExamples \
       {ComplexEcho {type echoReply comment {Requested Echo -- text and timestamp}}} \
       {
           TestString      {type string comment {The text to echo back}}
       } \
       {Echo a string and a timestamp back} {

           set timeStamp [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ} -gmt yes]
       return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp]  ]
   }


    Client Side 

       package require WS::Client

       ##
   ## Get Definition of the offered services
   ##
   ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsExamples/wsdl

       set testString "This is a test"
   set inputs [list TestString $testString]

       ##
   ## Call synchronously
   ##
   puts stdout "Calling SimpleEcho via DoCalls!"
   set results [::WS::Client::DoCall wsExamples SimpleEcho $inputs]
   puts stdout "\t Received: {$results}"

       puts stdout "Calling ComplexEcho via DoCalls!"
   set results [::WS::Client::DoCall wsExamples ComplexEcho $inputs]
   puts stdout "\t Received: {$results}"



       ##
   ## Generate stubs and use them for the calls
   ##
   ::WS::Client::CreateStubs wsExamples
   puts stdout "Calling SimpleEcho via Stubs!"
   set results [::wsExamples::SimpleEcho $testString]
   puts stdout "\t Received: {$results}"

       puts stdout "Calling ComplexEcho via Stubs!"
   set results [::wsExamples::ComplexEcho $testString]
   puts stdout "\t Received: {$results}"

       ##
   ## Call asynchronously
   ##
   proc success {service operation result} {
       global waitVar

           puts stdout "A call to $operation of $service was successful and returned $result"
       set waitVar 1
   }

       proc hadError {service operation errorCode errorInfo} {
       global waitVar

           puts stdout "A call to $operation of $service was failed with {$errorCode} {$errorInfo}"
       set waitVar 1
   }

       set waitVar 0
   puts stdout "Calling SimpleEcho via DoAsyncCall!"
   ::WS::Client::DoAsyncCall wsExamples SimpleEcho $inputs \
           [list success wsExamples SimpleEcho] \
           [list hadError wsExamples SimpleEcho]
   vwait waitVar

       puts stdout "Calling ComplexEcho via DoAsyncCall!"
   ::WS::Client::DoAsyncCall wsExamples ComplexEcho $inputs \
           [list success wsExamples SimpleEcho] \
           [list hadError wsExamples SimpleEcho]
   vwait waitVar

       exit


    tclws-3.5.0/docs/Tcl_Web_Service_Math_Example.html000064400000000000000000000075051471124032000214710ustar00nobodynobody Tcl Web Service Math Example

    Tcl Web Service Math Example

    Server Side

    The following is placed in the httpdthread.tcl: 

       package require WS::Server
   package require WS::Utils

    The following is placed in the a file in the custom directory: 

        ##
    ## Define the service
    ##
    ::WS::Server::Service \
        -service wsMathExample \
        -description  {Tcl Web Services Math Example} \
        -host         $::Config(host):$::Config(port)

    ##
    ## Define any special types
    ##
    ::WS::Utils::ServiceTypeDef Server wsMathExample Term {
       `coef         {type float}
        powerTerms   {type PowerTerm()}
    }
    ::WS::Utils::ServiceTypeDef Server wsMathExample PowerTerm {
        var          {type string}
        exponet      {type float}
    }
    ::WS::Utils::ServiceTypeDef Server wsMathExample Variables {
        var          {type string}
        value        {type float}
    }

   ##
   ## Define the operations available
   ##
   ::WS::Server::ServiceProc \
        wsMathExample \
        {EvaluatePolynomial {type float comment {Result of evaluating a polynomial}}} \
        {
            varList       {type Variables() comment {The variables to be substitued into the polynomial}}
            polynomial    {type Term() comment {The polynomial}}
        } \
        {Evaluate a polynomial} {
        set equation {0 }
        foreach varDict $varList {
            set var [dict get $varDict var]
            set val [dict get $varDict value]
            set vars($var) $val
        }
        foreach term $polynomial {
            if {[dict exists $term coef]} {
                set coef [dict get $term coef]
            } else {
                set coef 1
            }
            append equation "+ ($coef"
            foreach pow [dict get $term powerTerms] {
                if {[dict exists $pow exponet]} {
                    set exp [dict get $pow exponet]
                } else {
                    set exp 1
                }
                append equation [format { * pow($vars(%s),%s} [dict get $pow var] $exp]
            }
            append equation ")"
        }
        set result [expr $equation]
        return [list SimpleEchoResult $result]
    }


    Client Side 

        package require WS::Client
    ##
    ## Get Definition of the offered services
    ##
    ::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsMathExamples/wsdl

    dict set term var X
    dict set term value 2.0
    dict lappend varList $term
    dict set term var Y
    dict set term value 3.0
    dict lappend varList $term

    set term {}
    set powerTerm {}
    dict set powerTerm coef 2.0
    dict set term var X
    dict set term pow 2.0
    dict lappend terms $term
    dict set term var Y
    dict set term pow 3.0
    dict lappend terms $term
    dict set powerTerm powerTerms $terms

    dict set powerTerm coef -2.0
    dict set term var X
    dict set term pow 3.0
    dict lappend terms $term
    dict set term var Y
    dict set term pow 2.0
    dict lappend terms $term
    dict set powerTerm powerTerms $terms
    dict lappend polynomial powerTerms $powerTerm

    dict set input [list varList $varList polynomial $polynomial]
    ##
    ## Call service
    ##
    puts stdout "Calling EvaluatePolynomial wiht {$input}"
    set resultsDict [::WS::Client::DoCall wsMathExample EvaluatePolynomial $input]
    puts stdout "Results are {$resultsDict}"


    tclws-3.5.0/docs/Using_Options.html000064400000000000000000000226121471124032000166420ustar00nobodynobody Using Web Service Options

    Using Web Service Options

    Contents

    Overview

    The Webservices Client and Server packages make use of the following options:

    The attributes can be retrieved and set using ::WS::Utils::SetOption.

    If called by the client side, the following options are overwritten and restored on any call:

    • genOutAttr
    • nsOnChangeOnly
    • parseInAttr
    • suppressNS
    • UseNS
    • useTypeNs
    • valueAttrCompatiblityMode

    Loading the Webservices Utilities Package

    To load the webservices server package, do: 

     package require WS::Utils

    This command will only load the utilities the first time it is used, so it causes no ill effects to put this in each file using the utilties.

    Access Routine

    Procedure Name : ::WS::Utils::SetOption

    Description : Retrieve or set an option

    Arguments : 

        option - name of the option
    value - value of the option (optional)

    Returns : The value of the option

    Side-Effects : None

    Exception Conditions :None

    Pre-requisite Conditions : None

    genOutAttr - generate attributes on outbound tags

    The genOutAttr option, if set to a "true" value, will convert all dictionary keys of the entry for a given field tag to attribute value pairs of the tag in the outbound XML. For attributes in the "http://www.w3.org/2001/XMLSchema-instance" url, the key will be the attribute name prepended with two colons (e.g. ::type) and the value will be the value of the attribute. For attributes other than those in the "http://www.w3.org/2001/XMLSchema-instance" url, the key will be the attribute name and the value will be the value of the attribute. The value of the tag will have a key determined by the valueAttrCompatiblityMode.

    The default value, "0", is for this option to be turned off.

    includeDirectory - disk directory to use for XSD includes when they can not be accessed via the Web.

    The includeDirectory option, if set, instructs TclWs to look in the specified directory for any XSD includes that can not be found via the web.

    The default value, "{}", is for this option to be turned off.

    nsOnChangeOnly - only put namespace prefix when namespaces change

    The nsOnChangeOnly option, if set to a "true" value, will only place namespace prefixes when the namespaces change.

    This option is only relevant, if the option UseNS is set.

    The default value, "0", is for this option to be turned off.

    parseInAttr - parse attributes on inbound tags

    The parseInAttr option, if set to a "true" value, will convert all attributes of inbound field tags to dictionary entries for that tag. For attributes in the "http://www.w3.org/2001/XMLSchema-instance" url, the key will be the attribute name prepended with two colons (e.g. ::type) and the value will be the value of the attribute. For attributes other than those in the "http://www.w3.org/2001/XMLSchema-instance" url, the key will be the attribute name and the value will be the value of the attribute. The value of the tag will have a key determined by the valueAttrCompatiblityMode.

    The default value, "0", is for this option to be turned off.

    queryTimeout - set http(s) query timeout

    Timeout to any network query in ms. The client side package has an option with the same functionality, which is used, when there is a call option context.

    Default value: 60000 (1 minuite).

    StrictMode - WSDL processing mode

    The StrictMode option determines what happens when an error is detected in parsing a WSDL. The legal values are:

    • debug
    • warning
    • error

    If the StrictMode is set to debug or warning, a message is logged using the ::log package at that level and the error is then ignored.

    If the StrictMode is set to any value other than debug or warning, a message is logged using the ::log package at the error level and exception is generated.

    The default value is error.

    A major use of this is to ignore namespace imports in a WDSL that do not actually import any definitions.

    UseNS - put namespaces on field tags

    The UseNS option, if set to a "true" value, will put a namespace alias on all field tags.

    The default value, "1", is for this option to be turned on.

    useTypeNs - use type's namespace prefix as prefix of elements

    The useTypeNs option, if set to a "true" value, will use the prefix of the type's namespace instead of the prefix of the element's namespace.

    This option is only relevant, if the option UseNS is set.

    The default value, "0", is for this option to be turned off.

    suppressNS - do not put a given namespace prefix.

    The suppressNS option, if set, will cause the given namespace to never be used as a prefix (i.e. tags that would normally have had the given prefix will not have any prefix).

    This option is only relevant, if the option UseNS is set.

    The default value, "{}", is for this option to be turned off.

    valueAttrCompatiblityMode - specify dictionary key for value when attributes are in use

    This option is only meaningful when the parseInAttr or genOutAttr option is set to a "true" value. When set to a "true" value, the value of the tag will have a key of the null string (i.e. {}). When set to a "false" value, the value of the tag will have a key of ::value.

    The default value, "0", is for this option to be turned off.

    tclws-3.5.0/docs/index.html000064400000000000000000000070611471124032000151520ustar00nobodynobody Tcl Web Services

    Tcl Web Services

    Summary

    The distribution provides both client side access to Web Services and server side creation of Web Services. Currently only document/literal and rpc/encoded with HTTP Soap transport are supported on the client side. The server side currently works only with TclHttpd or embedded into an application. The server side provides all services as document/literal over HTTP Soap transport. Documentation for the package, including examples can be found here.

    The client is known to work with #C and Java based Web Services (your mileage may very).

    License

    Standard BSD.

    Web Servers

    The server side works with the following web servers:

    Packages Required

    The following packages are used:

    If you are running the TclHttpd on Windows, it is highly recommended that you use the iocpsock extension.

    The following packages are additionally used in Embedded Server mode:

    tclws-3.5.0/docs/style.css000064400000000000000000000300351471124032000150240ustar00nobodynobody/* General settings for the entire page */ body { margin: 0ex 0ex; padding: 0px; background-color: #fef3bc; font-family: sans-serif; } /* The project logo in the upper left-hand corner of each page */ div.logo { display: inline; text-align: center; vertical-align: bottom; font-weight: bold; font-size: 2.5em; color: #a09048; } /* The page title centered at the top of each page */ div.title { display: table-cell; font-size: 2em; font-weight: bold; text-align: left; padding: 0 0 0 5px; color: #a09048; vertical-align: bottom; width: 100%; } /* The login status message in the top right-hand corner */ div.status { display: table-cell; text-align: right; vertical-align: bottom; color: #a09048; padding: 5px 5px 0 0; font-size: 0.8em; font-weight: bold; } /* The header across the top of the page */ div.header { display: table; width: 100%; } /* The main menu bar that appears at the top of the page beneath ** the header */ div.mainmenu { padding: 5px 10px 5px 10px; font-size: 0.9em; font-weight: bold; text-align: center; letter-spacing: 1px; background-color: #a09048; color: black; } /* The submenu bar that *sometimes* appears below the main menu */ div.submenu, div.sectionmenu { padding: 3px 10px 3px 0px; font-size: 0.9em; text-align: center; background-color: #c0af58; color: white; } div.mainmenu a, div.mainmenu a:visited, div.submenu a, div.submenu a:visited, div.sectionmenu>a.button:link, div.sectionmenu>a.button:visited { padding: 3px 10px 3px 10px; color: white; text-decoration: none; } div.mainmenu a:hover, div.submenu a:hover, div.sectionmenu>a.button:hover { color: #a09048; background-color: white; } /* All page content from the bottom of the menu or submenu down to ** the footer */ div.content { padding: 1ex 5px; } div.content a { color: #706532; } div.content a:link { color: #706532; } div.content a:visited { color: #704032; } div.content a:hover { background-color: white; color: #706532; } /* Some pages have section dividers */ div.section { margin-bottom: 0px; margin-top: 1em; padding: 3px 3px 0 3px; font-size: 1.2em; font-weight: bold; background-color: #a09048; color: white; } /* The "Date" that occurs on the left hand side of timelines */ div.divider { background: #e1d498; border: 2px #a09048 solid; font-size: 1em; font-weight: normal; padding: .25em; margin: .2em 0 .2em 0; float: left; clear: left; } /* The footer at the very bottom of the page */ div.footer { font-size: 0.8em; margin-top: 12px; padding: 5px 10px 5px 10px; text-align: right; background-color: #a09048; color: white; } /* Hyperlink colors */ div.footer a { color: white; } div.footer a:link { color: white; } div.footer a:visited { color: white; } div.footer a:hover { background-color: white; color: #558195; } /* blocks */ pre.verbatim { background-color: #f5f5f5; padding: 0.5em; } /* The label/value pairs on (for example) the ci page */ table.label-value th { vertical-align: top; text-align: right; padding: 0.2ex 2ex; } /* Side-by-side diff */ table.sbsdiff { background-color: #ffffc5; font-family: fixed, Dejavu Sans Mono, Monaco, Lucida Console, monospace; font-size: 8pt; border-collapse:collapse; white-space: pre; width: 98%; border: 1px #000 dashed; } table.sbsdiff th.diffhdr { border-bottom: dotted; border-width: 1px; } table.sbsdiff tr td { white-space: pre; padding-left: 3px; padding-right: 3px; margin: 0px; } table.sbsdiff tr td.lineno { text-align: right; } table.sbsdiff tr td.meta { background-color: #a09048; text-align: center; } table.sbsdiff tr td.added { background-color: rgb(210, 210, 100); } table.sbsdiff tr td.removed { background-color: rgb(190, 200, 110); } table.sbsdiff tr td.changed { background-color: rgb(200, 210, 120); }/* The nomenclature sidebox for branches,.. */ div.sidebox { float: right; background-color: white; border-width: medium; border-style: double; margin: 10px; } /* The nomenclature title in sideboxes for branches,.. */ div.sideboxTitle { display: inline; font-weight: bold; } /* The defined element in sideboxes for branches,.. */ div.sideboxDescribed { display: inline; font-weight: bold; } /* The defined element in sideboxes for branches,.. */ span.disabled { color: red; } /* The suppressed duplicates lines in timeline, .. */ span.timelineDisabled { font-style: italic; font-size: small; } /* the format for the timeline data table */ table.timelineTable { border: 0; } /* the format for the timeline data cells */ td.timelineTableCell { vertical-align: top; text-align: left; } /* the format for the timeline leaf marks */ span.timelineLeaf { font-weight: bold; } /* the format for the timeline version links */ a.timelineHistLink { } /* the format for the timeline version display(no history permission!) */ span.timelineHistDsp { font-weight: bold; } /* the format for the timeline time display */ td.timelineTime { vertical-align: top; text-align: right; } /* the format for the grap placeholder cells in timelines */ td.timelineGraph { width: 20px; text-align: left; vertical-align: top; } /* the format for the tag links */ a.tagLink { } /* the format for the tag display(no history permission!) */ span.tagDsp { font-weight: bold; } /* the format for wiki errors */ span.wikiError { font-weight: bold; color: red; } /* the format for fixed/canceled tags,.. */ span.infoTagCancelled { font-weight: bold; text-decoration: line-through; } /* the format for fixed/cancelled tags,.. on wiki pages */ span.wikiTagCancelled { text-decoration: line-through; } /* format for the file display table */ table.browser { /* the format for wiki errors */ width: 100% ; border: 0; } /* format for cells in the file browser */ td.browser { width: 24% ; vertical-align: top; } /* format for the list in the file browser */ ul.browser { margin-left: 0.5em; padding-left: 0.5em; } /* table format for login/out label/input table */ table.login_out { text-align: left; margin-right: 10px; margin-left: 10px; margin-top: 10px; } /* captcha display options */ div.captcha { text-align: center; } /* format for the layout table, used for the captcha display */ table.captcha { margin: auto; padding: 10px; border-width: 4px; border-style: double; border-color: black; } /* format for the label cells in the login/out table */ td.login_out_label { text-align: center; } /* format for login error messages */ span.loginError { color: red; } /* format for leading text for notes */ span.note { font-weight: bold; } /* format for textarea labels */ span.textareaLabel { font-weight: bold; } /* format for the user setup layout table */ table.usetupLayoutTable { outline-style: none; padding: 0; margin: 25px; } /* format of the columns on the user setup list page */ td.usetupColumnLayout { vertical-align: top } /* format for the user list table on the user setup page */ table.usetupUserList { outline-style: double; outline-width: 1px; padding: 10px; } /* format for table header user in user list on user setup page */ th.usetupListUser { text-align: right; padding-right: 20px; } /* format for table header capabilities in user list on user setup page */ th.usetupListCap { text-align: center; padding-right: 15px; } /* format for table header contact info in user list on user setup page */ th.usetupListCon { text-align: left; } /* format for table cell user in user list on user setup page */ td.usetupListUser { text-align: right; padding-right: 20px; white-space:nowrap; } /* format for table cell capabilities in user list on user setup page */ td.usetupListCap { text-align: center; padding-right: 15px; } /* format for table cell contact info in user list on user setup page */ td.usetupListCon { text-align: left } /* layout definition for the capabilities box on the user edit detail page */ div.ueditCapBox { float: left; margin-right: 20px; margin-bottom: 20px; } /* format of the label cells in the detailed user edit page */ td.usetupEditLabel { text-align: right; vertical-align: top; white-space: nowrap; } /* color for capabilities, inherited by nobody */ span.ueditInheritNobody { color: green; } /* color for capabilities, inherited by developer */ span.ueditInheritDeveloper { color: red; } /* color for capabilities, inherited by reader */ span.ueditInheritReader { color: black; } /* color for capabilities, inherited by anonymous */ span.ueditInheritAnonymous { color: blue; } /* format for capabilities, mentioned on the user edit page */ span.capability { font-weight: bold; } /* format for different user types, mentioned on the user edit page */ span.usertype { font-weight: bold; } /* leading text for user types, mentioned on the user edit page */ span.usertype:before { content:"'"; } /* trailing text for user types, mentioned on the user edit page */ span.usertype:after { content:"'"; } /* selected lines of text within a linenumbered artifact display */ div.selectedText { font-weight: bold; color: blue; background-color: #d5d5ff; border: 1px blue solid; } /* format for missing privileges note on user setup page */ p.missingPriv { color: blue; } /* format for leading text in wikirules definitions */ span.wikiruleHead { font-weight: bold; } /* format for labels on ticket display page */ td.tktDspLabel { text-align: right; } /* format for values on ticket display page */ td.tktDspValue { text-align: left; vertical-align: top; background-color: #d0d0d0; } /* format for ticket error messages */ span.tktError { color: red; font-weight: bold; } /* format for example tables on the report edit page */ table.rpteditex { float: right; margin: 0; padding: 0; width: 125px; text-align: center; border-collapse: collapse; border-spacing: 0; } /* format for example table cells on the report edit page */ td.rpteditex { border-width: thin; border-color: #000000; border-style: solid; } /* format for user color input on checkin edit page */ input.checkinUserColor { /* no special definitions, class defined, to enable color pickers, f.e.: ** add the color picker found at http:jscolor.com as java script include ** to the header and configure the java script file with ** 1. use as bindClass :checkinUserColor ** 2. change the default hash adding behaviour to ON ** or change the class defition of element identified by id="clrcust" ** to a standard jscolor definition with java script in the footer. */ } /* format for end of content area, to be used to clear page flow(sidebox on branch,.. */ div.endContent { clear: both; } /* format for general errors */ p.generalError { color: red; } /* format for tktsetup errors */ p.tktsetupError { color: red; font-weight: bold; } /* format for xfersetup errors */ p.xfersetupError { color: red; font-weight: bold; } /* format for th script errors */ p.thmainError { color: red; font-weight: bold; } /* format for th script trace messages */ span.thTrace { color: red; } /* format for report configuration errors */ p.reportError { color: red; font-weight: bold; } /* format for report configuration errors */ blockquote.reportError { color: red; font-weight: bold; } /* format for artifact lines, no longer shunned */ p.noMoreShun { color: blue; } /* format for artifact lines beeing shunned */ p.shunned { color: blue; } /* a broken hyperlink */ span.brokenlink { color: red; } /* List of files in a timeline */ ul.filelist { margin-top: 3px; line-height: 100%; } /* side-by-side diff display */ div.sbsdiff { font-family: monospace; font-size: smaller; white-space: pre; } /* context diff display */ div.udiff { font-family: monospace; white-space: pre; } /* changes in a diff */ span.diffchng { background-color: #c0c0ff; } /* added code in a diff */ span.diffadd { background-color: #c0ffc0; } /* deleted in a diff */ span.diffrm { background-color: #ffc8c8; } /* suppressed lines in a diff */ span.diffhr { color: #0000ff; } /* line numbers in a diff */ span.diffln { color: #a0a0a0; } /* Moderation Pending message on timeline */ span.modpending { color: #b03800; font-style: italic; } tclws-3.5.0/license.terms000064400000000000000000000041571471124032000147260ustar00nobodynobodyThis software is copyrighted by the Gerald W. Leser and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the Government shall have only "Restricted Rights" as defined in Clause 252.227-7014 (b) (3) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the terms specified in this license. tclws-3.5.0/pkgIndex.tcl000064400000000000000000000011701471124032000144750ustar00nobodynobodypackage ifneeded WS::AOLserver 2.5.0 [list source [file join $dir AOLserver.tcl]] package ifneeded WS::Channel 2.5.0 [list source [file join $dir ChannelServer.tcl]] package ifneeded WS::Client 3.1.0 [list source [file join $dir ClientSide.tcl]] package ifneeded WS::Embeded 3.4.0 [list source [file join $dir Embedded.tcl]] package ifneeded WS::Server 3.5.0 [list source [file join $dir ServerSide.tcl]] package ifneeded WS::Utils 3.2.0 [list source [file join $dir Utilities.tcl]] package ifneeded WS::Wub 2.5.0 [list source [file join $dir WubServer.tcl]] package ifneeded Wsdl 2.4.0 [list source [file join $dir WubServer.tcl]]