summaryrefslogtreecommitdiff
path: root/third-party/s-xml-rpc/test
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2009-10-30 20:52:07 +0100
committerMatthias Benkard <code@mail.matthias.benkard.de>2009-10-30 20:52:07 +0100
commitddb83b1fb2d305e0c06fc067d82d6bab5458b0fd (patch)
tree8f9003926f0b5295c7a04b2ca257c0a2155ce841 /third-party/s-xml-rpc/test
parent15937a1a4f1cf40bc55aa34eb71c67b88466ff57 (diff)
Add third-party XML processing libraries.
Ignore-this: 5ca28497555bf944858ca2f58bc8a62b darcs-hash:a0b0f9baa7c9b1259e755435db1fb17123630a6c
Diffstat (limited to 'third-party/s-xml-rpc/test')
-rw-r--r--third-party/s-xml-rpc/test/all-tests.lisp17
-rw-r--r--third-party/s-xml-rpc/test/test-base64.lisp123
-rw-r--r--third-party/s-xml-rpc/test/test-extensions.lisp53
-rw-r--r--third-party/s-xml-rpc/test/test-xml-rpc.lisp176
-rw-r--r--third-party/s-xml-rpc/test/test.b641
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