-
Notifications
You must be signed in to change notification settings - Fork 0
/
xmlrpc.tcl
75 lines (66 loc) · 2.11 KB
/
xmlrpc.tcl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
# Based on XMLRPC package from TclSOAP
# XMLRPC.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net>
# Copyright (C) 2008 Andreas Kupries <andreask@activestate.com>
package require tdom
namespace eval ::XMLRPC {
}
# Description:
# Prepare an XML-RPC fault response
# Parameters:
# faultcode the XML-RPC fault code (numeric)
# faultstring summary of the fault
# detail list of {detailName detailInfo}
# Result:
# Returns the XML text of the generated fault response
#
proc ::XMLRPC::fault {faultcode faultstring {detail {}}} {
set xml [join [list \
"<?xml version=\"1.0\" ?>" \
"<methodResponse>" \
" <fault>" \
" <value>" \
" <struct>" \
" <member>" \
" <name>faultCode</name>"\
" <value><int>${faultcode}</int></value>" \
" </member>" \
" <member>" \
" <name>faultString</name>"\
" <value><string>${faultstring}</string></value>" \
" </member>" \
" </struct> "\
" </value>" \
" </fault>" \
"</methodResponse>"] "\n"]
return $xml
}
# -------------------------------------------------------------------------
# Description:
# Generate a reply packet for a simple reply containing one result element
# Parameters:
# result the reply data
# Result:
# Returns the XML text of the generated reply packet
#
proc ::XMLRPC::reply {result} {
set xml [join [list \
"<?xml version=\"1.0\" ?>" \
"<methodResponse>" \
" <params>" \
" <param>" \
" <value><string>${result}</string></value>" \
" </param>" \
" </params>" \
"</methodResponse>"] "\n"]
return $xml
}
proc ::XMLRPC::parsequery {xml} {
set doc [dom parse $xml]
set method [[$doc selectNodes /methodCall/methodName] asText]
set params [lmap param [$doc selectNodes {/methodCall/params/param/value/string}] {
$param asText
}]
$doc delete
return [list $method $params]
}
package provide xmlrpc 0.0