Initial Import

tcl/system-init.tcl

+# /packages/xml-rpc/tcl/system-init.tcl
+ad_library {
+     Register standard system procs
+     @author Vinod Kurup [vinod@kurup.com]
+     @creation-date Thu Oct  9 22:21:14 2003
+     @cvs-id $Id$
+}
+
+xmlrpc::register_proc system.listMethods
+xmlrpc::register_proc system.methodHelp
+xmlrpc::register_proc system.multicall
+xmlrpc::register_proc system.add

tcl/system-procs.tcl

+# /packages/xml-rpc/tcl/system-procs.tcl
+ad_library {
+    Standard reserved nmethods
+    http://xmlrpc.usefulinc.com/doc/reserved.html
+
+    @author Vinod Kurup [vinod@kurup.com]
+    @creation-date Thu Oct  9 22:14:04 2003
+    @cvs-id $Id$
+}
+
+ad_proc -public system.listMethods {} {
+    Enumerate the methods implemented by the XML-RPC server.
+
+    The system.listMethods method requires no parameters. 
+
+    @return an array of strings, each of which is the name of a method 
+    implemented by the server.
+    @author Vinod Kurup
+} {
+    set result [list]
+    foreach proc_name [xmlrpc::list_methods] {
+        lappend result [list -string $proc_name]
+    }
+
+    return [list -array $result]
+}
+
+# system.methodSignature not implemented because we don't keep track of 
+# parameter types or return types
+
+ad_proc -public system.methodHelp {
+    methodName
+} {    
+    This method takes one parameter, the name of a method implemented by 
+    the XML-RPC server.
+
+    @param methodName method implemented in XML-RPC
+    @return a documentation string describing the use of that method. 
+    If no such string is available, an empty string is returned. The 
+    documentation string may contain HTML markup.
+    @author Vinod Kurup
+} {
+    return [list -string [api_proc_documentation $methodName]]
+}
+
+ad_proc -public system.multicall {
+    array
+} {
+    <p>
+    Perform multiple requests in one call - see 
+    http://www.xmlrpc.com/discuss/msgReader$1208
+    </p>
+
+    <p>
+    Takes an array of XML-RPC calls encoded as structs of the form (in a 
+    Pythonish notation here):
+    <pre>
+    {'methodName': string, 'params': array}
+    </pre>
+    </p>
+    @param array  array of structs containing XML-RPC calls
+    @return an array of responses. There will be one response for each call 
+    in the original array. The result will either be a one-item array 
+    containing the result value - this mirrors the use of &lt;params> in 
+    &lt;methodResponse> - or a struct of the form found inside the 
+    standard &lt;fault> element.
+    @author Vinod Kurup
+} {
+    set responses [list]
+
+    foreach call $array {
+        # parse the call for methodName and params
+        if { [catch {
+            array unset c
+            array set c $call
+            set method $c(methodName)
+            set params $c(params) 
+        } errmsg ] } {
+            # if we can't get a methodName and params, then fault
+            lappend responses [list -struct \
+                                   [list faultCode [list -int 5] \
+                                        faultString "Invalid request. $errmsg"
+                                   ]]
+        } else {
+            # call the method
+            set errno [catch {xmlrpc::invoke_method $method $params} result]
+            if { $errno } {
+                # fault
+                lappend responses [list -struct \
+                                       [list faultCode [list -int $errno] \
+                                            faultString $result]]
+            } else {
+                lappend responses $result
+            }
+        }
+    }
+    return [list -array $responses]
+}
+
+ad_proc -public system.add {
+    args
+} {
+    Simple test function.
+    Add a variable number of integers.
+
+    @param args variable number of integers
+    @return integer sum
+} {
+    set sum 0
+    foreach value $args {
+        incr sum $value
+    }
+    return [list -int $sum]
+}

tcl/test/xml-rpc-test-procs.tcl

+# /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$
+}
+
+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 <b>html</b> 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 &lt;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>$value</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 "<string>a string</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 "<int>22</int>"]
+        aa_equals "int test" $result 22
+
+        set result [xmlrpc_decode_test_prep "<int>33</int>"]
+        aa_equals "i4 test" $result 33
+
+        set result [xmlrpc_decode_test_prep "<double>3.1415</double>"]
+        aa_equals "double test" $result 3.1415
+
+        set result [xmlrpc_decode_test_prep "<boolean>1</boolean>"]
+        aa_equals "boolean test 1" $result 1
+
+        set result [xmlrpc_decode_test_prep "<boolean>f</boolean>"]
+        aa_equals "boolean test 2" $result 0
+
+        set result [xmlrpc_decode_test_prep "<dateTime.iso8601>20030821T083122</dateTime.iso8601>"]
+        aa_equals "date test" $result 1061469082
+
+
+        unset result
+        array set result [xmlrpc_decode_test_prep "<struct><member><name>id</name><value><int>19</int></value></member><member><name>content</name><value><string>My content</string></value></member></struct>"]
+        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 "<array><data><value>phrase 1</value><value>2nd phrase</value><value>final phrase</value></data></array>"]
+        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 "<array><data><value>phrase 1</value><value><struct><member><name>sublist</name><value><array><data><value>Got it!</value></data></array></value></member></struct></value></data></array>"]
+        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 "<i4>33</i4>"
+
+        # 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 "<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 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 "<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>"
+    }
+
+    # test context parameter
+    set arglist {-int 33}
+    set result [xmlrpc::construct "foo bar" $arglist]
+    aa_equals "context test" $result "<foo><bar><i4>33</i4></bar></foo>"
+
+}
+
+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
+        }
+    }
+}

tcl/validator-init.tcl

+# /packages/xml-rpc/tcl/validator-init.tcl
+ad_library {
+     Register validator XML-RPC procs
+     @author Vinod Kurup [vinod@kurup.com]
+     @creation-date Fri Oct  3 19:25:19 2003
+     @cvs-id $Id$
+}
+
+xmlrpc::register_proc validator1.arrayOfStructsTest
+xmlrpc::register_proc validator1.countTheEntities
+xmlrpc::register_proc validator1.easyStructTest
+xmlrpc::register_proc validator1.echoStructTest
+xmlrpc::register_proc validator1.manyTypesTest
+xmlrpc::register_proc validator1.moderateSizeArrayCheck
+xmlrpc::register_proc validator1.nestedStructTest
+xmlrpc::register_proc validator1.simpleStructReturnTest
+ 

www/admin/index.adp

+<master>
+<property name="title">XML-RPC Administration</property>
+
+<table>
+<tr>
+  <th>XML-RPC URL:</th> 
+  <td>@rpc_url@ </td>
+</tr>
+
+<tr>
+  <th>Status: </th> 
+  <td>
+    <a href="toggle"><if @server_enabled_p@>Enabled</if><else>Disabled</else></a>
+  </td>
+</tr>
+
+</table>
+
+<p>
+The following procedures are registered:
+</p>
+
+<table>
+<tr>
+<th>Proc Name</th> <th>Enabled?</th>
+</tr>
+
+<multiple name="rpc_procs">
+  <tr>
+    <td>@rpc_procs.name;noquote@</td> <td>@rpc_procs.enabled_p@</td>
+  </tr>
+</multiple>
+</table>

www/admin/index.tcl

+# /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$
+} {
+} -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
+}

www/admin/toggle.tcl

+# /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$
+} {
+}
+
+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

www/index.adp

+<master>
+
+<p>
+This is the URL from which XML-RPC Requests will be handled.
+</p>
+
+<p>
+Perhaps you want the <a href="admin">Admin Pages</a> or the <a
+href="doc">Documentation</a>.
+</p>

www/index.tcl

+# /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$
+} {
+}
+
+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

xml-rpc.info

+<?xml version="1.0"?>
+<!-- Generated by the OpenACS Package Manager -->
+
+<package key="xml-rpc" url="http://openacs.org/repository/apm/packages/xml-rpc" type="apm_service">
+    <package-name>XML-RPC Server</package-name>
+    <pretty-plural>XML-RPC Server</pretty-plural>
+    <initial-install-p>f</initial-install-p>
+    <singleton-p>t</singleton-p>
+    <auto-mount>RPC2</auto-mount>
+
+    <version name="0.2" url="http://openacs.org/repository/download/apm/xml-rpc-0.2.apm">
+        <owner url="mailto:vinod@kurup.com">Vinod Kurup</owner>
+        <summary>A simple XML-RPC server.</summary>
+        <release-date>2003-10-09</release-date>
+        <vendor url="http://kurup.org">Vinod Kurup</vendor>
+        <description format="text/plain">This package implements a simple XML-RPC server. It receives XML-RPC calls, decodes the XML and then calls the requested method on the OpenACS server. Code is based on ns_xmlrpc, but now uses tDOM.</description>
+
+        <provides url="xml-rpc" version="0.2"/>
+        <requires url="acs-kernel" version="5.0d2"/>
+
+        <callbacks>
+        </callbacks>
+        <parameters>
+            <parameter datatype="number"  min_n_values="1"  max_n_values="1"  name="EnableXMLRPCServer"  default="1" description="Turn your XML-RPC Server On (1) or Off (0)"/>
+        </parameters>
+
+    </version>
+</package>