'"
+ }
+
+ return [xmlrpc::remote_call $url validator1.countTheEntities -string $string]
+}
+
+proc validate1.easyStructTest {
+ {url "http://www.theashergroup.com/RPC2"}
+ {struct ""}
+} {
+ if {[string equal "" $struct]} {
+ set struct \
+ [list moe [list -int 1] \
+ curly [list -int 2] \
+ larry [list -int 3]]
+
+ }
+ return [xmlrpc::remote_call $url validator1.easyStructTest -struct $struct]
+}
+
+proc validate1.echoStructTest {
+ {url "http://www.theashergroup.com/RPC2"}
+ {struct ""}
+} {
+ if {[string equal $struct ""]} {
+ set struct [list bob [list -int 5]]
+ }
+ return [xmlrpc::remote_call $url validator1.echoStructTest -struct $struct]
+}
+
+proc validate1.manyTypesTest {
+ {url http://www.theashergroup.com/RPC2}
+ {int 1}
+ {boolean 0}
+ {string wazzup}
+ {double 3.14159}
+ {date "20010704T11:50:30"}
+ {base64 "R0lGODlhFgASAJEAAP/////OnM7O/wAAACH5BAEAAAAALAAAAAAWABIAAAJAhI+py40zDIzujEDBzW0n74AaFGChqZUYylyYq7ILXJJ1BU95l6r23RrRYhyL5jiJAT/Ink8WTPoqHx31im0UAAA7"}
+} {
+ return [xmlrpc::remote_call $url validator1.manyTypesTest \
+ -int $int -boolean $boolean -string $string \
+ -double $double -date $date -base64 $base64]
+}
+
+proc validate1.moderateSizeArrayCheck {
+ {url http://www.theashergroup.com/RPC2}
+ {array ""}
+ } {
+ if {[string equal "" $array]} {
+ set array [list Wisconsin Vermont Utah Idaho Kansas California \
+ Virginia Iowa {New York} Mississippi Maine Delaware \
+ Ohio Washington {West Virginia} Delaware Kentucky \
+ {Rhode Island} Hawaii Oregon Kansas {South Carolina} \
+ Maine Louisiana {West Virginia} Nebraska Georgia \
+ {North Dakota} {North Dakota} Hawaii California Hawaii \
+ {South Dakota} Texas Kentucky Alaska Pennsylvania \
+ Missouri Ohio Wisconsin Hawaii Pennsylvania \
+ Utah Alabama Ohio Michigan Idaho \
+ Montana {New York} Arizona Alaska Vermont \
+ {North Carolina} Washington Alabama {New Mexico} Utah \
+ Nevada {South Dakota} Oklahoma Arizona Mississippi \
+ {New York} Illinois {North Carolina} Georgia Wisconsin \
+ Pennsylvania Wisconsin Minnesota Arkansas Alaska \
+ Iowa Louisiana {West Virginia} Georgia Arizona \
+ Washington Wisconsin Delaware {South Dakota} Delaware \
+ Kentucky {North Dakota} Wisconsin Connecticut Alabama \
+ Delaware Colorado Alabama {New Mexico} Iowa \
+ Michigan Wyoming Oklahoma {South Dakota} Kentucky \
+ Massachusetts Hawaii {North Carolina} Virginia \
+ Delaware Wyoming Colorado Louisiana {West Virginia} \
+ Michigan Utah Connecticut Oklahoma {South Dakota} \
+ {South Dakota} California Minnesota {Rhode Island} \
+ Georgia Kansas Kentucky Michigan Wyoming Nevada \
+ Missouri {New York} Maine Oregon Tennessee {New York} \
+ Washington Connecticut {South Dakota} Wyoming \
+ Minnesota {South Dakota} {New York} {West Virginia} \
+ Hawaii {North Dakota} Ohio Washington Delaware \
+ Massachusetts Nebraska Texas {New York}]
+ }
+ return [xmlrpc::remote_call $url validator1.moderateSizeArrayCheck -array $array]
+}
+
+proc validate1.nestedStructTest {
+ {url http://www.theashergroup.com/RPC2}
+ {moe 1}
+ {larry 2}
+ {curly 4}
+ {startyear 1999}
+ {endyear 2001}
+} {
+
+ set calendar ""
+ # for each year
+ for {set y $startyear} {$y <= $endyear} {incr y} {
+
+ set year [list]
+ # for each month
+ for {set m 1} {$m <= 12} {incr m} {
+
+ set month [list]
+ # for each day
+ set mstr [format %02d $m]
+ for {set d 1} {$d <= 31} {incr d} {
+ set dstr [format %02d $d]
+ # exit test (to find end of month)
+ set date \
+ [clock format \
+ [clock scan "[expr $d - 1] day" \
+ -base [clock scan "$y-${mstr}-01"]] \
+ -format "%y:%m:%d"]
+ set date [split $date :]
+ set reald [lindex $date 2]
+ if {![string equal $reald $dstr]} {
+ break
+ }
+
+ if {($y == 2000) && ($m == 4) && ($d == 1)} {
+ set dayta \
+ [list -struct \
+ [list moe [list -int $moe] \
+ curly [list -int $curly] \
+ larry [list -int $larry]]]
+ } else {
+ set dayta \
+ [list -struct \
+ [list moe [list -int [expr 2 * $moe]]]]
+ }
+ set month [concat $month [list $dstr $dayta]]
+ }
+ set year [concat $year [list $mstr [list -struct $month]]]
+ }
+ set calendar [concat $calendar [list $y [list -struct $year]]]
+ }
+
+ return [xmlrpc::remote_call $url validator1.nestedStructTest -struct $calendar]
+}
+
+
+proc validate1.simpleStructReturnTest {
+ {url http://www.theashergroup.com/RPC2}
+ {number 2}
+} {
+ return [xmlrpc::remote_call $url validator1.simpleStructReturnTest -int $number]
+}
+
Index: openacs-4/packages/xml-rpc/tcl/xml-rpc-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xml-rpc/tcl/xml-rpc-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xml-rpc/tcl/xml-rpc-procs.tcl 26 Nov 2003 02:59:13 -0000 1.1
@@ -0,0 +1,708 @@
+# /packages/xml-rpc/tcl/xml-rpc-procs.tcl
+ad_library {
+
+ Initially created by Dave Bauer 2001-03-30 with inspiration from
+ Steve Ball and help from Aaron Swartz and Jerry Asher.
+
+
+ Modified by Vinod Kurup to
+
+ - Use the xml abstraction procs in
+ packages/acs-tcl/tcl/30-xml-utils-procs.tcl (which use tDom now)
+ - Fit in OpenACS 5 framework
+
+
+
+ @author Vinod Kurup [vinod@kurup.com]
+ @creation-date 2003-09-30
+ @cvs-id $Id: xml-rpc-procs.tcl,v 1.1 2003/11/26 02:59:13 vinodk Exp $
+}
+
+# setup nsv array to hold procs that are registered for xml-rpc access
+nsv_array set xmlrpc_procs [list]
+
+namespace eval xmlrpc {}
+
+ad_proc -public xmlrpc::url {} {
+ @return the URL that is listening for RPC requests
+
+ @author Vinod Kurup
+} {
+ # ok to use this since this is a singleton package.
+ return [apm_package_url_from_key xml-rpc]
+}
+
+ad_proc -public xmlrpc::enabled_p {} {
+ @return whether the server is enabled
+} {
+ return [parameter::get_from_package_key \
+ -package_key xml-rpc \
+ -parameter EnableXMLRPCServer]
+}
+
+ad_proc -public xmlrpc::list_methods {} {
+ @return alphabetical list of XML-RPC procs on this server
+} {
+ return [lsort [nsv_array names xmlrpc_procs]]
+}
+
+ad_proc -private xmlrpc::get_content {} {
+ There's no [ns_conn content] so this is a hack to get the content of the
+ XML-RPC request. Taken from ns_xmlrpc.
+
+ @return string - the XML request
+ @author Dave Bauer
+} {
+ # (taken from aol30/modules/tcl/form.tcl)
+ # Spool content into a temporary read/write file.
+ # ns_openexcl can fail, since tmpnam is known not to
+ # be thread/process safe. Hence spin till success
+ set fp ""
+ while {$fp == ""} {
+ set filename "[ns_tmpnam][clock clicks].xmlrpc2"
+ set fp [ns_openexcl $filename]
+ }
+
+ fconfigure $fp -translation binary
+ ns_conncptofp $fp
+ close $fp
+
+ set fp [open $filename r]
+ while {![eof $fp]} {
+ append text [read $fp]
+ }
+ close $fp
+ ns_unlink $filename
+ return $text
+}
+
+ad_proc -private xmlrpc::fault {
+ code
+ msg
+} {
+ Format a fault response to a XML-RPC request
+
+ @param code error code (integer)
+ @param msg error message
+
+ @return XML-RPC fault message
+} {
+ # we could build this with the tDom commands, but it's quite a pain
+ # and I don't see the benefit for our simple needs - vinodk
+ set result "
+
+
+
+
+
+ faultCode
+ $code
+
+
+ faultString
+ [ad_quotehtml $msg]
+
+
+
+
+
+"
+
+ # now re-parse and then re-extract to make sure it's well formed
+ set doc [xml_parse -persist $result]
+ if { [catch {xml_doc_render $doc} result] } {
+ return -code error \
+ "xmlrpc::fault XML is not well formed. error = $result"
+ }
+ xml_doc_free $doc
+ return $result
+}
+
+ad_proc -public xmlrpc::register_proc {
+ proc_name
+} {
+
+ Register a proc to be available via XML-RPC. proc_name is
+ the name of a proc that is defined in the usual OpenACS way (i.e. ad_proc).
+ The proc_name is added to the xmlrpc_procs nsv array with a
+ value of 1. When an XML-RPC call comes in, this array is searched to see
+ if the proc_name has been registered. Currently, the presence of
+ proc_name in the nsv is enough to indicate
+ that the proc can be called via XML-RPC. At some point we may allow
+ administrators to disable procs, so we could set the value associated
+ with proc_name from 1 to 0.
+
+
+ @param proc_name Name of proc to be registered.
+ @return nothing
+} {
+ nsv_set xmlrpc_procs $proc_name 1
+}
+
+
+ad_proc -private xmlrpc::decode_value {
+ node
+} {
+ Unpack the data in a value element. Most value elements will have a
+ subnode describing the datatype (e.g <string> or <int>). If no
+ subnode is present, then we should assume the value is a string.
+
+ @param node <value> node that we're decoding
+ @return Returns the contents of the <value> node. If the value is
+ a <struct> then returns the data in a TCL array. If the value is an
+ <array> then returns the data in a TCL list.
+} {
+ set result ""
+ if {[llength [xml_node_get_children $node]]} {
+ # subnode is specified
+ set subnode [xml_node_get_first_child $node]
+ set datatype [xml_node_get_name $subnode]
+
+ switch -- $datatype {
+ string -
+ i4 -
+ int -
+ double -
+ base64 {
+ set result [xml_node_get_content $subnode]
+ }
+
+ boolean {
+ set result [string is true [xml_node_get_content $subnode]]
+ }
+
+ dateTime.iso8601 {
+ set result [clock scan [xml_node_get_content $subnode]]
+ }
+
+ struct {
+ foreach member \
+ [xml_node_get_children_by_name $subnode member] {
+ lappend result \
+ [xml_node_get_content \
+ [xml_node_get_children_by_name \
+ $member name]]
+ lappend result \
+ [xmlrpc::decode_value \
+ [xml_node_get_children_by_name \
+ $member value]]
+ }
+ }
+
+ array {
+ foreach entry [xml_node_get_children \
+ [xml_node_get_children_by_name \
+ $subnode data]] {
+ lappend result [xmlrpc::decode_value $entry]
+ }
+ }
+
+ default {
+ # we received a tag which is not a recognized datatype.
+ ns_log notice xmlrpc::decode_value ignored type: $datatype
+ }
+ }
+ } else {
+ # no datatype subnode, therefore it's a string
+ set result [xml_node_get_content $node]
+ }
+ return $result
+}
+
+ad_proc -private xmlrpc::respond {
+ data
+} {
+ Format a success response to an XML-RPC request
+
+ @param data data to be returned to the client
+ @return data encoded in a properly formed XML-RPC response
+} {
+ set result ""
+ append result [xmlrpc::construct {} $data]
+ append result ""
+
+ # now re-parse and then re-extract to make sure it's well formed
+ set doc [xml_parse -persist $result]
+ if { [catch {xml_doc_render $doc} result] } {
+ return -code error \
+ "xmlrpc::respond XML is not well formed. err = $result"
+ }
+ xml_doc_free $doc
+ return $result
+}
+
+ad_proc -private xmlrpc::construct {
+ context
+ arglist
+} {
+
+ Construct an XML-RPC element. arglist is a 2-element list
+ which is converted to XML. The first element of arglist is
+ the datatype and the second element is the value.
+
+ Example:
+
+ set arglist {-int 33}
+ set result [xmlrpc::construct {} $arglist]
+ set result ==> <i4>33</i4>
+
+
+ This proc works recursively, so if your top level list has a list within
+ it, then that list will be processed first. The two examples of this are
+ arrays and structs. In addition, structs and arrays can contain each
+ other.
+
+ Array example:
+
+ set arglist {-array {
+ {-int 6682}
+ {-boolean 0}
+ {-text Iowa}
+ {-double 8931.33333333}
+ {-date {Fri Jan 01 05:41:30 EST 1904}}}}
+
+ set result [xmlrpc::construct {} $arglist]
+ set result ==> <array>
+ <data>
+ <value>
+ <i4>6682</i4>
+ </value>
+ <value>
+ <boolean>0</boolean>
+ </value>
+ <value>
+ <string>Iowa</string>
+ </value>
+ <value>
+ <double>8931.33333333</double>
+ </value>
+ <value>
+ <dateTime.iso8601>19040101T05:41:30</dateTime.iso8601>
+ </value>
+ </data>
+ </array>
+
+
+ struct's have the special format: -struct {name1 {-datatype1 value1} name2 {-datatype2 value2}}
+
+ Struct Example:
+
+ set arglist {-struct {
+ ctLeftAngleBrackets {-int 5}
+ ctRightAngleBrackets {-int 6}
+ ctAmpersands {-int 7}
+ ctApostrophes {-int 0}
+ ctQuotes {-int 3}}}
+
+ set result [xmlrpc::construct {} $arglist]
+ set result ==> <struct>
+ <member>
+ <name>ctLeftAngleBrackets</name>
+ <value>
+ <i4>5</i4>
+ </value>
+ </member>
+ <member>
+ <name>ctRightAngleBrackets</name>
+ <value>
+ <i4>6</i4>
+ </value>
+ </member>
+ <member>
+ <name>ctAmpersands</name>
+ <value>
+ <i4>7</i4>
+ </value>
+ </member>
+ <member>
+ <name>ctApostrophes</name>
+ <value>
+ <i4>0</i4>
+ </value>
+ </member>
+ <member>
+ <name>ctQuotes</name>
+ <value>
+ <i4>3</i4>
+ </value>
+ </member>
+ </struct>
+
+
+ The context parameter is used internally to create tags within tags.
+
+ Example:
+
+ set arglist {-int 33}
+ set result [xmlrpc::construct {foo bar} $arglist]
+ set result ==> <foo><bar><i4>33</i4></bar></foo>
+
+
+ @param context extra tags to wrap around the data
+ @param arglist datatype-value list (or more complex types as described
+ above)
+
+ @return XML formatted result
+} {
+ set result ""
+ # list of valid options
+ set options_list [list "-string" "-text" "-i4" "-int" "-integer" \
+ "-boolean" "-double" "-date" "-binary" "-base64" \
+ "-variable" "-structvariable" "-struct" \
+ "-array" "-keyvalue"]
+
+ # if no valid option is specified, treat it as string
+ if {[lsearch $options_list [lindex $arglist 0]] == -1} {
+ set value "[ad_quotehtml $arglist]"
+ return [xmlrpc::create_context $context $arglist]
+ }
+
+ if { [llength $arglist] % 2} {
+ # datatype required for each value
+ return -code error \
+ "no value for option \"[lindex $arglist end]\""
+ }
+
+ foreach {option value} $arglist {
+ switch -- $option {
+ -string -
+ -text {
+ set value "[ad_quotehtml $value]"
+ append result [xmlrpc::create_context $context $value]
+ }
+
+ -i4 -
+ -int -
+ -integer {
+ if {![string is integer $value]} {
+ return -code error \
+ "value \"$value\" for option \"$option\" is not an integer:"
+ }
+ set value "$value"
+ append result [xmlrpc::create_context $context $value]
+ }
+
+ -boolean {
+ set value "[string is true $value]"
+ append result [xmlrpc::create_context $context $value]
+ }
+
+ -double {
+ if {![string is double $value]} {
+ return -code error \
+ "value \"$value\" for option \"$option\" is not a floating point value"
+ }
+ set value "$value"
+ append result [xmlrpc::create_context $context $value]
+ }
+
+ -date {
+ if {[catch {clock format [clock scan $value] \
+ -format {%Y%m%dT%T} } datevalue]} {
+ return -code error \
+ "value \"$value\" for option \"$option\" is not a valid date ($datevalue)"
+ }
+
+ set value "$datevalue"
+ append result [xmlrpc::create_context $context $value]
+ }
+
+ -binary -
+ -base64 {
+ # it is up to the application to do the encoding
+ # before the data gets here
+ set value "$value"
+ append result [xmlrpc::create_context $context $value]
+ }
+
+ -array {
+ set data ""
+ foreach datum $value {
+ append data [xmlrpc::construct value $datum]
+ }
+ append data ""
+ append result [xmlrpc::create_context $context $data]
+ }
+
+ -struct -
+ -keyvalue {
+ set data ""
+ foreach {name mvalue} $value {
+ append data "[ad_quotehtml $name]"
+ append data [xmlrpc::construct value $mvalue]
+ append data ""
+ }
+ append data ""
+ append result [xmlrpc::create_context $context $data]
+ }
+
+ default {
+ # anything else will be ignored
+ ns_log notice xmlrpc::construct ignored option: $option \
+ with value: $value
+ }
+ }
+ }
+
+ return $result
+}
+
+ad_proc -private xmlrpc::create_context {
+ context
+ value
+} {
+ Return the value wrapped in appropriate context tags. If context is
+ a list of items, then the result will be wrapped in multiple tags.
+ Example:
+
+ xmlrpc::create_context {param value} 78
+ returns ==> "78"
+
+
+ @param context context to create
+ @param value character data
+ @return string with value wrapped in context tags
+} {
+ # reverse the list (algorithm from TCL Wiki)
+ set r_context {}
+ set i [llength $context]
+ while {$i} {lappend r_context [lindex $context [incr i -1]]}
+
+ set result "$value"
+ foreach child_name $r_context {
+ set result "<$child_name>$result"
+ }
+
+ return $result
+}
+
+ad_proc -public xmlrpc::remote_call {
+ url
+ method
+ {args ""}
+} {
+ Invoke a method on a remote server using XML-RPC
+
+ @param url url of service
+ @param method method to call
+ @param args list of args to the method
+
+ @return the response of the remote service. Error if remote service returns
+ a fault.
+} {
+ set call "$method"
+ append call ""
+ if { [llength $args] } {
+ append call [xmlrpc::construct {param value} $args]
+ }
+ append call ""
+
+ # now re-parse and then re-extract to make sure it's well formed
+ set doc [xml_parse -persist $call]
+ if { [catch {xml_doc_render $doc} request] } {
+ return -code error \
+ "xmlrpc::fault XML is not well formed. error = $request"
+ }
+ xml_doc_free $doc
+
+ # make the call
+ if {[catch {xmlrpc::httppost -url $url -content $request } response ]} {
+ ns_log error xmlrpc::remote_call \
+ url: $url request: $request error: $response
+ return -code error [list HTTP_ERROR \
+ "HTTP request failed due to \"$response\""]
+ }
+ return [xmlrpc::parse_response $response]
+}
+
+ad_proc -private xmlrpc::httppost {
+ -url
+ {-timeout 30}
+ {-depth 0}
+ -content
+} {
+ The proc util_httppost doesn't work for our needs. We need to send
+ Content-type of text/xml and we need to send a Host header. So, roll
+ our own XML-RPC HTTP POST. Wait - lars-blogger sends out XML-RPC pings
+ to weblogs.com. I'll steal the POST code from there and simplify that
+ call.
+
+ @author Vinod Kurup
+} {
+ if [catch {
+ if {[incr depth] > 10} {
+ return -code error "xmlrpc::httppost: Recursive redirection: $url"
+ }
+ set req_hdrs [ns_set create]
+
+ # headers necesary for a post and the form variables
+ ns_set put $req_hdrs Accept "*/*"
+ ns_set put $req_hdrs User-Agent "[ns_info name]-Tcl/[ns_info version]"
+ ns_set put $req_hdrs "Content-type" "text/xml"
+ ns_set put $req_hdrs "Content-length" [string length $content]
+
+ set http [ns_httpopen POST $url $req_hdrs 30 $content]
+ set rfd [lindex $http 0]
+ set wfd [lindex $http 1]
+ set rpset [lindex $http 2]
+
+ flush $wfd
+ close $wfd
+
+ set headers $rpset
+ set response [ns_set name $headers]
+ set status [lindex $response 1]
+
+ # follow 302
+ if {$status == 302} {
+ set location [ns_set iget $headers location]
+ if {$location != ""} {
+ ns_set free $headers
+ close $rfd
+ set page [xmlrpc::httppost -url $location \
+ -timeout $timeout -depth $depth -content $content]
+ }
+ } else {
+ set length [ns_set iget $headers content-length]
+ if [string match "" $length] {set length -1}
+ set err [catch {
+ while 1 {
+ set buf [_ns_http_read $timeout $rfd $length]
+ append page $buf
+ if [string match "" $buf] break
+ if {$length > 0} {
+ incr length -[string length $buf]
+ if {$length <= 0} break
+ }
+ }
+ } errMsg]
+ ns_set free $headers
+ close $rfd
+ if $err {
+ global errorInfo
+ return -code error -errorinfo $errorInfo $errMsg
+ }
+ }
+ } errmsg ] {
+ ns_log warning "xmlrpc::httppost error: $errmsg"
+ return -1
+ } else {
+ return $page
+ }
+}
+
+ad_proc -private xmlrpc::parse_response {xml} {
+ Parse the response from a XML-RPC call.
+
+ @param xml the XML response
+ @return result
+} {
+ set doc [xml_parse -persist $xml]
+ set root [xml_doc_get_first_node $doc]
+
+ if { ![string equal [xml_node_get_name $root] "methodResponse"] } {
+ set root_name [xml_node_get_name $root]
+ xml_doc_free $doc
+ return -code error "xmlrpc::parse_response: invalid server reponse - root node is not methodResponse. it's $root_name"
+ }
+
+ set node [xml_node_get_first_child $root]
+ switch -- [xml_node_get_name $node] {
+ params {
+ # need more error checking here.
+ # if the response is not well formed, we'll probably
+ # get an error, but it may be hard to track down
+ set param [xml_node_get_first_child $node]
+ set value [xml_node_get_first_child $param]
+ set result [xmlrpc::decode_value $value]
+ }
+ fault {
+ # should do more checking here...
+ array set fault [xmlrpc::decode_value \
+ [xml_node_get_first_child $node]]
+ xml_doc_free $doc
+ return -code error -errorcode $fault(faultCode) $fault(faultString)
+ }
+ default {
+ set type [xml_node_get_name $node]
+ xml_doc_free $doc
+ return -code error "xmlrpc::parse_response: invalid server response ($type)"
+ }
+ }
+ xml_doc_free $doc
+
+ return $result
+}
+
+ad_proc -private xmlrpc::invoke {
+ xml
+} {
+ Take the XML-RPC request and invoke the method on the server.
+ The methodName element contains the Tcl procedure to evaluate. The
+ method is called from the global stack level.
+
+ @param xml XML-RPC data from the client
+ @return result encoded in XML and ready for return to the client
+} {
+ # check that the XML-RPC Server is enabled
+ if { ![xmlrpc::enabled_p] } {
+ set result [xmlrpc::fault 3 "XML-RPC Server disabled"]
+ ns_log error "xmlrpc::invoke fault $result"
+ return $result
+ }
+
+ ns_log debug "xmlrpc::invoke REQUEST: $xml"
+ if {[catch {set doc [xml_parse -persist $xml]} err_msg]} {
+ set result [xmlrpc::fault 1 "error parsing request: $err_msg"]
+ ns_log error "xmlrpc::invoke: error parsing request: $err_msg"
+ } else {
+ # parse OK - get data
+ set data [xml_doc_get_first_node $doc]
+
+ set method_name \
+ [xml_node_get_content \
+ [lindex \
+ [xml_node_get_children_by_name $data methodName] 0 ]]
+
+ set arguments [list]
+ set params [xml_node_get_children_by_name $data params]
+ foreach parameter [xml_node_get_children_by_name $params param] {
+ lappend arguments \
+ [xmlrpc::decode_value [xml_node_get_first_child $parameter]]
+ }
+
+ set errno [catch {xmlrpc::invoke_method $method_name $arguments} result]
+ if { $errno } {
+ set result [xmlrpc::fault $errno $result]
+ ns_log error "xmlrpc_invoke: error in xmlrpc method REQUEST: $xml RESULT: $result"
+ } else {
+ # success
+ set result [xmlrpc::respond $result]
+ ns_log debug "xmlrpc::invoke result $result"
+ }
+ }
+ xml_doc_free $doc
+
+ return $result
+}
+
+ad_proc -private xmlrpc::invoke_method {
+ method_name
+ arguments
+} {
+ Call the given method on the OpenACS server. It's up to the caller
+ to catch any error that we get.
+
+ @param method_name methodName from XML-RPC
+ @param arguments list of arguments
+ @return result of the OpenACS proc
+ @author Vinod Kurup
+} {
+ # check that the method is registered as a valid XML-RPC method
+ if {![nsv_exists xmlrpc_procs $method_name]} {
+ return -code error -errorcode 2 "methodName $method_name doesn't exist"
+ }
+ ns_log debug "xmlrpc::invoke_method method $method_name args $arguments"
+ set result [uplevel #0 [list $method_name] $arguments]
+ return $result
+}
Index: openacs-4/packages/xml-rpc/tcl/test/xml-rpc-test-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xml-rpc/tcl/test/xml-rpc-test-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xml-rpc/tcl/test/xml-rpc-test-procs.tcl 26 Nov 2003 02:59:14 -0000 1.1
@@ -0,0 +1,181 @@
+# /packages/xml-rpc/tcl/test/xml-rpc-test-procs.tcl
+ad_library {
+ Test the XML-RPC interface
+ @author Vinod Kurup [vinod@kurup.com]
+ @creation-date Sat Oct 25 10:49:55 2003
+ @cvs-id $Id: xml-rpc-test-procs.tcl,v 1.1 2003/11/26 02:59:14 vinodk Exp $
+}
+
+aa_register_case -cats script xml_rpc_mounted {
+ Test to make sure the xml-rpc package has been mounted
+} {
+ aa_run_with_teardown -rollback -test_code {
+ aa_false "XML-RPC url not null" [empty_string_p [xmlrpc::url]]
+ }
+}
+
+aa_register_case -cats script xml_rpc_fault {
+ Test the fault generation code
+} {
+ set expected_code 22
+ set expected_string "my error message with html codes"
+
+ aa_run_with_teardown -rollback -test_code {
+ set result [xmlrpc::fault $expected_code $expected_string]
+
+ # extract faultCode and faultString
+ set doc [xml_parse -persist $result]
+ set value_node [xml_node_get_first_child [xml_node_get_first_child [xml_doc_get_first_node $doc]]]
+ array set fault [xmlrpc::decode_value $value_node]
+ xml_doc_free $doc
+
+ aa_equals "Proper faultCode" $fault(faultCode) $expected_code
+ aa_equals "Proper faultString" $fault(faultString) $expected_string
+ }
+}
+
+ad_proc -private xmlrpc_decode_test_prep { value } {
+ Takes the contents of a <value> node, calls xmlrpc::decode_value and
+ returns the result. This is done repeatedly in the xml_rpc_decode_value
+ test, so I broke it out into a separate function for that purpose
+} {
+ set doc [xml_parse -persist "$value"]
+ set result [xmlrpc::decode_value [xml_doc_get_first_node $doc]]
+ xml_doc_free $doc
+ return $result
+
+}
+
+aa_register_case -cats script xml_rpc_decode_value {
+ Test xmlrpc::decode_value to be sure it decodes properly
+} {
+ aa_run_with_teardown -rollback -test_code {
+ set result [xmlrpc_decode_test_prep "a string"]
+ aa_equals "string test" $result "a string"
+
+ set result [xmlrpc_decode_test_prep "- a naked string"]
+ aa_equals "naked string test" $result "- a naked string"
+
+ set result [xmlrpc_decode_test_prep "22"]
+ aa_equals "int test" $result 22
+
+ set result [xmlrpc_decode_test_prep "33"]
+ aa_equals "i4 test" $result 33
+
+ set result [xmlrpc_decode_test_prep "3.1415"]
+ aa_equals "double test" $result 3.1415
+
+ set result [xmlrpc_decode_test_prep "1"]
+ aa_equals "boolean test 1" $result 1
+
+ set result [xmlrpc_decode_test_prep "f"]
+ aa_equals "boolean test 2" $result 0
+
+ set result [xmlrpc_decode_test_prep "20030821T083122"]
+ aa_equals "date test" $result 1061469082
+
+
+ unset result
+ array set result [xmlrpc_decode_test_prep "id19contentMy content"]
+ aa_equals "struct test 1" $result(id) 19
+ aa_equals "struct test 2" $result(content) "My content"
+
+ unset result
+ set result [xmlrpc_decode_test_prep "phrase 12nd phrasefinal phrase"]
+ aa_equals "array test 1" [lindex $result 0] "phrase 1"
+ aa_equals "array test 2" [lindex $result 1] "2nd phrase"
+ aa_equals "array test 3" [lindex $result 2] "final phrase"
+
+ unset result
+ set result [xmlrpc_decode_test_prep "phrase 1sublistGot it!"]
+ array set struct [lindex $result 1]
+ aa_equals "array inside struct inside array" [lindex $struct(sublist) 0] "Got it!"
+ }
+}
+
+aa_register_case -cats script xml_rpc_respond {
+ Test the response generation code
+} {
+ set expected_data "my data"
+
+ aa_run_with_teardown -rollback -test_code {
+ set result [xmlrpc::respond $expected_data]
+
+ # extract data
+ set doc [xml_parse -persist $result]
+ set value_node [xml_node_get_first_child [xml_node_get_first_child [xml_node_get_first_child [xml_doc_get_first_node $doc]]]]
+ set data [xmlrpc::decode_value $value_node]
+ xml_doc_free $doc
+
+ aa_equals "Proper data" $data $expected_data
+ }
+}
+
+aa_register_case -cats script xml_rpc_construct {
+ Test the construction code
+} {
+
+ aa_run_with_teardown -rollback -test_code {
+ # use testcases from the ad_proc documentation
+
+ # int test
+ set arglist {-int 33}
+ set result [xmlrpc::construct {} $arglist]
+ aa_equals "int contruction" $result "33"
+
+ # array test
+ set arglist {-array {
+ {-int 6682}
+ {-boolean 0}
+ {-text Iowa}
+ {-double 8931.33333333}
+ {-date {Fri Jan 01 05:41:30 EST 1904}}}}
+
+ set result [xmlrpc::construct {} $arglist]
+ aa_equals "array construction" $result "66820Iowa8931.3333333319040101T05:41:30"
+
+ # struct test
+ set arglist {-struct {
+ ctLeftAngleBrackets {-int 5}
+ ctRightAngleBrackets {-int 6}
+ ctAmpersands {-int 7}
+ ctApostrophes {-int 0}
+ ctQuotes {-int 3}}}
+
+ set result [xmlrpc::construct {} $arglist]
+ aa_equals "struct test" $result "ctLeftAngleBrackets5ctRightAngleBrackets6ctAmpersands7ctApostrophes0ctQuotes3"
+ }
+
+ # test context parameter
+ set arglist {-int 33}
+ set result [xmlrpc::construct "foo bar" $arglist]
+ aa_equals "context test" $result "33"
+
+}
+
+aa_register_case -cats web xml_rpc_validate {
+ Test the standard XML-RPC validation suite
+} {
+
+ # run the validation suite specified in validator-procs.tcl
+ # if those procs change, this proc needs to change too
+ set test_list \
+ [list \
+ arrayOfStructsTest 6 \
+ countTheEntities {ctLeftAngleBrackets 4 ctRightAngleBrackets 4 ctAmpersands 9 ctApostrophes 7 ctQuotes 1} \
+ easyStructTest 6 \
+ echoStructTest {bob 5} \
+ manyTypesTest {1 0 wazzup 3.14159 994261830 R0lGODlhFgASAJEAAP/////OnM7O/wAAACH5BAEAAAAALAAAAAAWABIAAAJAhI+py40zDIzujEDBzW0n74AaFGChqZUYylyYq7ILXJJ1BU95l6r23RrRYhyL5jiJAT/Ink8WTPoqHx31im0UAAA7} \
+ moderateSizeArrayCheck {WisconsinNew York} \
+ nestedStructTest 7 \
+ simpleStructReturnTest {times1000 2000 times100 200 times10 20}
+ ]
+ set url [ad_url][xmlrpc::url]
+
+ aa_run_with_teardown -rollback -test_code {
+ foreach {test_name expected} $test_list {
+ set result [validate1.$test_name $url]
+ aa_equals $test_name $result $expected
+ }
+ }
+}
Index: openacs-4/packages/xml-rpc/www/index.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xml-rpc/www/index.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xml-rpc/www/index.adp 26 Nov 2003 02:59:14 -0000 1.1
@@ -0,0 +1,10 @@
+
+
+
+This is the URL from which XML-RPC Requests will be handled.
+
+
+
+Perhaps you want the Admin Pages or the Documentation.
+
Index: openacs-4/packages/xml-rpc/www/index.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xml-rpc/www/index.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xml-rpc/www/index.tcl 26 Nov 2003 02:59:14 -0000 1.1
@@ -0,0 +1,18 @@
+# /packages/xml-rpc/www/index.tcl
+ad_page_contract {
+ Accept XML-RPC POST requests and processes them. GET requests are shown
+ links to the admin pages or docs.
+
+ @author Vinod Kurup [vinod@kurup.com]
+ @creation-date Mon Sep 29 23:35:14 2003
+ @cvs-id $Id: index.tcl,v 1.1 2003/11/26 02:59:14 vinodk Exp $
+} {
+}
+
+if {[string equal [ns_conn method] POST]} {
+ set content [xmlrpc::get_content]
+ ns_return 200 text/xml [xmlrpc::invoke $content]
+ return
+}
+
+# GET requests fall through to index.adp
Index: openacs-4/packages/xml-rpc/www/admin/index.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xml-rpc/www/admin/index.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xml-rpc/www/admin/index.adp 26 Nov 2003 02:59:14 -0000 1.1
@@ -0,0 +1,33 @@
+
+XML-RPC Administration
+
+
+
+
+The following procedures are registered:
+
+
+
+
+| Proc Name | Enabled? |
+
+
+
+
+ | @rpc_procs.name;noquote@ | @rpc_procs.enabled_p@ |
+
+
+
Index: openacs-4/packages/xml-rpc/www/admin/index.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xml-rpc/www/admin/index.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xml-rpc/www/admin/index.tcl 26 Nov 2003 02:59:14 -0000 1.1
@@ -0,0 +1,28 @@
+# /packages/xml-rpc/www/admin/index.tcl
+ad_page_contract {
+ Front page of admin
+ @author Vinod Kurup [vinod@kurup.com]
+ @creation-date Thu Oct 9 15:22:41 2003
+ @cvs-id $Id: index.tcl,v 1.1 2003/11/26 02:59:14 vinodk Exp $
+} {
+} -properties {
+ rpc_url:onevalue
+ server_enabled_p:onevalue
+ rpc_procs:multirow
+}
+
+set rpc_url [ad_url][xmlrpc::url]
+set server_enabled_p [xmlrpc::enabled_p]
+
+multirow create rpc_procs name enabled_p
+
+foreach proc_name [xmlrpc::list_methods] {
+ if { $server_enabled_p } {
+ set enabled_p [ad_decode [nsv_get xmlrpc_procs $proc_name] 0 No Yes]
+ } else {
+ set enabled_p No
+ }
+
+ set proc_name [api_proc_link $proc_name]
+ multirow append rpc_procs $proc_name $enabled_p
+}
Index: openacs-4/packages/xml-rpc/www/admin/toggle.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xml-rpc/www/admin/toggle.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xml-rpc/www/admin/toggle.tcl 26 Nov 2003 02:59:14 -0000 1.1
@@ -0,0 +1,15 @@
+# /packages/xml-rpc/www/admin/toggle.tcl
+ad_page_contract {
+ Toggle the server status
+ @author Vinod Kurup [vinod@kurup.com]
+ @creation-date Sat Oct 11 01:10:06 2003
+ @cvs-id $Id: toggle.tcl,v 1.1 2003/11/26 02:59:14 vinodk Exp $
+} {
+}
+
+parameter::set_from_package_key \
+ -package_key xml-rpc \
+ -parameter EnableXMLRPCServer \
+ -value [string is false [xmlrpc::enabled_p]]
+
+ad_returnredirect ./
\ No newline at end of file
Index: openacs-4/packages/xml-rpc/www/doc/index.html
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xml-rpc/www/doc/index.html,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xml-rpc/www/doc/index.html 26 Nov 2003 02:59:14 -0000 1.1
@@ -0,0 +1,297 @@
+
+
+XML-RPC
+
+
+XML-RPC Server Documentation
+
+Overview
+
+
+
+XML-RPC is a protocol which allows clients to make remote procedure calls
+on your server. Data is transformed into a standard XML format before being
+transferred between the client and server. This allows software using
+different OS's and programming languages to interact. See XML-RPC.com for more information.
+
+
+
+Why do we need it in OpenACS?
+
+
+
+Some XML-RPC protocols have become popular in the web world. The Blogger API and
+the Metaweblog API allow
+users to manage their blogs using tools of their choice and these have
+become widespread enough that users expect to find this functionality in
+any blogging software. For this reason, it's important to provide this
+minimum of functionality.
+
+
+
+User Documentation
+
+
+
+There are no user-facing pages. XML-RPC client software may require the
+user to know the URL that is accepting XML-RPC requests, which is
+admin-definable (default: http://example.com/RPC2/). XML-RPC savvy users
+can call the XML-RPC method system.listMethods to see which
+methods the server supports.
+
+
+
+Admin Documentation
+
+
+
+The server is installed by default at /RPC2/. Administrators can change
+this by unmounting the package and remounting it at the desired URL. The
+server can be disabled or enabled via the /admin pages.
+
+
+
+The XML-RPC folks have defined a standard validation suite. These tests are
+implemented in the Automated Testing package, so admins can test their
+server against this suite (locally) by running all the automated
+tests. They can also go to http://validator.xmlrpc.com to test their site's
+validity (remotely) from there.
+
+
+
+Developer Documentation
+
+
+Adding XML-RPC support to your package
+
+
+
+The first thing you need to do is write the methods that you want to be
+available via XML-RPC. They should be defined as ad_procs just as any other
+OpenACS procs except for 2 differences.
+
+
+ -
+ They need to be able to accept arguments as sent to them
+ from xmlrpc::decode
+
+
+ In XML-RPC, every value has a datatype. Since TCL is a weakly-typed
+ language, we could care less about the datatype (for the most part). So
+ for scalar values (int, boolean, string, double, dateTime.iso8601,
+ base64), xmlrpc::decode simply sends along the value to your
+ proc. To recap, for scalar values, you need to do nothing
+ special. For the 2 complex types (structs and arrays), the
+ values are sent to your proc as TCL structures - XML-RPC structs are sent
+ TCL arrays and XML-RPC arrays are sent as TCL lists. For example, if your
+ proc expects a struct with 3 members (name, address and phone), then this
+ is how the beginning of your proc will look.
+
+
+ array set user_info $struct
+ set name $user_info(name)
+ set address $user_info(address)
+ set phone $user_info(phone)
+
+
+ Or if your proc expects an array with n integers, which it then sums,
+ then this is how your proc will look.
+
+
+ foreach num $array {
+ incr sum $num
+ }
+
+
+
+
+
+ -
+ They need to be able to return data that xmlrpc::respond
+ will be able to translate to XML.
+
+ Scalar data should be returned as a 2 item list {-datatype value}. So if
+ your proc returns an int, its last statement might be:
+
+
+
+ return [list -int $result]
+
+
+ Returning complex data structures (struct, array) is a little more *ahem*
+ complex. One of the confusing things is the terminology. As I noted
+ above, XML-RPC arrays are equivalent to TCL lists and XML-RPC structs are
+ equivalent to TCL arrays. The other confusing thing is that XML-RPC is
+ strongly typed and TCL isn't, so when you're converting from TCL to
+ XML-RPC, you need to add the datatype for each scalar value.
+
+ - Returning an array of mixed type
+
+ return [list -array [list [list -int 36] [list -string "foo"]]]
+
+
+
+ - Returning a struct (foo=22, bar=blah)
+
+ return [list -struct [list foo [list -int 22] bar [list -string blah]]]
+
+
+
+ - Returning the above struct using a TCL array
+
+ set my_struct(foo) [list -int 22]
+ set my_struct(bar) [list -string blah]
+ return [list -struct [array get my_struct]]
+
+
+
+ - Returning an array of structs
+
+ set user1(name) {-string "George Bush"}
+ set user1(id) {-int 41}
+ set user2(name) {-string "Bill Clinton"}
+ set user2(id) {-int 42}
+ return [list -array [list
+ [list -struct [array get user1]]
+ [list -struct [array get user2]]]]
+
+
+
+
+
+
+
+
+
+Once your procs are defined in packagekey/tcl/foo-procs.tcl, register them
+in packagekey/tcl/foo-init.tcl. The *-init.tcl files are loaded after all
+the *-procs.tcl files have been loaded, so xmlrpc::register_proc will be
+available if the xmlrpc package is installed. Make sure you add the xmlrpc
+package as a dependency of your package if you register any XML-RPC procs.
+If you don't want your package to depend on xmlrpc, you can test for the
+existence of the xmlrpc_procs nsv before calling xmlrpc::register_proc
+
+
+
+This registers 'system.listMethods'
+
+xmlrpc::register_proc system.listMethods
+
+
+
+
+Implementation details
+
+
+
+Here is the sequence of events in an XML-RPC call. See the documentation for each proc for more details.
+
+ - A POST request is made to your XML-RPC URL.
+ - The
xmlrpc::get_content proc grabs the content of the
+ POST request. This is a bit of a hack to cover the fact that there is
+ no ns_conn content proc.
+ xmlrpc::invoke is called to process the XML
+ request.- If the server is disabled, a fault is returned
+ - The XML is parsed for the methodName and
+ arguments.
xmlrpc::decode_value decodes the XML-RPC
+ params into TCL variables.
+ xmlrpc::invoke_method checks to be sure the method is
+ registered and then attempts to call the OpenACS procxmlrpc::invoke catches any errors from this attempt and
+ creates a XML-RPC fault to return to the client if so. If there was
+ no error, then xmlrpc::respond is called to format the
+ result as a XML-RPC response.xmlrpc::construct does the heavy work of converting the
+ TCL results back into valid XML-RPC params- Finally, if no errors occur in this process, the result is returned
+ to the client as text/xml
+
+
+
+More details are provided in the ad_proc documentation for each proc.
+
+
+
+
+XML-RPC client
+
+
+
+This package also implements a simple XML-RPC client. Any package that
+needs to make XML-RPC calls can simply add a dependency to this package and
+then call xmlrpc::remote_call. As an example, the
+system.add method sums a variable number of ints. To call the
+system.add method on http://example.com/RPC2, do this:
+
+catch {xmlrpc::remote_call http://example.com/RPC2 system.add -int 4 -int 44 -int 23} result
+set result ==> 71
+
+
+
+It's important to always catch outgoing
+XML-RPC calls. If there's an error, it will be written to the catch
+variable (result in the example above). If there's no error,
+then the return value will be in result.
+
+
+
+Implementation detail: The client needs to be able to POST
+requests to other servers. The util_httppost proc in
+acs-tcl/tcl/utilities-procs.tcl doesn't work because it doesn't let you
+specify the Content-Type, which needs to be text/xml, and it doesn't add
+Host headers, which are required if the server you're POSTing to is using
+virtual hosting. So, this package implemements its own HTTP POST proc
+(which was stolen from lars-blogger's weblogs.com XML-RPC ping).
+
+
+
+
+
+History of XML-RPC in OpenACS
+
+
+
+The first implementation of XML-RPC for AOLServer was ns_xmlrpc, whose credits
+state:
+
+ Ns_xml conversion by Dave Bauer (dave at thedesignexperience.org) with
+ help from Jerry Asher (jerry at theashergroup.com). This code is based
+ on the original Tcl-RPC by Steve Ball with contributions by Aaron
+ Swartz. The original Tcl-RPC uses TclXML and TclDOM to parse the
+ XML. It works fine but since OpenACS-4 will use ns_xml I converted it.
+
+
+
+
+I took this version and converted it into a OpenACS service package. All of
+the xml procs now use the XML abstraction procs inside acs-tcl (which
+currently use tDOM). All the procs are in a xmlrpc:: namespace and
+documentation has been added. I added support for some standard XML-RPC
+reserved procs (system.listMethods, system.methodHelp, system.multicall). I
+changed the semantics slightly in one area. XML-RPC arrays were being
+converted to TCL arrays, with the name of each item being an integer
+index. I thought it made more sense to make these TCL lists (since that is
+what a TCL list is anyways). It makes the code more consistent and makes it
+easier to understand how to deal with XML-RPC datatypes.
+
+XML-RPC struct = TCL array.
+XML-RPC array = TCL list.
+
+
+
+
+ChangeLog
+
+
+- First revision - 2003-10-13 - Vinod Kurup
+- Validation tests now implemented via automated-testing - 2003-11-01
+
+
+
+
+Vinod Kurup
+
+
\ No newline at end of file