diff options
Diffstat (limited to 'third-party/s-xml-rpc/test')
| -rw-r--r-- | third-party/s-xml-rpc/test/all-tests.lisp | 17 | ||||
| -rw-r--r-- | third-party/s-xml-rpc/test/test-base64.lisp | 123 | ||||
| -rw-r--r-- | third-party/s-xml-rpc/test/test-extensions.lisp | 53 | ||||
| -rw-r--r-- | third-party/s-xml-rpc/test/test-xml-rpc.lisp | 176 | ||||
| -rw-r--r-- | third-party/s-xml-rpc/test/test.b64 | 1 |
5 files changed, 370 insertions, 0 deletions
diff --git a/third-party/s-xml-rpc/test/all-tests.lisp b/third-party/s-xml-rpc/test/all-tests.lisp new file mode 100644 index 0000000..3b24e2a --- /dev/null +++ b/third-party/s-xml-rpc/test/all-tests.lisp @@ -0,0 +1,17 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: all-tests.lisp,v 1.2 2004-06-17 19:43:11 rschlatte Exp $ +;;;; +;;;; Load and execute all unit and functional tests +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; 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. + +(load (merge-pathnames "test-base64" *load-pathname*) :verbose t) +(load (merge-pathnames "test-xml-rpc" *load-pathname*) :verbose t) +(load (merge-pathnames "test-extensions" *load-pathname*) :verbose t) + +;;;; eof diff --git a/third-party/s-xml-rpc/test/test-base64.lisp b/third-party/s-xml-rpc/test/test-base64.lisp new file mode 100644 index 0000000..c263788 --- /dev/null +++ b/third-party/s-xml-rpc/test/test-base64.lisp @@ -0,0 +1,123 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: test-base64.lisp,v 1.1.1.1 2004-06-09 09:02:41 scaekenberghe Exp $ +;;;; +;;;; Unit and functional tests for base64.lisp +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; 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-base64) + +(assert + (equal (multiple-value-list (core-encode-base64 0 0 0)) + (list #\A #\A #\A #\A))) + +(assert + (equal (multiple-value-list (core-encode-base64 255 255 255)) + (list #\/ #\/ #\/ #\/))) + +(assert + (equal (multiple-value-list (core-encode-base64 1 2 3)) + (list #\A #\Q #\I #\D))) + +(assert + (equal (multiple-value-list (core-encode-base64 10 20 30)) + (list #\C #\h #\Q #\e))) + +(assert + (equal (multiple-value-list (core-decode-base64 #\A #\A #\A #\A)) + (list 0 0 0))) + +(assert + (equal (multiple-value-list (core-decode-base64 #\/ #\/ #\/ #\/)) + (list 255 255 255))) + +(assert + (equal (multiple-value-list (core-decode-base64 #\A #\Q #\I #\D)) + (list 1 2 3))) + +(assert + (equal (multiple-value-list (core-decode-base64 #\C #\h #\Q #\e)) + (list 10 20 30))) + +(assert + (let* ((string "Hello World!") + (bytes (map 'vector #'char-code string)) + encoded + decoded) + (setf encoded (with-output-to-string (out) + (encode-base64-bytes bytes out))) + (setf decoded (with-input-from-string (in encoded) + (decode-base64-bytes in))) + (equal string + (map 'string #'code-char decoded)))) + +;;; this is more of a functional test + +(defun same-character-file (file1 file2) + (with-open-file (a file1 :direction :input) + (with-open-file (b file2 :direction :input) + (loop + (let ((char-a (read-char a nil nil nil)) + (char-b (read-char b nil nil nil))) + (cond ((not (or (and (null char-a) (null char-b)) + (and char-a char-b))) + (return-from same-character-file nil)) + ((null char-a) + (return-from same-character-file t)) + ((char/= char-a char-b) + (return-from same-character-file nil)))))))) + +(defun same-binary-file (file1 file2) + (with-open-file (a file1 :direction :input :element-type 'unsigned-byte) + (with-open-file (b file2 :direction :input :element-type 'unsigned-byte) + (loop + (let ((byte-a (read-byte a nil nil)) + (byte-b (read-byte b nil nil))) + (cond ((not (or (and (null byte-a) (null byte-b)) + (and byte-a byte-b))) + (return-from same-binary-file nil)) + ((null byte-a) + (return-from same-binary-file t)) + ((/= byte-a byte-b) + (return-from same-binary-file nil)))))))) + +(let ((original (merge-pathnames "test.b64" *load-pathname*)) + (first-gif (merge-pathnames "test.gif" *load-pathname*)) + (b64 (merge-pathnames "test2.b64" *load-pathname*)) + (second-gif (merge-pathnames "test2.gif" *load-pathname*))) + (with-open-file (in original + :direction :input) + (with-open-file (out first-gif + :direction :output + :element-type 'unsigned-byte + :if-does-not-exist :create + :if-exists :supersede) + (decode-base64 in out))) + (with-open-file (in first-gif + :direction :input + :element-type 'unsigned-byte) + (with-open-file (out b64 + :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (encode-base64 in out nil))) + (assert (same-character-file original b64)) + (with-open-file (in b64 + :direction :input) + (with-open-file (out second-gif + :direction :output + :element-type 'unsigned-byte + :if-does-not-exist :create + :if-exists :supersede) + (decode-base64 in out))) + (assert (same-binary-file first-gif second-gif)) + (delete-file first-gif) + (delete-file b64) + (delete-file second-gif)) + +;;;; eof
\ No newline at end of file diff --git a/third-party/s-xml-rpc/test/test-extensions.lisp b/third-party/s-xml-rpc/test/test-extensions.lisp new file mode 100644 index 0000000..a3e3eb0 --- /dev/null +++ b/third-party/s-xml-rpc/test/test-extensions.lisp @@ -0,0 +1,53 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: test-extensions.lisp,v 1.2 2006-04-19 10:22:31 scaekenberghe Exp $ +;;;; +;;;; Unit and functional tests for xml-rpc.lisp +;;;; +;;;; 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) + +(let* ((server-port 8080) + (server-process (start-xml-rpc-server :port server-port)) + (server-args `(:port ,server-port)) + (*xml-rpc-package* (make-package (gensym))) + (symbols '(|system.listMethods| |system.methodSignature| + |system.methodHelp| |system.multicall| + |system.getCapabilities|))) + (import symbols *xml-rpc-package*) + (sleep 1) ; give the server some time to come up ;-) + (unwind-protect + (progn + (assert + (equal (sort (call-xml-rpc-server server-args "system.listMethods") + #'string<) + (sort (mapcar #'string symbols) #'string<))) + (assert + (every #'string= + (mapcar (lambda (name) + (call-xml-rpc-server server-args "system.methodHelp" + name)) + symbols) + (mapcar (lambda (name) + (or (documentation name 'function) "")) + symbols))) + (assert + (= 2 + (length (call-xml-rpc-server + server-args "system.multicall" + (list + (xml-rpc-struct "methodName" + "system.listMethods") + (xml-rpc-struct "methodName" + "system.methodHelp" + "params" + (list "system.multicall")))))))) + (s-sysdeps:kill-process server-process) + (delete-package *xml-rpc-package*))) + +;;;; eof
\ No newline at end of file diff --git a/third-party/s-xml-rpc/test/test-xml-rpc.lisp b/third-party/s-xml-rpc/test/test-xml-rpc.lisp new file mode 100644 index 0000000..3933a88 --- /dev/null +++ b/third-party/s-xml-rpc/test/test-xml-rpc.lisp @@ -0,0 +1,176 @@ +;;;; -*- mode: lisp -*- +;;;; +;;;; $Id: test-xml-rpc.lisp,v 1.4 2008-02-15 15:42:40 scaekenberghe Exp $ +;;;; +;;;; Unit and functional tests for xml-rpc.lisp +;;;; +;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. +;;;; +;;;; 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) + +(assert + (let ((now (get-universal-time))) + (equal (iso8601->universal-time (universal-time->iso8601 now)) + now))) + +(assert + (equal (with-input-from-string (in (encode-xml-rpc-call "add" 1 2)) + (decode-xml-rpc in)) + '("add" 1 2))) + +(assert + (equal (with-input-from-string (in (encode-xml-rpc-result '(1 2))) + (car (decode-xml-rpc in))) + '(1 2))) + +(let ((condition (with-input-from-string (in (encode-xml-rpc-fault "Fatal Error" 100)) + (decode-xml-rpc in)))) + (assert (typep condition 'xml-rpc-fault)) + (assert (equal (xml-rpc-fault-string condition) "Fatal Error")) + (assert (equal (xml-rpc-fault-code condition) 100))) + +(assert + (xml-rpc-time-p (xml-rpc-call (encode-xml-rpc-call "currentTime.getCurrentTime") + :host "time.xmlrpc.com"))) + +(assert + (equal (xml-rpc-call (encode-xml-rpc-call "examples.getStateName" 41) + :host "betty.userland.com") + "South Dakota")) + +(assert + (equal (call-xml-rpc-server '(:host "betty.userland.com") "examples.getStateName" 41) + "South Dakota")) + +#-clisp +(assert + (let ((server-process (start-xml-rpc-server :port 8080))) + (import 's-xml-rpc::xml-rpc-implementation-version :s-xml-rpc-exports) + (sleep 1) ; give the server some time to come up ;-) + (unwind-protect + (equal (xml-rpc-call (encode-xml-rpc-call "XML-RPC-IMPLEMENTATION-VERSION") :port 8080) + (xml-rpc-implementation-version)) + (s-sysdeps:kill-process server-process) + (unintern 's-xml-rpc::xml-rpc-implementation-version :s-xml-rpc-exports)))) + +(assert + (let* ((struct-in (xml-rpc-struct :foo 100 :bar "")) + (xml (with-output-to-string (out) + (encode-xml-rpc-value struct-in out))) + (struct-out (with-input-from-string (in xml) + (decode-xml-rpc in)))) + (xml-rpc-struct-equal struct-in struct-out))) + +;; testing whitespace handling + +(assert (null (decode-xml-rpc (make-string-input-stream +"<array> + <data> + </data> +</array>")))) + +(assert (equalp (decode-xml-rpc (make-string-input-stream +"<params> + <param> + <value> + foo + </value> + </param> + <param> + <value> + <array> + <data> + <value><i4>12</i4></value> + <value><string>Egypt</string></value> + <value><boolean>1</boolean></value> + <value> <string> </string> </value> + <value> </value> + <value> fgo </value> + <value><i4>-31</i4></value> + <value></value> + <double> -12.214 </double> + <dateTime.iso8601> + 19980717T14:08:55 </dateTime.iso8601> + <base64>eW91IGNhbid0IHJlYWQgdGhpcyE=</base64> + </data> + </array> + </value> + </param> +</params>")) +`(" + foo + " + (12 + "Egypt" + T + " " + " " + " fgo " + -31 + "" + -12.214D0 + ,(xml-rpc-time (iso8601->universal-time "19980717T14:08:55")) + #(121 111 117 32 99 97 110 39 116 32 114 101 97 100 32 116 104 105 115 33))))) + +(assert (equalp (decode-xml-rpc (make-string-input-stream +"<array> + <data> + <value></value> + </data> +</array>")) +'(""))) + +(assert (equalp (decode-xml-rpc (make-string-input-stream +"<array> + <data> + <value> + <string>XYZ</string> + </value> + </data> +</array>")) +'("XYZ"))) + +;; double decoding + +(assert (< (abs (- (decode-xml-rpc (make-string-input-stream "<value><double>3.141592653589793</double></value>")) + pi)) + 0.000000000001D0)) + +;; string decoding + +(assert (equal (decode-xml-rpc (make-string-input-stream "<value><string>foo</string></value>")) + "foo")) + +(assert (equal (decode-xml-rpc (make-string-input-stream "<value>foo</value>")) + "foo")) + +(assert (equal (decode-xml-rpc (make-string-input-stream "<value><string></string></value>")) + "")) + +(assert (equal (decode-xml-rpc (make-string-input-stream "<value></value>")) + "")) + +;; boolean encoding + +(assert (equal (with-output-to-string (out) + (encode-xml-rpc-value t out)) + "<value><boolean>1</boolean></value>")) + +(assert (equal (with-output-to-string (out) + (encode-xml-rpc-value nil out)) + "<value><boolean>0</boolean></value>")) + + +;; boolean decoding + +(assert (equal (decode-xml-rpc (make-string-input-stream "<value><boolean>1</boolean></value>")) + t)) + +(assert (equal (decode-xml-rpc (make-string-input-stream "<value><boolean>0</boolean></value>")) + nil)) + +;;;; eof diff --git a/third-party/s-xml-rpc/test/test.b64 b/third-party/s-xml-rpc/test/test.b64 new file mode 100644 index 0000000..55445dd --- /dev/null +++ b/third-party/s-xml-rpc/test/test.b64 @@ -0,0 +1 @@ +R0lGODlhNABYAMQAAP////vi5etreuM0SN8ZL+dOYPCIk+56hPi/xPGapPjP1N4EGvHr9PSstMzI6riw4IY+kHsie3lvyVtMu0Y4tN3b8Y+CzX1ast2ftskNNNBdfqGb2so0WeHL4E8spLA0aiH5BAAAAAAALAAAAAA0AFgAQAX/ICCOZGmeaKqeBUEc5WAATbECQnCfyiAWsFIBgfMJFoTOYcAQERYN0SK4KxEUp4FPC/ABXN/oKOCtmh0OxGPj+UAgHmKhIZiZHJLJhMKXNKsMFQAMFnp6EogWFxEWOAsCgw4VfyN5IhKNABMPZhAUe3yhoYiYFmsWiISYlCoMeaJ8ehR5hoektLCjEhCcJGgQqSkKC1BmxscBxEQkBAlOxSMDCzY/ZQAICyPEOwnbCgXgcyQCBeQFWCIHVDXhJN/hkMc0DR0iA80oPXbyI+Vd6CO+RdOxjAWVYz367bPXzciVHjKwGCAwg4AOfiUOEBgg4ICAe08WYCFgQ0aKBtaM/xWSEMuQKA+1WHrIhYpCJgB4KDzYA4BPFQejLAgdSvSB0QoOHgCT4GAEKqSfUuT8ZIHVCAYbWOaaQErSiqoYw4oVkWxBwRETt41RW2KBNWluq5QteCAbiQJxSRATQIDVRisLnJmQ5sLi2MNhP24cUIDxRcRjCAsG0HgHnbEaFRAwAURExxsJHh8jB2CJiQZBOALokHIEgXiqjQks3frcFyRdcKfzonGBaGMDxFzTIgDBMBd4GVN7sQSdAWpiuZQIsJHkCwNQqKOgCBmF2wZu5xj4XUL4MUJcMTlowmANhAgXhGoIIMA5NUKwQIWCcANNIkEMMPDBAWgUmAEGIgwDQ/97u2ByCQVNTdCIBRTssEEfVpUWjwgMpIHKTQCg0oQnguhhBgObPCBBLys4gIoEJVTA0gSCGIPUegBolV8tomwSVgUTiEBhehZsgMB6AZ4Q4JJLcjhIh1ntAeMITamw0ycSbDDJHx0aRdSLuPSIyQM1rnAEMcRc0R0/c7EADUppLgRAAoRtuE0ABvBF3lpmlTCMI9A5shkz1vB1G0AqtNkPEoWx9cwMGllRWEitmTCMSAlCw4ymAFxaz6KWOuqmnGuWaqqpHQTw6almbmSAAqoG8M0AB3XXA0mC/bWCbYjxNQ0JdHY6WQoJZDgaYymhJEICgaKQg1hXgDMYOuKooMD/hvJQx4BmlsYT7GyWGoZRcJRhm44z3HaaFzOD4mXeDglRVitlWMjgghYgJaCZuE8gWkW86ZJgxCOA0iBtp1royk8Zmi1UGAAT4WmSZwREYUClZhzQ7MX3MDqFri4kIK7BY12cxRW+4dNCuSaQNpYW74KHhALgbXawpQP4ixGzWoiD3UZ9HkAqCUKfysA9zx1AJznvrlkBmCuu10AGCFSgDg5Y0CFaIbLAAuIJF86CyAZGbWDKAxwcoEACFbzhgZEWwHEBV0H5oSNLX5eAipSkcDWBB3MjsocHeUhwwQdEoFgmABX4ZCJLrSylCwQfoFHB5RpwIAJ4BehIwQY49tTI/wMVArDTDu1JKRSL2GBBXdMkFNIE5JpMeQOKNYl9i+CFk9KLJIQ0gUpTURmTR+67J5/IA2iQQEhOthvjgH5crT7UUrZsMMIDNa04Vt9i75Ee+KNUiRF6sTDFIfU8toTIWUqm0PgmE5i/QpLyXGh/Ja/4AQHUsciFAGExEzGBhUOIMEF7JDfAUMykgFv5RB/CZ4sHGAsFeABFTJSXvCKFjlUgnA5cMBbCUPXpBBtCQB3yNCwa1OFqIkAADK5lgAOsygQdUMYJiPGWX5mgLo/BRmACooIcnpAZvjLPE2rVjVUxoGKiSoER4beysrQFU2TBohNgUBcSkmCK7piCAS62LlR12QUAC1hIC8aIHU6hAIzaGNYThtWNzbwGWGc04w0uVRAwhDGPufFhplqYnBUIMQB4WiKiREYMG2pjUJ0607A60MaJneBnJayCbjK5HR5y8pNiCQEAOw==
\ No newline at end of file |