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