home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / lib / tclsoap1.6.1 / rpcvar.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  15.0 KB  |  460 lines
  1. # rpcvar.tcl - Copyright (C) 2001 Pat Thoyts <Pat.Thoyts@bigfoot.com>
  2. #
  3. # Provide a mechanism for passing hints as to the XML-RPC or SOAP value type
  4. # from the user code to the TclSOAP framework.
  5. #
  6. # This package is intended to be imported into the SOAP and XMLRPC namespaces
  7. # where the rpctype command can be overridden to restrict the types to the
  8. # correct names. The client user should then be using SOAP::rpcvalue or
  9. # XMLRPC::rpctype to assign type information.
  10. #
  11. # -------------------------------------------------------------------------
  12. # This software is distributed in the hope that it will be useful, but
  13. # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  14. # or FITNESS FOR A PARTICULAR PURPOSE.  See the accompanying file `LICENSE'
  15. # for more details.
  16. # -------------------------------------------------------------------------
  17.  
  18. package provide rpcvar 1.1
  19.  
  20. namespace eval rpcvar {
  21.     variable version 1.1
  22.     variable magic "rpcvar$version"
  23.     variable rcs_id {$Id: rpcvar.tcl,v 1.7 2001/10/10 02:56:24 patthoyts Exp $}
  24.     variable typedefs
  25.     variable typens
  26.     variable enums
  27.  
  28.     # Initialise the core types
  29.     proc _init {xmlns typename} {
  30.         variable typedefs ; variable typens
  31.         set typedefs($typename) {}      ;# basic types have no typelist
  32.         set typens($typename) $xmlns    ;# set the namespace for this type
  33.     }
  34.  
  35.     namespace export rpcvar is_rpcvar rpctype rpcsubtype rpcvalue \
  36.             rpcnamespace rpcattributes rpcvalidate rpcheaders typedef \
  37.             schema_set
  38. }
  39.  
  40. # -------------------------------------------------------------------------
  41.  
  42. # Description:
  43. #   Create a typed variable with optionally an XML namespace for SOAP types.
  44. # Syntax:
  45. #   rpcvar ?-namespace soap-uri? ?-attributes list? type value
  46. # Parameters:
  47. #   namespace  - the SOAP XML namespace for this type
  48. #   attributes - a list of attribute name/value pairs for this element 
  49. #   type       - the XML-RPC or SOAP type of this value
  50. #   value      - the value being typed or, for struct type, either a list
  51. #                of name-value pairs, or the name of the Tcl array.
  52. # Result:
  53. #   Returns a reference to the newly created typed variable
  54. #
  55. proc rpcvar::rpcvar {args} {
  56.     variable magic
  57.  
  58.     set xmlns {}
  59.     set head {}
  60.     array set attr {}
  61.     while {[string match -* [lindex $args 0]]} {
  62.         switch -glob -- [lindex $args 0] {
  63.             -n* {
  64.                 # namespace
  65.                 set xmlns [lindex $args 1]
  66.                 set args [lreplace $args 0 0]
  67.             }
  68.             -a* {
  69.                 # attributes
  70.                 array set attr [lindex $args 1]
  71.                 set args [lreplace $args 0 0]
  72.             }
  73.             -h* {
  74.                 # headers
  75.                 set head [concat $head [lindex $args 1]]
  76.                 set args [lreplace $args 0 0]
  77.             }
  78.             --  {
  79.                 set args [lreplace $args 0 0]
  80.                 break 
  81.             }
  82.             default { return -code error "unknown option \"[lindex $args 0]\""}
  83.         }
  84.         set args [lreplace $args 0 0]
  85.     }
  86.  
  87.     if {[llength $args] != 2} {
  88.         return -code error "wrong # args: \
  89.                 should be \"rpcvar ?-namespace uri? type value\""
  90.     }
  91.  
  92.     set type [lindex $args 0]
  93.     set value [lindex $args 1]
  94.     if {[uplevel array exists [list $value]]} {
  95.         set value [uplevel array get [list $value]]
  96.     }
  97.  
  98.     if {! [rpcvalidate $type $value]} {
  99.         error "type mismatch: \"$value\" is not appropriate to the \"$type\"\
  100.                 type."
  101.     }
  102.     return [list $magic $xmlns [array get attr] $head $type $value]
  103. }
  104.  
  105. # -------------------------------------------------------------------------
  106.  
  107. # Description:
  108. #   Examine a variable to see if is a reference to a typed variable
  109. # Parameters:
  110. #   varref - reference to the object to be tested
  111. # Result:
  112. #   Returns 1 if the object is a typed value or 0 if not
  113. #
  114. proc rpcvar::is_rpcvar { varref } {
  115.     variable magic
  116.     set failed [catch {lindex $varref 0} ref_magic]
  117.     if { ! $failed && $ref_magic == $magic } {
  118.         return 1
  119.     }
  120.     return 0
  121. }
  122.  
  123. # -------------------------------------------------------------------------
  124.  
  125. # Description:
  126. #   Guess the SOAP or XML-RPC type of the input.
  127. #   For some simple types we can guess the value type. For others we have
  128. #   to use a typed variable. 
  129. # Parameters:
  130. #   arg  - the value for which we are trying to assign a  type.
  131. # Returns:
  132. #   The XML-RPC type is one of int, boolean, double, string,
  133. #   dateTime.iso8601, base64, struct or array. However, we only return one
  134. #   of struct, int, double, boolean or string unless we were passed a 
  135. #   typed variable.
  136. #
  137. proc rpcvar::rpctype { arg } {
  138.     set type {}
  139.     if { [is_rpcvar $arg] } {
  140.         set type [lindex $arg 4]
  141.     } elseif {[uplevel array exists [list $arg]]} {
  142.         set type "struct"
  143.     } elseif {[string is integer -strict $arg]} {
  144.         set type "int"
  145.     } elseif {[string is double -strict $arg]} {
  146.         set type "double"
  147.     } elseif {[string is boolean -strict $arg]} { 
  148.         set type "boolean"
  149.     } else {
  150.         set type "string"
  151.     }
  152.     return $type
  153. }
  154.  
  155. # -------------------------------------------------------------------------
  156.  
  157. # Description:
  158. #   --- IT DOESN'T WORK LIKE THIS NOW -- DELETE ME ?!
  159. #   --- we declare arrays as int() and struct() or MyType()
  160. #   --- Still used in SOAP.tcl
  161. #   ---
  162. #   If the value is not a typed variable, then there cannot be a subtype.
  163. #   otherwise we are looking for array(int) or struct(Typename) etc.
  164. # Result:
  165. #   Either the subtype of an array, or an empty string.
  166. #
  167. proc rpcvar::rpcsubtype { arg } {
  168.     set subtype {}
  169.     if {[is_rpcvar $arg]} {
  170.         regexp {([^(]+)(\((.+)\))?} [lindex $arg 4] -> type -> subtype
  171.     }
  172.     return $subtype
  173. }
  174.  
  175. # -------------------------------------------------------------------------
  176.  
  177. # Description:
  178. #   Retrieve the value from a typed variable or return the input.
  179. # Parameters:
  180. #   arg - either a value or a reference to a typed variable for which to 
  181. #         return the value
  182. # Result:
  183. #   Returns the value of a typed variable.
  184. #   If arg is not a typed variable it return the contents of arg
  185. #
  186. proc rpcvar::rpcvalue { arg } {
  187.     if { [is_rpcvar $arg] } {
  188.         return [lindex $arg 5]
  189.     } else {
  190.         return $arg
  191.     }
  192. }
  193. # -------------------------------------------------------------------------
  194.  
  195. # Description:
  196. #   Retrieve the xml namespace assigned to this variable. This is only used
  197. #   by SOAP.
  198. # Parameters:
  199. #   varref - reference to an RPC typed variable.
  200. # Result:
  201. #   Returns the set namespace or an empty value is no namespace is assigned.
  202. #
  203. proc rpcvar::rpcnamespace { varref } {
  204.     set xmlns {}
  205.     if { [is_rpcvar $varref] } {
  206.         set xmlns [lindex $varref 1]
  207.     }
  208.     return $xmlns
  209. }
  210.  
  211. # -------------------------------------------------------------------------
  212.  
  213. # Description:
  214. #   Retrieve the XML attributes assigned to this variable. This is only
  215. #   relevant to SOAP.
  216. # Parameters:
  217. #   varref - reference to an RPC typed variable.
  218. # Result:
  219. #   Returns the list of name/value pairs for the assigned attributes. The
  220. #   list is suitable for use in array set.
  221. #
  222. proc rpcvar::rpcattributes { varref } {
  223.     set attrs {}
  224.     if {[is_rpcvar $varref]} {
  225.         set attrs [lindex $varref 2]
  226.     }
  227.     return $attrs
  228. }
  229.  
  230. # -------------------------------------------------------------------------
  231.  
  232. # Description:
  233. #   Retrieve the optional list of SOAP Header elements defined for this
  234. #   variable. The intent of this mechanism is to allow a returning procedure
  235. #   to specify SOAP Header elements if required.
  236. # Results:
  237. #
  238. proc rpcvar::rpcheaders { varref } {
  239.     set head {}
  240.     if {[is_rpcvar $varref]} {
  241.         set head [lindex $varref 3]
  242.     }
  243.     return $head
  244. }
  245.  
  246. # -------------------------------------------------------------------------
  247.  
  248. # Description:
  249. #   Define a SOAP type for use with the TclSOAP package. This allows you
  250. #   to specify the SOAP XML namespace and typename for a chunk of data and
  251. #   enables the TclSOAP client code to determine the SOAP type imformation
  252. #   to put on request data.
  253. # Options:
  254. #   -enum             - flag the type as an enumerated type
  255. #   -exists typename  - boolean true if typename is defined
  256. #   -info typename    - return the definition of typename
  257. # Parameters
  258. #   typelist          - list of the type information needed to define the 
  259. #                       new type.
  260. #   typename          - the name of the new type
  261. # Notes:
  262. #   If the typename has already been defined then it will be overwritten.
  263. #   For enumerated types, the typelist is the list of valid enumerator names.
  264. #   Each enumerator may be a two element list, in which case the first element
  265. #   is the name and the second is the integer value.
  266. #
  267. proc rpcvar::typedef {args} {
  268.     variable typedefs
  269.     variable typens
  270.     variable enums
  271.  
  272.     set namespace {}
  273.     set enum 0
  274.     while {[string match -* [lindex $args 0]]} {
  275.         switch -glob -- [lindex $args 0] {
  276.             -n* {
  277.                 set namespace [lindex $args 1]
  278.                 set args [lreplace $args 0 0]
  279.                 if {[llength $args] == 1} {
  280.                     if {[catch {set typens($namespace)} r]} {
  281.                         set r {}
  282.                     }
  283.                     return $r
  284.                 }
  285.             }
  286.             -ex* {
  287.                 set typename [lindex $args 1]
  288.                 return [info exists typedefs($typename)]
  289.             }
  290.             -en* {
  291.                 set enum 1
  292.             }
  293.             -i* {
  294.                 set typename [lindex $args 1]
  295.                 if {[catch {set typedefs($typename)} typeinfo]} {
  296.                     set typeinfo {}
  297.                 }
  298.                 return $typeinfo
  299.             }
  300.             --  { 
  301.                 set args [lreplace $args 0 0]
  302.                 break 
  303.             }
  304.             default { return -code error "unknown option \"[lindex $args 0]\""}
  305.         }
  306.         set args [lreplace $args 0 0]
  307.     }
  308.  
  309.     if {[llength $args] != 2} {
  310.         return -code error "wrong # args: should be \
  311.                 \"typedef ?-namespace uri? ?-enum? typelist typename\n\
  312.                 \                     or \"typedef ?-exists? ?-info? typename\""
  313.     }
  314.  
  315.     set typelist [lindex $args 0]
  316.     set typename [lindex $args 1]
  317.  
  318.     if {$enum} {
  319.         set typedefs($typename) enum
  320.         set enums($typename) $typelist
  321.     } else {
  322.         set typedefs($typename) $typelist
  323.     }
  324.     set typens($typename) $namespace
  325.  
  326.     return $typename
  327. }
  328.  
  329. # -------------------------------------------------------------------------
  330.  
  331. # Description:
  332. #   Check that the value is suitable for type. Basically for enum's
  333. # Result:
  334. #   Returns a boolean true/false value.
  335. proc rpcvar::rpcvalidate {type value} {
  336.     variable enums
  337.     if {[typedef -info $type] == "enum"} {
  338.         if {[lsearch -exact $enums($type) $value] == -1} {
  339.             return 0
  340.         }
  341.     }
  342.     return 1
  343. }
  344.  
  345. # -------------------------------------------------------------------------
  346. #  typdef usage:
  347. #
  348. #  typedef -namespace urn:tclsoap-Test float TclFloat
  349. #
  350. #  typedef -enum -namespace urn:tclsoap-Test {red {green 3} {blue 9}} Colour
  351. #
  352. #  typedef {
  353. #      larry     integer
  354. #      moe       integer
  355. #      curly     integer
  356. #  } Stooges
  357. #  => SOAP::create m -params {myStruct Stooges}
  358. #  => m {larry 23 curly -98 moe 9}
  359. #
  360. #  typedef -namespace urn:soapinterop.org {
  361. #      varInt    integer
  362. #      varFloat  float
  363. #      varString string
  364. #  } SOAPStruct;    
  365. #
  366. #  => SOAP::create zm ... -params {myStruct SOAPStruct}
  367. #  => zm {varInt 2 varFloat 2.2 varString "hello"}
  368. #
  369. #  typedef {
  370. #      arrInt     int[]
  371. #      stooges    Stooges[]
  372. #      arrString  string[]
  373. #      arrColours Colour[]
  374. #  } arrStruct
  375. #  => SOAP::create m -params {myStruct arrStruct}
  376. #  => m {arrInt {1 2 3 4 5} \
  377. #        stooges { \
  378. #          {moe 1 larry 2 curly 3} \
  379. #          {moe 1 larry 2 curly 3} \
  380. #        } \
  381. #        arrString {One Two Three} \
  382. #        arrColours {red blue green}\
  383. #    }
  384.  
  385. # -------------------------------------------------------------------------
  386.  
  387. proc rpcvar::default_schemas {soapenv} {
  388.  
  389.     if {[string match $soapenv "http://schemas.xmlsoap.org/soap/encoding/"]} {
  390.         # SOAP 1.1
  391.         return [list \
  392.                     "xmlns:xsd"      "http://www.w3.org/1999/XMLSchema" \
  393.                     "xmlns:xsi"      "http://www.w3.org/1999/XMLSchema-instance" ]
  394.     }
  395.  
  396.     if {[string match $soapenv "http://www.w3.org/2001/06/soap-encoding"]} {        
  397.         # SOAP 1.2
  398.         return [list \
  399.                     "xmlns:xsd"      "http://www.w3.org/2001/XMLSchema" \
  400.                     "xmlns:xsi"      "http://www.w3.org/2001/XMLSchema-instance" ]
  401.     }
  402.  
  403.     return -code error "invalid soap version: \"$soapenv\" is not a valid SOAP URL"
  404. }
  405.  
  406. # initialize with the SOAP 1.1 encodings for xsd and SOAP-ENC
  407. #
  408. proc rpcvar::init_builtins {} {
  409.     # The xsi types from http://www.w3.org/TR/xmlschema-2/ section 3.2 & 3.3
  410.     # the uri's for these are http://www.w33.org/2001/XMLSchema#int etc
  411.     set xsd2001 [list \
  412.             string normalizedString boolean decimal integer float double \
  413.             duration dateTime time date gYearMonth gYear gMonthDay gDay \
  414.             gMonth hexBinary base64Binary anyURI QName NOTATION \
  415.             token language NMTOKEN NMTOKENS Name NCName ID IDREF IDREFS \
  416.             ENTITY ENTITIES nonPositiveInteger negativeInteger long int \
  417.             short byte nonNegativeInteger unsignedLong unsignedInt \
  418.             unsignedShort unsignedByte positiveInteger anyType anySimpleType]
  419.     
  420.     # The SOAP 1.1 encoding: uri = http://www.w3.org/1999/XMLSchema
  421.     set xsd1999 [list \
  422.             string boolean float double decimal timeDuration \
  423.             recurringDuration binary uriReference ID IDREF ENITY NOTATION \
  424.             QName language IDREFS ENTITIES NMTOKEN NMTOKENS Name NCName \
  425.             integer nonPositiveInteger negativeInteger long int short byte \
  426.             nonNegativeInteger unsignedLong unsignedInt unsignedShort \
  427.             unsignedByte positiveInteger timeInstant time timePeriod date \
  428.             month year century recurringDate recurringDay]
  429.  
  430.     # SOAP 1.1 encoding: uri = http://schemas.xmlsoap.org/soap/encoding/
  431.     set soapenc [list \
  432.             arrayCoordinate Array Struct base64 string boolean float double \
  433.             decimal timeDuration recurringDuration binary uriReference ID \
  434.             IDREF ENTITY NOTATION QName language IDREFS ENTITIES NMTOKEN \
  435.             NMTOKENS Name NCName integer nonPositiveInteger negativeInteger \
  436.             long int short byte nonNegativeInteger unsignedLong unsignedShort \
  437.             unsignedByte positiveInteger timeInstant time timePeriod date \
  438.             month year century recurringDate recurringDay ur-type]
  439.  
  440.     foreach type $soapenc {
  441.         _init SOAP-ENC $type
  442.     }
  443.  
  444.     foreach type $xsd1999 {
  445.         _init xsd $type
  446.     }
  447. }
  448.  
  449. # Initialize the core SOAP types. xsd and SOAP-ENC namespace names are
  450. # pre-defined within the TclSOAP framework. All other namespaces will
  451. # have to be fully specified
  452. if {! [info exists rpcvar::typedefs]} {
  453.     rpcvar::init_builtins
  454. }
  455.  
  456. # -------------------------------------------------------------------------
  457. # Local variables:
  458. #    indent-tabs-mode: nil
  459. # End:
  460.