Index: openacs-4/packages/tsoap/tsoap.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/tsoap/tsoap.info,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/tsoap/tsoap.info 17 Mar 2005 17:59:31 -0000 1.1
@@ -0,0 +1,33 @@
+
+
+
+
+ Tcl SOAP
+ Tcl SOAP
+ f
+ t
+
+
+
+ postgresql
+
+ Timo Hentschel
+
+ 2005-03-01
+ 0
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: openacs-4/packages/tsoap/tcl/SOAP-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/tsoap/tcl/SOAP-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/tsoap/tcl/SOAP-procs.tcl 17 Mar 2005 17:59:31 -0000 1.1
@@ -0,0 +1,1345 @@
+# SOAP.tcl - Copyright (C) 2001 Pat Thoyts
+#
+# Provide Tcl access to SOAP 1.1 methods.
+#
+# See http://tclsoap.sourceforge.net/ or doc/TclSOAP.html for usage details.
+#
+# -------------------------------------------------------------------------
+# This software is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE'
+# for more details.
+# -------------------------------------------------------------------------
+
+package require http 2.0; # tcl 8.n
+package require log; # tcllib 1.0
+package require uri; # tcllib 1.0
+catch {package require uri::urn}; # tcllib 1.2
+# package require SOAP::Utils; # TclSOAP
+# package require rpcvar; # TclSOAP
+package require tdom
+
+# -------------------------------------------------------------------------
+
+namespace eval ::SOAP {variable domVersion}
+
+# -------------------------------------------------------------------------
+
+namespace eval ::SOAP {
+ variable version 1.6.7
+ variable logLevel warning
+ variable rcs_version { $Id: SOAP-procs.tcl,v 1.1 2005/03/17 17:59:31 maltes Exp $ }
+
+ namespace export create cget dump configure proxyconfig export
+ catch {namespace import -force Utils::*} ;# catch to allow pkg_mkIndex.
+ catch {namespace import -force [uplevel {namespace current}]::rpcvar::*}
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Register the namespace for handling SOAP methods using 'scheme' as a
+# transport. See the http.tcl and smtp.tcl files for examples of how
+# to plug in a new scheme.
+# A SOAP transport package requires an 'xfer' method for performing the
+# SOAP method call and a 'configure' method for setting any transport
+# specific options via SOAP::configure -transport.
+# You may also have a 'dump' method to help with debugging.
+# Parameters:
+# scheme - should be a URI scheme (in fact it must be recognised by the
+# then uri package from tcllib)
+# namespace - the namespace within which the transport methods are defined.
+#
+proc ::SOAP::register {scheme namespace} {
+ variable transports
+ set transports($scheme) $namespace
+}
+
+# Description:
+# Internal method to return the namespace hosting a SOAP transport using
+# the URL scheme 'scheme'.
+#
+proc ::SOAP::schemeloc {scheme} {
+ variable transports
+ if {[info exists transports($scheme)]} {
+ return $transports($scheme)
+ } else {
+ return -code error "invalid transport scheme:\
+ \"$scheme\" is not registered. Try one of [array names transports]"
+ }
+}
+
+# Description:
+# Check for the existence of a SOAP Transport specific procedure.
+# If the named proc exists then the fully qualified name is returned
+# otherwise an empty string is returned.
+# Used by SOAP::destroy, SOAP::wait and others.
+#
+proc ::SOAP::transportHook {procVarName cmdname} {
+ upvar $procVarName procvar
+
+ array set URL [uri::split $procvar(proxy)]
+ if {$URL(scheme) == "urn"} {
+ set URL(scheme) "$a(scheme):$a(nid)"
+ }
+ set cmd [schemeloc $URL(scheme)]::$cmdname
+ if {[info command $cmd] == {}} {
+ set cmd {}
+ }
+ return $cmd
+}
+# -------------------------------------------------------------------------
+
+# Description:
+# Called from SOAP package methods, shift up to the callers level and
+# get the fully namespace qualified name for the given proc / var
+# Parameters:
+# name - the name of a Tcl entity, or list of command and arguments
+# Result:
+# Fully qualified namespace path for the named entity. If the name
+# parameter is a list the the first element is namespace qualified
+# and the remainder of the list is unchanged.
+#
+proc ::SOAP::qualifyNamespace {name} {
+ if {$name != {}} {
+ set name [lreplace $name 0 0 \
+ [uplevel 2 namespace origin [lindex $name 0]]]
+ }
+ return $name
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# An interal procedure to mangle and SOAP method name and it's namespace
+# and generate a name for use as a specific SOAP variable. This ensures
+# that similarly named methods in different namespaces do not conflict
+# within the SOAP package.
+# Parameters:
+# methodName - the SOAP method name
+#
+proc ::SOAP::methodVarName {methodName} {
+ if {[catch {uplevel 2 namespace origin $methodName} name]} {
+ return -code error "invalid method name:\
+ \"$methodName\" is not a SOAP method"
+ }
+ regsub -all {::+} $name {_} name
+ return [namespace current]::$name
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Set the amount of logging you would like to see. This is for debugging
+# the SOAP package. We use the tcllib log package for this so the level
+# must be one of log::levels. The default is 'warning'.
+# Parameters:
+# level - one of log::levels. See the tcllib log package documentation.
+#
+proc ::SOAP::setLogLevel {level} {
+ variable logLevel
+ set logLevel $level
+ log::lvSuppressLE emergency 0
+ log::lvSuppressLE $logLevel 1
+ log::lvSuppress $logLevel 0
+ return $logLevel
+}
+if {[info exists SOAP::logLevel]} {
+ SOAP::setLogLevel $SOAP::logLevel
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Retrieve configuration variables from the SOAP package. The options
+# are all as found for SOAP::configure.
+#
+# FIXME: do for -transport as well!
+#
+proc ::SOAP::cget { args } {
+
+ if { [llength $args] != 2 } {
+ return -code error "wrong # args:\
+ should be \"cget methodName optionName\""
+ }
+
+ set methodName [lindex $args 0]
+ set optionName [lindex $args 1]
+ set configVarName [methodVarName $methodName]
+
+ # FRINK: nocheck
+ if {[catch {set [subst $configVarName]([string trimleft $optionName "-"])} result]} {
+ # kenstir@synchonicity.com: Fixed typo.
+ return -code error "unknown option \"$optionName\""
+ }
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Dump out information concerning the last SOAP transaction for a
+# SOAP method. What you can dump depends on the transport involved.
+# Parameters:
+# ?-option? - specify type of data to dump.
+# methodName - the SOAP method to dump data from.
+# Notes:
+# Delegates to the transport namespace to a 'dump' procedure.
+#
+proc ::SOAP::dump {args} {
+ if {[llength $args] == 1} {
+ set type -reply
+ set methodName [lindex $args 0]
+ } elseif { [llength $args] == 2 } {
+ set type [lindex $args 0]
+ set methodName [lindex $args 1]
+ } else {
+ return -code error "wrong # args:\
+ should be \"dump ?option? methodName\""
+ }
+
+ # call the transports 'dump' proc if found
+ set procVarName [methodVarName $methodName]
+ if {[set cmd [transportHook $procVarName dump]] != {}} {
+ $cmd $methodName $type
+ } else {
+ return -code error "no dump available:\
+ the configured transport has no 'dump' procedure defined"
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Configure or display a SOAP method options.
+# Parameters:
+# procName - the SOAP method Tcl procedure name
+# args - list of option name / option pairs
+# Result:
+# Sets up a configuration array for the SOAP method.
+#
+proc ::SOAP::configure { procName args } {
+ variable transports
+
+ # The list of valid options, used in the error messsage
+ set options { uri proxy params name transport action \
+ wrapProc replyProc parseProc postProc \
+ command errorCommand schemas version \
+ encoding }
+
+ if { $procName == "-transport" } {
+ set scheme [lindex $args 0]
+ set config "[schemeloc $scheme]::configure"
+ if {[info command $config] != {}} {
+ return [eval $config [lrange $args 1 end]]
+ } else {
+ return -code error "invalid transport:\
+ \"$scheme\" is not a valid SOAP transport method."
+ }
+ }
+
+ if { [string match "-logLevel" $procName] } {
+ if {[llength $args] > 0} {
+ setLogLevel [lindex $args 0]
+ }
+ variable logLevel
+ return $logLevel
+ }
+
+ # construct the name of the options array from the procName.
+ set procVarName "[uplevel namespace current]::$procName"
+ regsub -all {::+} $procVarName {_} procVarName
+ set procVarName [namespace current]::$procVarName
+
+ # Check that the named method has actually been defined
+ if {! [array exists $procVarName]} {
+ return -code error "invalid command: \"$procName\" not defined"
+ }
+ upvar $procVarName procvar
+
+ # Add in transport plugin defined options and locate the
+ # configuration hook procedure if one exists.
+ set scheme [eval getTransportFromArgs $procVarName $args]
+ if {$scheme != {}} {
+ set transport_opts "[schemeloc $scheme]::method:options"
+ if {[info exists $transport_opts]} {
+ # FRINK: nocheck
+ set options [concat $options [set $transport_opts]]
+ }
+ set transportHook "[schemeloc $scheme]::method:configure"
+ }
+
+ # if no args - print out the current settings.
+ if { [llength $args] == 0 } {
+ set r {}
+ foreach opt $options {
+ if {[info exists procvar($opt)]} {
+ lappend r -$opt $procvar($opt)
+ }
+ }
+ return $r
+ }
+
+ foreach {opt value} $args {
+ switch -glob -- $opt {
+ -uri { set procvar(uri) $value }
+ -proxy { set procvar(proxy) $value }
+ -param* { set procvar(params) $value }
+ -trans* { set procvar(transport) $value }
+ -name { set procvar(name) $value }
+ -action { set procvar(action) $value }
+ -schema* { set procvar(schemas) $value }
+ -ver* { set procvar(version) $value }
+ -enc* { set procvar(encoding) $value }
+ -wrap* { set procvar(wrapProc) [qualifyNamespace $value] }
+ -rep* { set procvar(replyProc) [qualifyNamespace $value] }
+ -parse* { set procvar(parseProc) [qualifyNamespace $value] }
+ -post* { set procvar(postProc) [qualifyNamespace $value] }
+ -com* { set procvar(command) [qualifyNamespace $value] }
+ -err* {
+ set procvar(errorCommand) [qualifyNamespace $value]
+ }
+ default {
+ # might be better to delete the args as we process them
+ # and then call this once with all the remaining args.
+ # Still - this will work fine.
+ if {[info exists transportHook]
+ && [info command $transportHook] != {}} {
+ if {[catch {eval $transportHook $procVarName \
+ [list $opt] [list $value]}]} {
+ return -code error "unknown option \"$opt\":\
+ must be one of ${options}"
+ }
+ } else {
+ return -code error "unknown option \"$opt\":\
+ must be one of ${options}"
+ }
+ }
+ }
+ }
+
+ if { $procvar(name) == {} } {
+ set procvar(name) $procName
+ }
+
+ # If the transport proc is not overridden then set based upon the proxy
+ # scheme registered by SOAP::register.
+ if { $procvar(transport) == {} } {
+ set xferProc "[schemeloc $scheme]::xfer"
+ if {[info command $xferProc] != {}} {
+ set procvar(transport) $xferProc
+ } else {
+ return -code error "invalid transport:\
+ \"$scheme\" is improperly registered"
+ }
+ }
+
+ # The default version is SOAP 1.1
+ if { $procvar(version) == {} } {
+ set procvar(version) SOAP1.1
+ }
+ # Canonicalize the SOAP version URI
+ switch -glob -- $procvar(version) {
+ SOAP1.1 - 1.1 {
+ set procvar(version) "http://schemas.xmlsoap.org/soap/envelope/"
+ }
+ SOAP1.2 - 1.2 {
+ set procvar(version) "http://www.w3.org/2001/06/soap-envelope"
+ }
+ }
+
+ # Default SOAP encoding is SOAP 1.1
+ if { $procvar(encoding) == {} } {
+ set procvar(encoding) SOAP1.1
+ }
+ switch -glob -- $procvar(encoding) {
+ SOAP1.1 - 1.1 {
+ set procvar(encoding) "http://schemas.xmlsoap.org/soap/encoding/"
+ }
+ SOAP1.2 - 1.2 {
+ set procvar(encoding) "http://www.w3.org/2001/06/soap-encoding"
+ }
+ }
+
+ # Select the default parser unless one is specified
+ if { $procvar(parseProc) == {} } {
+ set procvar(parseProc) [namespace current]::parse_soap_response
+ }
+
+ # If no request wrapper is set, use the default SOAP wrap proc.
+ if { $procvar(wrapProc) == {} } {
+ set procvar(wrapProc) [namespace current]::soap_request
+ }
+
+ # Create the Tcl procedure that maps to this RPC method.
+ uplevel 1 "proc $procName { args } {eval [namespace current]::invoke $procVarName \$args}"
+
+ # return the fully qualified command name created.
+ return [uplevel 1 "namespace which $procName"]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Create a Tcl wrapper for a SOAP methodcall. This constructs a Tcl command
+# and the necessary data structures to support the method call using the
+# specified transport.
+#
+proc ::SOAP::create { args } {
+ if { [llength $args] < 1 } {
+ return -code error "wrong # args:\
+ should be \"create procName ?options?\""
+ } else {
+ set procName [lindex $args 0]
+ set args [lreplace $args 0 0]
+ }
+
+ set ns "[uplevel namespace current]::$procName"
+ regsub -all {::+} $ns {_} varName
+ set varName [namespace current]::$varName
+ array set $varName {}
+ array set $varName {uri {}} ;# the XML namespace URI for this method
+ array set $varName {proxy {}} ;# URL for the location of a provider
+ array set $varName {params {}} ;# name/type pairs for the parameters
+ array set $varName {transport {}} ;# transport procedure for this method
+ array set $varName {name {}} ;# SOAP method name
+ array set $varName {action {}} ;# Contents of the SOAPAction header
+ array set $varName {wrapProc {}} ;# encode request into XML for sending
+ array set $varName {replyProc {}} ;# post process the raw XML result
+ array set $varName {parseProc {}} ;# parse raw XML and extract the values
+ array set $varName {postProc {}} ;# post process the parsed result
+ array set $varName {command {}} ;# asynchronous reply handler
+ array set $varName {errorCommand {}} ;# asynchronous error handler
+ array set $varName {headers {}} ;# SOAP Head elements returned.
+ array set $varName {schemas {}} ;# List of SOAP Schemas in force
+ array set $varName {version {}} ;# SOAP Version in force (URI)
+ array set $varName {encoding {}} ;# SOAP Encoding (URI)
+
+ set scheme [eval getTransportFromArgs $varName $args]
+ if {$scheme != {}} {
+ # Add any transport defined method options
+ set transportOptions "[schemeloc $scheme]::method:options"
+ # FRINK: nocheck
+ foreach opt [set $transportOptions] {
+ array set $varName [list $opt {}]
+ }
+
+ # Call any transport defined construction proc
+ set createHook "[schemeloc $scheme]::method:create"
+ if {[info command $createHook] != {}} {
+ eval $createHook $varName $args
+ }
+ }
+
+ # call configure from the callers level so it can get the namespace.
+ return [uplevel 1 "[namespace current]::configure $procName $args"]
+}
+
+# Identify the transport protocol so we can include transport specific
+# creation code.
+proc getTransportFromArgs {procVarName args} {
+ upvar $procVarName procvar
+ set uri {}
+ set scheme {}
+ if {$procvar(proxy) != {}} {
+ set uri $procvar(proxy)
+ } elseif {[set n [lsearch -exact $args -proxy]] != -1} {
+ incr n
+ set uri [lindex $args $n]
+ }
+ if {$uri != {}} {
+ array set URL [uri::split $uri]
+ if {$URL(scheme) == "urn"} {
+ set URL(scheme) $URL(scheme):$URL(nid)
+ }
+ set scheme $URL(scheme)
+ }
+ return $scheme
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Export a list of procedure names as SOAP endpoints. This is only used
+# in the SOAP server code to specify the subset of Tcl commands that should
+# be accessible via a SOAP call.
+# Parameters:
+# args - a list of tcl commands to be made available as SOAP endpoints.
+#
+proc ::SOAP::export {args} {
+ foreach item $args {
+ uplevel "set \[namespace current\]::__soap_exports($item)\
+ \[namespace code $item\]"
+ }
+ return
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Reverse the SOAP::create command by deleting the SOAP method binding and
+# freeing up any allocated resources. This needs to delegate to the
+# transports cleanup procedure if one is defined as well.
+# Parameters:
+# methodName - the name of the SOAP method command
+#
+proc ::SOAP::destroy {methodName} {
+ set procVarName [methodVarName $methodName]
+
+ # Delete the SOAP command
+ uplevel rename $methodName {{}}
+
+ # Call the transport specific method destructor (if any)
+ if {[set cmd [transportHook $procVarName method:destroy]] != {}} {
+ $cmd $procVarName
+ }
+
+ # Delete the SOAP method configuration array
+ # FRINK: nocheck
+ unset $procVarName
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Wait for any pending asynchronous method calls.
+# Parameters:
+# methodName - the method binding we are interested in.
+#
+proc ::SOAP::wait {methodName} {
+ set procVarName [methodVarName $methodName]
+
+ # Call the transport specific method wait proc (if any)
+ if {[set cmd [transportHook $procVarName wait]] != {}} {
+ $cmd $procVarName
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Make a SOAP method call using the configured transport.
+# See also 'invoke2' for the reply handling which may be asynchronous.
+# Parameters:
+# procName - the SOAP method configuration variable path
+# args - the parameter list for the SOAP method call
+# Returns:
+# Returns the parsed and processed result of the method call
+#
+proc ::SOAP::invoke { procVarName args } {
+ set procName [lindex [split $procVarName {_}] end]
+ if {![array exists $procVarName]} {
+ return -code error "invalid command: \"$procName\" not defined"
+ }
+
+ upvar $procVarName procvar
+
+ # Get the URL
+ set url $procvar(proxy)
+
+ # Get the XML data containing our request by calling the -wrapProc
+ # procedure
+ set req [eval "$procvar(wrapProc) $procVarName $args"]
+
+ # Send the SOAP packet (req) using the configured transport procedure
+ set transport $procvar(transport)
+ set reply [$transport $procVarName $url $req]
+
+ # Check for an async command handler. If async then return now,
+ # otherwise call the invoke second stage immediately.
+ if { $procvar(command) != {} } {
+ return $reply
+ }
+ return [invoke2 $procVarName $reply]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# The second stage of the method invocation deals with unwrapping the
+# reply packet that has been received from the remote service.
+# Parameters:
+# procVarName - the SOAP method configuration variable path
+# reply - the raw data returned from the remote service
+# Notes:
+# This has been separated from `invoke' to support asynchronous
+# transports. It calls the various unwrapping hooks in turn.
+#
+proc ::SOAP::invoke2 {procVarName reply} {
+ set ::lastReply $reply
+
+ set procName [lindex [split $procVarName {_}] end]
+ upvar $procVarName procvar
+
+ # Post-process the raw XML using -replyProc
+ if { $procvar(replyProc) != {} } {
+ set reply [$procvar(replyProc) $procVarName $reply]
+ }
+
+ # Call the relevant parser to extract the returned values
+ set parseProc $procvar(parseProc)
+ if { $parseProc == {} } {
+ set parseProc parse_soap_response
+ }
+ set r [$parseProc $procVarName $reply]
+
+ # Post process the parsed reply using -postProc
+ if { $procvar(postProc) != {} } {
+ set r [$procvar(postProc) $procVarName $r]
+ }
+
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Dummy SOAP transports to examine the SOAP requests generated for use
+# with the test package and for debugging.
+# Parameters:
+# procVarName - SOAP method name configuration variable
+# url - URL of the remote server method implementation
+# soap - the XML payload for this SOAP method call
+#
+namespace eval SOAP::Transport::print {
+ variable method:options {}
+ proc configure {args} {
+ return
+ }
+ proc xfer { procVarName url soap } {
+ puts "$soap"
+ }
+ SOAP::register urn:print [namespace current]
+}
+
+namespace eval SOAP::Transport::reflect {
+ variable method:options {}
+ proc configure {args} {
+ return
+ }
+ proc xfer {procVarName url soap} {
+ return $soap
+ }
+ SOAP::register urn:reflect [namespace current]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Setup SOAP HTTP transport for an authenticating proxy HTTP server.
+# At present the SOAP package only supports Basic authentication and this
+# dialog is used to configure the proxy information.
+# Parameters:
+# none
+
+proc ::SOAP::proxyconfig {} {
+ package require Tk
+ if { [catch {package require base64}] } {
+ return -code error "proxyconfig requires the tcllib base64 package."
+ }
+ toplevel .tx
+ wm title .tx "Proxy Authentication Configuration"
+ set m [message .tx.m1 -relief groove -justify left -width 6c -aspect 200 \
+ -text "Enter details of your proxy server (if any) and your\
+ username and password if it is needed by the proxy."]
+ set f1 [frame .tx.f1]
+ set f2 [frame .tx.f2]
+ button $f2.b -text "OK" -command {destroy .tx}
+ pack $f2.b -side right
+ label $f1.l1 -text "Proxy (host:port)"
+ label $f1.l2 -text "Username"
+ label $f1.l3 -text "Password"
+ entry $f1.e1 -textvariable SOAP::conf_proxy
+ entry $f1.e2 -textvariable SOAP::conf_userid
+ entry $f1.e3 -textvariable SOAP::conf_passwd -show {*}
+ grid $f1.l1 -column 0 -row 0 -sticky e
+ grid $f1.l2 -column 0 -row 1 -sticky e
+ grid $f1.l3 -column 0 -row 2 -sticky e
+ grid $f1.e1 -column 1 -row 0 -sticky news
+ grid $f1.e2 -column 1 -row 1 -sticky news
+ grid $f1.e3 -column 1 -row 2 -sticky news
+ grid columnconfigure $f1 1 -weight 1
+ pack $f2 -side bottom -fill x
+ pack $m -side top -fill x -expand 1
+ pack $f1 -side top -anchor n -fill both -expand 1
+
+ #bind .tx "$f2.b invoke"
+
+ tkwait window .tx
+ SOAP::configure -transport http -proxy $SOAP::conf_proxy
+ if { [info exists SOAP::conf_userid] } {
+ SOAP::configure -transport http \
+ -headers [list "Proxy-Authorization" \
+ "Basic [lindex [base64::encode ${SOAP::conf_userid}:${SOAP::conf_passwd}] 0]" ]
+ }
+ unset SOAP::conf_passwd
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Prepare a SOAP fault message
+# Parameters:
+# faultcode - the SOAP faultcode e.g: SOAP-ENV:Client
+# faultstring - summary of the fault
+# detail - list of {detailName detailInfo}
+# Result:
+# returns the XML text of the SOAP Fault packet.
+#
+proc ::SOAP::fault {faultcode faultstring {detail {}}} {
+ set doc [dom createDocument "SOAP-ENV:Envelope"]
+ set bod [reply_envelope $doc]
+ set flt [$doc createElement "SOAP-ENV:Fault"]
+ $bod appendChild $flt
+ set fcd [$doc createElement "faultcode"]
+ $flt appendChild $fcd
+ $fcd appendChild [$doc createTextNode $faultcode]
+ set fst [$doc createElement "faultstring"]
+ $flt appendChild $fst
+ $fst appendChild [$doc createTextNode $faultstring]
+
+ if { $detail != {} } {
+ set dtl0 [$doc createElement "detail"]
+ $flt appendChild $dtl0
+ set dtl [$doc createElement "e:errorInfo"]
+ $dtl0 appendChild $dtl
+ $dtl setAttribute "xmlns:e" "urn:TclSOAP-ErrorInfo"
+
+ foreach {detailName detailInfo} $detail {
+ set err [$doc createElement $detailName]
+ $dtl appendChild $err
+ $err appendChild [$doc createTextNode $detailInfo]
+ }
+ }
+
+ # serialize the DOM document and return the XML text
+ regsub "\]*>\n" [$doc asXML] {} r
+ $doc delete
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Generate the common portion of a SOAP replay packet
+# Parameters:
+# doc - the document element of a DOM document
+# Result:
+# returns the body node
+#
+proc ::SOAP::reply_envelope { doc } {
+ set env [$doc documentElement]
+ $env setAttribute "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/"
+ $env setAttribute "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance"
+ $env setAttribute "xmlns:xsd" "http://www.w3.org/1999/XMLSchema"
+ $env setAttribute "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/"
+ set bod [$doc createElement "SOAP-ENV:Body"]
+ $env appendChild $bod
+ return $bod
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Generate a SOAP reply packet. Uses 'rpcvar' variable type information to
+# manage complex data structures and arrays.
+# Parameters:
+# doc empty DOM document element
+# uri URI of the SOAP method
+# methodName the SOAP method name
+# result the reply data
+# Result:
+# returns the DOM document root
+#
+proc ::SOAP::reply { doc uri methodName result } {
+ set bod [reply_envelope $doc]
+ set cmd [$doc createElement "ns:$methodName"]
+ $bod appendChild $cmd
+ $cmd setAttribute "xmlns:ns" $uri
+ $cmd setAttribute \
+ "SOAP-ENV:encodingStyle" \
+ "http://schemas.xmlsoap.org/soap/encoding/"
+
+ # insert the results into the DOM tree (unless it's a void result)
+ if {$result != {}} {
+ # Some methods may return a parameter list of name - value pairs.
+ if {[rpctype $result] == "PARAMLIST"} {
+ foreach {resultName resultValue} [rpcvalue $result] {
+ set retnode [$doc createElement $resultName]
+ $cmd appendChild $retnode
+ SOAP::insert_value $retnode $resultValue
+ }
+ } else {
+ set retnode [$doc createElement "return"]
+ $cmd appendChild $retnode
+ SOAP::insert_value $retnode $result
+ }
+ }
+
+ return $doc
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Procedure to generate the XML data for a configured SOAP procedure.
+# This is the default SOAP -wrapProc procedure
+# Parameters:
+# procVarName - the path of the SOAP method configuration variable
+# args - the arguments for this SOAP method
+# Result:
+# XML data containing the SOAP method call.
+# Notes:
+# We permit a small number of option to be specified on the method call
+# itself. -headers is used to set SOAP Header elements and -attr can be
+# used to set additional XML attributes on the method element (needed for
+# UDDI.)
+#
+proc ::SOAP::soap_request {procVarName args} {
+ upvar $procVarName procvar
+
+ set procName [lindex [split $procVarName {_}] end]
+ set params $procvar(params)
+ set name $procvar(name)
+ set uri $procvar(uri)
+ set soapenv $procvar(version)
+ set soapenc $procvar(encoding)
+
+ # Check for options (ie: -header) give up on the fist non-matching arg.
+ array set opts {-headers {} -attributes {}}
+ while {[string match -* [lindex $args 0]]} {
+ switch -glob -- [lindex $args 0] {
+ -header* {
+ set opts(-headers) [concat $opts(-headers) [lindex $args 1]]
+ set args [lreplace $args 0 0]
+ }
+ -attr* {
+ set opts(-attributes) [concat $opts(-attributes) [lindex $args 1]]
+ set args [lreplace $args 0 0]
+ }
+ -- {
+ set args [lreplace $args 0 0]
+ break
+ }
+ default {
+ # stop option processing at the first invalid option.
+ break
+ }
+ }
+ set args [lreplace $args 0 0]
+ }
+
+ # check for variable number of params and set the num required.
+ if {[lindex $params end] == "args"} {
+ set n_params [expr {( [llength $params] - 1 ) / 2}]
+ } else {
+ set n_params [expr {[llength $params] / 2}]
+ }
+
+ # check we have the correct number of parameters supplied.
+ if {[llength $args] < $n_params} {
+ set msg "wrong # args: should be \"$procName"
+ foreach { id type } $params {
+ append msg " " $id
+ }
+ append msg "\""
+ return -code error $msg
+ }
+
+ set doc [dom createDocument "SOAP-ENV:Envelope"]
+ set envx [$doc documentElement]
+
+ $envx setAttribute "xmlns:SOAP-ENV" $soapenv
+ $envx setAttribute "xmlns:SOAP-ENC" $soapenc
+ $envx setAttribute "SOAP-ENV:encodingStyle" $soapenc
+
+ # The set of namespaces depends upon the SOAP encoding as specified by
+ # the encoding option and the user specified set of relevant schemas.
+ foreach {nsname url} [concat \
+ [rpcvar::default_schemas $soapenc] \
+ $procvar(schemas)] {
+ if {! [string match "xmlns:*" $nsname]} {
+ set nsname "xmlns:$nsname"
+ }
+ $envx setAttribute $nsname $url
+ }
+
+ # Insert the Header elements (if any)
+ if {$opts(-headers) != {}} {
+ set headelt [$doc createElement "SOAP-ENV:Header"]
+ $envx appendChild $headelt
+ foreach {hname hvalue} $opts(-headers) {
+ set hnode [$doc createElement $hname]
+ $headelt appendChild $hnode
+ insert_value $hnode $hvalue
+ }
+ }
+
+ # Insert the body element and atributes.
+ set bod [$doc createElement "SOAP-ENV:Body"]
+ $envx appendChild $bod
+ if {$uri == ""} {
+ # don't use a namespace prefix if we don't have a namespace.
+ set cmd [$doc createElement "$name" ]
+ $bod appendChild $cmd
+ } else {
+ set cmd [$doc createElement "ns:$name" ]
+ $bod appendChild $cmd
+ $cmd setAttribute "xmlns:ns" $uri
+ }
+
+ # Insert any method attributes
+ if {$opts(-attributes) != {}} {
+ foreach {atname atvalue} $opts(-attributes) {
+ $cmd setAttribute $atname $atvalue
+ }
+ }
+
+ # insert the parameters.
+ set param_no 0
+ foreach {key type} $params {
+ set val [lindex $args $param_no]
+ set d_param [$doc createElement $key]
+ $cmd appendChild $d_param
+ insert_value $d_param [rpcvar::rpcvar $type $val]
+ incr param_no
+ }
+
+ # We have to strip out the DOCTYPE element though. It would be better to
+ # remove the DOM node for this, but that didn't work.
+ set prereq [$doc asXML]
+ set req {}
+ $doc delete ;# clean up
+ regsub "\]*>\r?\n?" $prereq {} req ;# hack
+
+ set req [encoding convertto utf-8 $req] ;# make it UTF-8
+ ns_log notice "\#\#\# request:\n$req"
+ return $req ;# return the XML data
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Procedure to generate the XML data for a configured XML-RPC procedure.
+# Parameters:
+# procVarName - the name of the XML-RPC method variable
+# args - the arguments for this RPC method
+# Result:
+# XML data containing the XML-RPC method call.
+#
+proc ::SOAP::xmlrpc_request {procVarName args} {
+ upvar $procVarName procvar
+
+ set procName [lindex [split $procVarName {_}] end]
+ set params $procvar(params)
+ set name $procvar(name)
+
+ if { [llength $args] != [expr { [llength $params] / 2 } ]} {
+ set msg "wrong # args: should be \"$procName"
+ foreach { id type } $params {
+ append msg " " $id
+ }
+ append msg "\""
+ return -code error $msg
+ }
+
+ set doc [dom createDocument "methodCall"]
+ set d_root [$doc documentElement]
+ set d_meth [$doc createElement "methodName"]
+ $d_root appendChild $d_meth
+ $d_meth appendChild [$doc createTextNode $name]
+
+ if { [llength $params] != 0 } {
+ set d_params [$doc createElement "params"]
+ $d_root appendChild $d_params
+ }
+
+ set param_no 0
+ foreach {key type} $params {
+ set val [lindex $args $param_no]
+ set d_param [$doc createElement "param"]
+ $d_params appendChild $d_param
+ XMLRPC::insert_value $d_param [rpcvar::rpcvar $type $val]
+ incr param_no
+ }
+
+ # We have to strip out the DOCTYPE element though. It would be better to
+ # remove the DOM element, but that didn't work.
+ set prereq [$doc asXML]
+ set req {}
+ $doc delete ;# clean up
+ regsub "\]*>\n" $prereq {} req ;# hack
+
+ return $req ;# return the XML data
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Parse a SOAP response payload. Check for Fault response otherwise
+# extract the value data.
+# Parameters:
+# procVarName - the name of the SOAP method configuration variable
+# xml - the XML payload of the response
+# Result:
+# The returned value data.
+# Notes:
+# Needs work to cope with struct or array types.
+#
+proc ::SOAP::parse_soap_response { procVarName xml } {
+ upvar $procVarName procvar
+
+ # Sometimes Fault packets come back with HTTP code 200
+ #
+ # kenstir@synchronicity.com: Catch xml parse errors and present a
+ # friendlier message. The parse method throws awful messages like
+ # "{invalid attribute list} around line 16".
+ if {$xml == {} && ![string match "http*" $procvar(proxy)]} {
+ # This is probably not an error. SMTP and FTP won't return anything
+ # HTTP should always return though (I think).
+ return {}
+ } else {
+ if {[catch {set doc [dom parse $xml]}]} {
+ return -code error -errorcode Server \
+ "Server response is not well-formed XML.\nresponse was $xml"
+ }
+ }
+
+ set faultNode [selectNode $doc "/Envelope/Body/Fault"]
+ if {$faultNode != {}} {
+ array set fault [decomposeSoap $faultNode]
+ $doc delete
+ if {![info exists fault(detail)]} { set fault(detail) {}}
+ return -code error -errorinfo $fault(detail) \
+ [list $fault(faultcode) $fault(faultstring)]
+ }
+
+ # If there is a header element then make it available via SOAP::getHeader
+ set headerNode [selectNode $doc "/Envelope/Header"]
+ if {$headerNode != {} \
+ && [string match \
+ "http://schemas.xmlsoap.org/soap/envelope/" \
+ [namespaceURI $headerNode]]} {
+ set procvar(headers) [decomposeSoap $headerNode]
+ } else {
+ set procvar(headers) {}
+ }
+
+ set result {}
+
+ if {[info exists procvar(name)]} {
+ set responseName "$procvar(name)Response"
+ } else {
+ set responseName "*"
+ }
+ set responseNode [selectNode $doc "/Envelope/Body/$responseName"]
+ if {$responseNode == {}} {
+ set responseNode [lindex [selectNode $doc "/Envelope/Body/*"] 0]
+ }
+
+ set nodes [getElements $responseNode]
+ foreach node $nodes {
+ set r [decomposeSoap $node]
+ if {$result == {}} { set result $r } else { lappend result $r }
+ }
+
+ $doc delete
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Parse an XML-RPC response payload. Check for fault response otherwise
+# extract the value data.
+# Parameters:
+# procVarName - the name of the XML-RPC method configuration variable
+# xml - the XML payload of the response
+# Result:
+# The extracted value(s). Array types are converted into lists and struct
+# types are turned into lists of name/value pairs suitable for array set
+# Notes:
+# The XML-RPC fault response doesn't allow us to add in extra values
+# to the fault struct. So where to put the servers errorInfo?
+#
+proc ::SOAP::parse_xmlrpc_response { procVarName xml } {
+ upvar $procVarName procvar
+ set result {}
+ if {$xml == {} && ![string match "http*" $procvar(proxy)]} {
+ # This is probably not an error. SMTP and FTP won't return anything
+ # HTTP should always return though (I think).
+ return {}
+ } else {
+ if {[catch {set doc [dom parse $xml]}]} {
+ return -code error -errorcode Server \
+ "Server response is not well-formed XML.\n\
+ response was $xml"
+ }
+ }
+
+ set faultNode [selectNode $doc "/methodResponse/fault"]
+ if {$faultNode != {}} {
+ array set err [lindex [decomposeXMLRPC \
+ [selectNode $doc /methodResponse]] 0]
+ $doc delete
+ return -code error \
+ -errorcode $err(faultCode) \
+ -errorinfo $err(faultString) \
+ "Received XML-RPC Error"
+ }
+
+ # Recurse over each params/param/value
+ set n_params 0
+ foreach valueNode [selectNode $doc \
+ "/methodResponse/params/param/value"] {
+ lappend result [xmlrpc_value_from_node $valueNode]
+ incr n_params
+ }
+ $doc delete
+
+ # If (as is usual) there is only one param, simplify things for the user
+ # ie: sort {one two three} should return a 3 element list, not a single
+ # element list whose first element has 3 elements!
+ if {$n_params == 1} {set result [lindex $result 0]}
+ return $result
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Parse an XML-RPC call payload. Extracts method name and parameters.
+# Parameters:
+# procVarName - the name of the XML-RPC method configuration variable
+# xml - the XML payload of the response
+# Result:
+# A list containing the name of the called method as first element
+# and the extracted parameter(s) as second element. Array types are
+# converted into lists and struct types are turned into lists of
+# name/value pairs suitable for array set
+# Notes:
+#
+proc ::SOAP::parse_xmlrpc_request { xml } {
+ set result {}
+ if {[catch {set doc [dom parse $xml]}]} {
+ return -code error -errorinfo Server \
+ "Client request is not well-formed XML.\n\
+ call was $xml"
+ }
+
+ set methodNode [selectNode $doc "/methodCall/methodName"]
+ set methodName [getElementValue $methodNode]
+
+ # Get the parameters.
+
+ # If there is only one parameter, simplify things for the user,
+ # ie: sort {one two three} should return a 3 element list, not a
+ # single element list whose first element has 3 elements!
+
+ set paramsNode [selectNode $doc "/methodCall/params"]
+ set paramValues {}
+ if {$paramsNode != {}} {
+ set paramValues [decomposeXMLRPC $paramsNode]
+ }
+ if {[llength $paramValues] == 1} {
+ set paramValues [lindex $paramValues 0]
+ }
+
+ catch {$doc delete}
+
+ return [list $methodName $paramValues]
+}
+
+# -------------------------------------------------------------------------
+
+### NB: this procedure needs to be moved into XMLRPC namespace
+
+# Description:
+# Retrieve the value under the given node.
+# Parameters:
+# valueNode - reference to a element in the response dom tree
+# Result:
+# Either a single value or a list of values. Arrays expand into a list
+# of values, structs to a list of name/value pairs.
+# Notes:
+# Called recursively when processing arrays and structs.
+#
+proc ::SOAP::xmlrpc_value_from_node {valueNode} {
+ set value {}
+ set elts [getElements $valueNode]
+
+ if {[llength $elts] != 1} {
+ return [getElementValue $valueNode]
+ }
+ set typeElement [lindex $elts 0]
+ set type [$typeElement nodeName]
+
+ if {$type == "array"} {
+ set dataElement [lindex [getElements $typeElement] 0]
+ foreach valueElement [getElements $dataElement] {
+ lappend value [xmlrpc_value_from_node $valueElement]
+ }
+ } elseif {$type == "struct"} {
+ # struct type has 1+ members which have a name and a value elt.
+ foreach memberElement [getElements $typeElement] {
+ set params [getElements $memberElement]
+ foreach param $params {
+ set nodeName [$param nodeName]
+ if { $nodeName == "name"} {
+ set pname [getElementValue $param]
+ } elseif { $nodeName == "value" } {
+ set pvalue [xmlrpc_value_from_node $param]
+ }
+ }
+ lappend value $pname $pvalue
+ }
+ } else {
+ set value [getElementValue $typeElement]
+ }
+ return $value
+}
+
+# -------------------------------------------------------------------------
+
+proc ::SOAP::insert_headers {node headers} {
+ set doc [SOAP::Utils::getDocumentElement $node]
+ if {[set h [selectNode $doc /Envelope/Header]] == {}} {
+ set e [$doc documentElement]
+ set h [$doc createElement "SOAP-ENV:Header"]
+ $e appendChild $h
+ }
+ foreach {name value} $headers {
+ if {$name != {}} {
+ set elt [$doc createElement $name]
+ $h appendChild $elt
+ insert_value $elt $value
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+proc ::SOAP::insert_value {node value} {
+
+ set type [rpctype $value]
+ set subtype [rpcsubtype $value]
+ set attrs [rpcattributes $value]
+ set headers [rpcheaders $value]
+ set value [rpcvalue $value]
+ set typeinfo [typedef -info $type]
+ set typexmlns [typedef -namespace $type]
+ set doc [$node ownerDocument]
+
+ # Handle any header elements
+ if {$headers != {}} {
+ insert_headers $node $headers
+ }
+
+ # If the rpcvar namespace is a URI then assign it a tag and ensure we
+ # have our colon only when required.
+ if {$typexmlns != {} && [regexp : $typexmlns]} {
+ $node setAttribute "xmlns:t" $typexmlns
+ set typexmlns t
+ }
+ if {$typexmlns != {}} { append typexmlns : }
+
+ # If there are any attributes assigned, apply them.
+ if {$attrs != {}} {
+ foreach {aname avalue} $attrs {
+ $node setAttribute $aname $avalue
+ }
+ }
+
+ if {[string match {*()} $typeinfo] || [string match {*()} $type]
+ || [string match array $type]} {
+ # array type: arrays are indicated by one or more () suffixes or
+ # the word 'array' (depreciated)
+
+ if {[string length $typeinfo] == 0} {
+ set dimensions [regexp -all -- {\(\)} $type]
+ set itemtype [string trimright $type ()]
+ if {$itemtype == "array"} {
+ set itemtype ur-type
+ set dimensions 1
+ }
+ } else {
+ set dimensions [regexp -all -- {\(\)} $typeinfo]
+ set itemtype [string trimright $typeinfo ()]
+ }
+
+ # Look up the typedef info of the item type
+ set itemxmlns [typedef -namespace $itemtype]
+ if {$itemxmlns != {} && [regexp : $itemxmlns]} {
+ $node setAttribute "xmlns:i" $itemxmlns
+ set itemxmlns i
+ }
+
+ # Currently we do not support non-0 offsets into the array.
+ # This is because I don;t know how I should present this to the
+ # user. It's got to be a dynamic attribute on the value.
+ $node setAttribute "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/"
+ $node setAttribute "xsi:type" "SOAP-ENC:Array"
+ $node setAttribute "SOAP-ENC:offset" "\[0\]"
+
+ # we need to break a multi-dim array into r0c0,r0c1,r1c0,r1c1
+ # so list0 followed by list1 etc.
+ # FIX ME
+ set arrayType "$itemxmlns:$itemtype"
+ #for {set cn 0} {$cn < $dimensions} {incr cn}
+ append arrayType "\[[llength $value]\]"
+ $node setAttribute "SOAP-ENC:arrayType" $arrayType
+
+ foreach elt $value {
+ set d_elt [$doc createElement "item"]
+ $node appendChild $d_elt
+ if {[string match "ur-type" $itemtype]} {
+ insert_value $d_elt $elt
+ } else {
+ insert_value $d_elt [rpcvar::rpcvar $itemtype $elt]
+ }
+ }
+ } elseif {[llength $typeinfo] > 1} {
+ # a typedef'd struct.
+ if {$typexmlns != {}} {
+ $node setAttribute "xsi:type" "${typexmlns}${type}"
+ }
+ array set ti $typeinfo
+ # Bounds checking -
+ if {[llength $typeinfo] != [llength $value]} {
+ return -code error "wrong # args:\
+ type $type contains \"$typeinfo\""
+ }
+ foreach {eltname eltvalue} $value {
+ set d_elt [$doc createElement $eltname]
+ $node appendChild $d_elt
+ if {![info exists ti($eltname)]} {
+ return -code error "invalid member name:\
+ \"$eltname\" is not a member of the $type type."
+ }
+ insert_value $d_elt [rpcvar::rpcvar $ti($eltname) $eltvalue]
+ }
+ } elseif {$type == "struct"} {
+ # an unspecified struct
+ foreach {eltname eltvalue} $value {
+ set d_elt [$doc createElement $eltname]
+ $node appendChild $d_elt
+ insert_value $d_elt $eltvalue
+ }
+ } else {
+ # simple type or typedef'd enumeration
+ if {$typexmlns != {}} {
+ $node setAttribute "xsi:type" "${typexmlns}${type}"
+ }
+ $node appendChild [$doc createTextNode $value]
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# package require SOAP::http; # TclSOAP 1.6.2+
+
+package provide SOAP $::SOAP::version
+
+# -------------------------------------------------------------------------
+
+# Local variables:
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/tsoap/tcl/XMLRPC-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/tsoap/tcl/XMLRPC-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/tsoap/tcl/XMLRPC-procs.tcl 17 Mar 2005 17:59:32 -0000 1.1
@@ -0,0 +1,222 @@
+# XMLRPC.tcl - Copyright (C) 2001 Pat Thoyts
+#
+# Provide Tcl access to XML-RPC provided methods.
+#
+# See http://tclsoap.sourceforge.net/ for usage details.
+#
+# -------------------------------------------------------------------------
+# This software is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE'
+# for more details.
+# -------------------------------------------------------------------------
+
+# package require SOAP 1.4
+# package require rpcvar
+
+namespace eval ::XMLRPC {
+ variable version 1.0
+ variable rcs_version { $Id: XMLRPC-procs.tcl,v 1.1 2005/03/17 17:59:32 maltes Exp $ }
+
+ namespace export create cget dump configure proxyconfig export
+ catch {namespace import -force [uplevel {namespace current}]::rpcvar::*}
+}
+
+# -------------------------------------------------------------------------
+
+# Delegate all these methods to the SOAP package. The only difference between
+# a SOAP and XML-RPC call are the method call wrapper and unwrapper.
+
+proc ::XMLRPC::create {args} {
+ set args [linsert $args 1 \
+ -wrapProc [namespace origin \
+ [namespace parent]::SOAP::xmlrpc_request] \
+ -parseProc [namespace origin \
+ [namespace parent]::SOAP::parse_xmlrpc_response]]
+ return [uplevel 1 "SOAP::create $args"]
+}
+
+proc ::XMLRPC::configure { args } {
+ return [uplevel 1 "SOAP::configure $args"]
+}
+
+proc ::XMLRPC::cget { args } {
+ return [uplevel 1 "SOAP::cget $args"]
+}
+
+proc ::XMLRPC::dump { args } {
+ return [uplevel 1 "SOAP::dump $args"]
+}
+
+proc ::XMLRPC::proxyconfig { args } {
+ return [uplevel 1 "SOAP::proxyconfig $args"]
+}
+
+proc ::XMLRPC::export {args} {
+ foreach item $args {
+ uplevel "set \[namespace current\]::__xmlrpc_exports($item)\
+ \[namespace code $item\]"
+ }
+ return
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Prepare an XML-RPC fault response
+# Parameters:
+# faultcode the XML-RPC fault code (numeric)
+# faultstring summary of the fault
+# detail list of {detailName detailInfo}
+# Result:
+# Returns the XML text of the SOAP Fault packet.
+#
+proc ::XMLRPC::fault {faultcode faultstring {detail {}}} {
+ set xml [join [list \
+ "" \
+ "" \
+ " " \
+ " " \
+ " " \
+ " " \
+ " faultCode"\
+ " ${faultcode}" \
+ " " \
+ " " \
+ " faultString"\
+ " ${faultstring}" \
+ " " \
+ " "\
+ " " \
+ " " \
+ ""] "\n"]
+ return $xml
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Generate a reply packet for a simple reply containing one result element
+# Parameters:
+# doc empty DOM document element
+# uri URI of the SOAP method
+# methodName the SOAP method name
+# result the reply data
+# Result:
+# Returns the DOM document root of the generated reply packet
+#
+proc ::XMLRPC::_reply {doc uri methodName result} {
+ set doc [dom createDocument "methodResponse"]
+ set d_root [$doc documentElement]
+ set d_params [$doc createElement "params"]
+ $d_root appendChild $d_params
+ set d_param [$doc createElement "param"]
+ $d_params appendChild $d_param
+ insert_value $d_param $result
+ return $doc
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Generate a reply packet for a reply containing multiple result elements
+# Parameters:
+# doc empty DOM document element
+# uri URI of the SOAP method
+# methodName the SOAP method name
+# args the reply data, one element per result.
+# Result:
+# Returns the DOM document root of the generated reply packet
+#
+proc ::XMLRPC::reply {doc uri methodName args} {
+ set d_root [dom createDocument "methodResponse"]
+ set d_root [$doc documentElement]
+ set d_params [$doc createElement "params"]
+ $d_root appendChild $d_params
+
+ foreach result $args {
+ set d_param [$doc createElement "param"]
+ $d_params appendChild $d_param
+ insert_value $d_param $result
+ }
+ return $doc
+}
+
+# -------------------------------------------------------------------------
+
+# node is the element
+proc ::XMLRPC::insert_value {node value} {
+
+ set type [rpctype $value]
+ set value [rpcvalue $value]
+ set typeinfo [typedef -info $type]
+ set doc [SOAP::Utils::getDocumentElement $node]
+
+ set value_elt [$doc createElement "value"]
+ $node appendChild $value_elt
+
+ if {[string match {*()} $type] || [string match array $type]} {
+ # array type: arrays are indicated by a () suffix of the word 'array'
+ set itemtype [string trimright $type ()]
+ if {$itemtype == "array"} {
+ set itemtype "any"
+ }
+ set array_elt [$doc createElement "array"]
+ $value_elt appendChild $array_elt
+ set data_elt [$doc createElement "data"]
+ $array_elt appendChild $data_elt
+ foreach elt $value {
+ if {[string match $itemtype "any"] || \
+ [string match $itemtype "ur-type"] || \
+ [string match $itemtype "anyType"]} {
+ XMLRPC::insert_value $data_elt $elt
+ } else {
+ XMLRPC::insert_value $data_elt [rpcvar $itemtype $elt]
+ }
+ }
+ } elseif {[llength $typeinfo] > 1} {
+ # a typedef'd struct
+ set struct_elt [$doc createElement "struct"]
+ $value_elt appendChild $struct_elt
+ array set ti $typeinfo
+ foreach {eltname eltvalue} $value {
+ set member_elt [$doc createElement "member"]
+ $struct_elt appendChild $member_elt
+ set name_elt [$doc createElement "name"]
+ $member_elt appendChild $name_elt
+ $name_elt appendChild [$doc createTextNode $eltname]
+ if {![info exists ti($eltname)]} {
+ error "invalid member name: \"$eltname\" is not a member of\
+ the $type type."
+ }
+ XMLRPC::insert_value $member_elt [rpcvar $ti($eltname) $eltvalue]
+ }
+
+ } elseif {[string match struct $type]} {
+ # an undefined struct
+ set struct_elt [$doc createElement "struct"]
+ $value_elt appendChild $struct_elt
+ foreach {eltname eltvalue} $value {
+ set member_elt [$doc createElement "member"]
+ $struct_elt appendChild $member_elt
+ set name_elt [$doc createElement "name"]
+ $member_elt appendChild $name_elt
+ $name_elt appendChild [$doc createTextNode $eltname]
+ XMLRPC::insert_value $member_elt $eltvalue
+ }
+ } else {
+ # simple type.
+ set type_elt [$doc createElement $type]
+ $value_elt appendChild $type_elt
+ $type_elt appendChild [$doc createTextNode $value]
+ }
+}
+
+# -------------------------------------------------------------------------
+
+package provide XMLRPC $XMLRPC::version
+
+# -------------------------------------------------------------------------
+
+# Local variables:
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/tsoap/tcl/babelfish-init.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/tsoap/tcl/babelfish-init.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/tsoap/tcl/babelfish-init.tcl 17 Mar 2005 17:59:32 -0000 1.1
@@ -0,0 +1,9 @@
+SOAP::configure -transport http -proxy {}
+
+SOAP::create translate \
+ -proxy {http://services.xmethods.net:80/perl/soaplite.cgi} \
+ -uri {urn:xmethodsBabelFish\#BabelFish} \
+ -params { translationmode string sourcedata string }
+
+# example:
+# set english [translate de_en "Hallo Welt, Guten Tag"]
Index: openacs-4/packages/tsoap/tcl/http-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/tsoap/tcl/http-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/tsoap/tcl/http-procs.tcl 17 Mar 2005 17:59:32 -0000 1.1
@@ -0,0 +1,374 @@
+# http.tcl - Copyright (C) 2001 Pat Thoyts
+#
+# The SOAP HTTP Transport.
+#
+# -------------------------------------------------------------------------
+# This software is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE'
+# for more details.
+# -------------------------------------------------------------------------
+
+package require http 2; # tcl
+
+namespace eval ::SOAP::Transport::http {
+ variable version 1.0
+ variable rcsid {$Id: http-procs.tcl,v 1.1 2005/03/17 17:59:32 maltes Exp $}
+ variable options
+
+ SOAP::register http [namespace current]
+
+ # Initialize the transport options.
+ if {![info exists options]} {
+ array set options {
+ headers {}
+ proxy {}
+ progress {}
+ timeout 0
+ }
+ }
+
+ # Declare the additional SOAP method options provided by this transport.
+ variable method:options [list \
+ httpheaders \
+ timeout \
+ ]
+
+ # Provide missing code for http < 2.3
+ if {[info proc ::http::ncode] == {}} {
+ namespace eval ::http {
+ proc ncode {token} {
+ return [lindex [split [code $token]] 1]
+ }
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Implement the additional SOAP method configuration options provide
+# for this transport.
+# Notes:
+# -httpheaders - additional HTTP headers may be defined for specific
+# SOAP methods. Argument should be a two element list made of
+# the header name and value eg: [list Cookie $cookiedata]
+# -timeout - the method can override the transport defined http timeout.
+# Set to {} to use the transport timeout, 0 for infinity.
+proc ::SOAP::Transport::http::method:configure {procVarName opt value} {
+ upvar $procVarName procvar
+ switch -glob -- $opt {
+ -httpheaders {
+ set procvar(httpheaders) $value
+ }
+ -timeout {
+ set procvar(timeout) $value
+ }
+ default {
+ # not reached.
+ return -code error "unknown option \"$opt\""
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Configure any http transport specific settings.
+#
+proc ::SOAP::Transport::http::configure {args} {
+ variable options
+
+ if {[llength $args] == 0} {
+ set r {}
+ foreach {opt value} [array get options] {
+ lappend r "-$opt" $value
+ }
+ return $r
+ }
+
+ foreach {opt value} $args {
+ switch -- $opt {
+ -proxy - -timeout - -progress {
+ set options([string trimleft $opt -]) $value
+ }
+ -headers {
+ set options(headers) $value
+ }
+ default {
+ return -code error "invalid option \"$opt\":\
+ must be \"-proxy host:port\" or \"-headers list\""
+ }
+ }
+ }
+ return {}
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Perform a remote procedure call using HTTP as the transport protocol.
+# This uses the Tcl http package to do the work. If the SOAP method has
+# the -command option set to something then the call is made
+# asynchronously and the result data passed to the users callback
+# procedure.
+# If you have an HTTP proxy to deal with then you should set up the
+# SOAP::Transport::http::filter procedure and proxy variable to suit.
+# This can be done using SOAP::proxyconfig.
+# Parameters:
+# procVarName - the name of the SOAP config array for this method.
+# url - the SOAP endpoint URL
+# request - the XML data making up the SOAP request
+# Result:
+# The request data is POSTed to the SOAP provider via HTTP using any
+# configured proxy host. If the HTTP returns an error code then an error
+# is raised otherwise the reply data is returned. If the method has
+# been configured to be asynchronous then the async handler is called
+# once the http request completes.
+#
+proc ::SOAP::Transport::http::xfer { procVarName url request } {
+ variable options
+ upvar $procVarName procvar
+
+ # Get the SOAP package version
+ # FRINK: nocheck
+ set version [set [namespace parent [namespace parent]]::version]
+
+ # setup the HTTP POST request
+ ::http::config -useragent "TclSOAP/$version ($::tcl_platform(os))"
+
+ # If a proxy was configured, use it.
+ if { [info exists options(proxy)] && $options(proxy) != {} } {
+ ::http::config -proxyfilter [namespace origin filter]
+ }
+
+ # Check for an HTTP progress callback.
+ set local_progress {}
+ if { [info exists options(progress)] && $options(progress) != {} } {
+ set local_progress "-progress [list $options(progress)]"
+ }
+
+ # Check for a timeout. Method timeout overrides transport timeout.
+ set timeout $options(timeout)
+ if {$procvar(timeout) != {}} {
+ set timeout $procvar(timeout)
+ }
+
+ # There may be http headers configured. eg: for proxy servers
+ # eg: SOAP::configure -transport http -headers
+ # [list "Proxy-Authorization" [basic_authorization]]
+ set local_headers {}
+ if {[info exists options(headers)]} {
+ set local_headers $options(headers)
+ }
+ if {[info exists procvar(httpheaders)]} {
+ set local_headers [concat $local_headers $procvar(httpheaders)]
+ }
+
+ # Add mandatory SOAPAction header (SOAP 1.1). This may be empty otherwise
+ # must be in quotes.
+ set action $procvar(action)
+ if { $action != {} } {
+ set action [string trim $action "\""]
+ set action "\"$action\""
+ lappend local_headers "SOAPAction" $action
+ }
+
+ # cleanup the last http request
+ if {[info exists procvar(http)] && $procvar(http) != {}} {
+ catch {::http::cleanup $procvar(http)}
+ }
+
+ # Check for an asynchronous handler and perform the transfer.
+ # If async - return immediately.
+ set command {}
+ if {$procvar(command) != {}} {
+ set command "-command {[namespace current]::asynchronous $procVarName}"
+ }
+
+ set token [eval ::http::geturl_followRedirects [list $url] \
+ -headers [list $local_headers] \
+ -type text/xml \
+ -timeout $timeout \
+ -query [list $request] \
+ $local_progress $command]
+
+ # store the http structure reference for possible access later.
+ set procvar(http) $token
+
+ if { $command != {}} {
+ return {}
+ }
+
+ log::log debug "[::http::status $token] - [::http::code $token]"
+
+ # Check for Proxy Authentication requests and handle it.
+ if {[::http::ncode $token] == 407} {
+ SOAP::proxyconfig
+ return [xfer $procVarName $url $request]
+ }
+
+ # Some other sort of error ...
+ switch -exact -- [set status [::http::status $token]] {
+ timeout {
+ return -code error "error: SOAP http transport timed out\
+ after $timeout ms"
+ }
+ ok {
+ }
+ default {
+ return -code error "SOAP transport error:\
+ token $token status is \"$status\" and HTTP result code is\
+ \"[::http::code $token]\""
+ }
+ }
+
+ return [::http::data $token]
+}
+
+# this proc contributed by [Donal Fellows]
+proc ::http::geturl_followRedirects {url args} {
+ set limit 10
+ while {$limit > 0} {
+ set token [eval [list ::http::geturl $url] $args]
+ switch -glob -- [ncode $token] {
+ 30[1237] {
+ incr limit -1
+ ### redirect - see below ###
+ }
+ default { return $token }
+ }
+ upvar \#0 $token state
+ array set meta $state(meta)
+ if {![info exist meta(Location)]} {
+ return $token
+ }
+ set url $meta(Location)
+ unset meta
+ }
+ return -code error "maximum relocation depth reached: site loop?"
+}
+
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Asynchronous http handler command.
+proc ::SOAP::Transport::http::asynchronous {procVarName token} {
+ upvar $procVarName procvar
+
+ if {[catch {asynchronous2 $procVarName $token} msg]} {
+ if {$procvar(errorCommand) != {}} {
+ set errorCommand $procvar(errorCommand)
+ if {[catch {eval $errorCommand [list $msg]} result]} {
+ bgerror $result
+ }
+ } else {
+ bgerror $msg
+ }
+ }
+ return $msg
+}
+
+proc ::SOAP::Transport::http::asynchronous2 {procVarName token} {
+ upvar $procVarName procvar
+ set procName [lindex [split $procVarName {_}] end]
+
+ # Some other sort of error ...
+ if {[::http::status $token] != "ok"} {
+ return -code error "SOAP transport error: \"[::http::code $token]\""
+ }
+
+ set reply [::http::data $token]
+
+ # Call the second part of invoke to unwrap the packet data.
+ set reply [SOAP::invoke2 $procVarName $reply]
+
+ # Call the users handler.
+ set command $procvar(command)
+ return [eval $command [list $reply]]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Handle a proxy server. If the -proxy options is set then this is used
+# to override the http package configuration.
+# Notes:
+# Needs expansion to use a list of non-proxied sites or a list of
+# {regexp proxy} or something.
+# The proxy variable in this namespace is set up by
+# SOAP::configure -transport http.
+#
+proc ::SOAP::Transport::http::filter {host} {
+ variable options
+ if { [string match "localhost*" $host] \
+ || [string match "127.*" $host] } {
+ return {}
+ }
+ return [lrange [split $options(proxy) {:}] 0 1]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Support asynchronous transactions and permit waiting for completed
+# calls.
+# Parameters:
+#
+proc ::SOAP::Transport::http::wait {procVarName} {
+ upvar $procVarName procvar
+ http::wait $procvar(http)
+}
+# -------------------------------------------------------------------------
+
+# Description:
+# Called to release any retained resources from a SOAP method. For the
+# http transport this is just the http token.
+# Parameters:
+# methodVarName - the name of the SOAP method configuration array
+#
+proc ::SOAP::Transport::http::method:destroy {methodVarName} {
+ upvar $methodVarName procvar
+ if {[info exists procvar(http)] && $procvar(http) != {}} {
+ catch {::http::cleanup $procvar(http)}
+ }
+}
+
+# -------------------------------------------------------------------------
+
+proc ::SOAP::Transport::http::dump {methodName type} {
+ SOAP::cget $methodName proxy
+ if {[catch {SOAP::cget $methodName http} token]} {
+ set token {}
+ }
+
+ if { $token == {} } {
+ return -code error "cannot dump:\
+ no information is available for \"$methodName\""
+ }
+
+ set result {}
+ switch -glob -- $type {
+ -meta {set result [lindex [array get $token meta] 1]}
+ -qu* -
+ -req* {set result [lindex [array get $token -query] 1]}
+ -rep* {set result [::http::data $token]}
+ default {
+ return -code error "unrecognised option: must be one of \
+ \"-meta\", \"-request\" or \"-reply\""
+ }
+ }
+
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+package provide SOAP::http $::SOAP::Transport::http::version
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/tsoap/tcl/https-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/tsoap/tcl/https-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/tsoap/tcl/https-procs.tcl 17 Mar 2005 17:59:32 -0000 1.1
@@ -0,0 +1,403 @@
+# https.tcl - Trivial modifications (by David Bleicher) to the HTTP
+# transport to enable SSL support. Original copyright
+# follows:
+#
+# Copyright (C) 2002 David Bleicher
+# Copyright (C) 2001 Pat Thoyts
+#
+# The SOAP HTTPS Transport.
+#
+# -------------------------------------------------------------------------
+# This software is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE'
+# for more details.
+# -------------------------------------------------------------------------
+
+package require http; # tcl
+package require tls; # Required for SSL support
+
+namespace eval ::SOAP::Transport::https {
+ variable version 1.0
+ variable rcsid {$Id: https-procs.tcl,v 1.1 2005/03/17 17:59:32 maltes Exp $}
+ variable options
+
+ ::SOAP::register https [namespace current]
+
+ # Initialize the transport options.
+ if {![info exists options]} {
+ array set options {
+ headers {}
+ proxy {}
+ progress {}
+ timeout 0
+ }
+ }
+
+ # Declare the additional SOAP method options provided by this transport.
+ variable method:options [list \
+ httpheaders \
+ timeout \
+ ]
+
+ # Provide missing code for http < 2.3
+ if {[info proc ::http::ncode] == {}} {
+ namespace eval ::http {
+ proc ncode {token} {
+ return [lindex [split [code $token]] 1]
+ }
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Implement the additional SOAP method configuration options provide
+# for this transport.
+# Notes:
+# -httpheaders - additional HTTP headers may be defined for specific
+# SOAP methods. Argument should be a two element list made of
+# the header name and value eg: [list Cookie $cookiedata]
+# -timeout - the method can override the transport defined http timeout.
+# Set to {} to use the transport timeout, 0 for infinity.
+proc ::SOAP::Transport::https::method:configure {procVarName opt value} {
+ upvar $procVarName procvar
+ switch -glob -- $opt {
+ -httpheaders {
+ set procvar(httpheaders) $value
+ }
+ -timeout {
+ set procvar(timeout) $value
+ }
+ default {
+ # not reached.
+ return -code error "unknown option \"$opt\""
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Configure any https transport specific settings.
+#
+proc ::SOAP::Transport::https::configure {args} {
+ variable options
+
+ if {[llength $args] == 0} {
+ set r {}
+ foreach {opt value} [array get options] {
+ lappend r "-$opt" $value
+ }
+ return $r
+ }
+
+ foreach {opt value} $args {
+ switch -- $opt {
+ -proxy - -timeout - -progress {
+ set options([string trimleft $opt -]) $value
+ }
+ -headers {
+ set options(headers) $value
+ }
+ default {
+ return -code error "invalid option \"$opt\":\
+ must be \"-proxy host:port\" or \"-headers list\""
+ }
+ }
+ }
+ return {}
+}
+
+# Configure any TLS sepcific parameters (e.g. certificate location)
+# Pass any values received to the "::tls::init" proceure
+# --Added by David Bleicher 26/03/02
+proc ::SOAP::Transport::https::tlsConfigure {args} {
+ set validopts [list -cafile -cadir -certfile -cipher -command -keyfile \
+ -model -request -require -server -ssl2 -ssl3 -tls1]
+ set tlsoptslist "::tls::init"
+ foreach {opt value} $args {
+ if {[lsearch $validopts $opt] == -1} {
+ return -code error "Invalid option \"$opt\"\
+ (valid options are: $validopts)\n"
+ }
+ lappend tlsoptslist $opt $value
+ }
+ eval $tlsoptslist
+}
+
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Perform a remote procedure call using HTTP as the transport protocol.
+# This uses the Tcl http package to do the work. If the SOAP method has
+# the -command option set to something then the call is made
+# asynchronously and the result data passed to the users callback
+# procedure.
+# If you have an HTTP proxy to deal with then you should set up the
+# SOAP::Transport::https::filter procedure and proxy variable to suit.
+# This can be done using SOAP::proxyconfig.
+# Parameters:
+# procVarName - the name of the SOAP config array for this method.
+# url - the SOAP endpoint URL
+# request - the XML data making up the SOAP request
+# Result:
+# The request data is POSTed to the SOAP provider via HTTP using any
+# configured proxy host. If the HTTP returns an error code then an error
+# is raised otherwise the reply data is returned. If the method has
+# been configured to be asynchronous then the async handler is called
+# once the http request completes.
+#
+proc ::SOAP::Transport::https::xfer { procVarName url request } {
+ variable options
+ upvar $procVarName procvar
+
+ # Get the SOAP package version
+ # FRINK: nocheck
+ set version [set [namespace parent [namespace parent]]::version]
+
+ # setup the HTTP POST request
+ ::http::config -useragent "TclSOAP/$version ($::tcl_platform(os))"
+
+ # If a proxy was configured, use it.
+ if { [info exists options(proxy)] && $options(proxy) != {} } {
+ ::http::config -proxyfilter [namespace origin filter]
+ }
+
+ # Check for an HTTP progress callback.
+ set local_progress {}
+ if { [info exists options(progress)] && $options(progress) != {} } {
+ set local_progress "-progress [list $options(progress)]"
+ }
+
+ # Check for a timeout. Method timeout overrides transport timeout.
+ set timeout $options(timeout)
+ if {$procvar(timeout) != {}} {
+ set timeout $procvar(timeout)
+ }
+
+ # There may be http headers configured. eg: for proxy servers
+ # eg: SOAP::configure -transport http -headers
+ # [list "Proxy-Authorization" [basic_authorization]]
+ set local_headers {}
+ if {[info exists options(headers)]} {
+ set local_headers $options(headers)
+ }
+ if {[info exists procvar(httpheaders)]} {
+ set local_headers [concat $local_headers $procvar(httpheaders)]
+ }
+
+ # Add mandatory SOAPAction header (SOAP 1.1). This may be empty otherwise
+ # must be in quotes.
+ set action $procvar(action)
+ if { $action != {} } {
+ set action [string trim $action "\""]
+ set action "\"$action\""
+ lappend local_headers "SOAPAction" $action
+ }
+
+ # cleanup the last http request
+ if {[info exists procvar(http)] && $procvar(http) != {}} {
+ catch {::http::cleanup $procvar(http)}
+ }
+
+ # Check for an asynchronous handler and perform the transfer.
+ # If async - return immediately.
+ set command {}
+ if {$procvar(command) != {}} {
+ set command "-command {[namespace current]::asynchronous $procVarName}"
+ }
+
+ # Must test for the port and register an SSL socket with TLS
+ # If there is a port number in the url, use it, otherwise use 443
+ # --Added by David Bleicher 26/03/02
+ regexp -nocase {^(https://)?([^:/]+)(:([0-9]+))?(/.*)} $url tX_x tX_protocol tX_server tX_y tX_port tX_path
+ if {[string length $tX_port] == 0} {set tX_port 443}
+ ::http::register https $tX_port ::tls::socket
+
+ set token [eval ::http::geturl_followRedirects [list $url] \
+ -headers [list $local_headers] \
+ -type text/xml \
+ -timeout $timeout \
+ -query [list $request] \
+ $local_progress $command]
+
+ # store the http structure reference for possible access later.
+ set procvar(http) $token
+
+ if { $command != {}} {
+ return {}
+ }
+
+ log::log debug "[::http::status $token] - [::http::code $token]"
+
+ # Check for Proxy Authentication requests and handle it.
+ if {[::http::ncode $token] == 407} {
+ SOAP::proxyconfig
+ return [xfer $procVarName $url $request]
+ }
+
+ # Some other sort of error ...
+ switch -exact -- [::http::status $token] {
+ timeout {
+ return -code error "error: SOAP https transport timed out\
+ after $timeout ms"
+ }
+ ok {
+ }
+ default {
+ return -code error "SOAP transport error: \"[::http::code $token]\""
+ }
+ }
+
+ return [::http::data $token]
+}
+
+# this proc contributed by [Donal Fellows]
+proc ::http::geturl_followRedirects {url args} {
+ set limit 10
+ while {$limit > 0} {
+ set token [eval [list ::http::geturl $url] $args]
+ switch -glob -- [ncode $token] {
+ 30[1237] {
+ incr limit -1
+ ### redirect - see below ###
+ }
+ default { return $token }
+ }
+ upvar #0 $token state
+ array set meta $state(meta)
+ if {![info exist meta(Location)]} {
+ return $token
+ }
+ set url $meta(Location)
+ unset meta
+ }
+ return -code error "maximum relocation depth reached: site loop?"
+}
+
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Asynchronous http handler command.
+proc ::SOAP::Transport::https::asynchronous {procVarName token} {
+ upvar $procVarName procvar
+
+ if {[catch {asynchronous2 $procVarName $token} msg]} {
+ if {$procvar(errorCommand) != {}} {
+ set errorCommand $procvar(errorCommand)
+ if {[catch {eval $errorCommand [list $msg]} result]} {
+ bgerror $result
+ }
+ } else {
+ bgerror $msg
+ }
+ }
+ return $msg
+}
+
+proc ::SOAP::Transport::https::asynchronous2 {procVarName token} {
+ upvar $procVarName procvar
+ set procName [lindex [split $procVarName {_}] end]
+
+ # Some other sort of error ...
+ if {[::http::status $token] != "ok"} {
+ return -code error "SOAP transport error: \"[::http::code $token]\""
+ }
+
+ set reply [::http::data $token]
+
+ # Call the second part of invoke to unwrap the packet data.
+ set reply [SOAP::invoke2 $procVarName $reply]
+
+ # Call the users handler.
+ set command $procvar(command)
+ return [eval $command [list $reply]]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Handle a proxy server. If the -proxy options is set then this is used
+# to override the http package configuration.
+# Notes:
+# Needs expansion to use a list of non-proxied sites or a list of
+# {regexp proxy} or something.
+# The proxy variable in this namespace is set up by
+# SOAP::configure -transport http.
+#
+proc ::SOAP::Transport::https::filter {host} {
+ variable options
+ if { [string match "localhost*" $host] \
+ || [string match "127.*" $host] } {
+ return {}
+ }
+ return [lrange [split $options(proxy) {:}] 0 1]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Support asynchronous transactions and permit waiting for completed
+# calls.
+# Parameters:
+#
+proc ::SOAP::Transport::https::wait {procVarName} {
+ upvar $procVarName procvar
+ http::wait $procvar(http)
+}
+# -------------------------------------------------------------------------
+
+# Description:
+# Called to release any retained resources from a SOAP method. For the
+# http transport this is just the http token.
+# Parameters:
+# methodVarName - the name of the SOAP method configuration array
+#
+proc ::SOAP::Transport::https::method:destroy {methodVarName} {
+ upvar $methodVarName procvar
+ if {[info exists procvar(http)] && $procvar(http) != {}} {
+ catch {::http::cleanup $procvar(http)}
+ }
+}
+
+# -------------------------------------------------------------------------
+
+proc ::SOAP::Transport::https::dump {methodName type} {
+ SOAP::cget $methodName proxy
+ if {[catch {SOAP::cget $methodName http} token]} {
+ set token {}
+ }
+
+ if { $token == {} } {
+ return -code error "cannot dump: no information is available\
+ for \"$methodName\""
+ }
+
+ set result {}
+ switch -glob -- $type {
+ -meta {set result [lindex [array get $token meta] 1]}
+ -qu* -
+ -req* {set result [lindex [array get $token -query] 1]}
+ -rep* {set result [::http::data $token]}
+ default {
+ return -code error "unrecognised option: must be one of \
+ \"-meta\", \"-request\" or \"-reply\""
+ }
+ }
+
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+package provide SOAP::https $::SOAP::Transport::https::version
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/tsoap/tcl/rpcvar-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/tsoap/tcl/rpcvar-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/tsoap/tcl/rpcvar-procs.tcl 17 Mar 2005 17:59:32 -0000 1.1
@@ -0,0 +1,580 @@
+# rpcvar.tcl - Copyright (C) 2001 Pat Thoyts
+#
+# Provide a mechanism for passing hints as to the XML-RPC or SOAP value type
+# from the user code to the TclSOAP framework.
+#
+# This package is intended to be imported into the SOAP and XMLRPC namespaces
+# where the rpctype command can be overridden to restrict the types to the
+# correct names. The client user should then be using SOAP::rpcvalue or
+# XMLRPC::rpctype to assign type information.
+#
+# -------------------------------------------------------------------------
+# This software is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE'
+# for more details.
+# -------------------------------------------------------------------------
+
+namespace eval ::rpcvar {
+ variable version 1.2
+ variable magic "rpcvar$version"
+ variable rcs_id {$Id: rpcvar-procs.tcl,v 1.1 2005/03/17 17:59:32 maltes Exp $}
+ variable typedefs
+ variable typens
+ variable enums
+
+ # Initialise the core types
+ proc _init {xmlns typename} {
+ variable typedefs ; variable typens
+ set typedefs($typename) {} ;# basic types have no typelist
+ set typens($typename) $xmlns ;# set the namespace for this type
+ }
+
+ namespace export rpcvar is_rpcvar rpctype rpcsubtype rpcvalue \
+ rpcnamespace rpcattributes rpcvalidate rpcheaders typedef \
+ schema_set
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Create a typed variable with optionally an XML namespace for SOAP types.
+# Syntax:
+# rpcvar ?-namespace soap-uri? ?-attributes list? type value
+# rpcvar -paramlist name rpcvalue ?name rpcvalue ...?
+# Parameters:
+# namespace - the SOAP XML namespace for this type
+# attributes - a list of attribute name/value pairs for this element
+# type - the XML-RPC or SOAP type of this value
+# value - the value being typed or, for struct type, either a list
+# of name-value pairs, or the name of the Tcl array.
+# Result:
+# Returns a reference to the newly created typed variable
+#
+proc ::rpcvar::rpcvar {args} {
+ variable magic
+
+ set xmlns {}
+ set head {}
+ set paramlist false
+ array set attr {}
+ while {[string match -* [lindex $args 0]]} {
+ switch -glob -- [lindex $args 0] {
+ -n* { set xmlns [Pop args 1] }
+ -a* { array set attr [Pop args 1] }
+ -h* { set head [concat $head [Pop args 1]] }
+ -p* { set paramlist true }
+ -- { Pop args ; break }
+ default { return -code error "unknown option \"[lindex $args 0]\""}
+ }
+ Pop args
+ }
+
+ if {$paramlist} {
+ set type PARAMLIST
+ set value $args
+ } else {
+
+ if {[llength $args] != 2} {
+ return -code error "wrong # args: \
+ should be \"rpcvar ?-namespace uri? type value\""
+ }
+
+ set type [lindex $args 0]
+ set value [lindex $args 1]
+
+ # For struct types (or typedefs that are structs) accept an array name or a list.
+ if {$type != "string" && [uplevel array exists [list $value]]} {
+ set value [uplevel array get [list $value]]
+ }
+
+ if {! [rpcvalidate $type $value]} {
+ error "type mismatch: \"$value\" is not appropriate to the \"$type\"\
+ type."
+ }
+ }
+ return [list $magic $xmlns [array get attr] $head $type $value]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::rpcvar::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Examine a variable to see if is a reference to a typed variable
+# Parameters:
+# varref - reference to the object to be tested
+# Result:
+# Returns 1 if the object is a typed value or 0 if not
+#
+proc ::rpcvar::is_rpcvar { varref } {
+ variable magic
+ set failed [catch {lindex $varref 0} ref_magic]
+ if { ! $failed && $ref_magic == $magic } {
+ return 1
+ }
+ return 0
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Guess the SOAP or XML-RPC type of the input.
+# For some simple types we can guess the value type. For others we have
+# to use a typed variable.
+# Parameters:
+# arg - the value for which we are trying to assign a type.
+# Returns:
+# The XML-RPC type is one of int, boolean, double, string,
+# dateTime.iso8601, base64, struct or array. However, we only return one
+# of struct, int, double, boolean or string unless we were passed a
+# typed variable.
+#
+proc ::rpcvar::rpctype { arg } {
+ set type {}
+ if { [is_rpcvar $arg] } {
+ set type [lindex $arg 4]
+ } elseif {[uplevel array exists [list $arg]]} {
+ set type "struct"
+ } elseif {[string is integer -strict $arg]} {
+ set type "int"
+ } elseif {[string is double -strict $arg]} {
+ # See: http://www.w3.org/TR/xmlschema-2/#float
+ if {[expr {(abs($arg) > (pow(2,24)*pow(2,-149)))
+ && (abs($arg) < (pow(2,24)*pow(2,104)))}]} {
+ set type "float"
+ } else {
+ set type "double"
+ }
+ } elseif {[string is boolean -strict $arg]} {
+ set type "boolean"
+ } else {
+ set type "string"
+ }
+ return $type
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# --- IT DOESN'T WORK LIKE THIS NOW -- DELETE ME ?!
+# --- we declare arrays as int() and struct() or MyType()
+# --- Still used in SOAP.tcl
+# ---
+# If the value is not a typed variable, then there cannot be a subtype.
+# otherwise we are looking for array(int) or struct(Typename) etc.
+# Result:
+# Either the subtype of an array, or an empty string.
+#
+proc ::rpcvar::rpcsubtype { arg } {
+ set subtype {}
+ if {[is_rpcvar $arg]} {
+ regexp {([^(]+)(\((.+)\))?} [lindex $arg 4] -> type -> subtype
+ }
+ return $subtype
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Retrieve the value from a typed variable or return the input.
+# Parameters:
+# arg - either a value or a reference to a typed variable for which to
+# return the value
+# Result:
+# Returns the value of a typed variable.
+# If arg is not a typed variable it return the contents of arg
+#
+proc ::rpcvar::rpcvalue { arg } {
+ if { [is_rpcvar $arg] } {
+ return [lindex $arg 5]
+ } else {
+ return $arg
+ }
+}
+# -------------------------------------------------------------------------
+
+# Description:
+# Retrieve the xml namespace assigned to this variable. This is only used
+# by SOAP.
+# Parameters:
+# varref - reference to an RPC typed variable.
+# Result:
+# Returns the set namespace or an empty value is no namespace is assigned.
+#
+proc ::rpcvar::rpcnamespace { varref } {
+ set xmlns {}
+ if { [is_rpcvar $varref] } {
+ set xmlns [lindex $varref 1]
+ }
+ return $xmlns
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Retrieve the XML attributes assigned to this variable. This is only
+# relevant to SOAP.
+# Parameters:
+# varref - reference to an RPC typed variable.
+# Result:
+# Returns the list of name/value pairs for the assigned attributes. The
+# list is suitable for use in array set.
+#
+proc ::rpcvar::rpcattributes { varref } {
+ set attrs {}
+ if {[is_rpcvar $varref]} {
+ set attrs [lindex $varref 2]
+ }
+ return $attrs
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Retrieve the optional list of SOAP Header elements defined for this
+# variable. The intent of this mechanism is to allow a returning procedure
+# to specify SOAP Header elements if required.
+# Results:
+#
+proc ::rpcvar::rpcheaders { varref } {
+ set head {}
+ if {[is_rpcvar $varref]} {
+ set head [lindex $varref 3]
+ }
+ return $head
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Define a SOAP type for use with the TclSOAP package. This allows you
+# to specify the SOAP XML namespace and typename for a chunk of data and
+# enables the TclSOAP client code to determine the SOAP type imformation
+# to put on request data.
+# Options:
+# -enum - flag the type as an enumerated type
+# -exists typename - boolean true if typename is defined
+# -info typename - return the definition of typename
+# Parameters
+# typelist - list of the type information needed to define the
+# new type.
+# typename - the name of the new type
+# Notes:
+# If the typename has already been defined then it will be overwritten.
+# For enumerated types, the typelist is the list of valid enumerator names.
+# Each enumerator may be a two element list, in which case the first element
+# is the name and the second is the integer value.
+#
+proc ::rpcvar::typedef {args} {
+ variable typedefs
+ variable typens
+ variable enums
+
+ set namespace {}
+ set enum 0
+ while {[string match -* [lindex $args 0]]} {
+ switch -glob -- [lindex $args 0] {
+ -n* {
+ set namespace [lindex $args 1]
+ set args [lreplace $args 0 0]
+ if {[llength $args] == 1} {
+ if {[catch {set typens($namespace)} r]} {
+ set r {}
+ }
+ return $r
+ }
+ }
+ -ex* {
+ set typename [lindex $args 1]
+ return [info exists typedefs($typename)]
+ }
+ -en* {
+ set enum 1
+ }
+ -i* {
+ set typename [lindex $args 1]
+ if {[catch {set typedefs($typename)} typeinfo]} {
+ set typeinfo {}
+ }
+ return $typeinfo
+ }
+ -- {
+ set args [lreplace $args 0 0]
+ break
+ }
+ default { return -code error "unknown option \"[lindex $args 0]\""}
+ }
+ set args [lreplace $args 0 0]
+ }
+
+ if {[llength $args] != 2} {
+ return -code error "wrong # args: should be \
+ \"typedef ?-namespace uri? ?-enum? typelist typename\n\
+ \ or \"typedef ?-exists? ?-info? typename\""
+ }
+
+ set typelist [lindex $args 0]
+ set typename [lindex $args 1]
+
+ if {$enum} {
+ set typedefs($typename) enum
+ set enums($typename) $typelist
+ } else {
+ set typedefs($typename) $typelist
+ }
+ set typens($typename) $namespace
+
+ return $typename
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Check that the value is suitable for type. Basically for enum's
+# Result:
+# Returns a boolean true/false value.
+proc ::rpcvar::rpcvalidate {type value} {
+ variable enums
+ if {[typedef -info $type] == "enum"} {
+ if {[lsearch -exact $enums($type) $value] == -1} {
+ return 0
+ }
+ }
+ return 1
+}
+
+# -------------------------------------------------------------------------
+# typdef usage:
+#
+# typedef -namespace urn:tclsoap-Test float TclFloat
+#
+# typedef -enum -namespace urn:tclsoap-Test {red {green 3} {blue 9}} Colour
+#
+# typedef {
+# larry integer
+# moe integer
+# curly integer
+# } Stooges
+# => SOAP::create m -params {myStruct Stooges}
+# => m {larry 23 curly -98 moe 9}
+#
+# typedef -namespace urn:soapinterop.org {
+# varInt integer
+# varFloat float
+# varString string
+# } SOAPStruct;
+#
+# => SOAP::create zm ... -params {myStruct SOAPStruct}
+# => zm {varInt 2 varFloat 2.2 varString "hello"}
+#
+# typedef {
+# arrInt int()
+# stooges Stooges()
+# arrString string()
+# arrColours Colour()
+# } arrStruct
+# => SOAP::create m -params {myStruct arrStruct}
+# => m {arrInt {1 2 3 4 5} \
+# stooges { \
+# {moe 1 larry 2 curly 3} \
+# {moe 1 larry 2 curly 3} \
+# } \
+# arrString {One Two Three} \
+# arrColours {red blue green}\
+# }
+
+# -------------------------------------------------------------------------
+
+proc ::rpcvar::default_schemas {soapenv} {
+
+ if {[string match $soapenv "http://schemas.xmlsoap.org/soap/encoding/"]} {
+ # SOAP 1.1
+ return [list \
+ "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" \
+ "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" ]
+ }
+
+ if {[string match $soapenv "http://www.w3.org/2001/06/soap-encoding"]} {
+ # SOAP 1.2
+ return [list \
+ "xmlns:xsd" "http://www.w3.org/2001/XMLSchema" \
+ "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance" ]
+ }
+
+ return -code error "invalid soap version: \"$soapenv\" is not a valid SOAP URL"
+}
+
+# initialize with the SOAP 1.1 encodings for xsd and SOAP-ENC
+#
+proc ::rpcvar::init_builtins {} {
+ # The xsi types from http://www.w3.org/TR/xmlschema-2/ section 3.2 & 3.3
+ # the uri's for these are http://www.w33.org/2001/XMLSchema#int etc
+ set xsd2001 [list \
+ string normalizedString boolean decimal integer float double \
+ duration dateTime time date gYearMonth gYear gMonthDay gDay \
+ gMonth hexBinary base64Binary anyURI QName NOTATION \
+ token language NMTOKEN NMTOKENS Name NCName ID IDREF IDREFS \
+ ENTITY ENTITIES nonPositiveInteger negativeInteger long int \
+ short byte nonNegativeInteger unsignedLong unsignedInt \
+ unsignedShort unsignedByte positiveInteger anyType anySimpleType]
+
+ # The SOAP 1.1 encoding: uri = http://www.w3.org/1999/XMLSchema
+ set xsd1999 [list \
+ string boolean float double decimal timeDuration \
+ recurringDuration binary uriReference ID IDREF ENITY NOTATION \
+ QName language IDREFS ENTITIES NMTOKEN NMTOKENS Name NCName \
+ integer nonPositiveInteger negativeInteger long int short byte \
+ nonNegativeInteger unsignedLong unsignedInt unsignedShort \
+ unsignedByte positiveInteger timeInstant time timePeriod date \
+ month year century recurringDate recurringDay]
+
+ # SOAP 1.1 encoding: uri = http://schemas.xmlsoap.org/soap/encoding/
+ set soapenc [list \
+ arrayCoordinate Array Struct base64 string boolean float double \
+ decimal timeDuration recurringDuration binary uriReference ID \
+ IDREF ENTITY NOTATION QName language IDREFS ENTITIES NMTOKEN \
+ NMTOKENS Name NCName integer nonPositiveInteger negativeInteger \
+ long int short byte nonNegativeInteger unsignedLong unsignedShort \
+ unsignedByte positiveInteger timeInstant time timePeriod date \
+ month year century recurringDate recurringDay ur-type]
+
+ foreach type $soapenc {
+ _init SOAP-ENC $type
+ }
+
+ foreach type $xsd1999 {
+ _init xsd $type
+ }
+}
+
+# Initialize the core SOAP types. xsd and SOAP-ENC namespace names are
+# pre-defined within the TclSOAP framework. All other namespaces will
+# have to be fully specified
+if {! [info exists ::rpcvar::typedefs]} {
+ ::rpcvar::init_builtins
+}
+
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+namespace eval ::types {
+ variable types
+ namespace export typedef
+}
+
+proc ::types::typedef {args} {
+ variable types
+ array set opts {namespace {}}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -n* { set opts(namespace) [Pop args 1] }
+ -ex* {
+ set typename [lindex $args 1]
+ if {[string length $opts(namespace)] > 0} {
+ set typename $opts(namespace):$typename
+ }
+ return [info exists types($typename)]
+ }
+ -i* {
+ set namespace *
+ set typename [lindex $args 1]
+ if {[string length $opts(namespace)] > 0} {
+ set namespace $opts(namespace)
+ }
+ set typename $namespace:$typename
+ if {[catch {array get types $typename} typeinfo]} {
+ set typeinfo {}
+ }
+ return $typeinfo
+ }
+ -- { Pop args ; break }
+ default {
+ set options [join [lsort [array names opts]] ", -"]
+ return -code error "bad option $option:\
+ must be one of -$options"
+ }
+ }
+ Pop args
+ }
+
+ if {[llength $args] != 2} {
+ return -code error "wrong # args: should be \
+ \"typedef ?-namespace uri? ?-enum? typelist typename\n\
+ \ or \"typedef ?-exists? ?-info? typename\""
+ }
+
+ set typelist [lindex $args 0]
+ set typename [lindex $args 1]
+
+ set types($opts(namespace):$typename) $typelist
+ return $typename
+}
+
+proc ::types::SetupBuiltins {} {
+ # The xsi types from http://www.w3.org/TR/xmlschema-2/ section 3.2 & 3.3
+ # the uri's for these are http://www.w3.org/2001/XMLSchema#int etc
+ set xsd2001 [list \
+ string normalizedString boolean decimal integer float double \
+ duration dateTime time date gYearMonth gYear gMonthDay gDay \
+ gMonth hexBinary base64Binary anyURI QName NOTATION \
+ token language NMTOKEN NMTOKENS Name NCName ID IDREF IDREFS \
+ ENTITY ENTITIES nonPositiveInteger negativeInteger long int \
+ short byte nonNegativeInteger unsignedLong unsignedInt \
+ unsignedShort unsignedByte positiveInteger anyType anySimpleType]
+ foreach type $xsd2001 {
+ typedef -namespace http://www.w3.org/2001/XMLSchema $type $type
+ }
+
+ # The SOAP 1.1 encoding: uri = http://www.w3.org/1999/XMLSchema
+ set xsd1999 [list \
+ string boolean float double decimal timeDuration \
+ recurringDuration binary uriReference ID IDREF ENITY NOTATION \
+ QName language IDREFS ENTITIES NMTOKEN NMTOKENS Name NCName \
+ integer nonPositiveInteger negativeInteger long int short byte \
+ nonNegativeInteger unsignedLong unsignedInt unsignedShort \
+ unsignedByte positiveInteger timeInstant time timePeriod date \
+ month year century recurringDate recurringDay]
+ foreach type $xsd1999 {
+ typedef -namespace http://www.w3.org/1999/XMLSchema $type $type
+ }
+
+ # SOAP 1.1 encoding: uri = http://schemas.xmlsoap.org/soap/encoding/
+ set soapenc [list \
+ arrayCoordinate Array Struct base64 string boolean float double \
+ decimal timeDuration recurringDuration binary uriReference ID \
+ IDREF ENTITY NOTATION QName language IDREFS ENTITIES NMTOKEN \
+ NMTOKENS Name NCName integer nonPositiveInteger negativeInteger \
+ long int short byte nonNegativeInteger unsignedLong unsignedShort \
+ unsignedByte positiveInteger timeInstant time timePeriod date \
+ month year century recurringDate recurringDay ur-type]
+ foreach type $soapenc {
+ typedef -namespace http://schemas.xmlsoap.org/soap/encoding/ \
+ $type $type
+ }
+}
+
+proc ::types::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+package provide rpcvar $::rpcvar::version
+
+# -------------------------------------------------------------------------
+# Local variables:
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/tsoap/tcl/utils-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/tsoap/tcl/utils-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/tsoap/tcl/utils-procs.tcl 17 Mar 2005 17:59:32 -0000 1.1
@@ -0,0 +1,538 @@
+# utils.tcl - Copyright (C) 2001 Pat Thoyts
+#
+# DOM data access utilities for use in the TclSOAP package.
+#
+# -------------------------------------------------------------------------
+# This software is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE'
+# for more details.
+# -------------------------------------------------------------------------
+
+namespace eval ::SOAP {
+ namespace eval Utils {
+ variable version 1.0.1
+ variable rcsid {$Id: utils-procs.tcl,v 1.1 2005/03/17 17:59:32 maltes Exp $}
+ namespace export getElements getElementsByName \
+ getElementValue getElementName \
+ getElementValues getElementNames \
+ getElementNamedValues \
+ getElementAttributes getElementAttribute \
+ decomposeSoap decomposeXMLRPC selectNode \
+ namespaceURI targetNamespaceURI \
+ nodeName baseElementName
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Provide a version independent selectNode implementation. We either use
+# the version from the dom package or use the SOAP::xpath version if there
+# is no dom one.
+# Parameters:
+# node - reference to a dom tree
+# path - XPath selection
+# Result:
+# Returns the selected node or a list of matching nodes or an empty list
+# if no match.
+#
+proc ::SOAP::Utils::selectNode2 {node path} {
+ # package require SOAP::xpath
+ if {[catch {SOAP::xpath::xpath -node $node $path} r]} {
+ set r {}
+ }
+ return $r
+}
+
+proc ::SOAP::Utils::selectNode {doc path} {
+ set path [split [string trimleft $path {/}] {/}]
+ set node [$doc documentElement]
+ set log [list]
+
+ if {[lindex [SOAP::xpath::xmlnsSplit [$node nodeName]] 1] != [lindex $path 0]} {
+ return ""
+ }
+ set path [lreplace $path 0 0]
+ lappend log [$node nodeName]
+
+ foreach step $path {
+ foreach child [$node child all] {
+ set node ""
+ if {[lindex [SOAP::xpath::xmlnsSplit [$child nodeName]] 1] == $step} {
+ set node $child
+ lappend log [$node nodeName]
+ break
+ }
+ }
+
+ if {[empty_string_p $node]} {
+ break
+ }
+ }
+
+ return $node
+}
+
+# -------------------------------------------------------------------------
+
+# for extracting the parameters from a SOAP packet.
+# Arrays -> list
+# Structs -> list of name/value pairs.
+# a methods parameter list comes out looking like a struct where the member
+# names == parameter names. This allows us to check the param name if we need
+# to.
+
+proc ::SOAP::Utils::is_array {domElement} {
+ # Look for "xsi:type"="SOAP-ENC:Array"
+ # FIX ME
+ # This code should check the namespace using namespaceURI code (CGI)
+ #
+ set attr [$domElement attributes]
+ upvar #0 attr Attr
+ if {[info exists Attr(SOAP-ENC:arrayType)]} {
+ return 1
+ }
+ if {[info exists Attr(xsi:type)]} {
+ set type $Attr(xsi:type)
+ if {[string match -nocase {*:Array} $type]} {
+ return 1
+ }
+ }
+
+ # If all the child element names are the same, it's an array
+ # but of there is only one element???
+ set names [getElementNames $domElement]
+ if {[llength $names] > 1 && [llength [lsort -unique $names]] == 1} {
+ return 1
+ }
+
+ return 0
+}
+
+# -------------------------------------------------------------------------
+
+# Break down a SOAP packet into a Tcl list of the data.
+proc ::SOAP::Utils::decomposeSoap {domElement} {
+ set result {}
+
+ # get a list of the child elements of this base element.
+ set child_elements [getElements $domElement]
+
+ # if no child element - return the value.
+ if {[empty_string_p $child_elements]} {
+ set result [$domElement text]
+ } else {
+ # decide if this is an array or struct
+ if {[is_array $domElement] == 1} {
+ foreach child $child_elements {
+ lappend result [decomposeSoap $child]
+ }
+ } else {
+ foreach child $child_elements {
+ lappend result [nodeName $child] [decomposeSoap $child]
+ }
+ }
+
+ }
+
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+# I expect domElement to be the params element.
+proc ::SOAP::Utils::decomposeXMLRPC {domElement} {
+ set result {}
+ foreach param_elt [getElements $domElement] {
+ lappend result [getXMLRPCValue [getElements $param_elt]]
+ }
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+proc ::SOAP::Utils::getXMLRPCValue {value_elt} {
+ set value {}
+ if {$value_elt == {}} { return $value }
+
+ # if there is not type element then the specs say it's a string type.
+ set type_elt [getElements $value_elt]
+ if {$type_elt == {}} {
+ return [$value_elt text]
+ }
+
+ set type [getElementName $type_elt]
+ if {[string match "struct" $type]} {
+ foreach member_elt [getElements $type_elt] {
+ foreach elt [getElements $member_elt] {
+ set eltname [getElementName $elt]
+ if {[string match "name" $eltname]} {
+ set m_name [$elt text]
+ } elseif {[string match "value" $eltname]} {
+ set m_value [getXMLRPCValue $elt]
+ }
+ }
+ lappend value $m_name $m_value
+ }
+ } elseif {[string match "array" $type]} {
+ foreach elt [getElements [lindex [getElements $type_elt] 0]] {
+ lappend value [getXMLRPCValue $elt]
+ }
+ } else {
+ set value [$type_elt text]
+ }
+ return $value
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Return a list of all the immediate children of domNode that are element
+# nodes.
+# Parameters:
+# domNode - a reference to a node in a dom tree
+#
+proc ::SOAP::Utils::getElements {domNode} {
+ set elements {}
+ if {$domNode != {}} {
+ foreach node [$domNode child all] {
+ if {[$node nodeType] == "ELEMENT_NODE"} {
+ lappend elements $node
+ }
+ }
+ }
+ return $elements
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# If there are child elements then recursively call this procedure on each
+# child element. If this is a leaf element, then get the element value data.
+# Parameters:
+# domElement - a reference to a dom element node
+# Result:
+# Returns a value or a list of values.
+#
+proc ::SOAP::Utils::getElementValues {domElement} {
+ set result {}
+ if {$domElement != {}} {
+ set nodes [getElements $domElement]
+ if {$nodes =={}} {
+ set result [getElementValue $domElement]
+ } else {
+ foreach node $nodes {
+ lappend result [getElementValues $node]
+ }
+ }
+ }
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+proc ::SOAP::Utils::getElementValuesList {domElement} {
+ set result {}
+ if {$domElement != {}} {
+ set nodes [getElements $domElement]
+ if {$nodes =={}} {
+ set result [getElementValue $domElement]
+ } else {
+ foreach node $nodes {
+ lappend result [getElementValues $node]
+ }
+ }
+ }
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+proc ::SOAP::Utils::getElementNames {domElement} {
+ set result {}
+ if {$domElement != {}} {
+ set nodes [getElements $domElement]
+ if {$nodes == {}} {
+ set result [getElementName $domElement]
+ } else {
+ foreach node $nodes {
+ lappend result [getElementName $node]
+ }
+ }
+ }
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+proc ::SOAP::Utils::getElementNamedValues {domElement} {
+ set name [getElementName $domElement]
+ set value {}
+ set nodes [getElements $domElement]
+ if {$nodes == {}} {
+ set value [getElementValue $domElement]
+ } else {
+ foreach node $nodes {
+ lappend value [getElementNamedValues $node]
+ }
+ }
+ return [list $name $value]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Merge together all the child node values under a given dom element
+# This procedure will also cope with elements whose data is elsewhere
+# using the href attribute. We currently expect the data to be a local
+# reference.
+# Params:
+# domElement - a reference to an element node in a dom tree
+# Result:
+# A string containing the elements value
+#
+proc ::SOAP::Utils::getElementValue {domElement} {
+ set r {}
+ set dataNodes [$domElement child all]
+ if {[set href [href $domElement]] != {}} {
+ if {[string match "\#*" $href]} {
+ set href [string trimleft $href "\#"]
+ } else {
+ return -code error "cannot follow non-local href"
+ }
+ set r [[uplevel proc:name] [getNodeById \
+ [getDocumentElement $domElement] $href]]
+ }
+ foreach dataNode $dataNodes {
+ append r [$dataNode nodeValue]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Get the name of the current proc
+# - from http://purl.org/thecliff/tcl/wiki/526.html
+proc ::SOAP::Utils::proc:name {} {
+ lindex [info level -1] 0
+}
+
+# -------------------------------------------------------------------------
+
+proc ::SOAP::Utils::href {node} {
+ set a [$node attributes]
+ upvar #0 $a A
+ if {[info exists A(href)]} {
+ return $A(href)
+ }
+ return {}
+}
+
+# -------------------------------------------------------------------------
+
+proc ::SOAP::Utils::id {node} {
+ set a [$node attributes]
+ upvar #0 $a A
+ if {[info exists A(id)]} {
+ return $A(id)
+ }
+ return {}
+}
+# -------------------------------------------------------------------------
+
+proc ::SOAP::Utils::getElementName {domElement} {
+ return [$domElement nodeName]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::SOAP::Utils::getElementAttributes {domElement} {
+ set attr [$domElement attributes]
+ set attrlist [array get $attr]
+ return $attrlist
+}
+
+# -------------------------------------------------------------------------
+
+# Find a node by id (sort of the xpath id() function)
+proc ::SOAP::Utils::getNodeById {base id} {
+ if {[string match $id [id $base]]} {
+ return $base
+ }
+ set r {}
+ set children [$base child all]
+ foreach child $children {
+ set r [getNodeById $child $id]
+ if {$r != {}} { return $r }
+ }
+ return {}
+}
+
+# -------------------------------------------------------------------------
+
+# Walk up the DOM until you get to the top.
+proc ::SOAP::Utils::getDocumentElement {node} {
+ set parent [$node parentNode]
+ if {$parent == {}} {
+ return $node
+ } else {
+ return [getDocumentElement $parent]
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Return the value of the specified atribute. First check for an exact match,
+# if that fails look for an attribute name without any namespace specification.
+# Result:
+# Returns the value of the attribute.
+#
+proc ::SOAP::Utils::getElementAttribute {node attrname} {
+ set r {}
+ set attrs [array get [$node attributes]]
+ if {[set ndx [lsearch -exact $attrs $attrname]] == -1} {
+ set ndx [lsearch -regexp $attrs ":${attrname}\$"]
+ }
+
+ if {$ndx != -1} {
+ incr ndx
+ set r [lindex $attrs $ndx]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Get the namespace of the given node. This code will examine the nodes
+# attributes and if necessary the parent nodes attributes until it finds
+# a relevant namespace declaration.
+# Parameters:
+# node - the node for which to return a namespace
+# Result:
+# returns either the namespace uri or an empty string.
+# Notes:
+# The TclDOM 2.0 package provides a -namespaceURI option. The C code module
+# does not, so we have the second chunk of code.
+# The hasFeature method doesn't seem to provide information about this
+# but the versions that support 'query' seem to have the namespaceURI
+# method so we'll use this test for now.
+#
+proc ::SOAP::Utils::namespaceURI {node} {
+ #if {[dom::DOMImplementation hasFeature query 1.0]} {
+ # return [$node namespaceURI]
+ #}
+ if {[catch {$node namespaceURI} result]} {
+ set nodeName [$node nodeName]
+ set ndx [string last : $nodeName]
+ set nodeNS [string range $nodeName 0 $ndx]
+ set nodeNS [string trimright $nodeNS :]
+
+ set result [find_namespaceURI $node $nodeNS]
+ }
+ return $result
+}
+
+# Description:
+# As for namespaceURI except that we are interested in the targetNamespace
+# URI. This is commonly used in XML schemas to specify the default namespace
+# for the defined items.
+#
+proc ::SOAP::Utils::targetNamespaceURI {node value} {
+ set ndx [string last : $value]
+ set ns [string trimright [string range $value 0 $ndx] :]
+ #set base [string trimleft [string range $value $ndx end] :]
+ return [find_namespaceURI $node $ns 1]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Obtain the unqualified part of a node name.
+# Parameters:
+# node - a DOM node
+# Result:
+# the node name without any namespace prefix.
+#
+proc ::SOAP::Utils::nodeName {node} {
+ set nodeName [$node nodeName]
+ set nodeName [string range $nodeName [string last : $nodeName] end]
+ return [string trimleft $nodeName :]
+}
+
+proc ::SOAP::Utils::baseElementName {nodeName} {
+ set nodeName [string range $nodeName [string last : $nodeName] end]
+ return [string trimleft $nodeName :]
+}
+# -------------------------------------------------------------------------
+
+# Description:
+# Obtain the uri for the nsname namespace name working up the DOM tree
+# from the given node.
+# Parameters:
+# node - the starting point in the tree.
+# nsname - the namespace name. May be an null string.
+# Result:
+# Returns the namespace uri or an empty string.
+#
+proc ::SOAP::Utils::find_namespaceURI {node nsname {find_targetNamespace 0}} {
+ if {$node == {}} { return {} }
+ set atts [$node attributes]
+ upvar #0 atts Atts
+
+ # check for the default namespace or targetNamespace
+ if {$nsname == {}} {
+ if {$find_targetNamespace} {
+ if {[info exists Atts(targetNamespace)]} {
+ return $Atts(targetNamespace)
+ }
+ } else {
+ if {[info exists Atts(xmlns)]} {
+ return $Atts(xmlns)
+ }
+ }
+ } else {
+
+ # check the defined namespace names.
+ foreach {attname attvalue} [array get $atts] {
+ if {[string match "xmlns:$nsname" $attname]} {
+ return $attvalue
+ }
+ }
+
+ }
+
+ # recurse through the parents.
+ return [find_namespaceURI [$node parentNode] $nsname $find_targetNamespace]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Return a list of all the immediate children of domNode that are element
+# nodes.
+# Parameters:
+# domNode - a reference to a node in a dom tree
+#
+proc ::SOAP::Utils::getElementsByName {domNode name} {
+ set elements {}
+ if {$domNode != {}} {
+ foreach node [$domNode child all] {
+ if {[$node nodeType] == "ELEMENT_NODE"
+ && [string match $name [$node nodeName]]} {
+ lappend elements $node
+ }
+ }
+ }
+ return $elements
+}
+
+# -------------------------------------------------------------------------
+package provide SOAP::Utils $::SOAP::Utils::version
+
+# -------------------------------------------------------------------------
+# Local variables:
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/tsoap/tcl/xpath-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/tsoap/tcl/xpath-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/tsoap/tcl/xpath-procs.tcl 17 Mar 2005 17:59:32 -0000 1.1
@@ -0,0 +1,249 @@
+# xpath.tcl - Copyright (C) 2001 Pat Thoyts
+#
+# Provide a _SIGNIFICANTLY_ simplified version of XPath querying for DOM
+# document objects. This might get expanded to eventually conform to the
+# W3Cs XPath specification but at present this is purely for use in querying
+# DOM documents for specific elements by the SOAP package.
+#
+# Subject to interface changes
+#
+# -------------------------------------------------------------------------
+# This software is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE'
+# for more details.
+# -------------------------------------------------------------------------
+
+package require tdom
+
+namespace eval SOAP::xpath {
+ variable version 0.2
+ variable rcsid { $Id: xpath-procs.tcl,v 1.1 2005/03/17 17:59:32 maltes Exp $ }
+ namespace export xpath xmlnsSplit
+}
+
+# -------------------------------------------------------------------------
+
+# Given Envelope/Body/Fault and a DOM node, see if we can find a matching
+# element else return {}
+
+# TODO: Paths including attribute selection etc.
+
+proc ::SOAP::xpath::xpath { args } {
+ if { [llength $args] < 2 || [llength $args] > 3 } {
+ return -code error "wrong # args:\
+ should be \"xpath ?option? rootNode path\""
+ }
+
+ array set opts {
+ -node 0
+ -name 0
+ -attributes 0
+ }
+
+ if { [llength $args] == 3 } {
+ set opt [lindex $args 0]
+ switch -glob -- $opt {
+ -nod* { set opts(-node) 1 }
+ -nam* { set opts(-name) 1 }
+ -att* { set opts(-attributes) 1 }
+ default {
+ return -code error "bad option \"$opt\":\
+ must be [array names opts]"
+ }
+ }
+ set args [lrange $args 1 end]
+ }
+
+ set root [lindex $args 0]
+ set path [lindex $args 1]
+
+ # split the path up and call find_node to get the new node or nodes.
+ set root [find_node $root [split [string trimleft $path {/}] {/}]]
+
+ # return the elements value (if any)
+ if { $opts(-node) } {
+ return $root
+ }
+
+ set value {}
+ if { $opts(-attributes) } {
+ foreach node $root {
+ append value [array get [$node attributes]]
+ }
+ return $value
+ }
+
+ if { $opts(-name) } {
+ foreach node $root {
+ lappend value [$node nodeName]
+ }
+ return $value
+ }
+
+ foreach node $root {
+ set children [$node child all]
+ set v ""
+ foreach child $children {
+ append v [string trim [$child nodeValue] "\n"]
+ }
+ lappend value $v
+ }
+ return $value
+}
+
+# -------------------------------------------------------------------------
+
+# check for an element (called $target) that is a child of root. Returns
+# the node(s) or {}
+proc ::SOAP::xpath::find_node { root pathlist } {
+ set r {}
+ set kids ""
+
+ if { $pathlist == {} } {
+ return {}
+ }
+
+ #set target [split $path {/}]
+ set remainder [lrange $pathlist 1 end]
+ set target [lindex $pathlist 0]
+
+ # split the target into XML namespace and element names.
+ set targetName [xmlnsSplit $target]
+ set targetNamespace [lindex $targetName 0]
+ set targetName [lindex $targetName 1]
+
+ # get information about the child elements.
+ foreach element $root {
+ append kids [child_elements $element]
+ }
+
+ # match name and (optionally) namespace
+ foreach {node ns elt} $kids {
+ if { [string match $targetName $elt] } {
+ #puts "$node nodens=$ns elt=$elt targetNS=$targetNamespace\
+ #targetName=$targetName"
+ if { $targetNamespace == {} || [string match $targetNamespace $ns] } {
+ if {$remainder != ""} {
+ set rr [find_node $node $remainder]
+ } else {
+ set rr $node
+ }
+ set r [concat $r $rr]
+ #puts "$kids : $targetName : $remainder -> $r"
+ }
+ }
+ }
+
+ # Flatten the list out.
+ return [eval "list $r"]
+}
+
+# -------------------------------------------------------------------------
+
+# Return list of {node namespace elementname} for each child element of root
+proc ::SOAP::xpath::child_elements { root } {
+ set kids {}
+ set children [$root child all]
+ foreach node $children {
+ set type [string trim [$node nodeType ]]
+ if { $type == "element" } {
+ catch {unset xmlns}
+ array set xmlns [xmlnsConstruct $node]
+
+ #set name [xmlnsQualify xmlns [$node nodeName]]
+ set name [$node nodeName]
+ set name [xmlnsSplit $name]
+ lappend kids $node [lindex $name 0] [lindex $name 1]
+ }
+ }
+ return $kids
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Split a DOM element tag into the namespace and tag components. This
+# will even work for fully qualified namespace names eg:
+# Body -> {} Body
+# SOAP-ENV:Body -> SOAP-ENV Body
+# urn:test:Body -> urn:test Body
+# http://localhost:80/:Body -> http://localhost:80/ Body
+#
+proc ::SOAP::xpath::xmlnsSplit {elementName} {
+ set name [split $elementName :]
+ set len [llength $name]
+ if { $len == 1 } {
+ set ns {}
+ } else {
+ incr len -2
+ set ns [join [lrange $name 0 $len] :]
+ set name [lindex $name end]
+ }
+ return [list $ns $name]
+}
+
+# -------------------------------------------------------------------------
+
+# Build a list of any XML namespace definitions for node
+# Returns a list of {namesnameName qualifiedName}
+#
+proc ::SOAP::xpath::xmlnsGet {node} {
+ set result {}
+ foreach {ns fqns} [array get [$node attributes]] {
+ set ns [split $ns :]
+ if { [lindex $ns 0] == "xmlns" } {
+ lappend result [lindex $ns 1] $fqns
+ }
+ }
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+# Build a list of {{xml namespace name} {qualified namespace}} working up the
+# DOM tree from node. You should look for the last occurrence of your name
+# in the list.
+proc ::SOAP::xpath::xmlnsConstruct {node} {
+ set result [xmlnsGet $node]
+ set parent [$node parentNode]
+ while { [$parent nodeType] == "element" } {
+ set result [concat [xmlnsGet $parent] $result]
+ set parent [$parent parentNode]
+ }
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+# Split an XML element name into its namespace and name parts and return
+# a fully qualified XML element name.
+# xmlnsNamespaces should be an array of namespaceNames to qualified names
+# constructed using array set var [xmlnsConstruct $node]
+#
+proc ::SOAP::xpath::xmlnsQualify {xmlnsNamespaces elementName} {
+ upvar $xmlnsNamespaces xmlns
+ set name [split $elementName :]
+ if { [llength $name] == 1} {
+ return $elementName
+ }
+ if { [llength $name] != 2 } {
+ return -code error "wrong # elements:\
+ name should be namespaceName:elementName"
+ }
+ if { [catch {set fqns $xmlns([lindex $name 0])}] } {
+ return -code error "invalid namespace name:\
+ \"[lindex $name 0]\" not found"
+ }
+
+ return "${fqns}:[lindex $name 1]"
+}
+
+# -------------------------------------------------------------------------
+
+package provide SOAP::xpath $::SOAP::xpath::version
+
+# -------------------------------------------------------------------------
+# Local variables:
+# indent-tabs-mode: nil
+# End: