soap.tcl

Linux下的MSN聊天程序源码

    # 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