xml-rpc-procs.tcl

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

  1. Use the xml abstraction procs in packages/acs-tcl/tcl/30-xml-utils-procs.tcl (which use tDom now)
  2. Fit in OpenACS 5 framework

Location:
packages/xml-rpc/tcl/xml-rpc-procs.tcl
Created:
2003-09-30
Author:
Vinod Kurup [vinod@kurup.com]
CVS Identification:
$Id: xml-rpc-procs.tcl,v 1.20 2024/09/11 06:15:55 gustafn Exp $

Procedures in this file

Detailed information

xmlrpc::construct (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>
    

Parameters:
context (required)
extra tags to wrap around the data
arglist (required)
datatype-value list (or more complex types as described above)
Returns:
XML formatted result

Partial Call Graph (max 5 caller/called nodes):
%3 test_xml_rpc_construct xml_rpc_construct (test xml-rpc) xmlrpc::construct xmlrpc::construct test_xml_rpc_construct->xmlrpc::construct xmlrpc::create_context xmlrpc::create_context (private) xmlrpc::construct->xmlrpc::create_context xmlrpc::remote_call xmlrpc::remote_call (public) xmlrpc::remote_call->xmlrpc::construct xmlrpc::respond xmlrpc::respond (private) xmlrpc::respond->xmlrpc::construct

Testcases:
xml_rpc_construct

xmlrpc::create_context (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"
    

Parameters:
context (required)
context to create
value (required)
character data
Returns:
string with value wrapped in context tags

Partial Call Graph (max 5 caller/called nodes):
%3 xmlrpc::construct xmlrpc::construct (private) xmlrpc::create_context xmlrpc::create_context xmlrpc::construct->xmlrpc::create_context

Testcases:
No testcase defined.

xmlrpc::decode_value (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.

Parameters:
node (required)
<value> node that we're decoding
Returns:
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.

Partial Call Graph (max 5 caller/called nodes):
%3 test_xml_rpc_decode_value xml_rpc_decode_value (test xml-rpc) xmlrpc::decode_value xmlrpc::decode_value test_xml_rpc_decode_value->xmlrpc::decode_value test_xml_rpc_fault xml_rpc_fault (test xml-rpc) test_xml_rpc_fault->xmlrpc::decode_value test_xml_rpc_respond xml_rpc_respond (test xml-rpc) test_xml_rpc_respond->xmlrpc::decode_value xml_node_get_children xml_node_get_children (public) xmlrpc::decode_value->xml_node_get_children xml_node_get_children_by_name xml_node_get_children_by_name (public) xmlrpc::decode_value->xml_node_get_children_by_name xml_node_get_content xml_node_get_content (public) xmlrpc::decode_value->xml_node_get_content xml_node_get_first_child xml_node_get_first_child (public) xmlrpc::decode_value->xml_node_get_first_child xml_node_get_name xml_node_get_name (public) xmlrpc::decode_value->xml_node_get_name xmlrpc::invoke xmlrpc::invoke (private) xmlrpc::invoke->xmlrpc::decode_value xmlrpc::parse_response xmlrpc::parse_response (private) xmlrpc::parse_response->xmlrpc::decode_value xmlrpc::test::decode_test_prep xmlrpc::test::decode_test_prep (private) xmlrpc::test::decode_test_prep->xmlrpc::decode_value

Testcases:
xml_rpc_fault, xml_rpc_decode_value, xml_rpc_respond

xmlrpc::enabled_p (public)

 xmlrpc::enabled_p
Returns:
whether the server is enabled

Partial Call Graph (max 5 caller/called nodes):
%3 packages/xml-rpc/www/admin/index.tcl packages/xml-rpc/ www/admin/index.tcl xmlrpc::enabled_p xmlrpc::enabled_p packages/xml-rpc/www/admin/index.tcl->xmlrpc::enabled_p packages/xml-rpc/www/admin/toggle.tcl packages/xml-rpc/ www/admin/toggle.tcl packages/xml-rpc/www/admin/toggle.tcl->xmlrpc::enabled_p xmlrpc::invoke xmlrpc::invoke (private) xmlrpc::invoke->xmlrpc::enabled_p parameter::get_from_package_key parameter::get_from_package_key (public) xmlrpc::enabled_p->parameter::get_from_package_key

Testcases:
No testcase defined.

xmlrpc::fault (private)

 xmlrpc::fault code msg

Format a fault response to an XML-RPC request

Parameters:
code (required)
error code (integer)
msg (required)
error message
Returns:
XML-RPC fault message

Partial Call Graph (max 5 caller/called nodes):
%3 test_xml_rpc_fault xml_rpc_fault (test xml-rpc) xmlrpc::fault xmlrpc::fault test_xml_rpc_fault->xmlrpc::fault xml_doc_free xml_doc_free (public) xmlrpc::fault->xml_doc_free xml_doc_render xml_doc_render (public) xmlrpc::fault->xml_doc_render xml_parse xml_parse (public) xmlrpc::fault->xml_parse xmlrpc::invoke xmlrpc::invoke (private) xmlrpc::invoke->xmlrpc::fault xmlrpc::parse_response xmlrpc::parse_response (private) xmlrpc::parse_response->xmlrpc::fault

Testcases:
xml_rpc_fault

xmlrpc::get_content (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.

Returns:
string - the XML request
Author:
Dave Bauer

Partial Call Graph (max 5 caller/called nodes):
%3 packages/xml-rpc/www/index.tcl packages/xml-rpc/ www/index.tcl xmlrpc::get_content xmlrpc::get_content packages/xml-rpc/www/index.tcl->xmlrpc::get_content ad_tmpnam ad_tmpnam (public) xmlrpc::get_content->ad_tmpnam

Testcases:
No testcase defined.

xmlrpc::httppost (private)

 xmlrpc::httppost [ -url url ] [ -timeout timeout ] [ -depth depth ] \
    [ -content 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.

Switches:
-url (optional)
-timeout (optional, defaults to "30")
-depth (optional, defaults to "0")
-content (optional)
Author:
Vinod Kurup

Partial Call Graph (max 5 caller/called nodes):
%3 xmlrpc::remote_call xmlrpc::remote_call (public) xmlrpc::httppost xmlrpc::httppost xmlrpc::remote_call->xmlrpc::httppost util::http::post util::http::post (public) xmlrpc::httppost->util::http::post

Testcases:
No testcase defined.

xmlrpc::invoke (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.

Parameters:
xml (required)
XML-RPC data from the client
Returns:
result encoded in XML and ready for return to the client

Partial Call Graph (max 5 caller/called nodes):
%3 packages/xml-rpc/www/index.tcl packages/xml-rpc/ www/index.tcl xmlrpc::invoke xmlrpc::invoke packages/xml-rpc/www/index.tcl->xmlrpc::invoke xml_doc_free xml_doc_free (public) xmlrpc::invoke->xml_doc_free xml_doc_get_first_node xml_doc_get_first_node (public) xmlrpc::invoke->xml_doc_get_first_node xml_node_get_children_by_name xml_node_get_children_by_name (public) xmlrpc::invoke->xml_node_get_children_by_name xml_node_get_content xml_node_get_content (public) xmlrpc::invoke->xml_node_get_content xml_node_get_first_child xml_node_get_first_child (public) xmlrpc::invoke->xml_node_get_first_child

Testcases:
No testcase defined.

xmlrpc::invoke_method (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.

Parameters:
method_name (required)
methodName from XML-RPC
arguments (required)
list of arguments
Returns:
result of the OpenACS proc
Author:
Vinod Kurup

Partial Call Graph (max 5 caller/called nodes):
%3 system.multicall system.multicall (public) xmlrpc::invoke_method xmlrpc::invoke_method system.multicall->xmlrpc::invoke_method xmlrpc::invoke xmlrpc::invoke (private) xmlrpc::invoke->xmlrpc::invoke_method

Testcases:
No testcase defined.

xmlrpc::list_methods (public)

 xmlrpc::list_methods
Returns:
alphabetical list of XML-RPC procs on this server

Partial Call Graph (max 5 caller/called nodes):
%3 packages/xml-rpc/www/admin/index.tcl packages/xml-rpc/ www/admin/index.tcl xmlrpc::list_methods xmlrpc::list_methods packages/xml-rpc/www/admin/index.tcl->xmlrpc::list_methods system.listMethods system.listMethods (public) system.listMethods->xmlrpc::list_methods

Testcases:
No testcase defined.

xmlrpc::parse_response (private)

 xmlrpc::parse_response xml

Parse the response from an XML-RPC call.

Parameters:
xml (required)
the XML response
Returns:
result

Partial Call Graph (max 5 caller/called nodes):
%3 xmlrpc::remote_call xmlrpc::remote_call (public) xmlrpc::parse_response xmlrpc::parse_response xmlrpc::remote_call->xmlrpc::parse_response xml_doc_free xml_doc_free (public) xmlrpc::parse_response->xml_doc_free xml_doc_get_first_node xml_doc_get_first_node (public) xmlrpc::parse_response->xml_doc_get_first_node xml_node_get_first_child xml_node_get_first_child (public) xmlrpc::parse_response->xml_node_get_first_child xml_node_get_name xml_node_get_name (public) xmlrpc::parse_response->xml_node_get_name xml_parse xml_parse (public) xmlrpc::parse_response->xml_parse

Testcases:
No testcase defined.

xmlrpc::register_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.

Parameters:
proc_name (required)
Name of proc to be registered.
Returns:
nothing

Partial Call Graph (max 5 caller/called nodes):
%3 packages/xml-rpc/tcl/system-init.tcl packages/xml-rpc/ tcl/system-init.tcl xmlrpc::register_proc xmlrpc::register_proc packages/xml-rpc/tcl/system-init.tcl->xmlrpc::register_proc packages/xml-rpc/tcl/validator-init.tcl packages/xml-rpc/ tcl/validator-init.tcl packages/xml-rpc/tcl/validator-init.tcl->xmlrpc::register_proc

Testcases:
No testcase defined.

xmlrpc::remote_call (public)

 xmlrpc::remote_call url method [ args ]

Invoke a method on a remote server using XML-RPC

Parameters:
url (required)
url of service
method (required)
method to call
args (optional)
list of args to the method
Returns:
the response of the remote service. Error if remote service returns a fault.

Partial Call Graph (max 5 caller/called nodes):
%3 xml_doc_free xml_doc_free (public) xml_doc_render xml_doc_render (public) xml_parse xml_parse (public) xmlrpc::construct xmlrpc::construct (private) xmlrpc::httppost xmlrpc::httppost (private) xmlrpc::remote_call xmlrpc::remote_call xmlrpc::remote_call->xml_doc_free xmlrpc::remote_call->xml_doc_render xmlrpc::remote_call->xml_parse xmlrpc::remote_call->xmlrpc::construct xmlrpc::remote_call->xmlrpc::httppost

Testcases:
No testcase defined.

xmlrpc::respond (private)

 xmlrpc::respond data

Format a success response to an XML-RPC request

Parameters:
data (required)
data to be returned to the client
Returns:
data encoded in a properly formed XML-RPC response

Partial Call Graph (max 5 caller/called nodes):
%3 test_xml_rpc_respond xml_rpc_respond (test xml-rpc) xmlrpc::respond xmlrpc::respond test_xml_rpc_respond->xmlrpc::respond xml_doc_free xml_doc_free (public) xmlrpc::respond->xml_doc_free xml_doc_render xml_doc_render (public) xmlrpc::respond->xml_doc_render xml_parse xml_parse (public) xmlrpc::respond->xml_parse xmlrpc::construct xmlrpc::construct (private) xmlrpc::respond->xmlrpc::construct xmlrpc::invoke xmlrpc::invoke (private) xmlrpc::invoke->xmlrpc::respond

Testcases:
xml_rpc_respond

xmlrpc::url (public)

 xmlrpc::url
Returns:
the URL that is listening for RPC requests
Author:
Vinod Kurup

Partial Call Graph (max 5 caller/called nodes):
%3 test_xml_rpc_validate xml_rpc_validate (test xml-rpc) xmlrpc::url xmlrpc::url test_xml_rpc_validate->xmlrpc::url apm_package_url_from_key apm_package_url_from_key (public) xmlrpc::url->apm_package_url_from_key packages/xml-rpc/www/admin/index.tcl packages/xml-rpc/ www/admin/index.tcl packages/xml-rpc/www/admin/index.tcl->xmlrpc::url

Testcases:
xml_rpc_validate
[ hide source ] | [ make this the default ]

Content File Source

# /packages/xml-rpc/tcl/xml-rpc-procs.tcl
ad_library {
    <p>
    Initially created by Dave Bauer 2001-03-30 with inspiration from
    Steve Ball and help from Aaron Swartz and Jerry Asher.
    </p>
    <p>
    Modified by Vinod Kurup to
    <ol>
    <li>Use the xml abstraction procs in
    packages/acs-tcl/tcl/30-xml-utils-procs.tcl (which use tDom now) </li>
    <li>Fit in OpenACS 5 framework </li>
    </ol>
    </p>

    @author Vinod Kurup [vinod@kurup.com]
    @creation-date 2003-09-30
    @cvs-id $Id: xml-rpc-procs.tcl,v 1.20 2024/09/11 06:15:55 gustafn 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
} {
    if {[ns_info name] eq "NaviServer"} {
        #
        # NaviServer provides a generic means to access the content,
        # independent from the spooling configuration
        #
        set text [ns_getcontent -as_file false -binary false]
    } else {

        # (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 eq ""} {
            set filename "[ad_tmpnam][clock clicks -milliseconds].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
        file delete -- $filename
    }
    return $text
}

d_proc -private xmlrpc::fault {
    code
    msg
} {
    Format a fault response to an 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 "<?xml version=\"1.0\"?>
<methodResponse>
  <fault>
    <value>
      <struct>
        <member>
          <name>faultCode</name>
          <value><i4>$code</i4></value>
        </member>
        <member>
          <name>faultString</name>
          <value><string>[ns_quotehtml $msg]</string></value>
        </member>
      </struct>
    </value>
  </fault>
</methodResponse>
"

    # 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
}

d_proc -public xmlrpc::register_proc {
    proc_name
} {
    <p>
    Register a proc to be available via XML-RPC. <code>proc_name</code> is
    the name of a proc that is defined in the usual OpenACS way (i.e. ad_proc).
    The <code>proc_name</code> 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
    <code>proc_name</code> 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 <code>proc_name</code> from 1 to 0.
    </p>

    @param proc_name Name of proc to be registered.
    @return nothing
} {
    nsv_set xmlrpc_procs $proc_name 1
}


d_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. &lt;string> or &lt;int>). If no
    subnode is present, then we should assume the value is a string.

    @param node &lt;value> node that we're decoding
    @return Returns the contents of the &lt;value> node. If the value is
    a &lt;struct> then returns the data in a TCL array. If the value is an
    &lt;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 [string trimright [xml_node_get_content $subnode] Z]]
            }

            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
}

d_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 "<?xml version=\"1.0\"?><methodResponse><params><param><value>"
    append result [xmlrpc::construct {} $data]
    append result "</value></param></params></methodResponse>"

    # 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
}

d_proc -private xmlrpc::construct {
    context
    arglist
} {
    <p>
    Construct an XML-RPC element. <code>arglist</code> is a 2-element list
    which is converted to XML. The first element of <code>arglist</code> is
    the datatype and the second element is the value.
    </p>
    Example:
    <pre>
    set arglist {-int 33}
    set result [xmlrpc::construct {} $arglist]
    set result ==> &lt;i4>33&lt;/i4>
    </pre>
    <p>
    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.
    </p>
    Array example:
    <pre>
    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 ==>  &lt;array>
                    &lt;data>
                        &lt;value>
                            &lt;i4>6682&lt;/i4>
                        &lt;/value>
                        &lt;value>
                            &lt;boolean>0&lt;/boolean>
                        &lt;/value>
                        &lt;value>
                            &lt;string>Iowa&lt;/string>
                        &lt;/value>
                        &lt;value>
                            &lt;double>8931.33333333&lt;/double>
                        &lt;/value>
                        &lt;value>
                            &lt;dateTime.iso8601>19040101T05:41:30&lt;/dateTime.iso8601>
                        &lt;/value>
                    &lt;/data>
                &lt;/array>
    </pre>
    <p>
    <code>struct</code>'s have the special format: <code>-struct {name1 {-datatype1 value1} name2 {-datatype2 value2}}</code>
    </p>
    Struct Example:
    <pre>
    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 ==>  &lt;struct>
                    &lt;member>
                        &lt;name>ctLeftAngleBrackets&lt;/name>
                        &lt;value>
                            &lt;i4>5&lt;/i4>
                        &lt;/value>
                    &lt;/member>
                    &lt;member>
                        &lt;name>ctRightAngleBrackets&lt;/name>
                        &lt;value>
                            &lt;i4>6&lt;/i4>
                        &lt;/value>
                    &lt;/member>
                    &lt;member>
                        &lt;name>ctAmpersands&lt;/name>
                        &lt;value>
                            &lt;i4>7&lt;/i4>
                        &lt;/value>
                    &lt;/member>
                    &lt;member>
                        &lt;name>ctApostrophes&lt;/name>
                        &lt;value>
                            &lt;i4>0&lt;/i4>
                        &lt;/value>
                    &lt;/member>
                    &lt;member>
                        &lt;name>ctQuotes&lt;/name>
                        &lt;value>
                            &lt;i4>3&lt;/i4>
                        &lt;/value>
                    &lt;/member>
                &lt;/struct>
    </pre>
    <p>
    The context parameter is used internally to create tags within tags.
    </p>
    Example:
    <pre>
    set arglist {-int 33}
    set result [xmlrpc::construct {foo bar} $arglist]
    set result ==> &lt;foo>&lt;bar>&lt;i4>33&lt;/i4>&lt;/bar>&lt;/foo>
    </pre>

    @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 "<string>[ns_quotehtml $arglist]</string>"
        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 "<string>[ns_quotehtml $value]</string>"
                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 "<i4>$value</i4>"
                append result [xmlrpc::create_context $context $value]
            }

            -boolean {
                set value "<boolean>[string is true $value]</boolean>"
                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 "<double>$value</double>"
                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 "<dateTime.iso8601>$datevalue</dateTime.iso8601>"
                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 "<base64>$value</base64>"
                append result [xmlrpc::create_context $context $value]
            }

            -array {
                set data "<array><data>"
                foreach datum $value {
                    append data [xmlrpc::construct value $datum]
                }
                append data "</data></array>"
                append result [xmlrpc::create_context $context $data]
            }

            -struct -
            -keyvalue {
                set data "<struct>"
                foreach {name mvalue} $value {
                    append data "<member><name>[ns_quotehtml $name]</name>"
                    append data [xmlrpc::construct value $mvalue]
                    append data "</member>"
                }
                append data "</struct>"
                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
}

d_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:
    <pre>
    xmlrpc::create_context {param value} 78
    returns ==> "<param><value>78</value></param>"
    </pre>

    @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</$child_name>"
    }

    return $result
}

d_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 "<?xml version=\"1.0\"?><methodCall><methodName>$method</methodName>"
    append call "<params>"
    if { [llength $args] } {
        append call [xmlrpc::construct {param value} $args]
    }
    append call "</params></methodCall>"
    # 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]
}

d_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 {[incr depth] > 10} {
        return -code error "xmlrpc::httppost: Recursive redirection: $url"
    }
    set req_hdrs [ns_set create]

    # headers necessary 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 r [util::http::post -body $content -url $url -headers $req_hdrs]

    set headers [dict get $r headers]
    set status [dict get $r status]

    # follow 302
    if {$status == 302} {
        set location [expr {[dict exists $headers location] ? [dict get $headers location] : ""}]
        if {$location ne ""} {
            ns_set free $headers
            close $rfd
            set page [xmlrpc::httppost -url $location \
                          -timeout $timeout -depth $depth -content $content]
        }
    }
   return [dict get $r page]
}

ad_proc -private xmlrpc::parse_response {xml} {
    Parse the response from an 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 { [xml_node_get_name $root] ne "methodResponse" } {
        set root_name [xml_node_get_name $root]
        xml_doc_free $doc
        return -code error "xmlrpc::parse_response: invalid server response - 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
}

d_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
    }

    # check that the provided XML is nonempty
    if { $xml eq "" } {
        set result [xmlrpc::fault 3 "Empty XML document passed to XML-RPC"]
        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]
        if {$params ne ""} {
            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]
            global errorInfo
            ns_log error "xmlrpc_invoke: error in xmlrpc method REQUEST: $xml RESULT: $result\n$errorInfo"
        } else {
            # success
            set result [xmlrpc::respond $result]
            ns_log debug "xmlrpc::invoke result $result"
        }
    }
    if {[info exists doc]} {
        xml_doc_free $doc
    }

    return $result
}

d_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
}

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