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