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
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
Author: William Joye <wjoye@cfa.harvard.edu>
Description: Add a "method" argument to xmlrpc::call
This was taken from the changes in the saods9 package.
Comment: This is an incompatible patch; however since ds9 is the major use case
for tcl-xmlrpc, I decided to apply it [olebole]
--- a/xmlrpc.tcl
+++ b/xmlrpc.tcl
@@ -217,7 +217,7 @@
# send an XML-RPC request
#
-proc xmlrpc::call {url methodName params {ntabs 4} {distance 3}} {
+proc xmlrpc::call {url method methodName params {ntabs 4} {distance 3}} {
variable READSIZE
variable response
global readdone
@@ -233,7 +233,7 @@
set sock [socket $host $port]
fconfigure $sock -translation {lf lf} -buffersize $READSIZE
fconfigure $sock -blocking off
- if {[catch {set request [buildRequest $methodName $params $ntabs $distance]}]} {
+ if {[catch {set request [buildRequest $method $methodName $params $ntabs $distance]}]} {
return
}
puts -nonewline $sock $request
@@ -276,10 +276,7 @@
set expLenl [assoc "Content-Length" $headersl]
if {$expLenl == {}} {
- set expLenl [assoc "Content-length" $headersl]
- if {$expLenl == {}} {
- return [errReturn "No Content-length found"]
- }
+ return [errReturn "No Content-length found"]
}
set expLen [lindex $expLenl 1]
set body [readBody $body $expLen $sock]
@@ -453,7 +450,7 @@
# and a list of parameters,
# return an XML-RPC request
#
-proc xmlrpc::buildRequest {methodName params {ntabs 4} {distance 2}} {
+proc xmlrpc::buildRequest {method methodName params {ntabs 4} {distance 2}} {
# build the body
set body "<?xml version=\"1.0\"?>\n"
append body "<methodCall>\n"
@@ -468,14 +465,16 @@
append body "\t\t</params>\n"
}
append body "</methodCall>\n"
+ set body [regsub -all "\n" $body "\r\n"]
set lenbod [string length $body]
# build the header
- set header "POST /RPC2 HTTP/1.0\n"
+ set header "POST /$method HTTP/1.0\n"
append header "Content-Type: text/xml\n"
append header "Content-length: $lenbod\n"
+ set header [regsub -all "\n" $header "\r\n"]
- set request "$header\n$body"
+ set request "$header\r\n$body"
return $request
}
@@ -590,7 +589,16 @@
} elseif {$btag == "struct"} {
set res [umStruct $str]
} else {
- return [errReturn "Unknown type: $str"]
+ # assume string
+ set id [string first "<" $str ]
+ if {$id != -1} {
+ set vv [string range $str 0 [expr $id-1]]
+ set rr [string range $str $id end]
+ set str "<string>${vv}</string>${rr}"
+ set res [umString $str]
+ } else {
+ return [errReturn "Unknown type: $str"]
+ }
}
set rest [lindex $res 0]
@@ -744,7 +752,7 @@
}
set RE "<name>$WS*"; # name tag
- append RE "($W+)$WS*"; # key
+ append RE "($W+?)$WS*"; # key
append RE "</name>$WS*"; # end name tag
append RE "(<value>.*)"; # value tag
@@ -784,7 +792,7 @@
proc xmlrpc::assoc {key list} {
foreach {cons} $list {
set tkey [lindex $cons 0]
- if {$key == $tkey} {
+ if {[string tolower $key] == [string tolower $tkey]} {
return $cons
}
}
|
