picolisp

Unnamed repository; edit this file to name it for gitweb.
git clone https://logand.com/git/picolisp.git/
Log | Files | Refs | README | LICENSE

xmlrpc.l (2873B)

      1 # 31jul13abu
      2 # (c) Software Lab. Alexander Burger
      3 
      4 # (xmlrpc "localhost" 8080 "foo.bar" 'int 41 'string "abc" ..)
      5 (de xmlrpc (Host Port Meth . @)
      6    (let? Sock (connect Host Port)
      7       (let Xml (tmp 'xmlrpc)
      8          (out Xml
      9             (xml? T)
     10             (xml
     11                (list 'methodCall NIL
     12                   (list 'methodName NIL Meth)
     13                   (make
     14                      (link 'params NIL)
     15                      (while (args)
     16                         (link
     17                            (list 'param NIL
     18                               (list 'value NIL (list (next) NIL (next))) ) ) ) ) ) ) )
     19          (prog1
     20             (out Sock
     21                (prinl "POST /RPC2 HTTP/1.0^M")
     22                (prinl "Host: " Host "^M")
     23                (prinl "User-Agent: PicoLisp^M")
     24                (prinl "Content-Type: text/xml^M")
     25                (prinl "Accept-Charset: utf-8^M")
     26                (prinl "Content-Length: " (car (info Xml)) "^M")
     27                (prinl "^M")
     28                (in Xml (echo))
     29                (flush)
     30                (in Sock
     31                   (while (line))
     32                   (let? L (and (xml?) (xml))
     33                      (when (== 'methodResponse (car L))
     34                         (xmlrpcValue
     35                            (car (body L 'params 'param 'value)) ) ) ) ) )
     36             (close Sock) ) ) ) )
     37 
     38 (de xmlrpcKey (Str)
     39    (or (format Str) (intern Str)) )
     40 
     41 (de xmlrpcValue (Lst)
     42    (let X (caddr Lst)
     43       (casq (car Lst)
     44          (string X)
     45          ((i4 int) (format X))
     46          (boolean (= "1" X))
     47          (double (format X *Scl))
     48          (array
     49             (when (== 'data (car X))
     50                (mapcar
     51                   '((L)
     52                      (and (== 'value (car L)) (xmlrpcValue (caddr L))) )
     53                   (cddr X) ) ) )
     54          (struct
     55             (extract
     56                '((L)
     57                   (when (== 'member (car L))
     58                      (cons
     59                         (xmlrpcKey (caddr (assoc 'name L)))
     60                         (xmlrpcValue (caddr (assoc 'value L))) ) ) )
     61                (cddr Lst) ) ) ) ) )
     62 
     63 # SSL transactions
     64 # By meingbg <meingbg@gmail.com>
     65 (de xmlrpcssl (Url Meth . @)
     66    (let Xml (tmp "xmlrpcssl")
     67       (out Xml
     68          (xml? T)
     69          (xml
     70             (list 'methodCall NIL
     71                (list 'methodName NIL Meth)
     72                (make
     73                   (link 'params NIL)
     74                   (while (args)
     75                      (link
     76                         (list 'param NIL
     77                            (list 'value NIL (list (next) NIL (next))) ) ) ) ) ) ) )
     78       (in (list "wget" "--no-http-keep-alive" "--no-check-certificate" (pack "--post-file=" Xml) "-O" "-" "-o" "/dev/null" Url)
     79          (let? L (and (xml?) (xml))
     80             (when (== 'methodResponse (car L))
     81                (xmlrpcValue
     82                   (car (body L 'params 'param 'value)) ) ) ) ) ) )
     83 
     84 # vi:et:ts=3:sw=3