[s-xml-rpc-cvs] CVS update: s-xml-rpc/src/xml-rpc.lisp s-xml-rpc/src/package.lisp
Rudi Schlatte
rschlatte at common-lisp.net
Sun Jun 13 16:12:04 UTC 2004
Update of /project/s-xml-rpc/cvsroot/s-xml-rpc/src
In directory common-lisp.net:/tmp/cvs-serv8306/src
Modified Files:
xml-rpc.lisp package.lisp
Log Message:
Implement system.multicall
Date: Sun Jun 13 09:12:04 2004
Author: rschlatte
Index: s-xml-rpc/src/xml-rpc.lisp
diff -u s-xml-rpc/src/xml-rpc.lisp:1.2 s-xml-rpc/src/xml-rpc.lisp:1.3
--- s-xml-rpc/src/xml-rpc.lisp:1.2 Sun Jun 13 07:14:47 2004
+++ s-xml-rpc/src/xml-rpc.lisp Sun Jun 13 09:12:03 2004
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: xml-rpc.lisp,v 1.2 2004/06/13 14:14:47 rschlatte Exp $
+;;;; $Id: xml-rpc.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $
;;;;
;;;; This is a Common Lisp implementation of the XML-RPC protocol,
;;;; as documented on the website http://www.xmlrpc.com
@@ -97,6 +97,29 @@
"Create a new XML-RPC-TIME struct with the universal time specified, defaulting to now"
(make-xml-rpc-time :universal-time universal-time))
+;;; a wrapper for literal strings, where escaping #\< and #\& is not
+;;; desired
+
+(defstruct (xml-literal (:print-function print-xml-literal))
+ "A wrapper around a Common Lisp string that will be sent over
+ the wire unescaped"
+ content)
+
+(setf (documentation 'xml-literal-p 'function)
+ "Return T when the argument is an unescaped xml string"
+ (documentation 'xml-literal-content 'function)
+ "Return the content of a literal xml string")
+
+(defun print-xml-literal (xml-literal stream depth)
+ (declare (ignore depth))
+ (format stream
+ "#<XML-LITERAL \"~a\" >"
+ (xml-literal-content xml-literal)))
+
+(defun xml-literal (content)
+ "Create a new XML-LITERAL struct with the specified content."
+ (make-xml-literal :content content))
+
;;; an extra datatype for xml-rpc structures (associative maps)
(defstruct (xml-rpc-struct (:print-function print-xml-rpc-struct))
@@ -186,6 +209,8 @@
(princ "<dateTime.iso8601>" stream)
(universal-time->iso8601 (xml-rpc-time-universal-time arg) stream)
(princ "</dateTime.iso8601>" stream))
+ ((xml-literal-p arg)
+ (princ (xml-literal-content arg) stream))
((or (listp arg) (vectorp arg)) (encode-xml-rpc-array arg stream))
((xml-rpc-struct-p arg) (encode-xml-rpc-struct arg stream))
;; add generic method call
@@ -218,14 +243,21 @@
(encode-xml-rpc-args (list value) stream)
(princ "</methodResponse>" stream)))
-(defun encode-xml-rpc-fault (fault-string &optional (fault-code 0))
+(defun encode-xml-rpc-fault-value (fault-string &optional (fault-code 0))
+ ;; for system.multicall
(with-output-to-string (stream)
- (princ "<methodResponse><fault><value><struct>" stream)
+ (princ "<struct>" stream)
(format stream "<member><name>faultCode</name><value><int>~d</int></value></member>" fault-code)
(princ "<member><name>faultString</name><value><string>" stream)
(print-string-xml fault-string stream)
(princ "</string></value></member>" stream)
- (princ "</struct></value></fault></methodResponse>" stream)))
+ (princ "</struct>" stream)))
+
+(defun encode-xml-rpc-fault (fault-string &optional (fault-code 0))
+ (with-output-to-string (stream)
+ (princ "<methodResponse><fault><value>" stream)
+ (princ (encode-xml-rpc-fault-value fault-string fault-code) stream)
+ (princ "</value></fault></methodResponse>" stream)))
;;; decoding support
@@ -290,10 +322,10 @@
(lisp-implementation-version))
"String specifying the default XML-RPC agent to include in server responses")
-(defparameter *xml-rpc-debug* nil
+(defvar *xml-rpc-debug* nil
"When T the XML-RPC client and server part will be more verbose about their protocol")
-(defparameter *xml-rpc-debug-stream* nil
+(defvar *xml-rpc-debug-stream* nil
"When not nil it specifies where debugging output should be written to")
(defparameter *xml-rpc-proxy-host* nil
@@ -407,6 +439,9 @@
;;; server API
+(defvar *xml-rpc-call-hook* 'execute-xml-rpc-call
+ "A function to execute the xml-rpc call and return the result, accepting a method-name string and a optional argument list")
+
(defparameter +xml-rpc-method-characters+
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_.:/")
@@ -438,7 +473,7 @@
(if method
;; http://xmlrpc.usefulinc.com/doc/sysmethodsig.html says to
;; return a non-array if the signature is not available
- nil
+ "n/a"
(error "Method ~A not found." method-name))))
(defun |system.methodHelp| (method-name)
@@ -448,6 +483,27 @@
(or (documentation method 'function) "")
(error "Method ~A not found." method-name))))
+(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
+ ((error #'(lambda (c)
+ (format-debug
+ (or *xml-rpc-debug-stream* t)
+ "A call in a system.multicall failed with ~a~%" c)
+ (return-from do-one-multicall
+ (xml-literal
+ (encode-xml-rpc-fault-value (format nil "~a" c)))))))
+ (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))
+
(defun execute-xml-rpc-call (method-name &rest arguments)
"Execute method METHOD-NAME on ARGUMENTS, or raise an error if
no such method exists in *XML-RPC-PACKAGE*"
@@ -456,9 +512,6 @@
(apply method arguments)
(error "Method ~A not found." method-name))))
-(defvar *xml-rpc-call-hook* 'execute-xml-rpc-call
- "A function to execute the xml-rpc call and return the result, accepting a method-name string and a optional argument list")
-
(defun handle-xml-rpc-call (in id)
"Handle an actual call, reading XML from in and returning the
XML-encoded result."
@@ -477,7 +530,7 @@
(defun xml-rpc-implementation-version ()
"Identify ourselves"
(concatenate 'string
- "$Id: xml-rpc.lisp,v 1.2 2004/06/13 14:14:47 rschlatte Exp $"
+ "$Id: xml-rpc.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $"
" "
(lisp-implementation-type)
" "
Index: s-xml-rpc/src/package.lisp
diff -u s-xml-rpc/src/package.lisp:1.2 s-xml-rpc/src/package.lisp:1.3
--- s-xml-rpc/src/package.lisp:1.2 Sun Jun 13 07:14:47 2004
+++ s-xml-rpc/src/package.lisp Sun Jun 13 09:12:03 2004
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: package.lisp,v 1.2 2004/06/13 14:14:47 rschlatte Exp $
+;;;; $Id: package.lisp,v 1.3 2004/06/13 16:12:03 rschlatte Exp $
;;;;
;;;; S-XML-RPC package definition
;;;;
@@ -35,13 +35,14 @@
#:*xml-rpc-debug* #:*xml-rpc-debug-stream*
#:*xml-rpc-package* #:*xml-rpc-call-hook*
#:execute-xml-rpc-call #:stop-server
- #:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp|)
+ #:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp|
+ #:|system.multicall|)
(:documentation "An implementation of the standard XML-RPC protocol for both client and server"))
(defpackage s-xml-rpc-exports
(:use)
(:import-from :s-xml-rpc #:|system.listMethods| #:|system.methodSignature|
- #:|system.methodHelp|)
+ #:|system.methodHelp| #:|system.multicall|)
(:documentation "This package contains the functions callable via xml-rpc."))
;;;; eof
More information about the S-xml-rpc-cvs
mailing list