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 / XMLRPC.tcl < prev    next >
Encoding:
Text File  |  2001-10-22  |  6.1 KB  |  182 lines
  1. # XMLRPC.tcl - Copyright (C) 2001 Pat Thoyts <Pat.Thoyts@bigfoot.com>
  2. #
  3. # Provide Tcl access to XML-RPC provided methods.
  4. #
  5. # See http://tclsoap.sourceforge.net/ for usage details.
  6. #
  7. # -------------------------------------------------------------------------
  8. # This software is distributed in the hope that it will be useful, but
  9. # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  10. # or FITNESS FOR A PARTICULAR PURPOSE.  See the accompanying file `LICENSE'
  11. # for more details.
  12. # -------------------------------------------------------------------------
  13.  
  14. package provide XMLRPC 1.0
  15.  
  16. package require SOAP 1.4
  17. package require rpcvar
  18.  
  19. namespace eval XMLRPC {
  20.     variable version 1.0
  21.     variable rcs_version { $Id: XMLRPC.tcl,v 1.5 2001/08/08 15:35:34 patthoyts Exp $ }
  22.  
  23.     namespace export create cget dump configure proxyconfig export
  24.     catch {namespace import -force [uplevel {namespace current}]::rpcvar::*}
  25. }
  26.  
  27. # -------------------------------------------------------------------------
  28.  
  29. # Delegate all these methods to the SOAP package. The only difference between
  30. # a SOAP and XML-RPC call are the method call wrapper and unwrapper.
  31.  
  32. proc XMLRPC::create {args} {
  33.     set args [linsert $args 1 \
  34.             -wrapProc [namespace origin \
  35.                 [namespace parent]::SOAP::xmlrpc_request] \
  36.             -parseProc [namespace origin \
  37.                 [namespace parent]::SOAP::parse_xmlrpc_response]]
  38.     return [uplevel 1 "SOAP::create $args"]
  39. }
  40.  
  41. proc XMLRPC::configure { args } {
  42.     return [uplevel 1 "SOAP::configure $args"]
  43. }
  44.  
  45. proc XMLRPC::cget { args } {
  46.     return [uplevel 1 "SOAP::cget $args"] 
  47. }
  48.  
  49. proc XMLRPC::dump { args } {
  50.     return [uplevel 1 "SOAP::dump $args"] 
  51. }
  52.  
  53. proc XMLRPC::proxyconfig { args } {
  54.     return [uplevel 1 "SOAP::proxyconfig $args"] 
  55. }
  56.  
  57. proc XMLRPC::export {args} {
  58.     foreach item $args {
  59.         uplevel "set \[namespace current\]::__xmlrpc_exports($item)\
  60.                 \[namespace code $item\]"
  61.     }
  62.     return
  63. }
  64.  
  65. # -------------------------------------------------------------------------
  66.  
  67. # Description:
  68. #   Prepare an XML-RPC fault response
  69. # Parameters:
  70. #   faultcode   the XML-RPC fault code (numeric)
  71. #   faultstring summary of the fault
  72. #   detail      list of {detailName detailInfo}
  73. # Result:
  74. #   Returns the XML text of the SOAP Fault packet.
  75. #
  76. proc XMLRPC::fault {faultcode faultstring {detail {}}} {
  77.     set xml [join [list \
  78.         "<?xml version=\"1.0\" ?>" \
  79.         "<methodResponse>" \
  80.         "  <fault>" \
  81.         "    <value>" \
  82.         "      <struct>" \
  83.         "        <member>" \
  84.         "           <name>faultCode</name>"\
  85.         "           <value><int>${faultcode}</int></value>" \
  86.         "        </member>" \
  87.         "        <member>" \
  88.         "           <name>faultString</name>"\
  89.         "           <value><string>${faultstring}</string></value>" \
  90.         "        </member>" \
  91.         "      </struct> "\
  92.         "    </value>" \
  93.         "  </fault>" \
  94.         "</methodResponse>"] "\n"]
  95.     return $xml
  96. }
  97.  
  98. # -------------------------------------------------------------------------
  99.  
  100. # Description:
  101. #   Generate a reply packet for a simple reply containing one result element
  102. # Parameters:
  103. #   doc         empty DOM document element
  104. #   uri         URI of the SOAP method
  105. #   methodName  the SOAP method name
  106. #   result      the reply data
  107. # Result:
  108. #   Returns the DOM document root of the generated reply packet
  109. #
  110. proc XMLRPC::reply {doc uri methodName result} {
  111.     set d_root [dom::document createElement $doc "methodResponse"]
  112.     set d_params [dom::document createElement $d_root "params"]
  113.     set d_param [dom::document createElement $d_params "param"]
  114.     insert_value $d_param $result
  115.     return $doc
  116. }
  117.  
  118. # -------------------------------------------------------------------------
  119.  
  120. # node is the <param> element
  121. proc XMLRPC::insert_value {node value} {
  122.  
  123.     set type      [rpctype $value]
  124.     set value     [rpcvalue $value]
  125.     set typeinfo  [typedef -info $type]
  126.  
  127.     set value_elt [dom::document createElement $node "value"]
  128.  
  129.     if {[string match {*()} $type] || [string match array $type]} {
  130.         # array type: arrays are indicated by a () suffix of the word 'array'
  131.         set itemtype [string trimright $type ()]
  132.         if {$itemtype == "array"} {
  133.             set itemtype "any"
  134.         }
  135.         set array_elt [dom::document createElement $value_elt "array"]
  136.         set data_elt [dom::document createElement $array_elt "data"]
  137.         foreach elt $value {
  138.             if {[string match $itemtype "any"] || \
  139.                 [string match $itemtype "ur-type"] || \
  140.                 [string match $itemtype "anyType"]} {
  141.                 XMLRPC::insert_value $data_elt $elt
  142.             } else {
  143.                 XMLRPC::insert_value $data_elt [rpcvar $itemtype $elt]
  144.             }
  145.         }
  146.     } elseif {[llength $typeinfo] > 1} {
  147.         # a typedef'd struct
  148.         set struct_elt [dom::document createElement $value_elt "struct"]
  149.         array set ti $typeinfo
  150.         foreach {eltname eltvalue} $value {
  151.             set member_elt [dom::document createElement $struct_elt "member"]
  152.             set name_elt [dom::document createElement $member_elt "name"]
  153.             dom::document createTextNode $name_elt $eltname
  154.             if {![info exists ti($eltname)]} {
  155.                 error "invalid member name: \"$eltname\" is not a member of\
  156.                         the $type type."
  157.             }
  158.             XMLRPC::insert_value $member_elt [rpcvar $ti($eltname) $eltvalue]
  159.         }
  160.  
  161.     } elseif {[string match struct $type]} {
  162.         # an undefined struct
  163.         set struct_elt [dom::document createElement $value_elt "struct"]
  164.         foreach {eltname eltvalue} $value {
  165.             set member_elt [dom::document createElement $struct_elt "member"]
  166.             set name_elt [dom::document createElement $member_elt "name"]
  167.             dom::document createTextNode $name_elt $eltname
  168.             XMLRPC::insert_value $member_elt $eltvalue
  169.         }
  170.     } else {
  171.         # simple type.
  172.         set type_elt  [dom::document createElement $value_elt $type]
  173.         dom::document createTextNode $type_elt $value
  174.     }    
  175. }
  176.  
  177. # -------------------------------------------------------------------------
  178.  
  179. # Local variables:
  180. #    indent-tabs-mode: nil
  181. # End:
  182.