lisppaste, xml-rpc fix, more xml combinators

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 <rpc-response> 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

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 ;

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> <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 <rpc-method> 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 ;

libs/xml/test.factor

@@ -28,3 +28,8 @@ SYMBOL: xml-file
     "<main>a<sub>bc</sub>d<nothing/></main>" string>xml
     [ [ dup string? [ % ] [ drop ] if ] xml-each ] "" make
 ] unit-test
+[ "foo" ] [
+    "<a><b id='c'>%foo;</b><d id='e'/></a>" string>xml
+    "c" get-id tag-children [ reference? ] find nip
+    reference-name
+] unit-test

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 ;

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 ;