xml-rpc-test-procs.tcl

Publicity: Public Only All

xml-rpc-test-procs.tcl

Test the XML-RPC interface

Location:

packages/xml-rpc/tcl/test/xml-rpc-test-procs.tcl
Created:

Sat Oct 25 10:49:55 2003
Author:

Vinod Kurup [vinod@kurup.com]
CVS Identification:

$Id: xml-rpc-test-procs.tcl,v 1.9 2021/02/19 15:29:59 hectorr Exp $

Procedures in this file

_xml-rpc__xml_rpc_construct (private)
_xml-rpc__xml_rpc_decode_value (private)
_xml-rpc__xml_rpc_fault (private)
_xml-rpc__xml_rpc_mounted (private)
_xml-rpc__xml_rpc_respond (private)
_xml-rpc__xml_rpc_validate (private)
xmlrpc::test::decode_test_prep (private)

Detailed information

_xml-rpc__xml_rpc_construct (private)

 _xml-rpc__xml_rpc_construct

Partial Call Graph (max 5 caller/called nodes):

Testcases:
No testcase defined.

_xml-rpc__xml_rpc_decode_value (private)

 _xml-rpc__xml_rpc_decode_value

Partial Call Graph (max 5 caller/called nodes):

Testcases:
No testcase defined.

_xml-rpc__xml_rpc_fault (private)

 _xml-rpc__xml_rpc_fault

Partial Call Graph (max 5 caller/called nodes):

Testcases:
No testcase defined.

_xml-rpc__xml_rpc_mounted (private)

 _xml-rpc__xml_rpc_mounted

Partial Call Graph (max 5 caller/called nodes):

Testcases:
No testcase defined.

_xml-rpc__xml_rpc_respond (private)

 _xml-rpc__xml_rpc_respond

Partial Call Graph (max 5 caller/called nodes):

Testcases:
No testcase defined.

_xml-rpc__xml_rpc_validate (private)

 _xml-rpc__xml_rpc_validate

Partial Call Graph (max 5 caller/called nodes):

Testcases:
No testcase defined.

xmlrpc::test::decode_test_prep (private)

 xmlrpc::test::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

Parameters:

value (required)

Partial Call Graph (max 5 caller/called nodes):

Testcases:
No testcase defined.

[ hide source ] | [ make this the default ]

Content File Source

# /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.9 2021/02/19 15:29:59 hectorr 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" {[xmlrpc::url] eq ""}
    }
}

aa_register_case \
    -cats script \
    -procs {
        xmlrpc::fault
        xmlrpc::decode_value
        xml_parse
        xml_node_get_first_child
        xml_doc_get_first_node
        xml_doc_free
    } \
    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
    }
}

namespace eval xmlrpc::test {}

ad_proc -private xmlrpc::test::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 \
    -procs {
        xml_parse
        xmlrpc::decode_value
    } \
    xml_rpc_decode_value {
        Test xmlrpc::decode_value to be sure it decodes properly
} {
    aa_run_with_teardown -rollback -test_code {
        set result [xmlrpc::test::decode_test_prep "<string>a string</string>"]
        aa_equals "string test" $result "a string"

        set result [xmlrpc::test::decode_test_prep "- a naked string"]
        aa_equals "naked string test" $result "- a naked string"

        set result [xmlrpc::test::decode_test_prep "<int>22</int>"]
        aa_equals "int test" $result 22

        set result [xmlrpc::test::decode_test_prep "<int>33</int>"]
        aa_equals "i4 test" $result 33

        set result [xmlrpc::test::decode_test_prep "<double>3.1415</double>"]
        aa_equals "double test" $result 3.1415

        set result [xmlrpc::test::decode_test_prep "<boolean>1</boolean>"]
        aa_equals "boolean test 1" $result 1

        set result [xmlrpc::test::decode_test_prep "<boolean>f</boolean>"]
        aa_equals "boolean test 2" $result 0

        set result [xmlrpc::test::decode_test_prep "<dateTime.iso8601>20030821T083122</dateTime.iso8601>"]
        aa_equals "date test" $result 1061469082


        unset result
        array set result [xmlrpc::test::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::test::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::test::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 \
    -procs {
        xmlrpc::respond
        xmlrpc::decode_value
        xml_parse
        xml_node_get_first_child
        xml_doc_get_first_node
        xml_doc_free
    } \
    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 \
    -procs xmlrpc::construct \
    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 construction" $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 {
    api
    web
} -procs {
    xmlrpc::url
} 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 994247430 R0lGODlhFgASAJEAAP/////OnM7O/wAAACH5BAEAAAAALAAAAAAWABIAAAJAhI+py40zDIzujEDBzW0n74AaFGChqZUYylyYq7ILXJJ1BU95l6r23RrRYhyL5jiJAT/Ink8WTPoqHx31im0UAAA7} \
             moderateSizeArrayCheck {WisconsinNew York} \
             nestedStructTest 7 \
             simpleStructReturnTest {times1000 2000 times100 200 times10 20}
        ]

    set url [ad_url]
    if {$url eq ""} {
        set url [util_current_location]
    }
    set url $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
        }
    }
}

# Local variables:
#    mode: tcl
#    tcl-indent-level: 4
#    indent-tabs-mode: nil
# End: