rpcvar.tcl

来自「Linux下的MSN聊天程序源码」· TCL 代码 · 共 581 行 · 第 1/2 页

                        set r {}
                    }
                    return $r
                }
            }
            -ex* {
                set typename [lindex $args 1]
                return [info exists typedefs($typename)]
            }
            -en* {
                set enum 1
            }
            -i* {
                set typename [lindex $args 1]
                if {[catch {set typedefs($typename)} typeinfo]} {
                    set typeinfo {}
                }
                return $typeinfo
            }
            --  { 
                set args [lreplace $args 0 0]
                break 
            }
            default { return -code error "unknown option \"[lindex $args 0]\""}
        }
        set args [lreplace $args 0 0]
    }

    if {[llength $args] != 2} {
        return -code error "wrong # args: should be \
                \"typedef ?-namespace uri? ?-enum? typelist typename\n\
                \                     or \"typedef ?-exists? ?-info? typename\""
    }

    set typelist [lindex $args 0]
    set typename [lindex $args 1]

    if {$enum} {
        set typedefs($typename) enum
        set enums($typename) $typelist
    } else {
        set typedefs($typename) $typelist
    }
    set typens($typename) $namespace

    return $typename
}

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

# Description:
#   Check that the value is suitable for type. Basically for enum's
# Result:
#   Returns a boolean true/false value.
proc ::rpcvar::rpcvalidate {type value} {
    variable enums
    if {[typedef -info $type] == "enum"} {
        if {[lsearch -exact $enums($type) $value] == -1} {
            return 0
        }
    }
    return 1
}

# -------------------------------------------------------------------------
#  typdef usage:
#
#  typedef -namespace urn:tclsoap-Test float TclFloat
#
#  typedef -enum -namespace urn:tclsoap-Test {red {green 3} {blue 9}} Colour
#
#  typedef {
#      larry     integer
#      moe       integer
#      curly     integer
#  } Stooges
#  => SOAP::create m -params {myStruct Stooges}
#  => m {larry 23 curly -98 moe 9}
#
#  typedef -namespace urn:soapinterop.org {
#      varInt    integer
#      varFloat  float
#      varString string
#  } SOAPStruct;    
#
#  => SOAP::create zm ... -params {myStruct SOAPStruct}
#  => zm {varInt 2 varFloat 2.2 varString "hello"}
#
#  typedef {
#      arrInt     int()
#      stooges    Stooges()
#      arrString  string()
#      arrColours Colour()
#  } arrStruct
#  => SOAP::create m -params {myStruct arrStruct}
#  => m {arrInt {1 2 3 4 5} \
#        stooges { \
#          {moe 1 larry 2 curly 3} \
#          {moe 1 larry 2 curly 3} \
#        } \
#        arrString {One Two Three} \
#        arrColours {red blue green}\
#    }

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

proc ::rpcvar::default_schemas {soapenv} {

    if {[string match $soapenv "http://schemas.xmlsoap.org/soap/encoding/"]} {
        # SOAP 1.1
        return [list \
                    "xmlns:xsd"      "http://www.w3.org/1999/XMLSchema" \
                    "xmlns:xsi"      "http://www.w3.org/1999/XMLSchema-instance" ]
    }

    if {[string match $soapenv "http://www.w3.org/2001/06/soap-encoding"]} {        
        # SOAP 1.2
        return [list \
                    "xmlns:xsd"      "http://www.w3.org/2001/XMLSchema" \
                    "xmlns:xsi"      "http://www.w3.org/2001/XMLSchema-instance" ]
    }

    return -code error "invalid soap version: \"$soapenv\" is not a valid SOAP URL"
}

# initialize with the SOAP 1.1 encodings for xsd and SOAP-ENC
#
proc ::rpcvar::init_builtins {} {
    # The xsi types from http://www.w3.org/TR/xmlschema-2/ section 3.2 & 3.3
    # the uri's for these are http://www.w33.org/2001/XMLSchema#int etc
    set xsd2001 [list \
            string normalizedString boolean decimal integer float double \
            duration dateTime time date gYearMonth gYear gMonthDay gDay \
            gMonth hexBinary base64Binary anyURI QName NOTATION \
            token language NMTOKEN NMTOKENS Name NCName ID IDREF IDREFS \
            ENTITY ENTITIES nonPositiveInteger negativeInteger long int \
            short byte nonNegativeInteger unsignedLong unsignedInt \
            unsignedShort unsignedByte positiveInteger anyType anySimpleType]
    
    # The SOAP 1.1 encoding: uri = http://www.w3.org/1999/XMLSchema
    set xsd1999 [list \
            string boolean float double decimal timeDuration \
            recurringDuration binary uriReference ID IDREF ENITY NOTATION \
            QName language IDREFS ENTITIES NMTOKEN NMTOKENS Name NCName \
            integer nonPositiveInteger negativeInteger long int short byte \
            nonNegativeInteger unsignedLong unsignedInt unsignedShort \
            unsignedByte positiveInteger timeInstant time timePeriod date \
            month year century recurringDate recurringDay]

    # SOAP 1.1 encoding: uri = http://schemas.xmlsoap.org/soap/encoding/
    set soapenc [list \
            arrayCoordinate Array Struct base64 string boolean float double \
            decimal timeDuration recurringDuration binary uriReference ID \
            IDREF ENTITY NOTATION QName language IDREFS ENTITIES NMTOKEN \
            NMTOKENS Name NCName integer nonPositiveInteger negativeInteger \
            long int short byte nonNegativeInteger unsignedLong unsignedShort \
            unsignedByte positiveInteger timeInstant time timePeriod date \
            month year century recurringDate recurringDay ur-type]

    foreach type $soapenc {
        _init SOAP-ENC $type
    }

    foreach type $xsd1999 {
        _init xsd $type
    }
}

# Initialize the core SOAP types. xsd and SOAP-ENC namespace names are
# pre-defined within the TclSOAP framework. All other namespaces will
# have to be fully specified
if {! [info exists ::rpcvar::typedefs]} {
    ::rpcvar::init_builtins
}


# -------------------------------------------------------------------------
# -------------------------------------------------------------------------
namespace eval ::types {
    variable types
    namespace export typedef
}

proc ::types::typedef {args} {
    variable types
    array set opts {namespace {}}
    while {[string match -* [set option [lindex $args 0]]]} {
        switch -glob -- $option {
            -n* { set opts(namespace) [Pop args 1] }
            -ex* {
                set typename [lindex $args 1]
                if {[string length $opts(namespace)] > 0} {
                    set typename $opts(namespace):$typename
                }
                return [info exists types($typename)]
            }
            -i* {
                set namespace *
                set typename [lindex $args 1]
                if {[string length $opts(namespace)] > 0} {
                    set namespace $opts(namespace)
                }
                set typename $namespace:$typename
                if {[catch {array get types $typename} typeinfo]} {
                    set typeinfo {}
                }
                return $typeinfo
            }
            -- { Pop args ; break }
            default {
                set options [join [lsort [array names opts]] ", -"]
                return -code error "bad option $option:\
                    must be one of -$options"
            }
        }
        Pop args
    }
    
    if {[llength $args] != 2} {
        return -code error "wrong # args: should be \
                \"typedef ?-namespace uri? ?-enum? typelist typename\n\
                \                     or \"typedef ?-exists? ?-info? typename\""
    }

    set typelist [lindex $args 0]
    set typename [lindex $args 1]

    set types($opts(namespace):$typename) $typelist
    return $typename
}

proc ::types::SetupBuiltins {} {
    # The xsi types from http://www.w3.org/TR/xmlschema-2/ section 3.2 & 3.3
    # the uri's for these are http://www.w3.org/2001/XMLSchema#int etc
    set xsd2001 [list \
            string normalizedString boolean decimal integer float double \
            duration dateTime time date gYearMonth gYear gMonthDay gDay \
            gMonth hexBinary base64Binary anyURI QName NOTATION \
            token language NMTOKEN NMTOKENS Name NCName ID IDREF IDREFS \
            ENTITY ENTITIES nonPositiveInteger negativeInteger long int \
            short byte nonNegativeInteger unsignedLong unsignedInt \
            unsignedShort unsignedByte positiveInteger anyType anySimpleType]
    foreach type $xsd2001 {
        typedef -namespace http://www.w3.org/2001/XMLSchema $type $type
    }
    
    # The SOAP 1.1 encoding: uri = http://www.w3.org/1999/XMLSchema
    set xsd1999 [list \
            string boolean float double decimal timeDuration \
            recurringDuration binary uriReference ID IDREF ENITY NOTATION \
            QName language IDREFS ENTITIES NMTOKEN NMTOKENS Name NCName \
            integer nonPositiveInteger negativeInteger long int short byte \
            nonNegativeInteger unsignedLong unsignedInt unsignedShort \
            unsignedByte positiveInteger timeInstant time timePeriod date \
            month year century recurringDate recurringDay]
    foreach type $xsd1999 {
        typedef -namespace http://www.w3.org/1999/XMLSchema $type $type
    }

    # SOAP 1.1 encoding: uri = http://schemas.xmlsoap.org/soap/encoding/
    set soapenc [list \
            arrayCoordinate Array Struct base64 string boolean float double \
            decimal timeDuration recurringDuration binary uriReference ID \
            IDREF ENTITY NOTATION QName language IDREFS ENTITIES NMTOKEN \
            NMTOKENS Name NCName integer nonPositiveInteger negativeInteger \
            long int short byte nonNegativeInteger unsignedLong unsignedShort \
            unsignedByte positiveInteger timeInstant time timePeriod date \
            month year century recurringDate recurringDay ur-type]
    foreach type $soapenc {
        typedef -namespace http://schemas.xmlsoap.org/soap/encoding/ \
            $type $type
    }
}

proc ::types::Pop {varname {nth 0}} {
    upvar $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

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

package provide rpcvar $::rpcvar::version

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