From ddb83b1fb2d305e0c06fc067d82d6bab5458b0fd Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Fri, 30 Oct 2009 20:52:07 +0100
Subject: Add third-party XML processing libraries.

Ignore-this: 5ca28497555bf944858ca2f58bc8a62b

darcs-hash:a0b0f9baa7c9b1259e755435db1fb17123630a6c
---
 third-party/s-xml-rpc/src/extensions.lisp | 107 ++++++++++++++++++++++++++++++
 1 file changed, 107 insertions(+)
 create mode 100644 third-party/s-xml-rpc/src/extensions.lisp

(limited to 'third-party/s-xml-rpc/src/extensions.lisp')

diff --git a/third-party/s-xml-rpc/src/extensions.lisp b/third-party/s-xml-rpc/src/extensions.lisp
new file mode 100644
index 0000000..fa961e2
--- /dev/null
+++ b/third-party/s-xml-rpc/src/extensions.lisp
@@ -0,0 +1,107 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: extensions.lisp,v 1.1 2004-06-17 19:43:11 rschlatte Exp $
+;;;;
+;;;; Extensions for xml-rpc:
+;;;;
+;;;; Server introspection:
+;;;; http://xmlrpc.usefulinc.com/doc/reserved.html
+;;;;
+;;;; Multicall:
+;;;; http://www.xmlrpc.com/discuss/msgReader$1208
+;;;;
+;;;; Capabilities:
+;;;; http://groups.yahoo.com/group/xml-rpc/message/2897
+;;;; 
+;;;;
+;;;; Copyright (C) 2004 Rudi Schlatte
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml-rpc)
+
+;;; Introspection
+
+(defun |system.listMethods| ()
+  "List the methods that are available on this server."
+  (let ((result nil))
+    (do-symbols (sym *xml-rpc-package* (sort result #'string-lessp))
+      (when (and (fboundp sym) (valid-xml-rpc-method-name-p (symbol-name sym)))
+        (push (symbol-name sym) result)))))
+
+(defun |system.methodSignature| (method-name)
+  "Dummy system.methodSignature implementation.  There's no way
+  to get (and no concept of) required argument types in Lisp, so
+  this function always returns nil or errors."
+  (let ((method (find-xml-rpc-method method-name)))
+    (if method
+        ;; http://xmlrpc.usefulinc.com/doc/sysmethodsig.html says to
+        ;; return a non-array if the signature is not available
+        "n/a"
+        (error "Method ~A not found." method-name))))
+
+(defun |system.methodHelp| (method-name)
+  "Returns the function documentation for the given method."
+  (let ((method (find-xml-rpc-method method-name)))
+    (if method
+        (or (documentation method 'function) "")
+        (error "Method ~A not found." method-name))))
+
+;;; system.multicall
+
+(defun do-one-multicall (call-struct)
+  (let ((name (get-xml-rpc-struct-member call-struct :|methodName|))
+        (params (get-xml-rpc-struct-member call-struct :|params|)))
+    (handler-bind
+        ((xml-rpc-fault
+          #'(lambda (c)
+              (format-debug (or *xml-rpc-debug-stream* t)
+                            "Call to ~A in system.multicall failed with ~a~%"
+                            name c)
+              (return-from do-one-multicall
+                (xml-literal
+                 (encode-xml-rpc-fault-value (xml-rpc-fault-string c)
+                                             (xml-rpc-fault-code c))))))
+         (error
+          #'(lambda (c)
+              (format-debug
+               (or *xml-rpc-debug-stream* t)
+               "Call to ~A in system.multicall failed with ~a~%" name c)
+              (return-from do-one-multicall
+                (xml-literal
+                 (encode-xml-rpc-fault-value
+                  ;; -32603 ---> server error. internal xml-rpc error
+                  (format nil "~a" c) -32603))))))
+      (format-debug (or *xml-rpc-debug-stream* t)
+                    "system.multicall calling ~a with ~s~%" name params)
+      (let ((result (apply *xml-rpc-call-hook* name params)))
+        (list result)))))
+
+(defun |system.multicall| (calls)
+  "Implement system.multicall; see http://www.xmlrpc.com/discuss/msgReader$1208
+  for the specification."
+  (mapcar #'do-one-multicall calls))
+
+;;; system.getCapabilities
+
+(defun |system.getCapabilities| ()
+  "Get a list of supported capabilities; see
+  http://groups.yahoo.com/group/xml-rpc/message/2897 for the
+  specification."
+  (let ((capabilities
+         '("xmlrpc" ("specUrl" "http://www.xmlrpc.com/spec"
+                     "specVersion" 1)
+           "introspect" ("specUrl" "http://xmlrpc.usefulinc.com/doc/reserved.html"
+                         "specVersion" 1)
+           "multicall" ("specUrl" "http://www.xmlrpc.com/discuss/msgReader$1208"
+                        "specVersion" 1)
+           "faults_interop" ("specUrl" "http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php"
+                             "specVersion" 20010516))))
+    (apply #'xml-rpc-struct
+           (loop for (name description) on capabilities by #'cddr
+                collecting name
+                collecting (apply #'xml-rpc-struct description)))))
+
+;;;; eof
-- 
cgit v1.2.3