From 4f9416860bc1424c680ed486e20ed1e1bd8bb593 Mon Sep 17 00:00:00 2001 From: microdan Date: Sat, 2 Dec 2006 03:32:55 +0000 Subject: [PATCH] lisppaste, xml-rpc fix, more xml combinators --- libs/xml-rpc/example.factor | 7 ------- libs/xml-rpc/lisppaste.factor | 13 ++++++++++++ libs/xml-rpc/xml-rpc.factor | 15 +++++++++++++- libs/xml/test.factor | 5 +++++ libs/xml/utilities.factor | 39 +++++++++++++++++++++++++++++++---- libs/xml/writer.factor | 3 +++ 6 files changed, 70 insertions(+), 12 deletions(-) create mode 100644 libs/xml-rpc/lisppaste.factor diff --git a/libs/xml-rpc/example.factor b/libs/xml-rpc/example.factor index 0f4c84ee34..0223dfde69 100644 --- a/libs/xml-rpc/example.factor +++ b/libs/xml-rpc/example.factor @@ -16,13 +16,6 @@ USING: kernel hashtables xml-rpc xml calendar sequences receive-rpc dup rpc-method-name swap rpc-method-params apply-function send-rpc ; -: put-http-response ( string -- ) - "HTTP/1.1 200 OK\nConnection: close\nContent-Length: " write - dup length number>string write - "\nContent-Type: text/xml\nDate: " write - now timestamp>http-string write "\n\n" write - write ; - : respond-rpc-arith ( -- ) "raw-response" get string>xml problem>solution xml>string diff --git a/libs/xml-rpc/lisppaste.factor b/libs/xml-rpc/lisppaste.factor new file mode 100644 index 0000000000..fb8b6719f5 --- /dev/null +++ b/libs/xml-rpc/lisppaste.factor @@ -0,0 +1,13 @@ +IN: lisppaste +REQUIRES: libs/xml-rpc ; +USING: arrays kernel xml-rpc ; + +: url "http://www.common-lisp.net:8185/RPC2" ; + +: channels ( -- seq ) + { } "listchannels" url invoke-method ; + +: lisppaste ( seq -- response ) + ! seq is { channel user title contents } + ! or { channel user title contents annotation-number } + "newpaste" url invoke-method ; diff --git a/libs/xml-rpc/xml-rpc.factor b/libs/xml-rpc/xml-rpc.factor index e464539471..161d41c8b1 100644 --- a/libs/xml-rpc/xml-rpc.factor +++ b/libs/xml-rpc/xml-rpc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: xml-rpc USING: kernel xml arrays math errors errors generic http-client - hashtables namespaces io base64 sequences strings ; + hashtables namespaces io base64 sequences strings calendar ; ! * Sending RPC requests ! TODO: time @@ -111,6 +111,10 @@ TAG: struct xml>item TAG: base64 xml>item children>string base64> ; +TAG: array xml>item + first-child-tag children-tags + [ first-child-tag xml>item ] map ; + : params>array ( tag -- array ) children-tags [ first-child-tag first-child-tag xml>item ] map ; @@ -141,3 +145,12 @@ TAG: base64 xml>item >r "text/xml" swap send-rpc xml>string r> http-post 2nip string>xml receive-rpc ; +: invoke-method ( params method url -- ) + >r swap r> post-rpc ; + +: put-http-response ( string -- ) + "HTTP/1.1 200 OK\nConnection: close\nContent-Length: " write + dup length number>string write + "\nContent-Type: text/xml\nDate: " write + now timestamp>http-string write "\n\n" write + write ; diff --git a/libs/xml/test.factor b/libs/xml/test.factor index 9006f20f3c..6b82c89331 100644 --- a/libs/xml/test.factor +++ b/libs/xml/test.factor @@ -28,3 +28,8 @@ SYMBOL: xml-file "
abcd
" string>xml [ [ dup string? [ % ] [ drop ] if ] xml-each ] "" make ] unit-test +[ "foo" ] [ + "%foo;" string>xml + "c" get-id tag-children [ reference? ] find nip + reference-name +] unit-test diff --git a/libs/xml/utilities.factor b/libs/xml/utilities.factor index d27595f57d..269034a361 100644 --- a/libs/xml/utilities.factor +++ b/libs/xml/utilities.factor @@ -22,7 +22,7 @@ M: process-missing error. : PROCESS: CREATE dup H{ } clone "xtable" set-word-prop - dup literalize \ run-process 2array >quotation define-compound ; parsing + dup [ run-process ] curry define-compound ; parsing : TAG: scan scan-word [ @@ -67,7 +67,8 @@ M: object (xml-each) swap call ; M: xml-doc (xml-each) delegate (xml-each) ; -: xml-each ( tag quot -- ) swap (xml-each) ; inline +: xml-each ( tag quot -- ) ! quot: tag -- + swap (xml-each) ; inline GENERIC: (xml-map) ( quot tag -- tag ) inline M: tag (xml-map) @@ -78,10 +79,40 @@ M: object (xml-map) swap call ; M: xml-doc (xml-map) [ (xml-map) ] with-delegate ; -: xml-map ( tag quot -- tag ) swap (xml-map) ; inline +: xml-map ( tag quot -- tag ) ! quot: tag -- tag + swap (xml-map) ; inline -: xml-subset ( quot tag -- seq ) +: xml-subset ( quot tag -- seq ) ! quot: tag -- ? V{ } clone rot [ swap >r [ swap call ] 2keep rot r> swap [ [ push ] keep ] [ nip ] if ] xml-each nip ; + +GENERIC: (xml-find) ( quot tag -- tag ) inline +M: tag (xml-find) + [ swap call ] 2keep rot [ + tag-children f swap + [ nip over >r (xml-find) r> swap dup ] find + 2drop ! leaves result of quot + ] unless nip ; +M: object (xml-find) + [ swap call ] keep f ? ; +M: xml-doc (xml-find) + delegate (xml-find) ; +: xml-find ( tag quot -- tag ) ! quot: tag -- ? + swap (xml-find) ; inline + +: prop-name ( name-tag tag -- seq/f ) + #! gets the property with the name-tag string specified + tag-props [ + hash-keys [ name-tag over = ] find + ] keep hash 2nip ; + +: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) + swap [ + dup any-tag? [ + "id" swap prop-name + [ string? ] subset concat + over = + ] [ drop f ] if + ] xml-find nip ; diff --git a/libs/xml/writer.factor b/libs/xml/writer.factor index 4ac3216c6f..e558b9e57a 100644 --- a/libs/xml/writer.factor +++ b/libs/xml/writer.factor @@ -73,6 +73,9 @@ M: instruction (xml>string) dup delegate (xml>string) xml-doc-after [ (xml>string) ] each ; +: print-xml ( xml-doc -- ) + write-xml terpri ; + : xml>string ( xml-doc -- string ) [ write-xml ] string-out ;