steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Use xml.interpolate for xml-rpc

db4
Daniel Ehrenberg 2009-01-26 16:48:14 -06:00
parent 02b09fdca4
commit dd553440dc
2 changed files with 39 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
basis/xml-rpc/xml-rpc.factor
View File

@ -3,7 +3,7 @@
USING: accessors kernel xml arrays math generic http.client USING: accessors kernel xml arrays math generic http.client
combinators hashtables namespaces io base64 sequences strings combinators hashtables namespaces io base64 sequences strings
calendar xml.data xml.writer xml.utilities assocs math.parser calendar xml.data xml.writer xml.utilities assocs math.parser
debugger calendar.format math.order ; debugger calendar.format math.order xml.interpolate ;
IN: xml-rpc IN: xml-rpc
! * Sending RPC requests ! * Sending RPC requests
@ -15,56 +15,70 @@ GENERIC: item>xml ( object -- xml )
M: integer item>xml M: integer item>xml
dup 31 2^ neg 31 2^ 1 - between? dup 31 2^ neg 31 2^ 1 - between?
[ "Integers must fit in 32 bits" throw ] unless [ "Integers must fit in 32 bits" throw ] unless
number>string "i4" build-tag ; number>string [XML <i4><-></i4> XML] ;
UNION: boolean t POSTPONE: f ; UNION: boolean t POSTPONE: f ;
M: boolean item>xml M: boolean item>xml
"1" "0" ? "boolean" build-tag ; "1" "0" ? [XML <boolean><-></boolean> XML] ;
M: float item>xml M: float item>xml
number>string "double" build-tag ; number>string [XML <double><-></double> XML] ;
M: string item>xml ! This should change < and & M: string item>xml
"string" build-tag ; [XML <string><-></string> XML] ;
: struct-member ( name value -- tag ) : struct-member ( name value -- tag )
swap dup string? over string? [ "Struct member name must be string" throw ] unless
[ "Struct member name must be string" throw ] unless item>xml
"name" build-tag swap [XML
item>xml "value" build-tag <member>
2array "member" build-tag* ; <name><-></name>
<value><-></value>
</member>
XML] ;
M: hashtable item>xml M: hashtable item>xml
[ struct-member ] { } assoc>map [ struct-member ] { } assoc>map
"struct" build-tag* ; [XML <struct><-></struct> XML] ;
M: array item>xml M: array item>xml
[ item>xml "value" build-tag ] map [ item>xml [XML <value><-></value> XML] ] map
"data" build-tag* "array" build-tag ; [XML <array><data><-></data></array> XML] ;
TUPLE: base64 string ; TUPLE: base64 string ;
C: <base64> base64 C: <base64> base64
M: base64 item>xml M: base64 item>xml
string>> >base64 "base64" build-tag ; string>> >base64
[XML <base64><-></base64> XML] ;
: params ( seq -- xml ) : params ( seq -- xml )
[ item>xml "value" build-tag "param" build-tag ] map [ item>xml [XML <param><value><-></value></param> XML] ] map
"params" build-tag* ; [XML <params><-></params> XML] ;
: method-call ( name seq -- xml ) : method-call ( name seq -- xml )
params [ "methodName" build-tag ] dip params
2array "methodCall" build-tag* build-xml ; <XML
<methodCall>
<methodName><-></methodName>
<->
</methodCall>
XML> ;
: return-params ( seq -- xml ) : return-params ( seq -- xml )
params "methodResponse" build-tag build-xml ; params <XML <methodResponse><-></methodResponse> XML> ;
: return-fault ( fault-code fault-string -- xml ) : return-fault ( fault-code fault-string -- xml )
[ "faultString" set "faultCode" set ] H{ } make-assoc item>xml [ "faultString" set "faultCode" set ] H{ } make-assoc item>xml
"value" build-tag "fault" build-tag "methodResponse" build-tag <XML
build-xml ; <methodResponse>
<fault>
<value><-></value>
</fault>
</methodResponse>
XML> ;
TUPLE: rpc-method name params ; TUPLE: rpc-method name params ;

5
basis/xml/interpolate/interpolate.factor
View File

@ -3,7 +3,7 @@
USING: xml xml.state kernel sequences fry assocs xml.data USING: xml xml.state kernel sequences fry assocs xml.data
accessors strings make multiline parser namespaces macros accessors strings make multiline parser namespaces macros
sequences.deep generalizations locals words combinators sequences.deep generalizations locals words combinators
math present ; math present arrays ;
IN: xml.interpolate IN: xml.interpolate
<PRIVATE <PRIVATE
@ -31,7 +31,8 @@ DEFER: interpolate-sequence
GENERIC: push-item ( item -- ) GENERIC: push-item ( item -- )
M: string push-item , ; M: string push-item , ;
M: object push-item , ; M: object push-item , ;
M: sequence push-item % ; M: sequence push-item
[ dup array? [ % ] [ , ] if ] each ;
GENERIC: interpolate-item ( table item -- ) GENERIC: interpolate-item ( table item -- )
M: object interpolate-item nip , ; M: object interpolate-item nip , ;