soap.tcl

Linux下的MSN聊天程序源码

    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 [dom::DOMImplementation create]
    set bod [reply_envelope $doc]
    set flt [dom::document createElement $bod "SOAP-ENV:Fault"]
    set fcd [dom::document createElement $flt "faultcode"]
    dom::document createTextNode $fcd $faultcode
    set fst [dom::document createElement $flt "faultstring"]
    dom::document createTextNode $fst $faultstring

    if { $detail != {} } {
        set dtl0 [dom::document createElement $flt "detail"]
        set dtl  [dom::document createElement $dtl0 "e:errorInfo"]
        dom::element setAttribute $dtl "xmlns:e" "urn:TclSOAP-ErrorInfo"
        
        foreach {detailName detailInfo} $detail {
            set err [dom::document createElement $dtl $detailName]
            dom::document createTextNode $err $detailInfo
        }
    }
    
    # serialize the DOM document and return the XML text
    regsub "<!DOCTYPE\[^>\]*>\n" [dom::DOMImplementation serialize $doc] {} r
    dom::DOMImplementation destroy $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 [dom::document createElement $doc "SOAP-ENV:Envelope"]
    dom::element setAttribute $env \
            "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/"
    dom::element setAttribute $env \
            "xmlns:xsi"      "http://www.w3.org/1999/XMLSchema-instance"
    dom::element setAttribute $env \
            "xmlns:xsd"      "http://www.w3.org/1999/XMLSchema"
    dom::element setAttribute $env \
            "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/"
    set bod [dom::document createElement $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 [dom::document createElement $bod "ns:$methodName"]
    dom::element setAttribute $cmd "xmlns:ns" $uri
    dom::element setAttribute $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 [dom::document createElement $cmd $resultName]
                SOAP::insert_value $retnode $resultValue
            }
        } else {
            set retnode [dom::document createElement $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 [dom::DOMImplementation create]
    set envx [dom::document createElement $doc "SOAP-ENV:Envelope"]

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

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

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

    # Insert any method attributes
    if {$opts(-attributes) != {}} {
        foreach {atname atvalue} $opts(-attributes) {
            dom::element setAttribute $cmd $atname $atvalue
        }
    }

    # insert the parameters.
    set param_no 0
    foreach {key type} $params {
        set val [lindex $args $param_no]
        set d_param [dom::document createElement $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 prereq [dom::DOMImplementation serialize $doc]
    set req {}
    dom::DOMImplementation destroy $doc              ;# clean up
    regsub "<!DOCTYPE\[^>\]*>\r?\n?" $prereq {} req  ;# hack

    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 [dom::DOMImplementation create]
    set d_root [dom::document createElement $doc "methodCall"]
    set d_meth [dom::document createElement $d_root "methodName"]
    dom::document createTextNode $d_meth $name
    
    if { [llength $params] != 0 } {
        set d_params [dom::document createElement $d_root "params"]
    }
    
    set param_no 0
    foreach {key type} $params {
        set val [lindex $args $param_no]
        set d_param [dom::document createElement $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 prereq [dom::DOMImplementation serialize $doc]
    set req {}
    dom::DOMImplementation destroy $doc          ;# clean up
    regsub "<!DOCTYPE\[^>\]*>\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
    #
    # [e-mail]: 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::DOMImplementation 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 != {}} {