# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
# -- Tcl Module

# @@ Meta Begin
# Package SOAP 1.6.8.1
# Meta as::author      {Pat Thoyts}
# Meta as::build::date 2015-07-09
# Meta as::origin      http://tclsoap.sourceforge.net
# Meta category        SOAP
# Meta description     Provide support for building clients and servers for
# Meta description     the SOAP remote procedure call protocol from Tcl.
# Meta description     SOAP is an XML based RPC mechanism which provides
# Meta description     cross-platform and cross language compatability.
# Meta license         BSD
# Meta platform        tcl
# Meta recommend       base64
# Meta recommend       uri::urn
# Meta require         SOAP::Utils
# Meta require         SOAP::http
# Meta require         {http 2.0}
# Meta require         log
# Meta require         rpcvar
# Meta require         uri
# Meta subject         SOAP RPC remote XML XMLRPC
# Meta summary         Tcl commands for SOAP remote procedure calls
# @@ Meta End


# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require SOAP::Utils
catch { package require SOAP::http } ; # Circular, recover
package require http 2.0
package require log
package require rpcvar
package require uri

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide SOAP 1.6.8.1

# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
# SOAP.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net>
#            Copyright (C) 2008 Andreas Kupries <andreask@activestate.com>
#
# 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 

# -------------------------------------------------------------------------

namespace eval ::SOAP {variable domVersion}

# -------------------------------------------------------------------------

namespace eval ::SOAP {
    variable version 1.6.8.1
    variable logLevel warning
    variable rcs_version { $Id: SOAP.tcl,v 1.51 2008/07/09 16:14:23 andreas_kupries 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 {
            -rpcprot*  { set procvar(rpcprotocol) $value }
            -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 }
            -namedpar* { set procvar(namedparams) $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"
        }
    } 
    
        
    if {$procvar(rpcprotocol) eq "SOAP"} {
        # 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 {rpcprotocol SOAP} ;# SOAP, XMLRPC or JSONRPC
    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)
    array set $varName {namedparams false}; # Use named or positional params ?

    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 <Enter> "$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 [newDocument]
    set bod [reply_envelope $doc]
    set flt [addNode $bod "SOAP-ENV:Fault"]
    set fcd [addNode $flt "faultcode"]
    addTextNode $fcd $faultcode
    set fst [addNode $flt "faultstring"]
    addTextNode $fst $faultstring

    if { $detail != {} } {
        set dtl0 [addNode $flt "detail"]
        set dtl  [addNode $dtl0 "e:errorInfo"]
        setElementAttribute $dtl "xmlns:e" "urn:TclSOAP-ErrorInfo"
        
        foreach {detailName detailInfo} $detail {
            set err [addNode $dtl $detailName]
            addTextNode $err $detailInfo
        }
    }
    
    # serialize the DOM document and return the XML text
    set r [generateXML $doc]
    deleteDocument $doc
    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 [addNode $doc "SOAP-ENV:Envelope"]
    setElementAttribute $env \
            "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/"
    setElementAttribute $env \
            "xmlns:xsi"      "http://www.w3.org/1999/XMLSchema-instance"
    setElementAttribute $env \
            "xmlns:xsd"      "http://www.w3.org/1999/XMLSchema"
    setElementAttribute $env \
            "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/"
    set bod [addNode $env "SOAP-ENV:Body"]
    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 [addNode $bod "ns:$methodName"]
    setElementAttribute $cmd "xmlns:ns" $uri
    setElementAttribute $cmd \
            "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 [addNode $cmd $resultName]
                SOAP::insert_value $retnode $resultValue
            }
        } else {
            set retnode [addNode $cmd "return"]
            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 [newDocument]
    set envx [addNode $doc "SOAP-ENV:Envelope"]

    setElementAttribute $envx "xmlns:SOAP-ENV" $soapenv
    setElementAttribute $envx "xmlns:SOAP-ENC" $soapenc
    setElementAttribute $envx "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"
        }
        setElementAttribute $envx $nsname $url
    }

    # Insert the Header elements (if any)
    if {$opts(-headers) != {}} {
        set headelt [addNode $envx "SOAP-ENV:Header"]
        foreach {hname hvalue} $opts(-headers) {
            set hnode [addNode $headelt $hname]
            insert_value $hnode $hvalue
        }
    }

    # Insert the body element and atributes.
    set bod [addNode $envx "SOAP-ENV:Body"]
    if {$uri == ""} {
        # don't use a namespace prefix if we don't have a namespace.
        set cmd [addNode $bod "$name" ]
    } else {
        set cmd [addNode $bod "ns:$name" ]
        setElementAttribute $cmd "xmlns:ns" $uri
    }

    # Insert any method attributes
    if {$opts(-attributes) != {}} {
        foreach {atname atvalue} $opts(-attributes) {
            setElementAttribute $cmd $atname $atvalue
        }
    }

    # insert the parameters.
    set param_no 0
    foreach {key type} $params {
        set val [lindex $args $param_no]
        set d_param [addNode $cmd $key]
        insert_value $d_param [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 req [generateXML $doc]
    deleteDocument $doc              ;# clean up

    set req [encoding convertto utf-8 $req]          ;# make it UTF-8
    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 [newDocument]
    set d_root [addNode $doc "methodCall"]
    set d_meth [addNode $d_root "methodName"]
    addTextNode $d_meth $name
    
    if { [llength $params] != 0 } {
        set d_params [addNode $d_root "params"]
    }
    
    set param_no 0
    foreach {key type} $params {
        set val [lindex $args $param_no]
        set d_param [addNode $d_params "param"]
        XMLRPC::insert_value $d_param [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 req [generateXML $doc]
    deleteDocument $doc          ;# clean up

    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 [parseXML $xml]}]} {
            return -code error -errorcode Server \
                "Server response is not well-formed XML.\nresponse was $xml"
        }
    }

    set faultNode [selectNode $doc "/SENV:Envelope/SENV:Body/SENV:Fault"]
    if {$faultNode != {}} {
        array set fault [decomposeSoap $faultNode]
        deleteDocument $doc
        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 "/SENV:Envelope/SENV: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 "/SENV:Envelope/SENV:Body/$responseName"]
    if {$responseNode == {}} {
        set responseNode [lindex [selectNode $doc "/SENV:Envelope/SENV:Body/*"] 0]
    }

    set nodes [getElements $responseNode]
    foreach node $nodes {
        set r [decomposeSoap $node]
        if {$result == {}} { set result $r } else { lappend result $r }
    }

    deleteDocument $doc
    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 [parseXML $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]
        deleteDocument $doc
        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
    }
    deleteDocument $doc

    # 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 [parseXML $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 {deleteDocument $doc}

    return [list $methodName $paramValues]
}

# -------------------------------------------------------------------------

### NB: this procedure needs to be moved into XMLRPC namespace

# Description:
#   Retrieve the value under the given <value> node.
# Parameters:
#   valueNode - reference to a <value> 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 [getElementName $typeElement]

    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 [getElementName $param]
                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 [getDocumentElement $node]
    if {[set h [selectNode $doc /SENV:Envelope/SENV:Header]] == {}} {
        set e [documentElement $doc]
        set h [addNode $e "SOAP-ENV:Header"]
    }
    foreach {name value} $headers {
        if {$name != {}} {
            set elt [addNode $h $name]
            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]

    # 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]} {
        setElementAttribute $node "xmlns:t" $typexmlns
        set typexmlns t
    }
    if {$typexmlns != {}} { append typexmlns : }

    # If there are any attributes assigned, apply them.
    if {$attrs != {}} {
        foreach {aname avalue} $attrs {
            setElementAttribute $node $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]} {
            setElementAttribute $node "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.
        setElementAttribute $node \
                "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/"
        setElementAttribute $node "xsi:type" "SOAP-ENC:Array"
        setElementAttribute $node "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]\]"
        setElementAttribute $node "SOAP-ENC:arrayType" $arrayType

        foreach elt $value {
            set d_elt [addNode $node "item"]
            if {[string match "ur-type" $itemtype]} {
                insert_value $d_elt $elt
            } else {
                insert_value $d_elt [rpcvar $itemtype $elt]
            }
        }
    } elseif {[llength $typeinfo] > 1} {
        # a typedef'd struct.
        if {$typexmlns != {}} {
            setElementAttribute $node "xsi:type" "${typexmlns}${type}"
        }
        array set ti $typeinfo
        # Bounds checking - <simon@e-ppraisal.com>
        if {[llength $typeinfo] != [llength $value]} {
            return -code error "wrong # args:\
                type $type contains \"$typeinfo\""
        }
        foreach {eltname eltvalue} $value {
            set d_elt [addNode $node $eltname]
            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 $ti($eltname) $eltvalue]
        }
    } elseif {$type == "struct"} {
        # an unspecified struct
        foreach {eltname eltvalue} $value {
            set d_elt [addNode $node $eltname]
            insert_value $d_elt $eltvalue
        }
    } else {
        # simple type or typedef'd enumeration
        if {$typexmlns != {}} {
            setElementAttribute $node "xsi:type" "${typexmlns}${type}"
        }
        addTextNode $node $value
    }
}

# -------------------------------------------------------------------------

package provide SOAP $::SOAP::version

if {[catch {package present SOAP::http}]} {
    package require SOAP::http;             # TclSOAP 1.6.2+
}

# -------------------------------------------------------------------------

# Local variables:
#    indent-tabs-mode: nil
# End: