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

Tweak XML-RPC

db4
Slava Pestov 2008-08-29 04:33:05 -05:00
parent 6ead724b25
commit c9df16e931
2 changed files with 7 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg ! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel xml arrays math generic http.client combinators USING: accessors kernel xml arrays math generic http.client
hashtables namespaces io base64 sequences strings calendar combinators hashtables namespaces io base64 sequences strings
xml.data xml.writer xml.utilities assocs math.parser debugger calendar xml.data xml.writer xml.utilities assocs math.parser
calendar.format math.order ; debugger calendar.format math.order ;
IN: xml-rpc IN: xml-rpc
! * Sending RPC requests ! * Sending RPC requests
@ -17,7 +17,7 @@ M: integer item>xml
[ "Integers must fit in 32 bits" throw ] unless [ "Integers must fit in 32 bits" throw ] unless
number>string "i4" build-tag ; number>string "i4" build-tag ;
PREDICATE: boolean < object { t f } member? ; UNION: boolean t POSTPONE: f ;
M: boolean item>xml M: boolean item>xml
"1" "0" ? "boolean" build-tag ; "1" "0" ? "boolean" build-tag ;
@ -147,10 +147,10 @@ TAG: array xml>item
xml>item [ "faultCode" get "faultString" get ] bind ; xml>item [ "faultCode" get "faultString" get ] bind ;
: receive-rpc ( xml -- rpc ) : receive-rpc ( xml -- rpc )
dup name-tag dup "methodCall" = dup main>> dup "methodCall" =
[ drop parse-method <rpc-method> ] [ [ drop parse-method <rpc-method> ] [
"methodResponse" = [ "methodResponse" = [
dup first-child-tag name-tag "fault" = dup first-child-tag main>> "fault" =
[ parse-fault <rpc-fault> ] [ parse-fault <rpc-fault> ]
[ parse-rpc-response <rpc-response> ] if [ parse-rpc-response <rpc-response> ] if
] [ "Bad main tag name" server-error ] if ] [ "Bad main tag name" server-error ] if

11
core/generic/standard/standard-tests.factor
View File

@ -317,14 +317,3 @@ M: xref-tuple-2 xref-test (xref-test) ;
[ t ] [ [ t ] [
\ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
] unit-test ] unit-test
GENERIC: wide-predicate-bug ( obj -- n )
PREDICATE: b-predicate < object { { } } member? ;
M: b-predicate wide-predicate-bug drop 0 ;
M: array wide-predicate-bug drop 1 ;
[ 0 ] [ { } wide-predicate-bug ] unit-test
[ 1 ] [ { 1 } wide-predicate-bug ] unit-test