soap.tcl

Linux下的MSN聊天程序源码

# SOAP.tcl - Copyright (C) 2001 Pat Thoyts <[e-mail]>
#
# 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}
if {[catch {package require dom 3.0} ::SOAP::domVersion]} {
    if { [catch {package require dom 2.0} ::SOAP::domVersion]} {
        if { [catch {package require dom 1.6} ::SOAP::domVersion]} {
            error "require dom package greater than 1.6"
        }
        package require SOAP::xpath;    # TclSOAP
    }
    proc ::SOAP::createDocument {name} {
        set doc [dom::DOMImplementation create]
        return [dom::document createElement $doc $name]
    }
}

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

namespace eval ::SOAP {
#1.6.7 modified to work with dom 3.0 and up
    variable version 1.6.7.1
    variable logLevel warning
    variable rcs_version { $Id: SOAP.tcl 6394 2006-04-14 17:36:29Z tjikkun $ }

    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]} {
        # [e-mail]: 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
    }