tclws-2.3.8/docs/Creating_a_Tcl_Web_Service.html000644 001750 001750 00000025037 12500417200 021253 0ustar00mxmmxm000000 000000 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: 

             -host           - The host name for this service.
                               Defaults to "ip:port" in embedded mode,
                               and to "localhost" otherwise."
             -description    - The HTML description for this service
             -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

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.

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-2.3.8/Examples/tclhttpd/htdocs/version_history.tml000644 001750 001750 00000002200 12500417200 023161 0ustar00mxmmxm000000 000000 [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:

FTP site

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

[mypage::footer] tclws-2.3.8/Examples/Math/CallMathWebService.tcl000644 001750 001750 00000011346 12500417200 021137 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## 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-2.3.8/Wub.tcl000644 001750 001750 00000051004 12500417200 013554 0ustar00mxmmxm000000 000000 ##***************************************************************************## ## ## ## 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.2.1 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-2.3.8/Examples/wub/WubApp.tcl000644 001750 001750 00000003341 12500417200 016571 0ustar00mxmmxm000000 000000 #! /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-2.3.8/Examples/aolserver/servers/tclws/000755 001750 001750 00000000000 12500417200 020720 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/Echo/EchoWebService.tcl000644 001750 001750 00000007432 12500417200 020316 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## 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-2.3.8/Examples/Echo/EchoEmbeddedService.tcl000644 001750 001750 00000010103 12500417200 021257 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## 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 2.3.0 package require WS::Utils 2.3.0 package require WS::Embeded 2.3.0 ## ## 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 {} ::WS::Embeded::Listen 8015 set ::errorInfo {} puts stdout {Starting event loop} flush stdout ::WS::Embeded::Start puts stdout {Exited event loop} flush stdout tclws-2.3.8/docs/Tcl_Web_Service_Example.html000644 001750 001750 00000007735 12500417200 020617 0ustar00mxmmxm000000 000000 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-2.3.8/Examples/tclhttpd/htdocs/templates/self.tml000644 001750 001750 00000003171 12500417200 022652 0ustar00mxmmxm000000 000000 [::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-2.3.8/docs/Using_Options.html000644 001750 001750 00000020573 12500417200 016740 0ustar00mxmmxm000000 000000 Using Web Service Options

Using Web Service Options

[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 "

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.

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.

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.

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.

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.

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.

The default value, "0", 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.

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).

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

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.

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.

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.

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

tclws-2.3.8/Examples/aolserver/lib/aolserver-log/000755 001750 001750 00000000000 12500417200 021422 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/tclhttpd/htdocs/index.tml000644 001750 001750 00000007176 12500417200 021043 0ustar00mxmmxm000000 000000 [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-2.3.8/000755 001750 001750 00000000000 12500417200 012313 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/aolserver/servers/000755 001750 001750 00000000000 12500417200 017564 5ustar00mxmmxm000000 000000 tclws-2.3.8/CheckAndBuild.tcl000644 001750 001750 00000057162 12500417200 015452 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## Copyright (c) 2006, Arnulf Wiedemann ## 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. ## ## ## ## 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 package require WS::Utils ; # dict package require tdom package require log package provide WS::CheckAndBuild 0.0.3 namespace eval ::WS::CheckAndBuild { variable resultTree variable currNode } ########################################################################### # # 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 # tagName - The name of the starting tag # xmlString - The XML string to validate # typeInfos - The types infos # # Returns : 1 if validation ok, 0 if not # # 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/14/2006 A.Wiedemann Initial version # # ########################################################################### proc ::WS::CheckAndBuild::Validate {mode serviceName tagName xmlString typeInfos} { variable resultTree variable currNode set startInfos [dict get $typeInfos types $tagName] dom parse $xmlString resultTree $resultTree documentElement currNode set nodeName [$currNode nodeName] 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" } return [checkTags $mode $serviceName $startInfos $typeInfos] } ########################################################################### # # Public Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PUBLIC<< # # Procedure Name : ::WS::CheckAndBuild::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 # typeInfos - The types infos # # 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 # # ########################################################################### proc ::WS::CheckAndBuild::BuildRequest {mode serviceName tagName typeInfos valueInfos} { upvar $valueInfos values variable resultTree variable currNode set startInfos [dict get $typeInfos types $tagName] set resultTree [::dom createDocument $tagName] $resultTree documentElement currNode buildTags $mode $serviceName $startInfos $typeInfos $valueInfos return [$resultTree asXML] } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::CheckAndBuild::buildValue # # Description : Check a Value to be put into a tag pair according to the # XML schema description # # Arguments : # mode - Client/Server # serviceName - The name of the service # key - The element to handle # typeInfo - The type info for the element to handle # valueInfos - The name of the array with the values # # Returns : The value or an error if checking not ok # # 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 # # ########################################################################### proc ::WS::CheckAndBuild::buildValue {mode serviceName key typeInfo valueInfos} { upvar $valueInfos values catch {unset typeInfos} array set typeInfos [list \ minLength 0 \ maxLength -1 \ minOccurs 0 \ maxOccurs -1 \ fixed false \ length -1 \ ] array set typeInfos $typeInfo set val "" set gotVal 0 if {[info exists values($key)]} { set val $values($key) set gotVal 0 } set minLength $typeInfos(minLength) set maxLength $typeInfos(maxLength) set minOccurs $typeInfos(minOccurs) set maxOccurs $typeInfos(maxOccurs) set fixed $typeInfos(fixed) if {$minOccurs > 0} { if {!$gotVal} { return \ -code error \ -errorcode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $key $val $pattern]] \ "No value for '$key' which is mandatory typeInfo:$typeInfo:" } } if {$minLength >= 0} { if {[string length $val] < $minLength} { return \ -code error \ -errorcode [list WS CHECK VALUE_TO_SHORT [list $key $val $minLength $typeInfo]] \ "Value for $key: '$val' is too short, minLength: $minLength:" } } if {$maxLength >= 0} { if {[string length $val] > $maxLength} { return \ -code error \ -errorcode [list WS CHECK VALUE_TO_LONG [list $key $val $maxLength $typeInfo]] \ "Value for $key: '$val' is too long, maxLength: $maxLength:" } } set haveEnumeration 0 set isOk 0 set enumerationVals [list] set enumerationInfos [dict get $typeInfo enumeration] foreach {typeKey typeVal} $enumerationInfos { set haveEnumeration 1 lappend enumerationVals $typeVal if {[string equal $val $typeVal]} { set isOk 1 } } if {$haveEnumeration && $fixed} { return [lindex $enumerationVals 0] } if {$haveEnumeration && ! $isOk} { return \ -code error \ -errorcode [list WS CHECK VALUE_NOT_IN_ENUMERATION [list $key $val $enumerationVals $typeInfo]] \ "Value for $key: '$val' is not in enumeration values: '$enumerationVals':" } if {[info exists typeInfos(pattern)]} { set pattern $typeInfos(pattern) if {! [regexp $pattern $val]} { return \ -code error \ -errorcode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $key $val $pattern $typeInfo]] \ "Value for $key: '$val' does not match pattern: '$pattern':" } } return $val } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::CheckAndBuild::buildTags # # Description : Recursively 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 # startInfos - The infos for the current tag # typeInfos - The types infos # valueInfos - The name of the array with the values # # 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 # # ########################################################################### proc ::WS::CheckAndBuild::buildTags {mode serviceName startInfos typeInfos valueInfos} { upvar $valueInfos values variable resultTree variable currNode foreach {key value} $startInfos { lappend keyList $key } foreach entry $keyList { foreach {key dummy} $entry break if {[dict exists $startInfos $key type]} { set allDone 0 if {[info exists ::WS::Parse::simpleTypes($key)]} { if {![info exists ::WS::Parse::simpleTypes($mode,$serviceName,$key)]} { set typeInfo [list type $key] set val [buildValue $mode $serviceName $key $typeInfo $valueInfos] $currNode appendChild [$resultTree createElement $key node] $node appendChild [$resultTree createTextNode $val] set all_done 1 } } if {!$allDone} { set typeName [dict get $startInfos $key type] set typeName [string trimright $typeName "()"] if {[dict exists $typeInfos types $typeName]} { set subStartInfos [dict get $typeInfos types $typeName] set saveNode $currNode $currNode appendChild [$resultTree createElement $key currNode] buildTags $mode $serviceName $subStartInfos $typeInfos $valueInfos set currNode $saveNode } else { set simpleTypeInfos [::WS::Utils::GetServiceSimpleTypeDef $mode $serviceName $typeName] set val [buildValue $mode $serviceName $key $simpleTypeInfos $valueInfos] $currNode appendChild [$resultTree createElement $key node] $node appendChild [$resultTree createTextNode $val] } } } else { return \ -code error \ -errorcode [list WS CHECK SIMPLE_TYPES2_NOT_IMPLEMENTED [list $key $startInfos]] \ "simple type 2 part not yet implemented (in handling key: $key startInfos: $startInfos:" } } } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::CheckAndBuild::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 # key - The element to handle # value - The value to check # typeInfo - The type info for the element to handle # # Returns : 1 if ok or 0 if checking not ok # # 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/14/2006 A.Wiedemann Initial version # # ########################################################################### proc ::WS::CheckAndBuild::checkValue {mode serviceName key value typeInfo} { catch {unset typeInfos} array set typeInfos [list \ minLength 0 \ maxLength -1 \ minOccurs 0 \ maxOccurs -1 \ fixed false \ length -1 \ ] array set typeInfos $typeInfo set minLength $typeInfos(minLength) set maxLength $typeInfos(maxLength) set minOccurs $typeInfos(minOccurs) set maxOccurs $typeInfos(maxOccurs) set fixed $typeInfos(fixed) if {$minOccurs > 0} { if {[string length $value] == 0} { return \ -code error \ -errorcode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $key $value $pattern]] \ "No value for $key which is mandatory typeInfo:$typeInfo:" } } if {$minLength >= 0} { if {[string length $value] < $minLength} { return \ -code error \ -errorcode [list WS CHECK VALUE_TO_SHORT [list $key $value $minLength $typeInfo]] \ "Value for $key: '$value' is too short, minLength: $minLength:" } } if {$maxLength >= 0} { if {[string length $value] > $maxLength} { return \ -code error \ -errorcode [list WS CHECK VALUE_TO_LONG [list $key $value $maxLength $typeInfo]] \ "Value for $key: '$value' is too long, maxLength: $maxLength:" } } set haveEnumeration 0 set isOk 0 set enumerationVals [list] set enumerationInfos [dict get $typeInfo enumeration] foreach {typeKey typeVal} $enumerationInfos { set haveEnumeration 1 lappend enumerationVals $typeVal if {[string equal $value $typeVal]} { set isOk 1 } } if {$haveEnumeration && ! $isOk} { return \ -code error \ -errorcode [list WS CHECK VALUE_NOT_IN_ENUMERATION [list $key $value $enumerationVals $typeInfo]] \ "Value for $key: '$value' is not in enumeration values: '$enumerationVals':" } if {[info exists typeInfos(pattern)]} { set pattern $typeInfos(pattern) if {! [regexp $pattern $value]} { return \ -code error \ -errorcode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $key $value $pattern $typeInfo]] \ "Value for $key: '$value' does not match pattern: '$pattern':" } } return 1 } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::CheckAndBuild::checkTags # # Description : Recursively check the tags and values inside the tags # # Arguments : # mode - Client/Server # serviceName - The service name # startInfos - The infos for the current tag # typeInfos - The types infos # # Returns : 1 if ok, 0 otherwise # # 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 # # ########################################################################### proc ::WS::CheckAndBuild::checkTags {mode serviceName startInfos typeInfos} { variable resultTree variable currNode foreach {key value} $startInfos { lappend keyList $key } set node [$currNode firstChild] set lastNode [$currNode lastChild] foreach entry $keyList { foreach {key dummy} $entry break if {[dict exists $startInfos $key type]} { set allDone 0 if {[info exists ::WS::Parse::simpleTypes($key)]} { if {![info exists ::WS::Parse::simpleTypes($mode,$serviceName,$key)]} { set typeInfo [list type $key] if {[$node hasChildNodes]} { set textNode [$node firstChild] set value [$textNode nodeValue] } else { # there is no text node so set value to empty set value "" } checkValue $mode $serviceName $key $value $typeInfo set all_done 1 } } if {!$allDone} { set typeName [dict get $startInfos $key type] set typeName [string trimright $typeName "()"] if {[dict exists $typeInfos types $typeName]} { set subStartInfos [dict get $typeInfos types $typeName] set currNode $node checkTags $mode $serviceName $subStartInfos $typeInfos set node $currNode } else { set simpleTypeInfos [::WS::Utils::GetServiceSimpleTypeDef $mode $serviceName $typeName] if {[$node hasChildNodes]} { set textNode [$node firstChild] set value [$textNode nodeValue] } else { # there is no text node so set value to empty set value "" } checkValue $mode $serviceName $key $value $simpleTypeInfos } } } else { return \ -code error \ -errorcode [list WS CHECK SIMPLE_TYPES2_NOT_IMPLEMENTED [list $key $startInfos]] \ "simple type 2 part not yet implemented (in handling key: $key startInfos: $startInfos:" } if {$node != $lastNode} { set node [$node nextSibling] } } return 1 } tclws-2.3.8/Examples/aolserver/servers/tclws/pages/favicon.ico000644 001750 001750 00000000476 12500417200 024147 0ustar00mxmmxm000000 000000 (( €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-2.3.8/Examples/aolserver/servers/tclws/modules/tcl/tclws/000755 001750 001750 00000000000 12500417200 024306 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/tclhttpd/htdocs/templates/form.tml000644 001750 001750 00000002115 12500417200 022661 0ustar00mxmmxm000000 000000 [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-2.3.8/AOLserver.tcl000644 001750 001750 00000004736 12500417200 014673 0ustar00mxmmxm000000 000000 package require Tcl 8.4 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.0.0 tclws-2.3.8/Examples/tclhttpd/htdocs/templates/index.tml000644 001750 001750 00000005764 12500417200 023042 0ustar00mxmmxm000000 000000 [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-2.3.8/Examples/aolserver/servers/tclws/pages/ws/echoexample/index.tcl000644 001750 001750 00000002156 12500417200 026561 0ustar00mxmmxm000000 000000 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-2.3.8/Examples/tclhttpd/htdocs/register.tml000644 001750 001750 00000003105 12500417200 021544 0ustar00mxmmxm000000 000000 [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-2.3.8/Examples/tclhttpd/custom/MathWebService.tcl000644 001750 001750 00000011640 12500417200 022607 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## 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-2.3.8/Examples/tclhttpd/htdocs/test.tml000644 001750 001750 00000001006 12500417200 020675 0ustar00mxmmxm000000 000000 [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-2.3.8/Examples/aolserver/000755 001750 001750 00000000000 12500417200 016073 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/Echo/CallEchoWebService.tcl000644 001750 001750 00000010711 12500417200 021104 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## 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::Utils 2.1.3 package require WS::Client 2.1.3 ## ## 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-2.3.8/docs/index.html000644 001750 001750 00000006076 12500417200 015251 0ustar00mxmmxm000000 000000 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:

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

Lastly following packages are additionally used in Embedded Server mode:

tclws-2.3.8/Examples/tclhttpd/000755 001750 001750 00000000000 12500417200 015717 5ustar00mxmmxm000000 000000 tclws-2.3.8/docs/style.css000644 001750 001750 00000030035 12500417200 015116 0ustar00mxmmxm000000 000000 /* 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-2.3.8/ChannelServer.tcl000644 001750 001750 00000026710 12500417200 015564 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## 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 # 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.0.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-2.3.8/docs/Dictionary_Representation_of_XML_Arrays.html000644 001750 001750 00000004437 12500417200 024055 0ustar00mxmmxm000000 000000 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-2.3.8/Examples/tclhttpd/custom/dodirs.tcl000755 001750 001750 00000000754 12500417200 021232 0ustar00mxmmxm000000 000000 # 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-2.3.8/Examples/aolserver/tclws.tcl000644 001750 001750 00000005562 12500417200 017743 0ustar00mxmmxm000000 000000 # # $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-2.3.8/docs/Defining_Types.html000644 001750 001750 00000016561 12500417200 017051 0ustar00mxmmxm000000 000000 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-2.3.8/docs/Embedded_Web_Service.html000644 001750 001750 00000005437 12500417200 020110 0ustar00mxmmxm000000 000000 Embeding a Web Service

Embeding a Web Service

Contents

Loading the Webservices Server Package

To load the webservices server package, do: 

 package require WS::Embedded

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

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. Defaults to {}.
     keyfile  -- Name of the key file. Defaults to {}.
     userpwds -- A list of username:password. Defaults to {}.
     realm    -- The seucrity realm. Defaults to {}.

Returns : Handle of socket

Side-Effects : None

Exception Conditions :  : None

Pre-requisite Conditions : None

Enter the event queue

To serve any requests, the interpreter must enter the event queue using, for example:

     vwait waitVariable

Stop the server

To stop serving requests, the server socket may be closed. The socket handle was returned by ::WS::Embeded::Listen. Optionally, the event queue may be stopped as follows:

     close $handle
     set waitVariable 1
tclws-2.3.8/Examples/aolserver/servers/tclws/pages/global/file-not-found.tcl000644 001750 001750 00000000561 12500417200 026613 0ustar00mxmmxm000000 000000 # 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-2.3.8/Examples/aolserver/lib/aolserver-log/log.tcl000644 001750 001750 00000000242 12500417200 022705 0ustar00mxmmxm000000 000000 namespace eval ::log { proc log {level args} { ::ns_log [string totitle $level] [join $args " "] } namespace export * } package provide log 2.4.0 tclws-2.3.8/Examples/aolserver/servers/tclws/pages/global/server-error.tcl000644 001750 001750 00000000111 12500417200 026411 0ustar00mxmmxm000000 000000 global errorInfo ns_return 500 text/plain "Oops screwed up: $errorInfo" tclws-2.3.8/ServerSide.tcl000644 001750 001750 00000225645 12500417200 015110 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## 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.4 package require WS::Utils 2.3.7 ; # provides dict package require html package require log package require tdom package provide WS::Server 2.3.7 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: # -host - The host name for this service. # Defaults to "ip:port" in embedded mode, # and to "localhost" otherwise. # -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 # # # 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 # # ########################################################################### proc ::WS::Server::Service {args} { variable serviceArr variable procInfo variable mode ::log::log debug "Defining Service as $args" array set defaults { -description {} -checkheader {::WS::Server::ok} -inheaders {} -outheaders {} -intransform {} -outtransform {} -htmlhead {TclHttpd Based Web Services} -author {} -description {} -mode {tclhttpd} -ports {80} -traceEnabled {Y} -docFormat {text} -stylesheet {} } array set defaults $args if {[string equal $defaults(-mode) channel]} { set defaults(-ports) {stdin stdout} array set defaults $args } set requiredList {-service} set missingList {} foreach opt $requiredList { if {![info exists defaults($opt)]} { lappend missingList $opt } } if {[llength $missingList]} { return \ -code error \ -errorcode [list WSSERVER MISSREQARG $missingList] \ "Missing required arguments '[join $missingList {,}]'" } set service $defaults(-service) if {![info exists defaults(-prefix)]} { set defaults(-prefix) /service/$service } # find default host if {![info exists defaults(-host)]} { switch -exact -- $defaults(-mode) { embedded { set me [socket -server garbage_word -myaddr [info hostname] 0] set defaults(-host) [lindex [fconfigure $me -sockname] 0] close $me if {0 !=[llength $defaults(-ports)] && 80 != [lindex $defaults(-ports) 0]} { append defaults(-host) ":[lindex $defaults(-ports) 0]" } } default { set defaults(-host) localhost } } } set defaults(-uri) $service namespace eval ::$service {} set serviceArr($service) [array get defaults] if {![dict exists $procInfo $service operationList]} { dict set procInfo $service operationList {} } set mode $defaults(-mode) ## ## Install wsdl doc ## interp alias {} ::WS::Server::generateInfo_${service} \ {} ::WS::Server::generateInfo ${service} ::log::log debug "Installing Generate info for $service at $defaults(-prefix)" switch -exact -- $mode { embedded { package require WS::Embeded 2.1.3 foreach port $defaults(-ports) { ::WS::Embeded::AddHandler $port $defaults(-prefix) ::WS::Server::generateInfo_${service} } } tclhttpd { ::Url_PrefixInstall $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 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 $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::log debug "Installing GenerateWsdl info for $service at $defaults(-prefix)/wsdl" switch -exact -- $mode { embedded { foreach port $defaults(-ports) { ::WS::Embeded::AddHandler $port $defaults(-prefix)/wsdl ::WS::Server::generateWsdl_${service} } } channel { package require WS::Channel ::WS::Channel::AddHandler $defaults(-ports) {} ::WS::Server::generateWsdl_${service} } tclhttpd { ::Url_PrefixInstall $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::log debug "Installing callOperation info for $service at $defaults(-prefix)/op" switch -exact -- $mode { embedded { foreach port $defaults(-ports) { ::WS::Embeded::AddHandler $port $defaults(-prefix)/op ::WS::Server::callOperation_${service} } } channel { package require WS::Channel ::WS::Channel::AddHandler $defaults(-ports) {op} ::WS::Server::callOperation_${service} } tclhttpd { ::Url_PrefixInstall $defaults(-prefix)/op ::WS::Server::callOperation_${service} \ -thread 1 } default { ## Do nothing } } return; } ########################################################################### # # 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 three 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 # 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 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] ::log::log debug "Defining operation $name for $service" set argOrder {} ::log::log 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] ::WS::Utils::ServiceTypeDef Server $service ${name}Results [list ${name}Result $typeInfo] ::WS::Utils::ServiceTypeDef Server $service ${name}Request $arglist set tclArgList {} foreach {arg typeinfo} $arglist { lappend tclArgList [lindex $arg 0] } 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:// # # 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 # # ########################################################################### proc ::WS::Server::GetWsdl {serviceName {urlPrefix ""}} { variable serviceArr variable procInfo array set serviceData $serviceArr($serviceName) set operList [lsort -dictionary [dict get $procInfo $serviceName operationList]] ::log::log 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://$serviceData(-host)$serviceData(-prefix)" \ targetNamespace "http://$serviceData(-host)$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 $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 $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 $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 "http://$serviceData(-host)" } $address setAttribute \ location "$urlPrefix$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 $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 $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 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 - 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 # 2 12/12/2009 W.Kocjan Support for services over SSL in Tclhttpd # # ########################################################################### proc ::WS::Server::generateWsdl {serviceName sock args} { variable serviceArr variable procInfo variable mode array set serviceData $serviceArr($serviceName) set operList [lsort -dictionary [dict get $procInfo $serviceName operationList]] ::log::log debug "Generating WSDL for $serviceName on $sock with {$args}" 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 { ::WS::Embeded::ReturnData \ $sock \ "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 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 } switch -exact -- $mode { tclhttpd { upvar #0 ::Httpd$sock s set urlPrefix "" catch { set urlPrefix [lindex $s(self) 0]://$serviceData(-host) set urlPrefix [lindex $s(self) 0]://$s(mime,host) } set xml [GetWsdl $serviceName $urlPrefix] ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } channel { set xml [GetWsdl $serviceName] ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } embedded { set xml [GetWsdl $serviceName] ::WS::Embeded::ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } rivet { set xml [GetWsdl $serviceName] headers type text/xml headers numeric 200 puts $xml } aolserver { set xml [GetWsdl $serviceName] ::WS::AOLserver::ReturnData $sock text/xml $xml 200 } wibble { set xml [GetWsdl $serviceName] upvar 1 [lindex $args 0] responseDict ::WS::Wibble::ReturnData responseDict text/xml $xml 200 } default { ## Do nothing } } } ########################################################################### # # 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 # # 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 # ########################################################################### proc ::WS::Server::GenerateScheme {mode serviceName doc parent} { variable serviceArr array set serviceData $serviceArr($serviceName) set targetNamespace "http://$serviceData(-host)$serviceData(-prefix)" return [::WS::Utils::GenerateScheme $mode $serviceName $doc $parent $targetNamespace] } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Server::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 - 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::generateInfo {service sock args} { variable serviceArr variable procInfo variable mode ::log::log debug "Generating HTML Documentation for $service on $sock with {$args}" if {![info exists serviceArr($service)]} { set msg "Unknown service '$service'" switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData \ $sock \ "text/html; charset=UTF-8" \ "Webservice Error

$msg

" \ 404 } embedded { ::WS::Embeded::ReturnData \ $sock \ "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($service) $menuList] ## ## Display TOC ## append msg [generateTocInfo $serviceArr($service) $menuList] ## ## Display Operations ## ::log::log debug "\tDisplay Operations" append msg [generateOperationInfo $serviceArr($service) $menuList] ## ## Display custom types ## ::log::log debug "\tDisplay custom types" append msg [generateCustomTypeInfo $serviceArr($service) $menuList] ## ## Display list of simple types ## ::log::log debug "\tDisplay list of simply types" append msg [generateSimpleTypeInfo $serviceArr($service) $menuList] ## ## All Done ## append msg [::html::end] switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData $sock "text/html; charset=UTF-8" $msg 200 } embedded { ::WS::Embeded::ReturnData $sock "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 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 } } } ########################################################################### # # 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 # 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::callOperation {service sock args} { variable procInfo variable serviceArr variable mode switch -exact -- $mode { embedded { upvar #0 ::WS::Embeded::Httpd$sock data set inXML $data(query) #parray data } 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) } } ::log::log debug "In ::WS::Server::callOperation {$service $sock $args}" array set serviceInfo $serviceArr($service) ::log::log debug "\tDocument is {$inXML}" set ::errorInfo {} set ::errorCode {} set ns $service set inTransform $serviceInfo(-intransform) set outTransform $serviceInfo(-outtransform) set first [string first {<} $inXML] if {$first > 0} { set inXML [string range $inXML $first end] } if {![string equal $inTransform {}]} { set inXML [$inTransform REQUEST $inXML] } dom parse $inXML doc $doc documentElement top ::log::log debug [list $doc selectNodesNamespaces \ [list ENV http://schemas.xmlsoap.org/soap/envelope/ \ $service http://$serviceInfo(-host)$serviceInfo(-prefix)]] $doc selectNodesNamespaces \ [list ENV http://schemas.xmlsoap.org/soap/envelope/ \ $service http://$serviceInfo(-host)$serviceInfo(-prefix)] $doc documentElement rootNode ## ## Determine the name of the method being invoked. ## set top [$rootNode selectNodes /ENV:Envelope/ENV:Body/*] catch {$top localName} requestMessage set legacyRpcMode 0 if {$requestMessage == ""} { # older RPC/Encoded clients need to try nodeName instead. # Python pySoap needs this. catch {$top nodeName} requestMessage set legacyRpcMode 1 } ::log::log debug "requestMessage = {$requestMessage}" if {[string match {*Request} $requestMessage]} { set operation [string range $requestMessage 0 end-7] } else { # broken clients might not have sent the correct Document Wrapped name. # Python pySoap and Perl SOAP::Lite need this. set operation $requestMessage set legacyRpcMode 1 } ## ## Check that the method exists. ## if {![dict exists $procInfo $service op$operation argList]} { set msg "Method $operation not found" ::log::log error $msg set ::errorInfo {} set ::errorCode [list Server UNKNOWN_METHOD $operation] set xml [generateError \ $serviceInfo(-traceEnabled) \ CLIENT \ $msg \ [list "errorCode" $::errorCode "stackTrace" $::errorInfo]] catch {$doc delete} ::log::log debug "Leaving @ error 1::WS::Server::callOperation $xml" switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 500 } embedded { ::WS::Embeded::ReturnData $sock "text/xml; charset=UTF-8" $xml 500 } rivet { headers type text/xml headers numeric 500 puts $xml } aolserver { ::WS::AOLserver::ReturnData $sock text/xml $xml 500 } wibble { ::WS::Wibble::ReturnData responseDict text/xml $xml 500 } default { ## Do nothing } } return; } 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 { foreach pass [list 1 2 3] { set tclArgList {} set gotAnyArgs 0 set argIndex 0 foreach argName [dict get $procInfo $ns $cmdName argOrder] { set argType [string trim [dict get $argInfo $argName type]] set typeInfoList [::WS::Utils::TypeInfo Server $service $argType] if {$pass == 1} { # access arguments by name using full namespace set path $service:$argName set node [$top selectNodes $path] } elseif {$pass == 2} { # legacyRpcMode only, access arguments by unqualified name set path $argName set node [$top selectNodes $path] } else { # legacyRpcMode only, access arguments by index set path "legacy argument index $argIndex" set node [lindex [$top childNodes] $argIndex] incr argIndex } if {[string equal $node {}]} { ::log::log debug "did not find argument for $argName using $path, leaving blank" lappend tclArgList {} continue } ::log::log debug "found argument $argName using $path, processing $node" set gotAnyArgs 1 switch -exact -- $typeInfoList { {0 0} { ## ## Simple non-array ## lappend tclArgList [$node asText] } {0 1} { ## ## Simple array ## set tmp {} foreach row $node { lappend tmp [$row asText] } lappend tclArgList $tmp } {1 0} { ## ## Non-simple non-array ## lappend tclArgList [::WS::Utils::convertTypeToDict Server $service $node $argType $top] } {1 1} { ## ## Non-simple array ## set tmp {} set argType [string trimright $argType {()}] foreach row $node { lappend tmp [::WS::Utils::convertTypeToDict Server $service $row $argType $top] } lappend tclArgList $tmp } default { ## Do nothing } } } ::log::log debug "gotAnyArgs $gotAnyArgs, legacyRpcMode $legacyRpcMode" if {$gotAnyArgs || !$legacyRpcMode} break } ::log::log debug "finalargs $tclArgList" } errMsg]} { ::log::log error $errMsg set localerrorCode $::errorCode set localerrorInfo $::errorInfo set xml [generateError \ $serviceInfo(-traceEnabled) \ CLIENT \ "Error Parsing Arguments -- $errMsg" \ [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo]] catch {$doc delete} ::log::log debug "Leaving @ error 3::WS::Server::callOperation $xml" switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 500 } embedded { ::WS::Embeded::ReturnData $sock "text/xml; charset=UTF-8" $xml 500 } channel { ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $xml 500 } rivet { headers type text/xml headers numeric 500 puts $xml } aolserver { ::WS::AOLserver::ReturnData $sock text/xml $xml 500 } wibble { ::WS::Wibble::ReturnData responseDict text/xml $xml 500 } default { ## Do nothing } } return; } ## ## Run the premonitor hook, if necessary. ## if {[info exists serviceInfo(-premonitor)] && [string length $serviceInfo(-premonitor)]} { set precmd $serviceInfo(-premonitor) lappend precmd PRE $service $operation $tclArgList catch $precmd } ## ## Convert the HTTP request headers. ## set headerList {} foreach headerType $serviceInfo(-inheaders) { if {[string equal $headerType {}]} { continue } foreach node [$top selectNodes data:$headerType] { lappend headerList [::WS::Utils::convertTypeToDict Server $service $node $headerType $top] } } ## ## Actually execute the method. ## if {[catch { set cmd $serviceInfo(-checkheader) switch -exact -- $mode { wibble { lappend cmd \ $ns \ $baseName \ [dict get $requestDict peerhost] \ [dict keys [dict get $requestDict header]] \ $headerList } embedded { lappend cmd $ns $baseName $data(ipaddr) $data(headers) $headerList } default { lappend cmd $ns $baseName $data(ipaddr) $data(headerlist) $headerList } } eval $cmd set results [eval \$methodName $tclArgList] # generate a reply packet set xml [generateReply $ns $baseName $results] # regsub "\]+>\n" $xml {} xml catch {$doc delete} set xml [string map {{} {}} $xml] if {![string equal $outTransform {}]} { set xml [$outTransform REPLY $xml $operation $results] } if {[info exists serviceInfo(-postmonitor)] && [string length $serviceInfo(-postmonitor)]} { set precmd $serviceInfo(-postmonitor) lappend precmd POST $service $operation OK $results catch $precmd } ::log::log debug "Leaving ::WS::Server::callOperation $xml" switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } embedded { ::WS::Embeded::ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } channel { ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $xml 200 } rivet { headers type text/xml headers numeric 200 puts $xml } aolserver { ::WS::AOLserver::ReturnData $sock text/xml $xml 200 } wibble { ::WS::Wibble::ReturnData responseDict text/xml $xml 200 } default { ## Do nothing } } } msg]} { ## ## Handle errors ## set localerrorCode $::errorCode set localerrorInfo $::errorInfo if {[info exists serviceInfo(-postmonitor)] && [string length $serviceInfo(-postmonitor)]} { set precmd $serviceInfo(-postmonitor) lappend precmd POST $service $operation ERROR $msg catch $precmd } set xml [generateError \ $serviceInfo(-traceEnabled) \ CLIENT \ $msg \ [list "errorCode" $localerrorCode "stackTrace" $localerrorInfo]] catch {$doc delete} ::log::log debug "Leaving @ error 2::WS::Server::callOperation $xml" switch -exact -- $mode { tclhttpd { ::Httpd_ReturnData $sock "text/xml; charset=UTF-8" $xml 500 } embedded { ::WS::Embeded::ReturnData $sock "text/xml; charset=UTF-8" $xml 500 } channel { ::WS::Channel::ReturnData $sock "text/xml; charset=UTF-8" $xml 500 } rivet { headers type text/xml headers numeric 500 puts $xml } aolserver { ::WS::AOLserver::ReturnData $sock text/xml $xml 500 } wibble { ::WS::Wibble::ReturnData responseDict text/xml $xml 500 } default { ## Do nothing } } return; } return; } ########################################################################### # # 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. # # 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} { ::log::log 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 } } 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 "SOAP-ENV:faultcode" fcd] $fcd appendChild [$doc createTextNode $faultcode] $flt appendChild [$doc createElement "SOAP-ENV:faultstring" fst] $fst appendChild [$doc createTextNode $faultstring] if { $detail != {} } { $flt appendChild [$doc createElement "SOAP-ENV:detail" dtl0] $dtl0 appendChild [$doc createElement "e:errorInfo" dtl] $dtl setAttribute "xmlns:e" "urn:TclErrorInfo" foreach {detailName detailInfo} $detail { if {!$includeTrace && $detailName == "stackTrace"} { continue } $dtl appendChild [$doc createElement $detailName err] $err appendChild [$doc createTextNode $detailInfo] } } # serialize the DOM document and return the XML text append xml \ {} \ "\n" \ [$doc asXML -indent none -doctypeDeclaration 0] $doc delete ::log::log debug "Leaving (error) ::WS::Server::generateError $xml" return $xml } ########################################################################### # # 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 # # # 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 # # ########################################################################### proc ::WS::Server::generateReply {serviceName operation results} { ::log::log debug "Entering ::WS::Server::generateReply $serviceName $operation {$results}" variable serviceArr array set serviceData $serviceArr($serviceName) if {[info exists ::Config(docRoot)] && [file exists [file join $::Config(docRoot) $serviceName $operation.css]]} { set replaceText [format {}\ $serviceData(-host) \ $serviceName \ $operation] append replaceText "\n" } else { set replaceText {} } dom createDocument "SOAP-ENV:Envelope" doc $doc documentElement env $env setAttribute \ "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" \ "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" \ "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" \ "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" \ xmlns:$serviceName "http://$serviceData(-host)$serviceData(-prefix)" if {[llength $serviceData(-outheaders)]} { $env appendChild [$doc createElement "SOAP-ENV:Header" header] foreach headerType $serviceData(-outheaders) { #$header appendChild [$doc createElement ${serviceName}:${headerType} part] #::WS::Utils::convertDictToType Server $serviceName $doc $part $results $headerType ::WS::Utils::convertDictToType Server $serviceName $doc $header $results $headerType } } $env appendChild [$doc createElement "SOAP-ENV:Body" body] $body appendChild [$doc createElement ${serviceName}:${operation}Results reply] ::WS::Utils::convertDictToType Server $serviceName $doc $reply $results ${serviceName}:${operation}Results append xml \ {} \ "\n" \ [$doc asXML -indent none -doctypeDeclaration 0] #regsub "\]*>\n" [::dom::DOMImplementation serialize $doc] $replaceText xml $doc delete ::log::log debug "Leaving ::WS::Server::generateReply $xml" return $xml } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : :WS::Server::ok # # Description : Stub for header check # # Arguments : # serviceName - The name of the service # operation - The name of the operation # results - The results as a dictionary object # # # 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 # # ########################################################################### proc ::WS::Server::ok {args} { return; } ########################################################################### # # 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 - 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 {serviceInfo menuList} { variable procInfo ::log::log debug "\tDisplay Service General Information" array set serviceData $serviceInfo set service [dict get $serviceInfo -service] ::html::init ::html::author $serviceData(-author) if {[string equal $serviceData(-description) {}]} { ::html::description "Automatically generated human readable documentation for '$service'" } else { ::html::description $serviceData(-description) } if {$serviceData(-stylesheet) != ""} { ::html::headTag "link rel=\"stylesheet\" type=\"text/css\" href=\"$serviceData(-stylesheet)\"" } set head $serviceData(-htmlhead) set msg [::html::head $head] append msg [::html::bodyTag] array unset serviceData -service if {[info exists serviceData(-description)]} { set serviceData(-description) [::html::nl2br $serviceData(-description)] } set wsdl [format {WSDL(xml)} $serviceData(-prefix) wsdl] append msg [::html::openTag center] [::html::h1 "$head -- $wsdl"] [::html::closeTag] \ [::html::openTag table {border="2"}] foreach key [lsort -dictionary [array names serviceData]] { if {[string equal $serviceData($key) {}]} { append msg [::html::row [string range $key 1 end] {N/A}] } else { append msg [::html::row [string range $key 1 end] $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 : # serviceName - The name of the service # sock - The socket to return the WSDL on # args - not used # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : 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::generateTocInfo {serviceInfo menuList} { variable procInfo ## ## Display TOC ## ::log::log debug "\tTOC" set service [dict get $serviceInfo -service] append msg [::html::h2 {List of Operations}] set operList {} foreach oper [lsort -dictionary [dict get $procInfo $service operationList]] { 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 : # serviceName - The name of the service # sock - The socket to return the WSDL on # args - not used # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : 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::generateOperationInfo {serviceInfo menuList} { variable procInfo ## ## Display Operations ## ::log::log debug "\tDisplay Operations" set service [dict get $serviceInfo -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 $serviceInfo -docFormat] foreach {oper anchor} $operList { ::log::log debug "\t\tDisplaying '$oper'" 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;"}] append msg [::html::openTag {table} {border="2"}] append msg [::html::hdrRow Name Type Description] foreach arg [dict get $procInfo $service op$oper argOrder] { ::log::log debug "\t\t\tDisplaying '$arg'" if {[dict exists $procInfo $service op$oper argList $arg comment]} { set comment [dict get $procInfo $service op$oper argList $arg comment] } else { set comment {} } append msg [::html::row \ $arg \ [displayType $service [dict get $procInfo $service op$oper argList $arg type]] \ $comment \ ] } append msg [::html::closeTag] 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 {![llength $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 : # serviceName - The name of the service # sock - The socket to return the WSDL on # args - not used # # Returns : # 1 - On error # 0 - On success # # Side-Effects : None # # Exception Conditions : None # # Pre-requisite Conditions : None # # Original Author : 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::generateCustomTypeInfo {serviceInfo menuList} { variable procInfo ## ## Display custom types ## ::log::log debug "\tDisplay custom types" set service [dict get $serviceInfo -service] append msg [::html::h2 {Custom Types}] set localTypeInfo [::WS::Utils::GetServiceTypeDef Server $service] foreach type [lsort -dictionary [dict keys $localTypeInfo]] { ::log::log debug "\t\tDisplaying '$type'" set 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] foreach part [lsort -dictionary [dict keys $typeDetails]] { ::log::log debug "\t\t\tDisplaying '$part'" append msg [::html::row \ $part \ [displayType $service [dict get $typeDetails $part type]] ] } 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::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 - 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::generateSimpleTypeInfo {serviceInfo menuList} { variable procInfo ## ## Display list of simple types ## ::log::log debug "\tDisplay list of simply types" set service [dict get $serviceInfo -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::log 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::log 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-2.3.8/Examples/tclhttpd/custom/faq.tcl000644 001750 001750 00000007326 12500417200 020514 0ustar00mxmmxm000000 000000 # # 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-2.3.8/docs/Tcl_Web_Service_Math_Example.html000644 001750 001750 00000007505 12500417200 021563 0ustar00mxmmxm000000 000000 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-2.3.8/Examples/aolserver/servers/tclws/pages/ws/mathexample/000755 001750 001750 00000000000 12500417200 024755 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/tclhttpd/custom/hello.tcl000644 001750 001750 00000000753 12500417200 021045 0ustar00mxmmxm000000 000000 # 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-2.3.8/Examples/Echo/EchoRivetService.rvt000644 001750 001750 00000005601 12500417200 020717 0ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/tclhttpd/htdocs/templates/faqfaq.tml000644 001750 001750 00000003551 12500417200 023162 0ustar00mxmmxm000000 000000 [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-2.3.8/ClientSide.tcl000644 001750 001750 00000434413 12500417200 015053 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## 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.4 package require WS::Utils 2.3.7 ; # dict, lassign package require tdom 0.8 package require http 2 package require log package require uri catch { package require tls http::register https 443 [list ::tls::socket -ssl2 no -ssl3 no -tls1 yes] } package provide WS::Client 2.3.8 namespace eval ::WS::Client { ## ## 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 } 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 an option # # Arguments : # option - Option to be set/retrieved # args - Value to set the option to # # 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 ########################################################################### proc ::WS::Client::SetOption {option args} { variable options if {[info exists options($option)]} { if {[llength $args] == 0} { return $options($option) } elseif {[llength $args] == 1} { set options($option) [lindex $args 0] } else { return -code error \ -errorcode [list WS CLIENT INVALDCNT $args] \ "Invalid number of values: '$args'" } } else { return -code error \ -errorcode [list WS CLIENT UNKOPT $option] \ "Uknown option: '$option'" } } ########################################################################### # # 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 # # ########################################################################### proc ::WS::Client::CreateService {serviceName type url target args} { variable serviceArr variable options 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 [array names options] { dict set serviceArr($serviceName) $item $options($item) } foreach {name value} $args { set name [string trimleft $name {-}] dict set serviceArr($serviceName) $name $value } ::log::log debug "Setting Target Namespace tns1 as $target" if {[dict exists $serviceArr($serviceName) xns]} { foreach xnsItem [dict get $serviceArr($serviceName) xns] { lassign $xnsItem tns xns ::log::log debug "Setting targetNamespace $tns for $xns" 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 # item - The item to configure # value - Optional, the new value # # 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/14/2009 G.Lester Initial version # # ########################################################################### proc ::WS::Client::Config {serviceName item {value {}}} { variable serviceArr variable options set serviceInfo $serviceArr($serviceName) set validOptionList [array names options] lappend validOptionList location targetNamespace if {[lsearch -exact $validOptionList $item] == -1} { return -code error "Uknown option '$item' -- must be one of: [join $validOptionList {, }]" } if {![string equal $value {}]} { dict set serviceInfo $item $value set serviceArr($serviceName) $serviceInfo } return [dict get $serviceInfo $item] } ########################################################################### # # 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 {![string equal $inputArgs {}]} { set inType $objectName.$operationName.Request ::WS::Utils::ServiceTypeDef Client $serviceName $inType $inputArgs } else { set inType {} } if {![string equal $returnType {}]} { 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 # # ########################################################################### proc ::WS::Client::ImportNamespace {serviceName url} { variable serviceArr switch -exact -- [dict get [::uri::split $url] scheme] { file { upvar #0 [::uri::geturl $url] token set xml $token(data) unset token } http - https { set token [::http::geturl $url] ::http::wait $token set ncode [::http::ncode $token] set xml [::http::data $token] ::http::cleanup $token if {$ncode != 200} { return \ -code error \ -errorcode [list WS CLIENT HTTPFAIL $url] \ "HTTP get of import file failed '$url'" } } default { return \ -code error \ -errorcode [list WS CLIENT UNKURLTYP $url] \ "Unknown URL type '$url'" } } set tnsCount [expr {[llength [dict get $serviceArr($serviceName) targetNamespace]]/2}] set serviceInfo $serviceArr($serviceName) dict lappend serviceInfo imports $url ::WS::Utils::ProcessImportXml Client $url $xml $serviceName serviceInfo tnsCount set serviceArr($serviceName) $serviceInfo set result {} foreach {result target} [dict get $serviceArr($serviceName) targetNamespace] { if {[string equal $target $url]} { 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 {[string equal $object {}]} { 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 and 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 $operationName soapReplyHeader] lappend soapReplyHeader $headerType dict set serviceInfo operation $operationName 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 # # ########################################################################### proc ::WS::Client::LoadParsedWsdl {serviceInfo {headers {}} {serviceAlias {}}} { variable serviceArr variable options 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 if {[dict exists $serviceInfo types]} { foreach {typeName partList} [dict get $serviceInfo types] { set definition [dict get $partList definition] set xns [dict get $partList xns] set isAbstarct [dict get $partList abstract] if {[string equal [lindex [split $typeName {:}] 1] {}]} { ::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 {[string equal [lindex [split $typeName {:}] 1] {}]} { ::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. # # 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 # # ########################################################################### proc ::WS::Client::GetAndParseWsdl {url {headers {}} {serviceAlias {}}} { variable currentBaseUrl set currentBaseUrl $url switch -exact -- [dict get [::uri::split $url] scheme] { file { upvar #0 [::uri::geturl $url] token set wsdlInfo [ParseWsdl $token(data) -headers [string map {\{ \" \} \"} $headers] -serviceAlias $serviceAlias] unset token } http - https { if {[llength $headers]} { set token [::WS::Utils::geturl_followRedirects $url -headers [string map {\{ \" \} \"} $headers]] } else { set token [::WS::Utils::geturl_followRedirects $url] } ::http::wait $token set wsdlInfo [ParseWsdl [::http::data $token] -headers [string map {\{ \" \} \"} $headers] -serviceAlias $serviceAlias] ::http::cleanup $token } 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 # # Arguments : # wsdlXML - XML of the WSDL # # Optional Arguments: # -createStubs 0|1 - create stub routines for the service # NOTE -- Webservice arguments are position # independent, thus the proc arguments # will be defined in alphabetical order. # -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 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 # # ########################################################################### proc ::WS::Client::ParseWsdl {wsdlXML args} { variable currentBaseUrl variable serviceArr array set defaults { -createStubs 0 -headers {} -serviceAlias {} } array set defaults $args set first [string first {<} $wsdlXML] if {$first > 0} { set wsdlXML [string range $wsdlXML $first end] } ::log::log debug "Parsing WSDL {$wsdlXML}" dom parse $wsdlXML tmpdoc $tmpdoc xslt $::WS::Utils::xsltSchemaDom wsdlDoc $tmpdoc delete $wsdlDoc documentElement wsdlNode set nsCount 1 set targetNs [$wsdlNode getAttribute targetNamespace] set ::WS::Utils::targetNs $targetNs dict set nsDict url $targetNs tns$nsCount foreach itemList [$wsdlNode attributes xmlns:*] { set ns [lindex $itemList 0] set url [$wsdlNode 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 } dict set nsDict tns $ns $tns } $wsdlDoc selectNodesNamespaces { w http://schemas.xmlsoap.org/wsdl/ d http://schemas.xmlsoap.org/wsdl/soap/ xs http://www.w3.org/2001/XMLSchema } if {[info exists currentBaseUrl]} { set url $currentBaseUrl } else { set url $targetNs } array unset ::WS::Utils::includeArr ::WS::Utils::ProcessIncludes $wsdlNode $url if {[string length $defaults(-serviceAlias)]} { set serviceAlias $defaults(-serviceAlias) } else { set serviceAlias {} } set serviceInfo {} foreach serviceInfo [buildServiceInfo $wsdlNode $nsDict $serviceInfo $serviceAlias] { set serviceName [dict get $serviceInfo name] if {[llength $defaults(-headers)]} { dict set serviceInfo headers $defaults(-headers) } dict set serviceInfo types [::WS::Utils::GetServiceTypeDef Client $serviceName] dict set serviceInfo simpletypes [::WS::Utils::GetServiceSimpleTypeDef Client $serviceName] set serviceArr($serviceName) $serviceInfo if {$defaults(-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 {[string equal $inputHeaderType {}]} { continue } set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] set headerFields [dict keys [dict get $headerTypeInfo definition]] if {![string equal $headerFields {}]} { 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::log debug "no definition found for inputMsgType $inputMsgType" set inputFields {} } if {![string equal $inputFields {}]} { 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::log debug [list ::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 # # ########################################################################### proc ::WS::Client::DoRawCall {serviceName operationName argList {headers {}}} { variable serviceArr ::log::log debug "Entering ::WS::Client::DoRawCall {$serviceName $operationName $argList}" 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'" } 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 [dict get $serviceInfo operation $operationName action] } if {[llength $headers]} { ::log::log info [list ::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers [string map {\{ \" \} \"} $headers]] set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers [string map {\{ \" \} \"} $headers]] } else { ::log::log info [::http::geturl $url -query $query -type [dict get $serviceInfo contentType]] set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType]] } ::http::wait $token ## ## Check for errors ## set body [::http::data $token] ::log::log info "\nReceived: $body" if {![string equal [::http::status $token] ok] || ([::http::ncode $token] != 200 && [string equal $body {}])} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set errorInfo {} set results [::http::error $token] if {[string equal $results {}] && [string equal [::http::status $token] ok]} { set results [::http::code $token] } set hadError 1 } else { set hadError 0 set results [::http::data $token] } ::http::cleanup $token if {$hadError} { ::log::log debug "Leaving (error) ::WS::Client::DoRawCall" return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $results } else { ::log::log debug "Leaving ::WS::Client::DoRawCall 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::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 # # ########################################################################### proc ::WS::Client::DoCall {serviceName operationName argList {headers {}}} { variable serviceArr ::log::log debug "Entering ::WS::Client::DoCall {$serviceName $operationName $argList}" 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 [dict get $serviceInfo operation $operationName action] } if {[llength $headers]} { ::log::log info [list ::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers [string map {\{ \" \} \"} $headers]] set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers [string map {\{ \" \} \"} $headers]] } else { ::log::log info [list ::http::geturl $url -query $query -type [dict get $serviceInfo contentType] ] set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType] ] } ::http::wait $token ## ## Check for errors ## set httpStatus [::http::status $token] if {[string equal $httpStatus ok] && [::http::ncode $token] == 500} { set body [::http::data $token] ::log::log debug "\tReceived: $body" set outTransform [dict get $serviceInfo outTransform] if {![string equal $outTransform {}]} { SaveAndSetOptions $serviceName catch {set body [$outTransform $serviceName $operationName REPLY $body]} RestoreSavedOptions $serviceName } set hadError [catch {parseResults $serviceName $operationName $body} results] if {$hadError} { lassign $::errorCode mainError subError if {[string equal $mainError WSCLIENT] && [string equal $subError NOSOAP]} { ::log::log debug "\tHTTP error $body" set results $body set errorCode [list WSCLIENT HTTPERROR $body] set errorInfo {} set hadError 1 } else { ::log::log debug "Reply was $body" set errorCode $::errorCode set errorInfo $::errorInfo } } } elseif {![string equal $httpStatus ok] || [::http::ncode $token] != 200} { ::log::log debug "\tHTTP error [array get $token]" set results [::http::error $token] set errorCode [list WSCLIENT HTTPERROR [::http::code $token]] set errorInfo {} set hadError 1 } else { set body [::http::data $token] ::log::log debug "\tReceived: $body" set outTransform [dict get $serviceInfo outTransform] if {![string equal $outTransform {}]} { SaveAndSetOptions $serviceName catch {set body [$outTransform $serviceName $operationName REPLY $body]} RestoreSavedOptions $serviceName } SaveAndSetOptions $serviceName catch {set hadError [catch {parseResults $serviceName $operationName $body} results]} RestoreSavedOptions $serviceName if {$hadError} { ::log::log debug "Reply was $body" set errorCode $::errorCode set errorInfo $::errorInfo } } ::http::cleanup $token if {$hadError} { ::log::log debug "Leaving (error) ::WS::Client::DoCall" return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $results } else { ::log::log 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::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 # # ########################################################################### proc ::WS::Client::DoAsyncCall {serviceName operationName argList succesCmd errorCmd {headers {}}} { variable serviceArr ::log::log debug "Entering ::WS::Client::DoAsyncCall [list $serviceName $operationName $argList $succesCmd $errorCmd $headers]" 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]] } 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 {[llength $headers]} { ::log::log info [list \ ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -headers [string map {\{ \" \} \"} $headers] \ -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] \ ] ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -headers [string map {\{ \" \} \"} $headers] \ -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] } else { ::log::log info [list \ ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] \ ] ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -command [list ::WS::Client::asyncCallDone $serviceName $operationName $succesCmd $errorCmd] } ::log::log debug "Leaving ::WS::Client::DoAsyncCall" 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 {[string equal $inputHeaderType {}]} { continue } set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] set headerFields [dict keys [dict get $headerTypeInfo definition]] if {![string equal $headerFields {}]} { lappend argList [lsort -dictionary $headerFields] } } set inputMsgType [dict get $serviceInfo operation $operationName inputs] if {![string equal $inputMsgType {}]} { set inTypeDef [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] if {[dict exists $inTypeDef definition]} { set inputFields [dict keys [dict get $inTypeDef definition]] if {![string equal $inputFields {}]} { 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 {[string equal $inputHeaderType {}]} { continue } set headerTypeInfo [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] set headerFields [dict keys [dict get $headerTypeInfo definition]] if {![string equal $headerFields {}]} { lappend argList [lsort -dictionary $headerFields] } } set inputMsgType [dict get $serviceInfo operation $operationName inputs] set inputFields [dict keys [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputMsgType] definition]] if {![string equal $inputFields {}]} { 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::log debug "Entering ::WS::Client::asyncCallDone {$serviceName $operationName $succesCmd $errorCmd $token}" ## ## Check for errors ## set body [::http::data $token] ::log::log info "\nReceived: $body" if {![string equal [::http::status $token] ok] || ([::http::ncode $token] != 200 && [string equal $body {}])} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set hadError 1 set errorInfo [::http::error $token] } else { SaveAndSetOptions $serviceName if {[catch {set hadError [catch {parseResults $serviceName $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::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 # # ########################################################################### proc ::WS::Client::parseResults {serviceName operationName inXML} { variable serviceArr ::log::log debug "In parseResults $serviceName $operationName {$inXML}" 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] } dom parse $inXML doc $doc documentElement top set xns { ENV http://schemas.xmlsoap.org/soap/envelope/ xsi "http://www.w3.org/2001/XMLSchema-instance" xs "http://www.w3.org/2001/XMLSchema" } foreach tmp [dict get $serviceInfo targetNamespace] { lappend xns $tmp } ::log::log debug "Using namespaces {$xns}" $doc selectNodesNamespaces $xns 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" } set rootNode [$body childNodes] ::log::log debug "Have [llength $rootNode] node under Body" if {[llength $rootNode] > 1} { foreach tmp $rootNode { #puts "\t Got {[$tmp localName]} looking for {$expectedMsgTypeBase}" if {[string equal [$tmp localName] $expectedMsgTypeBase] || [string equal [$tmp nodeName] $expectedMsgTypeBase] || [string equal [$tmp localName] Fault] || [string equal [$tmp nodeName] Fault]} { set rootNode $tmp break } } } if {([llength $rootNode] == 1) && ![string equal $rootNode {}]} { set rootName [$rootNode localName] if {[string equal $rootName {}]} { set rootName [$rootNode nodeName] } } else { set rootName {} } ::log::log debug "root name is {$rootName}" ## ## See if it is a standard error packet ## if {[string equal $rootName {Fault}]} { set faultcode {} set faultstring {} set detail {} foreach item {faultcode faultstring detail} { set tmpNode [$rootNode selectNodes ENV:$item] if {[string equal $tmpNode {}]} { set tmpNode [$rootNode selectNodes $item] } if {![string equal $tmpNode {}]} { 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 } ## ## Validated that it is the expected packet type ## if {![string equal $rootName $expectedMsgTypeBase]} { $doc delete return \ -code error \ -errorcode [list WS CLIENT BADREPLY [list $rootName $expectedMsgTypeBase]] \ "Bad reply type, received '$rootName; but expected '$expectedMsgTypeBase'." } ## ## 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 {[string equal $outHeaderType {}]} { 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::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode]" lappend results [::WS::Utils::convertTypeToDict Client $serviceName $node $outHeaderType $headerRootNode] } } ::log::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $rootNode $expectedMsgType $body]" if {![string equal $rootName {}]} { set bodyData [::WS::Utils::convertTypeToDict \ Client $serviceName $rootNode $expectedMsgType $body] if {![llength $bodyData] && ([dict get $serviceInfo skipLevelWhenActionPresent] || [dict get $serviceInfo skipLevelOnReply])} { ::log::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $rootNode $expectedMsgType $body] -- skipLevelWhenActionPresent was set" set bodyData [::WS::Utils::convertTypeToDict \ Client $serviceName $body $expectedMsgType $body] } 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] 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 {} set inTransform [dict get $serviceInfo inTransform] if {![string equal $inTransform {}]} { set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList] } ::log::log 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::log 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] 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 {[string equal $inputHeaderType {}]} { continue } set xns [dict get [::WS::Utils::GetServiceTypeDef Client $serviceName $inputHeaderType] xns] if {[info exists tnsArray($xns)]} { set xns $tnsArray($xns) } if {$firstHeader} { $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 } $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::log 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::log 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::log 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 {[string equal $inputHeaderType {}]} { 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] 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::log 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. # # 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 # # ########################################################################### proc ::WS::Client::buildServiceInfo {wsdlNode tnsDict {serviceInfo {}} {serviceAlias {}}} { ## ## Need to refactor to foreach service parseService ## Service drills down to ports, which drills down to bindings and messages ## ::log::log debug "Entering ::WS::Client::buildServiceInfo with doc $wsdlNode" ## ## Parse Service information ## set serviceNameList [$wsdlNode selectNodes w:service] if {[string length $serviceAlias] & ([llength $serviceNameList] > 1)} { return \ -code error \ -errorcode [list WS CLIENT MULTISVC] \ "Can not specify alias when WSDL defines multiple services" } elseif {[llength $serviceNameList] == 0} { return \ -code error \ -errorcode [list WS CLIENT NOSVC] \ "WSDL does not define any services" } foreach serviceNode $serviceNameList { lappend serviceInfo [parseService $wsdlNode $serviceNode $serviceAlias $tnsDict] } ::log::log 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::log 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::log 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 # # ########################################################################### 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 {[string equal $styleNode {}]} { ## ## 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 {!([string equal $style document] || [string equal $style rpc])} { ::log:::log debug "Leaving [lindex [info level 0] 0] with error @1" return \ -code error \ -errorcode [list WS CLIENT UNSSTY $style] \ "Unsupported calling style: '$style'" } if {![info exists use]} { set use [[$binding selectNodes {w:operation[1]/w:input/d:body}] getAttribute use] if {!([string equal $style document] && [string equal $use literal]) && !([string equal $style rpc] && [string equal $use encoded])} { ::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] } set typeList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style] set operName ${operName}_[lindex [split [lindex $typeList 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 typeList [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 {[string equal $actionNode {}]} { ::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 {![string equal $tmp $use]} { ::log:::log debug "Leaving [lindex [info level 0] 0] with error @3" return \ -code error \ -errorcode [list WS CLIENT MIXUSE $use $tmp] \ "Mixed usageage not supported!'" } 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 {![string equal $tmp $use]} { ::log:::log debug "Leaving [lindex [info level 0] 0] with error @4" return \ -code error \ -errorcode [list WS CLIENT MIXUSE $use $tmp] \ "Mixed usageage not supported!'" } 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 ## set inUse $use set outUse $use catch {set inUse [[$oper selectNodes w:input/d:body] getAttribute use]} catch {set outUse [[$oper selectNodes w:output/d:body] getAttribute use]} foreach tmp [list $inUse $outUse] { if {![string equal $tmp $use]} { ::log:::log debug "Leaving [lindex [info level 0] 0] with error @5" return \ -code error \ -errorcode [list WS CLIENT MIXUSE $use $tmp] \ "Mixed usageage not supported!'" } } #set typeList [getTypesForPort $wsdlNode $serviceName $baseName $portName $inName serviceInfo $style] ::log:::log debug "\t Messages are {$typeList}" foreach type $typeList mode {inputs outputs} { dict set serviceInfo operation $operName $mode $type } 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 # # 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::getTypesForPort {wsdlNode serviceName operName portName inName serviceInfoVar style} { ::log:::log debug "Enteringing [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 {[string equal $inName {}]} { 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] } set operNode [$wsdlNode selectNodes $operQuery] set inputMsgNode [$operNode selectNodes {w:input}] if {![string equal $inputMsgNode {}]} { set inputMsgPath [$inputMsgNode getAttribute message] set inputMsg [lindex [split $inputMsgPath {:}] end] set inType [messageToType $wsdlNode $serviceName $operName $inputMsg serviceInfo $style] } set outputMsgNode [$operNode selectNodes {w:output}] if {![string equal $outputMsgNode {}]} { set outputMsgPath [$outputMsgNode getAttribute message] set outputMsg [lindex [split $outputMsgPath {:}] end] set outType [messageToType $wsdlNode $serviceName $operName $outputMsg serviceInfo $style] } ## ## Return the types ## ::log:::log debug "Leaving [lindex [info level 0] 0] with [list $inType $outType]" return [list $inType $outType] } ########################################################################### # # 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 "Enteringing [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 {[string equal $msg {}] && [llength [set msgNameList [split $msgName {:}]]] > 1} { set tmpMsgName [join [lrange $msgNameList 1 end] {:}] set msgQuery [format {w:message[attribute::name='%s']} $tmpMsgName] set msg [$wsdlNode selectNodes $msgQuery] } if {[string equal $msg {}]} { 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 # # ########################################################################### proc ::WS::Client::DoRawRestCall {serviceName objectName operationName argList {headers {}} {location {}}} { variable serviceArr ::log::log 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 {![string equal $location {}]} { 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]] } if {[llength $headers]} { ::log::log info [list ::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers [string map {\{ \" \} \"} $headers]] set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers [string map {\{ \" \} \"} $headers]] } else { ::log::log [list ::http::geturl $url -query $query -type [dict get $serviceInfo contentType]] set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType]] } ::http::wait $token ## ## Check for errors ## set body [::http::data $token] if {![string equal [::http::status $token] ok] || ([::http::ncode $token] != 200 && [string equal $body {}])} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set errorInfo {} set results [::http::error $token] set hadError 1 } else { set hadError 0 set results [::http::data $token] } ::http::cleanup $token if {$hadError} { ::log::log debug "Leaving (error) ::WS::Client::DoRawRestCall" return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $results } else { ::log::log debug "Leaving ::WS::Client::DoRawRestCall 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::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 # # ########################################################################### proc ::WS::Client::DoRestCall {serviceName objectName operationName argList {headers {}} {location {}}} { variable serviceArr ::log::log 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 {![string equal $location {}]} { 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]] } if {[llength $headers]} { ::log::log info [list ::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers [string map {\{ \" \} \"} $headers]] set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers [string map {\{ \" \} \"} $headers]] } else { ::log::log info [list::http::geturl $url -query $query -type [dict get $serviceInfo contentType]] set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType]] } ::http::wait $token ## ## Check for errors ## set body [::http::data $token] ::log::log info "\tReceived: $body" set httpStatus [::http::status $token] set hadError 0 set results {} if {![string equal $httpStatus ok] || ([::http::ncode $token] != 200 && [string equal $body {}])} { ::log::log debug "\tHTTP error [array get $token]" set results [::http::error $token] set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set errorInfo {} set hadError 1 } 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} { ::log::log debug "Reply was [::http::data $token]" set errorCode $::errorCode set errorInfo $::errorInfo } } ::http::cleanup $token if {$hadError} { ::log::log debug "Leaving (error) ::WS::Client::DoRestCall" return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $results } else { ::log::log 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]} { lappend headers $svcHeaders } ::log::log debug "Entering ::WS::Client::DoAsyncRestCall [list $serviceName $objectName $operationName $argList $succesCmd $errorCmd $headers]" 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 } if {[llength $headers]} { ::log::log info [list \ ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -headers [string map {\{ \" \} \"} $headers] \ -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] \ ] ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -headers [string map {\{ \" \} \"} $headers] \ -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] } else { ::log::log info [list \ ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] \ ] ::http::geturl $url \ -query $query \ -type [dict get $serviceInfo contentType] \ -command [list ::WS::Client::asyncRestCallDone $serviceName $operationName $succesCmd $errorCmd] } ::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::log 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::log 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 {![string equal $inTransform {}]} { set xml [$inTransform $serviceName $operationName REQUEST $xml $url $argList] } ::log::log 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::log debug "In parseResults $serviceName $operationName {$inXML}" 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 {![string equal $outTransform {}]} { set inXML [$outTransform $serviceName $operationName REPLY $inXML] } set expectedMsgType [dict get $serviceInfo object $objectName operation $operationName outputs] dom parse $inXML doc $doc documentElement top set xns {} foreach tmp [dict get $serviceInfo targetNamespace] { lappend xns $tmp } ::log::log debug "Using namespaces {$xns}" set body $top set status [$body getAttribute status] ## ## See if it is a standard error packet ## if {![string equal $status {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::log debug "Calling [list ::WS::Utils::convertTypeToDict Client $serviceName $body $expectedMsgType $body]" if {![string equal $expectedMsgType {}]} { set node [$body childNodes] set nodeName [$node nodeName] if {![string equal $objectName $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::log debug "Entering ::WS::Client::asyncCallDone {$serviceName $objectName $operationName $succesCmd $errorCmd $token}" ## ## Check for errors ## set body [::http::data $token] ::log::log info "\nReceived: $body" if {![string equal [::http::status $token] ok] || ([::http::ncode $token] != 200 && [string equal $body {}])} { set errorCode [list WS CLIENT HTTPERROR [::http::code $token]] set hadError 1 set errorInfo [::http::error $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-2.3.8/Examples/tclhttpd/htdocs/templates/simple.subst000644 001750 001750 00000001347 12500417200 023561 0ustar00mxmmxm000000 000000 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-2.3.8/docs/Creating_a_Web_Service_Type.html000644 001750 001750 00000016661 12500417200 021455 0ustar00mxmmxm000000 000000 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-2.3.8/Examples/tclhttpd/htdocs/service/000755 001750 001750 00000000000 12500417200 020643 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/tclhttpd/htdocs/000755 001750 001750 00000000000 12500417200 017203 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/Math/MathWebService.tcl000644 001750 001750 00000014715 12500417200 020346 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## 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-2.3.8/docs/000755 001750 001750 00000000000 12500417200 013243 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/Echo/000755 001750 001750 00000000000 12500417200 014747 5ustar00mxmmxm000000 000000 tclws-2.3.8/Utilities.tcl000644 001750 001750 00000541707 12500417200 015010 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## 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.4 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 log package require tdom 0.8 package require struct::set package provide WS::Utils 2.3.8 namespace eval ::WS {} namespace eval ::WS::Utils { set ::WS::Utils::typeInfo {} set ::WS::Utils::currentSchema {} array set ::WS::Utils::importedXref {} set nsList { w http://schemas.xmlsoap.org/wsdl/ d http://schemas.xmlsoap.org/wsdl/soap/ xs http://www.w3.org/2001/XMLSchema } array set ::WS::Utils::simpleTypes { 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 } set ::WS::Utils::standardAttributes { baseType comment 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::log debug "One Option {$opt}" if {[info exists options($opt)]} { return $options($opt) } else { ::log::log debug "Unkown 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::log debug "Setting Option {$opt} to {$value}" set options($opt) $value } else { ::log::log debug "Unkown option {$opt}" return \ -code error \ -errorcode [list WS CLIENT UNKOPTION $opt] \ "Unknown option'$opt'" } } } else { ::log::log 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 # # 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::ServiceTypeDef {mode service type definition {xns {}} {abstract {false}}} { ::log::log debug [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 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::log debug [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::log debug "\t Unsetting typeInfo $mode $service $type" ::log::log 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::log 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 # # ########################################################################### proc ::WS::Utils::ProcessImportXml {mode baseUrl xml serviceName serviceInfoVar tnsCountVar} { ::log::log debug "Entering ProcessImportXml $mode $baseUrl xml $serviceName $serviceInfoVar $tnsCountVar" upvar 1 $serviceInfoVar serviceInfo upvar 1 $tnsCountVar tnsCount variable currentSchema 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]} { puts stderr "Error processing include $schema $baseUrl" puts stderr $::errorInfo puts stderr $::errorCode puts stderr $errMsg } set prevSchema $currentSchema set currentSchema $schema parseScheme $mode $baseUrl $schema $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 set includeNodeList [$rootNode selectNodes -namespaces $nsList descendant::xs:include] set inXml [$rootNode asXML] set included 0 foreach includeNode $includeNodeList { if {![$includeNode hasAttribute schemaLocation]} { continue } set urlTail [$includeNode getAttribute schemaLocation] set url [::uri::resolve $baseUrl $urlTail] if {[lsearch -exact $includePath $url] != -1} { log::log warning "Include loop detected: [join $includePath { -> }]" continue } elseif {[info exists includeArr($url)]} { continue } else { set includeArr($url) 1 } incr included ::log::log 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::log info [list ::http::geturl $url] set token [::http::geturl $url] ::http::wait $token set ncode [::http::ncode $token] set xml [::http::data $token] ::log::log 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. # # 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} { variable simpleTypes variable typeInfo set type [string trim $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)] )}] 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 # # 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 # ########################################################################### proc ::WS::Utils::GenerateScheme {mode serviceName doc parent targetNamespace} { 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]] { ::log::log 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::log debug "\t parts {$baseTypeInfo}" foreach {field tmpTypeInfo} $baseTypeInfo { $seq appendChild [$doc createElement xs:element tmp] set tmpType [dict get $tmpTypeInfo type] ::log::log 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] 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 } 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 # # ########################################################################### proc ::WS::Utils::convertTypeToDict {mode serviceName node type root {isArray 0}} { 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::log debug [list ::WS::Utils::convertTypeToDict $mode $serviceName $node $type $root $isArray] 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::log debug "\t type def = {$typeDefInfo}" set xns [dict get $typeDefInfo xns] if {[$node hasAttribute href]} { set node [GetReferenceNode $root [$node getAttribute href]] } ::log::log 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::log 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::log debug "\t partsList is {$partsList}" set arrayOverride [expr {$isArray && ([llength $partsList] == 1)}] foreach partName $partsList { set partType [dict get $typeDefInfo definition $partName type] 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] 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::log debug "\tpartName $partName partType $partType xns $xns typeInfoList $typeInfoList" ## ## Try for fully qualified name ## ::log::log debug "Trying #1 [list $node selectNodes $partXns:$partName]" if {[catch {llength [set item [$node selectNodes $partXns:$partName]]} len] || ($len == 0)} { ::log::log 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::log 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::log 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::log debug "\t\t Found $partName [$childNode asXML]" lappend item $childNode } } if {![string length $item]} { ::log::log debug "\tSkipping" continue } } else { ::log::log debug "\t\t Found [llength $item] $partName" } } else { ::log::log debug "\t\t Found [llength $item] $partName" } } else { ::log::log debug "\t\t Found [llength $item] $partName" } set origItemList $item set newItemList {} foreach item $origItemList { if {[$item hasAttribute href]} { set oldXML [$item asXML] ::log::log debug "\t\t Replacing: $oldXML" set item [GetReferenceNode $root [$item getAttribute href]] ::log::log 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)} { if {$isAbstract && [$item hasAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type]} { set partType [$item getAttributeNS {http://www.w3.org/2001/XMLSchema-instance} type] $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] } else { dict set results $partName [convertTypeToDict $mode $serviceName $item $partType $root] } } {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] lappend tmp $rowList } else { lappend tmp [convertTypeToDict $mode $serviceName $row $partType $root 1] } } dict set results $partName $tmp } default { ## ## Placed here to shut up tclchecker ## } } } ::log::log debug [list Leaving ::WS::Utils::convertTypeToDict 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::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 # # 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 # # ########################################################################### proc ::WS::Utils::convertDictToType {mode service doc parent dict type {forceNs 0}} { ::log::log debug "Entering ::WS::Utils::convertDictToType $mode $service $doc $parent {$dict} $type" # ::log::log debug " Parent xml: [$parent asXML]" variable typeInfo variable simpleTypes variable options variable standardAttributes variable currentNs if {!$options(UseNS)} { return [::WS::Utils::convertDictToTypeNoNs $mode $service $doc $parent $dict $type] } if {$options(valueAttrCompatiblityMode)} { set valueAttr {} } else { set valueAttr {::value} } set typeInfoList [TypeInfo $mode $service $type] ::log::log debug "\t typeInfoList = {$typeInfoList}" if {[dict exists $typeInfo $mode $service $service:$type]} { set typeName $service:$type } else { set typeName $type } set itemList {} if {[lindex $typeInfoList 0] && [dict exists $typeInfo $mode $service $typeName definition]} { set itemList [dict get $typeInfo $mode $service $typeName definition] set xns [dict get $typeInfo $mode $service $typeName xns] } else { 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::log debug "\titemList is {$itemList} in $xns" set entryNs $currentNs if {!$forceNs} { set currentNs $xns } set fieldList {} foreach {itemName itemDef} $itemList { set baseName [lindex [split $itemName {:}] end] lappend fieldList $itemName set itemType [dict get $itemDef type] ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} itemType ={$itemType}" set typeInfoList [TypeInfo $mode $service $itemType] ::log::log debug "Expr [list ![dict exists $dict $itemName] && ![dict exists $dict $baseName]]" if {![dict exists $dict $itemName] && ![dict exists $dict $baseName]} { ::log::log debug "Neither {$itemName} nor {$baseName} are in dictionary {$dict}, skipping" 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::log debug "key = {$key} standardAttributes = {$standardAttributes}" } } ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} itemXns = {$itemXns} tmpInfo = {$tmpInfo} attrList = {$attrList}" set isAbstract false set baseType [string trimright $itemType ()] if {$options(genOutAttr) && [dict exists $typeInfo $mode $service $baseType abstract]} { set isAbstract [dict get $typeInfo $mode $service $baseType abstract] } ::log::log notice "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList} isAbstract = {$isAbstract}" 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::log 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 } else { convertDictToType $mode $service $doc $retNode $resultValue $itemType } if {[llength $attrList]} { ::WS::Utils::setAttr $retNode $attrList } } {1 1} { ## ## Non-simple array ## set dataList [dict get $dict $useName] set tmpType [string trimright $itemType ()] #::log::log debug "\t\t [llength $dataList] rows {$dataList}" foreach row $dataList { if {[string equal $itemXns $options(suppressNS)] || [string equal $itemXns {}]} { $parent appendChild [$doc createElement $itemName retNode] } else { $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 equal $currentNs $itemXns] && ![string equal $itemXns {}]} { set tmpNs $currentNs set currentNs $itemXns convertDictToType $mode $service $doc $retNode $resultValue $tmpType } else { convertDictToType $mode $service $doc $retNode $resultValue $tmpType } 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::log debug "Leaving ::WS::Utils::convertDictToType with xml: [$parent asXML]" return; } ########################################################################### # # Private Procedure Header - as this procedure is modified, please be sure # that you update this header block. Thanks. # #>>BEGIN PRIVATE<< # # Procedure Name : ::WS::Utils::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 # # 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 # # ########################################################################### proc ::WS::Utils::convertDictToTypeNoNs {mode service doc parent dict type} { ::log::log debug "Entering ::WS::Utils::convertDictToTypeNoNs $mode $service $doc $parent {$dict} $type" # ::log::log debug " Parent xml: [$parent asXML]" variable typeInfo variable simpleTypes variable options variable standardAttributes 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::log debug "\titemList is {$itemList}" foreach {itemName itemDef} $itemList { ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef}" set itemType [dict get $itemDef type] set isAbstract false set baseType [string trimright $itemType ()] 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] if {![dict exists $dict $itemName]} { 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::log debug "key = {$key} standardAttributes = {$standardAttributes}" } } ::log::log debug "\t\titemName = {$itemName} itemDef = {$itemDef} typeInfoList = {$typeInfoList}" 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}]} { 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 } {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 } } 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 # # ########################################################################### proc ::WS::Utils::convertDictToEncodedType {mode service doc parent dict type} { ::log::log debug "Entering ::WS::Utils::convertDictToEncodedType $mode $service $doc $parent {$dict} $type" variable typeInfo variable options set typeInfoList [TypeInfo $mode $service $type] ::log::log debug "\t typeInfoList = {$typeInfoList}" 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::log debug "\titemList is {$itemList} in $xns" foreach {itemName itemDef} $itemList { set itemType [dict get $itemList $itemName type] set typeInfoList [TypeInfo $mode $service $itemType] ::log::log debug "\t\t Looking for {$itemName} in {$dict}" if {![dict exists $dict $itemName]} { ::log::log debug "\t\t Not found, skipping" continue } ::log::log 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[%d]} $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::log debug [list ::WS::Utils::parseDynamicType $mode $serviceName $node $type] foreach child [$node childNodes] { ::log::log 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 # # ########################################################################### proc ::WS::Utils::parseScheme {mode baseUrl schemaNode serviceName serviceInfoVar tnsCountVar} { ::log::log debug "Entering :WS::Utils::parseScheme $mode $baseUrl $schemaNode $serviceName $serviceInfoVar $tnsCountVar" upvar 1 $tnsCountVar tnsCount upvar 1 $serviceInfoVar serviceInfo variable currentSchema variable nsList variable options variable unkownRef set currentSchema $schemaNode set tmpTargetNs $::WS::Utils::targetNs foreach attr [$schemaNode attributes] { set value {?} catch {set value [$schemaNode getAttribute $attr]} ::log::log debug "Attribute $attr = $value" } if {[$schemaNode hasAttribute targetNamespace]} { set xns [$schemaNode getAttribute targetNamespace] ::log::log debug "In Parse Scheme, found targetNamespace attribute with {$xns}" set ::WS::Utils::targetNs $xns } else { set xns $::WS::Utils::targetNs } ::log::log debug "@3a {$xns} {[dict get $serviceInfo tnsList url]}" if {![dict exists $serviceInfo tnsList url $xns]} { set tns [format {tns%d} [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::log 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 unkownRef while {($pass == 1) || ($lastUnknownRefCount != [array size unkownRef])} { ::log::log debug "Pass $pass over schema" incr pass set lastUnknownRefCount [array size unkownRef] array unset unkownRef foreach element [$schemaNode selectNodes -namespaces $nsList xs:import] { if {[catch {processImport $mode $baseUrl $element $serviceName serviceInfo tnsCount} msg]} { ::log::log notice "Import failed due to: {$msg}. Trace: $::errorInfo" } } ::log::log debug "Parsing Element types for $xns as $tns" foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:element] { ::log::log debug "\tprocessing $element" if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { ::log::log notice "Unhandled error: {$msg}. Trace: $::errorInfo" } } ::log::log debug "Parsing Attribute types for $xns as $tns" foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:attribute] { ::log::log debug "\tprocessing $element" if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { ::log::log notice "Unhandled error: {$msg}. Trace: $::errorInfo" } } ::log::log debug "Parsing Simple types for $xns as $tns" foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:simpleType] { ::log::log debug "\tprocessing $element" if {[catch {parseSimpleType $mode serviceInfo $serviceName $element $tns} msg]} { ::log::log notice "Unhandled error: {$msg}. Trace: $::errorInfo" } } ::log::log debug "Parsing Complex types for $xns as $tns" foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:complexType] { ::log::log debug "\tprocessing $element" if {[catch {parseComplexType $mode serviceInfo $serviceName $element $tns} msg]} { ::log::log notice "Unhandled error: {$msg}. Trace: $::errorInfo" } } } set lastUnknownRefCount [array size unkownRef] foreach {unkRef usedByTypeList} [array get unkownRef] { foreach usedByType $usedByTypeList { switch -exact -- $options(StrictMode) { debug - warning { log::log $options(StrictMode) "Unknown type reference $unkRef in type $usedByType" } error - default { log::log error "Unknown type reference $unkRef in type $usedByType" } } } } if {$lastUnknownRefCount} { switch -exact -- $options(StrictMode) { debug - warning { set ::WS::Utils::targetNs $tmpTargetNs ::log::log $options(StrictMode) "Found $lastUnknownRefCount forward type references: [join [array names unkownRef] {,}]" } error - default { set ::WS::Utils::targetNs $tmpTargetNs set ofd [open full.xsd w];puts $ofd [$schemaNode asXML];close $ofd return \ -code error \ -errorcode [list WS $mode UNKREFS [list $lastUnknownRefCount]] \ "Found $lastUnknownRefCount forward type references: [join [array names unkownRef] {,}]" } } } ## ## Ok, one more pass to report errors ## foreach element [$schemaNode selectNodes -namespaces $nsList xs:import] { if {[catch {processImport $mode $baseUrl $element $serviceName serviceInfo tnsCount} msg]} { switch -exact -- $options(StrictMode) { debug - warning { log::log $options(StrictMode) "Could not parse:\n [$element asXML]" log::log $options(StrictMode) "\t error was: $msg" } error - default { set errorCode $::errorCode set errorInfo $::errorInfo log::log error "Could not parse:\n [$element asXML]" log::log error "\t error was: $msg" log::log error "\t error info: $errorInfo" log::log error "\t error in: [lindex [info level 0] 0]" log::log error "\t error code: $errorCode" set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } ::log::log debug "Parsing Element types for $xns as $tns" foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:element] { ::log::log debug "\tprocessing $element" if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { switch -exact -- $options(StrictMode) { debug - warning { log::log $options(StrictMode) "Could not parse:\n [$element asXML]" log::log $options(StrictMode) "\t error was: $msg" } error - default { set errorCode $::errorCode set errorInfo $::errorInfo log::log error "Could not parse:\n [$element asXML]" log::log error "\t error was: $msg" log::log error "\t error info: $errorInfo" log::log error "\t last element: $::elementName" log::log error "\t error in: [lindex [info level 0] 0]" log::log error "\t error code: $errorCode" set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } ::log::log debug "Parsing Attribute types for $xns as $tns" foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:attribute] { ::log::log debug "\tprocessing $element" if {[catch {parseElementalType $mode serviceInfo $serviceName $element $tns} msg]} { switch -exact -- $options(StrictMode) { debug - warning { log::log $options(StrictMode) "Could not parse:\n [$element asXML]" log::log $options(StrictMode) "\t error was: $msg" } error - default { set errorCode $::errorCode set errorInfo $::errorInfo log::log error "Could not parse:\n [$element asXML]" log::log error "\t error was: $msg" log::log error "\t error info: $errorInfo" log::log error "\t error in: [lindex [info level 0] 0]" log::log error "\t error code: $errorCode" log::log error "\t last element: $::elementName" set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } ::log::log debug "Parsing Simple types for $xns as $tns" foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:simpleType] { ::log::log debug "\tprocessing $element" if {[catch {parseSimpleType $mode serviceInfo $serviceName $element $tns} msg]} { switch -exact -- $options(StrictMode) { debug - warning { log::log $options(StrictMode) "Could not parse:\n [$element asXML]" log::log $options(StrictMode) "\t error was: $msg" } error - default { set errorCode $::errorCode set errorInfo $::errorInfo log::log error "Could not parse:\n [$element asXML]" log::log error "\t error was: $msg" log::log error "\t error info: $errorInfo" log::log error "\t error in: [lindex [info level 0] 0]" log::log error "\t error code: $errorCode" set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } ::log::log debug "Parsing Complex types for $xns as $tns" foreach element [$schemaNode selectNodes -namespaces $nsList child::xs:complexType] { ::log::log debug "\tprocessing $element" if {[catch {parseComplexType $mode serviceInfo $serviceName $element $tns} msg]} { switch -exact -- $options(StrictMode) { debug - warning { log::log $options(StrictMode) "Could not parse:\n [$element asXML]" log::log $options(StrictMode) "\t error was: $msg" } error - default { set errorCode $::errorCode set errorInfo $::errorInfo log::log error "Could not parse:\n [$element asXML]" log::log error "\t error was: $msg" log::log error "\t error info: $errorInfo" log::log error "\t error in: [lindex [info level 0] 0]" log::log error "\t error code: $errorCode" set ::WS::Utils::targetNs $tmpTargetNs return \ -code error \ -errorcode $errorCode \ -errorinfo $errorInfo \ $msg } } } } set ::WS::Utils::targetNs $tmpTargetNs ::log::log debug "Leaving :WS::Utils::parseScheme $mode $baseUrl $schemaNode $serviceName $serviceInfoVar $tnsCountVar" ::log::log 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 # # ########################################################################### proc ::WS::Utils::processImport {mode baseUrl importNode serviceName serviceInfoVar tnsCountVar} { upvar 1 $serviceInfoVar serviceInfo upvar 1 $tnsCountVar tnsCount variable currentSchema variable importedXref variable options ::log::log 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::log info "Including $url" set lastPos [string last / $url] set testUrl [string range $url 0 [expr {$lastPos - 1}]] if { [info exists ::WS::Utils::redirectArray($testUrl)] } { set newUrl $::WS::Utils::redirectArray($testUrl) append newUrl [string range $url $lastPos end] ::log::log debug "newUrl = $newUrl" set url $newUrl } ::log::log 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::log 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::log debug "URL Scheme of {$url} is {$urlScheme}" switch -exact -- $urlScheme { file { ::log::log 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] #parray $token ::http::wait $token set ncode [::http::ncode $token] puts "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::log 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::log 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 unkownRef variable defaultType ::log::log debug "Entering [info level 0]" set isAbstractType false set defaultType string set typeName $tns:[$node getAttribute name] ::log::log debug "Complex Type is $typeName" if {[$node hasAttribute abstract]} { set isAbstractType [$node getAttribute abstract] ::log::log 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::log 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::log 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] 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] } lappend partList $partName [list type $partType] }]} { lappend unkownRef($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 [getQualifiedType $results [$middleNode getAttribute type string:string] $tns] set partMax [$middleNode getAttribute maxOccurs 1] if {$partMax <= 1} { lappend partList $partName [list type $partType comment $comment] } else { lappend partList $partName [list type [string trimright ${partType} {()}]() comment $comment] } } } 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::log 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 { foreach child [$middleNode childNodes] { set parent [$child parent] set contentType [$child localName] ::log::log 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::log debug "Calling partList for $contentType of $typeName" if {[catch {set tmp [partList $mode $child $serviceName results $tns]} msg]} { ::log::log debug "Error in partList {$msg}, errorInfo: $errorInfo" } ::log::log 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::log debug "at end of foreach {$typeName} with {$partList}" if {[llength $partList] || $isAbstractType} { #dict set results types $tns:$typeName $partList dict set results types $typeName $partList ::log:::log debug "Defining $typeName" if {[llength $partList] && ![string equal [lindex $partList 0] {}]} { ::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 unkownRef variable nsList variable defaultType variable options variable simpleTypes upvar 1 $dictVar results set partList {} set middle [$node localName] ::log::log debug "Entering [info level 0] -- for $middle" switch -exact -- $middle { anyAttribute - attribute { ## ## Do Nothing ## } element { catch { set partName [$node getAttribute name] set partType [getQualifiedType $results [$node getAttribute type string] $tns] set partMax [$node getAttribute maxOccurs 1] if {$partMax <= 1} { set partList [list $partName [list type $partType comment {}]] } else { set partList [list $partName [list type [string trimright ${partType} {()}]() comment {}]] } } } extension { set baseName [getQualifiedType $results [$node getAttribute base string] $tns] set baseTypeInfo [TypeInfo Client $serviceName $baseName] ::log::log 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::log debug "\t baseInfo is {$baseInfo}" if {[llength $baseInfo] == 0} { ::log::log debug "\t Unknown reference '$baseName'" set unkownRef($baseName) 1 return; } catch {set partList [concat $partList [dict get $baseInfo definition]]} } else { ::log::log 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::log debug "\telement list is {$elementList}" foreach element $elementList { ::log::log 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 [getQualifiedType $results $partName $tns] set partTypeInfo [::WS::Utils::GetServiceTypeDef $mode $serviceName $partType] set partName [lindex [split $partName {:}] end] ::log::log debug "\t\t\t part name is {$partName} type is {$partTypeInfo}" if {[dict exists $partTypeInfo definition $partName]} { set partType [dict get $partTypeInfo definition $partName type] } ::log::log 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] } } else { set partType [getQualifiedType $results [$element getAttribute type string] $tns] } } 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::log error "\tError processing {$msg} for [$element asXML]" if {$isRef} { ::log::log error "\t\t Was a reference. Additionally information is:" ::log::log 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 unkownRef ::log::log 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::log 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] } ::log::log debug "Elemental Type is $typeName" set partList {} set partType {} set isAbstractType false if {[$node hasAttribute abstract]} { set isAbstractType [$node getAttribute abstract] ::log::log debug "\t Abstract type = $isAbstractType" } set elements [$node selectNodes -namespaces $nsList xs:complexType/xs:sequence/xs:element] ::log::log debug "\t element list is {$elements} partList {$partList}" foreach element $elements { set ::elementName [$element asXML] ::log::log debug "\t\t Processing element {[$element nodeName]}" set elementsFound 1 set typeAttribute "" if {[$element hasAttribute ref]} { set partType [$element getAttribute ref] ::log::log 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::log 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 unkownRef($partType) $typeName log::log 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::log debug "\t\t\t has no ref has {[$element attributes]}" set childList [$element selectNodes -namespaces $nsList xs:complexType/xs:sequence/xs:element] ::log::log 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] parseElementalType $mode results $serviceName $element $tns } else { set partName [$element getAttribute name] if {[$element hasAttribute type]} { set partType [getQualifiedType $results [$element getAttribute type] $tns] } else { set partType xs:string } } } set partMax [$element getAttribute maxOccurs -1] ::log::log 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] } elseif {[$node hasAttribute base]} { set partType [getQualifiedType $results [$node getAttribute base] $tns] } 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::log debug "Entering [info level 0]" set typeName [$node getAttribute name] if {$typeName in {SAP_VALID_FROM}} { set foo 1 } set isList no ::log::log debug "Simple Type is $typeName" if {[string length [::WS::Utils::GetServiceTypeDef $mode $serviceName $tns:$typeName]]} { ::log::log 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::log 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 # ########################################################################### 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 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 $type $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 integer fieldInfoArr(maxOccurs)] && ($fieldInfoArr(maxOccurs) < [llength $fieldInfoArr($field)])} { ## ## Fields was required and present, but too many times ## set ::errorCode [list WS CHECK MAXOCCUR [list $type $field]] set 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 } array set typeInfos [GetServiceTypeDef $mode $serviceName $type] foreach {var value} [array get typeInfos] { set $var $value } set result 1 if {$minLength >= 0 && [string length $value] < $minLength} { set ::errorCode [list WS CHECK VALUE_TO_SHORT [list $key $value $minLength $typeInfo]] set result 0 } elseif {$maxLength >= 0 && [string length $value] > $maxLength} { set ::errorCode [list WS CHECK VALUE_TO_LONG [list $key $value $maxLength $typeInfo]] set result 0 } elseif {[info exists enumeration] && ([lsearch -exact $enumeration $value] == -1)} { set errorCode [list WS CHECK VALUE_NOT_IN_ENUMERATION [list $key $value $enumerationVals $typeInfo]] set result 0 } elseif {[info exists pattern] && (![regexp -- $pattern $value])} { set errorCode [list WS CHECK VALUE_NOT_MATCHES_PATTERN [list $key $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 # ########################################################################### 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 xns [dict get $typeInfo $mode $service $type 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 integer 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 $type $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 : Set attributes on a DOM node # # Arguments : # serviceInfo - service information dictionary # type - type to get local qualified type on # tns - current namespace # # 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::getQualifiedType {serviceInfo type tns} { set typePartsList [split $type {:}] if {[llength $typePartsList] == 1} { set result $tns:$type } else { lassign $typePartsList tmpTns tmpType 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::log error "Could not find tns '$tmpTns' in '[dict get $serviceInfo tnsList tns]' for type {$type}" set result $tns:$type return -code error } } 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::log debug "Entering [info level 0]" unset -nocomplain -- generatedTypes set result [_generateTemplateDict $mode $serviceName $type $arraySize] unset -nocomplain -- generatedTypes ::log::log 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 # # ########################################################################### proc ::WS::Utils::_generateTemplateDict {mode serviceName type arraySize {xns {}}} { variable typeInfo variable mutableTypeInfo variable options variable generatedTypes ::log::log debug "Entering [info level 0]" set results {} ## ## Check for circular reference ## if {[info exists generatedTypes([list $mode $serviceName $type])]} { set results {<** Circular Reference **>} ::log::log debug "Leaving [info level 0] with {$results}" return $results } else { set generatedTypes([list $mode $serviceName $type]) 1 } # 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::log 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::log 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::log debug "\t partsList is {$partsList}" foreach partName $partsList { set partType [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::log 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 #%d} $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::log 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 # ########################################################################### if {[package vcompare [info patchlevel] 8.5] == -1} { ## ## 8.4, so can not use {*} expansion ## proc ::WS::Utils::setAttr {node attrList} { foreach {name value} $attrList { $node setAttribute $name $value } } } else { ## ## 8.5 or later, so use {*} expansion ## proc ::WS::Utils::setAttr {node attrList} { $node setAttribute {*}$attrList } } proc ::WS::Utils::geturl_followRedirects {url args} { ::log::log debug "[info level 0]" #global redirectArray set initialUrl $url set finalUrl $url array set URI [::uri::split $url] ;# Need host info from here while {1} { if {[llength $args]} { ::log::log info [concat [list ::http::geturl $url] $args] set token [eval [list http::geturl $url] $args] } else { ::log::log info [list ::http::geturl $url] set token [::http::geturl $url] } set ncode [::http::ncode $token] ::log::log info "ncode = $ncode" if {![string match {30[1237]} $ncode]} { ::log::log 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::log debug "initialUrlDir = $initialUrlDir, finalUrlDir = $finalUrlDir" set ::WS::Utils::redirectArray($initialUrlDir) $finalUrlDir } return $token } elseif {![string match {20[1237]} $ncode]} { return $token } array set meta [set ${token}(meta)] if {![info exist meta(Location)]} { return $token } array set uri [::uri::split $meta(Location)] unset meta array unset meta if {[string equal $uri(host) {}]} { set uri(host) $URI(host) } # problem w/ relative versus absolute paths set url [eval ::uri::join [array get uri]] ::log::log debug "url = $url" set finalUrl $url } } tclws-2.3.8/Examples/tclhttpd/htdocs/templates/000755 001750 001750 00000000000 12500417200 021201 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/000755 001750 001750 00000000000 12500417200 014071 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/tclhttpd/htdocs/hacks.tml000644 001750 001750 00000004347 12500417200 021022 0ustar00mxmmxm000000 000000 [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-2.3.8/pkgIndex.tcl000644 001750 001750 00000002251 12500417200 014570 0ustar00mxmmxm000000 000000 # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. package ifneeded WS::Client 2.3.8 [list source [file join $dir ClientSide.tcl]] package ifneeded WS::Server 2.3.7 [list source [file join $dir ServerSide.tcl]] package ifneeded WS::Utils 2.3.8 [list source [file join $dir Utilities.tcl]] package ifneeded WS::Embeded 2.3.0 [list source [file join $dir Embedded.tcl]] package ifneeded WS::AOLserver 2.0.0 [list source [file join $dir AOLserver.tcl]] package ifneeded WS::Channel 2.0.0 [list source [file join $dir ChannelServer.tcl]] package ifneeded WS::Wub 2.2.1 [list source [file join $dir WubServer.tcl]] package ifneeded Wsdl 2.0.0 [list source [file join $dir WubServer.tcl]] package ifneeded WS::CheckAndBuild 0.0.3 [list source [file join $dir CheckAndBuild.tcl]] tclws-2.3.8/WubServer.tcl000644 001750 001750 00000002024 12500417200 014741 0ustar00mxmmxm000000 000000 # 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.0.0 package provide Wsdl 1.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-2.3.8/Examples/tclhttpd/custom/000755 001750 001750 00000000000 12500417200 017231 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/aolserver/lib/aolserver-log/pkgIndex.tcl000644 001750 001750 00000000153 12500417200 023676 0ustar00mxmmxm000000 000000 package ifneeded log 2.4.0 [list source [file normalize [file join [file dirname [info script]] log.tcl]]] tclws-2.3.8/Examples/aolserver/servers/tclws/pages/ws/000755 001750 001750 00000000000 12500417200 022450 5ustar00mxmmxm000000 000000 tclws-2.3.8/license.terms000644 001750 001750 00000004157 12500417200 015020 0ustar00mxmmxm000000 000000 This 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-2.3.8/Examples/aolserver/servers/tclws/pages/ws/echoexample/000755 001750 001750 00000000000 12500417200 024742 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/tclhttpd/htdocs/service/index.tml000644 001750 001750 00000002663 12500417200 022477 0ustar00mxmmxm000000 000000 [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-2.3.8/License.txt000644 001750 001750 00000003163 12500417200 014441 0ustar00mxmmxm000000 000000 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-2.3.8/Examples/aolserver/servers/tclws/pages/000755 001750 001750 00000000000 12500417200 022017 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/wub/000755 001750 001750 00000000000 12500417200 014666 5ustar00mxmmxm000000 000000 tclws-2.3.8/Embedded.tcl000644 001750 001750 00000052647 12500417200 014526 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## 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 require log package provide WS::Embeded 2.3.0 namespace eval ::WS::Embeded { array set portInfo {} set portList [list] set forever {} variable returnCodeText [dict create 200 OK 404 "Not Found"\ 500 "Internal Server Error" 501 "Not Implemented"] } ########################################################################### # # 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 # 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::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 # # ########################################################################### proc ::WS::Embeded::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::Embeded::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::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 # # ########################################################################### proc ::WS::Embeded::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::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 # keyfile -- Name of the key file # userpwds -- A list of username:password # realm -- The security realm # # 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 # # ########################################################################### proc ::WS::Embeded::Listen {port {certfile {}} {keyfile {}} {userpwds {}} {realm {}}} { variable portInfo variable portList lappend portList $port foreach key {port certfile keyfile userpwds realm} { set portInfo($port,$key) [set $key] } if {![info exists portInfo($port,handlers)]} { 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 set handle [::tls::socket -server [list ::WS::Embeded::accept $port] $port] } else { ::log::log debug [list socket -server [list ::WS::Embeded::accept $port] $port] set handle [socket -server [list ::WS::Embeded::accept $port] $port] } 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::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::Embeded::ReturnData {sock type data code} { upvar #0 ::WS::Embeded::Httpd$sock dataArray foreach var {type data code} { dict set dataArray(reply) $var [set $var] } return; } ########################################################################### # # 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] 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 } ########################################################################### # # 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::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::Embeded::checkauth {port sock ip auth} { variable portInfo if {[info exists portInfo($port,auths)] && [llength $portInfo($port,auths)] && [lsearch -exact $portInfo($port,auths) $auth]==-1} { set realm $portInfo($port,realm) respond $sock 401 "" "WWW-Authenticate: Basic realm=\"$realm\"\n" ::log::log warning "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::Embeded::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 # 2.3.0 10/31/2012 G.Lester bug fix for [68310fe3bd] -- correct encoding and data length # # ########################################################################### proc ::WS::Embeded::handler {port sock ip reqstring auth} { variable portInfo upvar #0 ::WS::Embeded::Httpd$sock req if {[catch {checkauth $port $sock $ip $auth}]} { ::log::log warning {Auth Failed} return } array set req $reqstring #foreach var {type data code} { # dict set req(reply) $var [set $var] #} set path "/[string trim $req(path) /]" if {[dict exists $portInfo($port,handlers) $path]} { set cmd [dict get $portInfo($port,handlers) $path] lappend cmd $sock {} #puts "Calling {$cmd}" if {[catch {eval $cmd} msg]} { ::log::log error "Return 404 due to eval error: $msg" respond $sock 404 "Error: $msg" } else { set type [dict get $req(reply) type] set encoding [string tolower [lindex [split [lindex [split $type {;}] 1] {=}] 1]] if {$encoding ni [encoding names]} { set encoding utf-8 set type "[lindex [split $type ";"] 0]; charset=UTF-8" } set data [encoding convertto $encoding [dict get $req(reply) data]] set reply "[httpreturncode [dict get $req(reply) code]]\n" append reply "Content-Type: $type\n" append reply "Connection: close\n" append reply "Content-length: [string length $data]\n" chan configure $sock -translation crlf puts $sock $reply chan configure $sock -translation binary puts -nonewline $sock $data ::log::log debug ok } } else { ::log::log warning "404 Error: URL not found" respond $sock 404 "URL not found" } return; } ########################################################################### # # 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. # # 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 # 2.3.0 10/31/2012 G.Lester Bug fix [66fb3aeef5] -- correct header parsing # # ########################################################################### proc ::WS::Embeded::accept {port sock ip clientport} { variable portInfo upvar #0 ::WS::Embeded::Httpd$sock query ::log::log info "Receviced request on $port for $ip:$clientport" array unset query reply chan configure $sock -translation crlf if {1 == [catch { gets $sock line ::log::log debug "Request is: $line" set auth {} 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]} { ::log::log warning "Connection closed from $ip" return } if {[dict exists $request header authorization]} { regexp -nocase {^basic +([^ ]+)$}\ [dict get $request header authorization] -> auth } if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} { ::log::log warning "Wrong request: $line" return } switch -exact -- $method { POST { ## ## This is all broken and needs to be fixed ## set data "" if {[dict exists $request header transfer-encoding] && [dict get $request header transfer-encoding] eq "chunked"} { # Receive chunked request body. while {[scan [gets $sock line] %x length] == 1 && $length > 0} { chan configure $sock -translation binary append data [read $sock $length] chan configure $sock -translation crlf } } else { # Receive non-chunked request body. chan configure $sock -translation binary set data [read $sock [dict get $request header content-length]] chan configure $sock -translation crlf } array set query [uri::split $url] set query(query) $data set query(headers) $request set query(ipaddr) $ip #parray query handler $port $sock $ip [array get query] $auth } GET { handler $port $sock $ip [uri::split $url] $auth } default { ::log::log warning "Unsupported method '$method' from $ip" respond $sock 501 "Method not implemented" } } } msg]} { ::log::log error "Error: $msg" # catch this against an eventual closed socket catch {respond $sock 500 "Server Error"} } catch {flush $sock} catch {close $sock} return } tclws-2.3.8/Examples/tclhttpd/custom/EchoWebService.tcl000644 001750 001750 00000007432 12500417200 022600 0ustar00mxmmxm000000 000000 ############################################################################### ## ## ## 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-2.3.8/Examples/aolserver/servers/tclws/pages/ws/mathexample/index.tcl000644 001750 001750 00000004445 12500417200 026577 0ustar00mxmmxm000000 000000 package 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-2.3.8/Makefile000644 001750 001750 00000000346 12500417200 013756 0ustar00mxmmxm000000 000000 # # "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-2.3.8/Examples/aolserver/servers/tclws/modules/tcl/000755 001750 001750 00000000000 12500417200 023152 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/aolserver/servers/tclws/modules/tcl/tclws/init.tcl000644 001750 001750 00000001331 12500417200 025753 0ustar00mxmmxm000000 000000 # 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-2.3.8/Examples/tclhttpd/custom/mypage.tcl000644 001750 001750 00000005440 12500417200 021222 0ustar00mxmmxm000000 000000 # # 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 "
    \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 } return $html } tclws-2.3.8/Examples/aolserver/servers/tclws/pages/global/000755 001750 001750 00000000000 12500417200 023257 5ustar00mxmmxm000000 000000 tclws-2.3.8/docs/Calling_a_Web_Service.html000644 001750 001750 00000052173 12500417200 020267 0ustar00mxmmxm000000 000000 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:

    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:

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

    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 :

    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.

    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

    Arguments : 

         wsdlXML - XML of the WSDL

    Optional Arguments: 

         -createStubs 0|1 - create stub routines for the service
                             NOTE -- Webservice arguments are position
                                     independent, thus the proc arguments
                                     will be defined in alphabetical order.
     -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 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.

     errorCmd        - A command prefix to be called if the operations
                       raises an error.  The error code and stack trace
                       are concatinated 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 : 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

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

    Description : Configure a service's information

    Arguments : 

         serviceName     - The name of the Webservice
     item   - The item to configure.  Must be one of

     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-2.3.8/Examples/aolserver/servers/tclws/pages/index.adp000644 001750 001750 00000011376 12500417200 023624 0ustar00mxmmxm000000 000000 <% 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-2.3.8/Examples/aolserver/lib/000755 001750 001750 00000000000 12500417200 016641 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/aolserver/servers/tclws/modules/000755 001750 001750 00000000000 12500417200 022370 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/Math/000755 001750 001750 00000000000 12500417200 014762 5ustar00mxmmxm000000 000000 tclws-2.3.8/Examples/README.txt000644 001750 001750 00000002217 12500417200 015571 0ustar00mxmmxm000000 000000 The 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/