soap.tcl

Linux下的MSN聊天程序源码

        array set fault [decomposeSoap $faultNode]
        dom::DOMImplementation destroy $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 "/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 }
    }

    dom::DOMImplementation destroy $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 [dom::DOMImplementation 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]
        dom::DOMImplementation destroy $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
    }
    dom::DOMImplementation destroy $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 [dom::DOMImplementation 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 {dom::DOMImplementation destroy $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 [dom::node cget $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 [dom::node cget $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 [dom::document cget $doc -documentElement]
        set h [dom::document createElement $e "SOAP-ENV:Header"]
    }
    foreach {name value} $headers {
        if {$name != {}} {
            set elt [dom::document createElement $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]} {
        dom::element setAttribute $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 {
            dom::element setAttribute $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]} {
            dom::element setAttribute $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.
        dom::element setAttribute $node \
                "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/"
        dom::element setAttribute $node "xsi:type" "SOAP-ENC:Array"
        dom::element setAttribute $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]\]"
        dom::element setAttribute $node "SOAP-ENC:arrayType" $arrayType

        foreach elt $value {
            set d_elt [dom::document createElement $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 != {}} {
            dom::element setAttribute $node "xsi:type" "${typexmlns}${type}"
        }
        array set ti $typeinfo
        # Bounds checking - <[e-mail]>
        if {[llength $typeinfo] != [llength $value]} {
            return -code error "wrong # args:\
                type $type contains \"$typeinfo\""
        }
        foreach {eltname eltvalue} $value {
            set d_elt [dom::document createElement $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 [dom::document createElement $node $eltname]
            insert_value $d_elt $eltvalue
        }
    } else {
        # simple type or typedef'd enumeration
        if {$typexmlns != {}} {
            dom::element setAttribute $node "xsi:type" "${typexmlns}${type}"
        }
        dom::document createTextNode $node $value
    }
}

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

package require SOAP::http;             # TclSOAP 1.6.2+

package provide SOAP $::SOAP::version

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

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