Index: ns_xmlrpc/README
===================================================================
RCS file: /usr/local/cvsroot/ns_xmlrpc/README,v
diff -u -r1.1 -r1.2
--- ns_xmlrpc/README 3 Jul 2001 17:45:43 -0000 1.1
+++ ns_xmlrpc/README 11 Jul 2001 15:44:34 -0000 1.2
@@ -1 +1,42 @@
-RBM: Placeholder file for the ns_xmlrpc module. Change this later :)
+ns_xmlrpc -- adds XML-RPC server and client features to
+ AOLserver/OpenACS
+
+Requirements: ns_xml 1.3
+ AOLserver 3. using nsd8x
+ OpenACS 3.2.5
+
+Setup: Copy the Tcl files into your private Tcl library, ie. /web/yoursite/tcl
+ and start/restart AOLserver
+
+ To test the server go to http://validator.xmlrpc.com. Enter the
+ domain of your server and click the validate button. Hopefully
+ everything works. If it doesn't, check your server error log.
+
+ Call xmlrpc_register_proc with the procedure name for every Tcl
+ procedure you want to be made available via XML-RPC.
+
+How it works: A registered proc is setup in validator.tcl that sends all
+ HTTP requests to /RPC2 to the XML-RPC handler. It checks to
+ make sure the methodName is registered as available via
+ XML-RPC. If the methodName is valid the XML-RPC request is
+ parsed and the parameters are passed to the procedure.
+
+ The procedure does whatever processing is necessary and returns
+ a result to the XML-RPC handler which builds an XML-RPC
+ methodResponse and returns it.
+
+Credits: Ns_xml conversion by Dave Bauer (dave@thedesignexperience.org)
+ with help from Jerry Asher (jerry@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.
+
+Reference: XML-RPC spec: http://www.xmlrpc.com/spec
+ OpenACS: http://openacs.org
+ AOLserver: http://www.aolserver.com
+ OpenNSD: http://www.opennsd.org
+ ns_xml: http://acs-misc.sourceforge.net
+
+
+
Index: ns_xmlrpc/ns_xmlrpc.tcl
===================================================================
RCS file: /usr/local/cvsroot/ns_xmlrpc/ns_xmlrpc.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ ns_xmlrpc/ns_xmlrpc.tcl 11 Jul 2001 15:44:34 -0000 1.1
@@ -0,0 +1,541 @@
+ns_log notice "Loading ns_xml-rpc.tcl"
+
+# ns_xml-rpc 2001/03/30
+# xml-rpc server and client implementation for AOLserver/OpenNSD
+# with ns_xml module
+# Dave Bauer dave@thedesignexperience.org
+# taken from xmlrpc.tcl from Steve Ball
+
+#
+# setup nsv array to hold procs that are registered for xmlrpc
+
+nsv_array set xmlrpc_procs [list]
+
+
+# xmlrpc_register_proc
+#
+# register a proc to be available via XML-RPC
+#
+# for now you have to call xmlrpc_register_proc for every
+# proc that you want to be available
+#
+
+proc xmlrpc_register_proc {proc_name} {
+ nsv_set xmlrpc_procs $proc_name $proc_name
+}
+
+# xmlrpc_respond
+#
+# format a sucess response to a XML-RPC request
+#
+# Arguments
+# data data to be returned to the client
+#
+# Results
+# return appropriately formatted text
+#
+
+proc xmlrpc_respond {data} {
+ set response [ns_xml doc create "1.0"]
+ set doc_id [ns_xml doc new_root $response methodResponse ""]
+ set params_id [ns_xml node new_child $doc_id params ""]
+ set param_id [ns_xml node new_child $params_id param ""]
+ set value_id [ns_xml node new_child $param_id value ""]
+
+ xmlrpc_construct $value_id {} $data
+
+ set result [ns_xml doc render $response]
+ ns_xml doc free $response
+
+ return $result
+}
+
+
+# xmlrpc_fault
+# format a fault response to a XML-RPC request
+#
+# Arguments
+# code error code
+# msg error message
+#
+# Results
+# returns appropriately formatted text
+#
+
+proc xmlrpc_fault {code msg} {
+
+ set response [ns_xml doc create "1.0"]
+ set value \
+ [ns_xml node new_child \
+ [ns_xml node new_child \
+ [ns_xml doc new_root $response methodResponse ""] \
+ fault ""] value ""]
+
+ set struct [ns_xml node new_child $value struct ""]
+ set codemember [ns_xml node new_child $struct member ""]
+ ns_xml node new_child \
+ [ns_xml node new_child $codemember value ""] \
+ int $code
+ set msgmember [ns_xml node new_child $struct member ""]
+ ns_xml node new_child \
+ [ns_xml node new_child $msgmember value ""] \
+ string $msg
+
+ set result [ns_xml doc render $response]
+
+ ns_xml doc free $response
+
+ return $result
+}
+
+# xmlrpc_invoke
+#
+# the methodName element contains the Tcl procedure to evaluate
+# the parameters are passed as arguments to the global eval
+#
+# Arguments
+# xml XML-RPC data from the client
+#
+# Results
+# return value of the method is encoded ready for return to
+# the client
+#
+
+proc xmlrpc_invoke {xml} {
+
+ if {[catch {ns_xml parse $xml} doc_id]} {
+ set result [xmlrpc_fault 1 "error parsing request: $doc_id"]
+ ns_log error "xmlrpc_invoke: error parsing request: $doc_id"
+ } else {
+ set data [ns_xml doc root $doc_id]
+ set methodName \
+ [ns_xml node getcontent \
+ [lindex \
+ [ns_xml_getElementsByTagName $data methodName] 0 ]]
+
+# check that the method is registered as a valid XML-RPC method
+#
+
+ if {![nsv_exists xmlrpc_procs $methodName]} {
+ set result [xmlrpc_fault "00" "methodName does not exist"]
+ return $result
+ }
+
+ set arguments [list]
+ set params [ns_xml_getElementsByTagName $data params]
+ foreach parameter \
+ [ns_xml_getElementsByTagName $params param] {
+
+ lappend arguments \
+ [xmlrpc_decodeValue \
+ [lindex [ns_xml_getChildrenTrim $parameter] 0]]
+ }
+
+ if {[catch {uplevel #0 [list $methodName] $arguments} result]} {
+ # don't ask me what the $:: means
+ set result [xmlrpc_fault "1" $result]
+ ns_log error "xmlrpc_invoke: error in xmlrpc method $methodName $result"
+ } else {
+ set result [xmlrpc_respond $result]
+ }
+ }
+ return $result
+}
+
+
+
+# xmlrpc_createContext
+#
+# create a container element for data
+#
+# Arguments
+#
+# parent parent node
+#
+# context context to create
+#
+#
+proc xmlrpc_createContext { parent context } {
+
+ foreach child $context {
+ set parent \
+ [ns_xml node new_child $parent $child ""]
+ }
+
+ return $parent
+}
+
+# xmlrpc_callResponse
+#
+# Arguments
+# request HTTP request token
+#
+# Result
+# returns the result of the XML-RPC request
+
+proc xmlrpc_callResponse {response} {
+ # ns_log debug xmlrpc_CallResponse response \"$response\"
+ if {[catch {xmlrpc_parse $response} result]} {
+ return -code error \
+ "XMLRPC-ERROR remote procedure call failed: \"$result\""
+ }
+
+ return $result
+}
+
+# xmlrpc_call
+#
+# invoke a method on the remote server using XML-RPC
+#
+# Arguments
+# url url of service
+# method method to call
+# args args to the method
+#
+# Results
+# return the response of the service or an error if
+# the service returns a fault
+
+proc xmlrpc_call {url method args} {
+ set rpc [ns_xml doc create "1.0"]
+ set cleanup [list ns_xml doc free $rpc]
+ set call [ns_xml doc new_root $rpc methodCall ""]
+ ns_xml node new_child $call methodName $method
+
+ set params [ns_xml node new_child $call params ""]
+
+ if {[catch {
+ xmlrpc_construct $params {param value} $args
+ } errMsg]} {
+ eval $cleanup
+ return -code error $errMsg
+ }
+
+ #make the call
+ # experimental, how can we use util_httppost
+
+ if {[catch {
+ set request [ns_xml doc render $rpc]
+ # ns_log debug xmlrpc_call url $url request \"$request\"
+ util_httppost $url $request
+ } response ]} {
+ eval $cleanup
+ ns_log error xmlrpc_call url $url methodName $method error: $response
+ return -code error \
+ [list HTTP_ERROR \
+ "HTTP request failed due to \"$response\""]
+ }
+
+ eval $cleanup
+ # skip over httpoptions part...
+ # that is for the HTTP package for Tcl
+
+ return [xmlrpc_callResponse $response]
+}
+
+
+
+# xmlrpc_construct --
+#
+# Construct the XML-RPC resquest or response
+#
+# Arguments
+# node node to add child elements to
+# context how to add the data
+# arglist configuration options?
+#
+# Results
+# Nodes added to document tree. Returns unrecognized options
+#
+
+proc xmlrpc_construct { node context arglist } {
+ set unused {}
+ # consume string arguments until configuration options found
+
+ while {[llength $arglist] && \
+ ![string match -* [lindex $arglist 0]]} {
+
+ ns_xml node setcontent \
+ [xmlrpc_createContext $node $context] \
+ [lindex $arglist 0]
+ set arglist [lreplace $arglist 0 0]
+ }
+
+ # Now process configuration options
+
+ if { [llength $arglist] % 2} {
+ return -code error \
+ "no value for option \"[lindex $arglist end]\""
+ }
+
+ foreach {option value} $arglist {
+ switch -- $option {
+ -string -
+ -text {
+ ns_xml node setcontent \
+ [xmlrpc_createContext $node $context] \
+ $value
+ }
+
+ -i4 -
+ -int -
+ -integer {
+ if {![string is integer $value]} {
+ return -code error \
+ "value \"$value\" for option \"$option\" is not an integer:"
+ }
+ ns_xml node new_child \
+ [xmlrpc_createContext $node $context] \
+ i4 $value
+ }
+
+ -boolean {
+ ns_xml node new_child \
+ [xmlrpc_createContext $node $context] \
+ boolean [string is true $value]
+ }
+
+ -double {
+ if {![string is double $value]} {
+ return -code error \
+ "value \"$value\" for option \"$option\" is not a floating point value"
+ }
+ ns_xml node new_child \
+ [xmlrpc_createContext $node $context] \
+ double $value
+ }
+
+ -date {
+
+ if {[catch {
+ clock format [clock scan $value] \
+ -format {%Y%m%dT%H:%M:%S}
+ } datevalue]} {
+ return -code error \
+ "value \"$value\" for option \"$option\" is not a valid date ($datevalue)"
+ }
+
+ ns_xml node new_child \
+ [xmlrpc_createContext $node $context] \
+ "dateTime.iso8601" $datevalue
+ }
+
+ -binary -
+ -base64 {
+
+ # it is up to the application to do the
+ # encoding, I think it's built into AOLserver..
+ # anyway it should be done before the
+ # data is sent here
+
+ ns_xml node new_child \
+ [xmlrpc_createContext $node $context] \
+ base64 $value
+
+ }
+
+ -variable {
+
+ upvar 2 $value var
+ if {[array exists var]} {
+ set data nx_xml node new_child \
+ [ns_xml node new_child \
+ [xmlrpc_createContext $node $context] \
+ array "" ] data "" ]
+
+ foreach {idx entry [array get var]} {
+ nx_xml node new_child $data value $entry
+ }
+ } else {
+ ns_xml node setcontent \
+ [xmlrpc_createContext $node $context] \
+ $value
+ }
+ }
+
+ -structvariable {
+
+ upvar 2 $value var
+ set struct [ns_xml node new_child \
+ [xmlrpc_createContext $node $context] $struct ""]
+
+ foreach [idx entry] [array get var] {
+ set member \
+ [ns_xml node newchild $struct member ""]
+ ns_xml node newchild $member name $idx
+ ns_xml node newchild $member value $entry
+ }
+ }
+
+ -array {
+
+ set data \
+ [ns_xml node new_child \
+ [ns_xml node new_child \
+ [xmlrpc_createContext $node $context] \
+ array ""] \
+ data ""]
+ foreach datum $value {
+ set result [xmlrpc_construct $data value $datum]
+ if {[llength $result]} {
+ return -code error \
+ "unknown configuration option \"[lindex $result 0]\""
+ }
+ }
+ }
+
+ -struct -
+ -keyvalue {
+ set struct \
+ [ns_xml node new_child \
+ [xmlrpc_createContext $node $context] \
+ struct ""]
+ foreach {name mvalue} $value {
+ set member \
+ [ns_xml node new_child $struct member ""]
+ ns_xml node new_child $member name $name
+ set result \
+ [xmlrpc_construct $member value $mvalue]
+ if {[llength $result]} {
+ return -code error \
+ "unkown configuration option \"[lindex $result 0]\""
+ }
+ }
+ }
+
+ default {
+ #anything else will be passed back
+ lappend unused $option $value
+ }
+ }
+}
+
+return $unused
+}
+
+
+# xmlrpc_decodeValue
+# Unpack the data in a value element
+#
+# Arguments
+# node value element node
+#
+# Results
+# Returns data. If the value is a struct then returns the data
+# in name-value pairs. If the value is an array then returns
+# the data as name-value pairs where the name is an integer
+# starting with 0.
+
+proc xmlrpc_decodeValue {node} {
+
+ set result ""
+
+ if {[llength [ns_xml node children $node]] != 0} {
+
+ set nodeType [ns_xml node type [ns_xml_firstChild $node]]
+ # ns_log debug decodeValue nodeType $nodeType
+ switch -- $nodeType {
+ cdata_section {
+ set result \
+ [ns_xml node getcontent \
+ [ns_xml_firstChild $node]]
+ # ns_log debug cdata result $result
+ }
+
+ attribute {
+ set attrType [ns_xml node name \
+ [ns_xml_firstChild $node]]
+ switch -- $attrType {
+ string -
+ i4 -
+ int -
+ double -
+ boolean {
+
+ set result \
+ [ns_xml node getcontent \
+ [ns_xml_firstChild $node]]
+ }
+
+ dateTime.iso8601 {
+ set result \
+ [clock scan \
+ [ns_xml node getcontent \
+ [ns_xml_firstChild $node]]]
+ }
+
+ base64 {
+ set result \
+ [ns_xml node getcontent \
+ [ns_xml_firstChild $node]]
+ }
+
+ struct {
+ foreach member \
+ [ns_xml_getElementsByTagName \
+ [ns_xml_firstChild $node] member] {
+ lappend result \
+ [ns_xml node getcontent \
+ [ns_xml_getElementsByTagName \
+ $member name]]
+ set stuff \
+ [xmlrpc_decodeValue \
+ [ns_xml_getElementsByTagName \
+ $member value]]
+# ns_log notice "XMLRPC:stuff:$stuff"
+ lappend result $stuff
+ }
+ }
+
+ array {
+ set index 0
+
+ foreach entry \
+ [ns_xml_getChildrenTrim \
+ [ns_xml_getElementsByTagName \
+ [ns_xml_firstChild $node] data ]] {
+ lappend result [incr index]
+ lappend result \
+ [xmlrpc_decodeValue $entry]
+ }
+ }
+
+ }
+ }
+
+ default {
+ ns_log notice "XMLRPC:decode:node type not found"
+ }
+
+ }
+ }
+ return $result
+}
+
+proc xmlrpc_parse {xml} {
+
+ set doc_id [ns_xml parse $xml]
+ set response [ns_xml doc root $doc_id]
+ set top [ns_xml_firstChild $response]
+ switch -- [ns_xml node name $top] {
+ params {
+ set param [ns_xml_firstChild $top]
+ #the above should be checked: node type, tag names, etc...
+ set firstChild [ns_xml_firstChild $param]
+ set result [xmlrpc_decodeValue $firstChild]
+ }
+ fault {
+ # should do more checking here...
+ # does value/struct/member, etc, exist? and so on
+ array set fault [xmlrpc_decodeValue [ns_xml_firstChild $top]]
+ return -code error [list $fault(faultCode) $fault(faultString)]
+ }
+ default {
+ set type [ns_xml node name $response]
+ return -code error "invalid server reposnse ($type)"
+ }
+ }
+ return $result
+}
+
+ns_log notice "Done ns_xml-rpc.tcl"
Index: ns_xmlrpc/validator.tcl
===================================================================
RCS file: /usr/local/cvsroot/ns_xmlrpc/validator.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ ns_xmlrpc/validator.tcl 11 Jul 2001 15:44:34 -0000 1.1
@@ -0,0 +1,334 @@
+# XML-RPC Validation Test
+# Written by, Aaron Swartz <aaron@theinfo.org>
+# Enhanced by Jerry Asher <jerry@theashergroup.com>
+# contains:
+# xml-rpc query dispatcher (registered proc)
+# xml-rpc client validator test implementation
+# xml-rpc server validation implementation
+
+############################################################
+
+# For some reason, AOLserver doesn't have an [ns_conn content]
+# function. It looks a bit like it was taken out at the last
+# minute. I have to talk about the AOLserver people about this.
+# In the meantime, I have this hack that does the same:
+
+proc getContent {} {
+
+ # (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
+}
+
+proc xml_rpcdispatcher {} {
+ if {[ns_conn method] == "GET"} {
+ ns_return 200 text/html "XML-RPC Validator App
+ <p>This is an
+ <a href=\"http://xml-rpc.com\">XML-RPC</a> application.
+ If you want to use it, try a POST request.
+ </p>
+ "
+ } else {
+ global content
+ set content [getContent]
+ ns_return 200 text/xml [xmlrpc_invoke $content]
+ }
+}
+
+ns_register_proc GET /RPC2 xml_rpcdispatcher
+ns_register_proc POST /RPC2 xml_rpcdispatcher
+
+############################################################
+# The xml-rpc client validator procedures begin here:
+
+# Takes an array, each of whose members is a struct. Return the
+# sum of all the values named curly from each struct.
+
+proc validator1.arrayOfStructsTest {params} {
+
+ set number 0
+ foreach {ignore param} $params {
+ array set struct $param
+ set number [expr $number + $struct(curly)]
+ }
+ return [list -int $number]
+
+ # Turn the list-ified array into a normal array (bigArray)
+ array set bigArray [lindex $args 0]
+
+ set counter 1
+ set number 0
+ # Loop
+ while {[info exists bigArray($counter)]} {
+ # De-list-ify the struct:
+ array set struct $bigArray($counter)
+ # Add curly to the number count:
+ set number [expr $number + $struct(curly)]
+ # Increment the counter before going on:
+ incr counter
+ }
+ # Return the number count as an integer:
+ return [list -int $number]
+}
+
+# Takes a string.
+# Return the number of each entity in a struct.
+
+proc validator1.countTheEntities {args} {
+ # HACK: The XML-RPC parse doesn't deal with entities
+ # very well. Instead, we get things directly.
+
+ global content
+ regexp {<value>(.*)</value>} $content {} string
+ set string [util_expand_entities $string]
+
+ # NORMAL VERSION:
+ #set string $args
+
+ # For each type of entity, do a regsub -all and return the result as an integer,
+ # then place it all in a struct with the proper names and return it.
+ return \
+ [list -struct \
+ [list \
+ ctLeftAngleBrackets [list -int [regsub -all {\<} $string "" string]] \
+ ctRightAngleBrackets [list -int [regsub -all {\>} $string "" string]] \
+ ctAmpersands [list -int [regsub -all {&} $string "" string]] \
+ ctApostrophes [list -int [regsub -all {\'} $string "" string]] \
+ ctQuotes [list -int [regsub -all {\"} $string "" string]]]]
+}
+
+# Takes a struct.
+# Return the sum of the values larry, curly and moe.
+
+proc validator1.easyStructTest {struct} {
+ # De-list-ify the stuct:
+ array set bigStruct $struct
+ # Return the sum as an integer:
+ return [list -int [expr \
+ $bigStruct(moe) \
+ + $bigStruct(curly) \
+ + $bigStruct(larry)]]
+}
+
+proc validator1.echoStructTest {struct} {
+ foreach {name value} $struct {
+ if {[llength $value] > 1} {
+ # For the substructs:
+ foreach {name2 value2} $value {
+ set returnArray($name2) [list -int $value2]
+ }
+ set output($name) [list -struct [array get returnArray]]
+ } else {
+ set output($name) $value
+ }
+ array set returnArray ""
+ }
+ return [list -struct [array get output]]
+}
+
+proc validator1.manyTypesTest {
+ number boolean string double dateTime base64
+} {
+ return [list -array \
+ [list \
+ [list -int $number] \
+ [list -boolean $boolean] \
+ [list -text $string] \
+ [list -double $double] \
+ [list -date [clock format $dateTime]] \
+ [list -base64 $base64]]]
+}
+
+proc validator1.moderateSizeArrayCheck {array} {
+ array set bigArray $array
+ set counter 1
+ while {[info exists bigArray($counter)]} {
+ incr counter
+ }
+ set counter [expr $counter - 1]
+ return "-string [list "$bigArray(1)$bigArray($counter)"]"
+}
+
+proc validator1.nestedStructTest {struct} {
+ array set bigStruct $struct
+ array set 2000 $bigStruct(2000)
+ array set April $2000(04)
+ array set first $April(01)
+ return "-int [expr $first(larry) \
+ + $first(curly) + $first(moe)]"
+}
+
+proc validator1.simpleStructReturnTest {number} {
+ set struct(times10) [expr $number * 10]
+ set struct(times100) [expr $number * 100]
+ set struct(times1000) [expr $number * 1000]
+
+ return "-struct [list [array get struct]]"
+}
+
+############################################################
+# XML-RPC Server Validator
+
+proc validate1.arrayOfStructsTest {
+ {url http://www.theashergroup.com/RPC2}
+ {array ""}
+} {
+ if {[string equal "" $array]} {
+ set array [list \
+ [list -struct [list moe [list -int 1] \
+ curly [list -int 2] \
+ larry [list -int 3]]] \
+ [list -struct [list moe [list -int 1] \
+ curly [list -int 2] \
+ larry [list -int 3]]] \
+ [list -struct [list moe [list -int 1] \
+ curly [list -int 2] \
+ larry [list -int 3]]]]
+ }
+ return [xmlrpc_call $url validator1.arrayOfStructsTest -array $array]
+}
+
+proc validate1.countTheEntities {
+ {url http://www.theashergroup.com/RPC2}
+ {string {<<<>>>}}
+} {
+ set response \
+ [xmlrpc_call \
+ $url validator1.countTheEntities -string $string]
+ return $response
+}
+
+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_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_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_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}
+ {first "Now is the time for all good men "}
+ {last "to come to the aid of their country"}
+ {fluff_length 20}
+} {
+ set array [list]
+
+ lappend array [list -string $first]
+ for {set i 0} {$i < $fluff_length} {incr i} {
+ lappend array [list -string ebede]
+ }
+ lappend array [list -string $last]
+
+ return [xmlrpc_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_call $url validator1.nestedStructTest -struct $calendar]
+}
+
+proc validate1.simpleStructReturnTest {
+ {url http://www.theashergroup.com/RPC2}
+ {number 2}
+} {
+ return [xmlrpc_call $url validator1.simpleStructReturnTest -int $number]
+}
\ No newline at end of file