1 (defpackage :rfc2388.test
 2   (:use :common-lisp))
 3 
 4 (in-package :rfc2388.test)
 5 
 6 (defconstant +crlf+ (format nil "~C~C" #\return #\linefeed))
 7 
 8 
 9 (defun generate-test-strings (parts)
10   (flet ((prepend (left list)
11            (mapcar (lambda (right)
12                      (format nil "~A~A" left right))
13                    list))
14          (postpend (right list)
15            (mapcar (lambda (left)
16                      (format nil "~A~A" left right))
17                    list)))
18     (cond ((null parts)
19            nil)
20           ((null (cdr parts))
21            (list (format nil "~A" (first parts))))
22           (t
23            (list* (format nil "~A" (first parts))
24                   (nconc (prepend (first parts) (rest parts))
25                          (postpend (first parts) (rest parts))
26                          (generate-test-strings (cdr parts))))))))
27 
28 
29 (defparameter *strings* (generate-test-strings `("X" " " "-" "--" "---" ,+crlf+ #\return #\linefeed)))
30 (defparameter *boundaries* '("x" "-x" "--x"))
31 
32 
33 (defun sanitize-test-string (string)
34   (with-output-to-string (out)
35     (loop for char across string
36        do (case char
37             (#\return   (write-string "[CR]" out))
38             (#\linefeed (write-string "[LF]" out))
39             (t (write-char char out))))))
40 
41 
42 (defun test-string (string &optional (boundary "boundary"))
43   (with-input-from-string (stream string)
44     (handler-bind ((simple-warning (lambda (condition)
45                                      (declare (ignore condition))
46                                      (format t "~&Testing: ~S (boundary ~S)~%"
47                                              (sanitize-test-string string)
48                                              boundary))))
49       (rfc2388::read-until-next-boundary stream boundary))))
50 
51 
52 (defun test ()
53   (declare (optimize debug))
54   (flet ((last-char (string)
55            (declare (type simple-string string))
56            (schar string (1- (length string))))
57 
58          (test (test expected boundary)
59            (multiple-value-bind (result more-p)
60                (test-string test boundary)
61              (unless (or (string= result expected)
62                          more-p)
63                (format t "~%String:   ~S (Boundary: ~S)~%Expected: ~S~%Got:      ~S~%More: ~S~%"
64                        (sanitize-test-string test)
65                        boundary
66                        (sanitize-test-string expected)
67                        (sanitize-test-string result)
68                        more-p)
69           (finish-output t)))))
70 
71     (dolist (string *strings*)
72       (dolist (boundary *boundaries*)
73         (dolist (trailing-separator '("--" ""))
74           (test (concatenate 'string string +crlf+ "--" boundary trailing-separator +crlf+)
75                 string
76                 boundary)
77           (unless (char= #\- (last-char string))
78             (test (concatenate 'string string "--" boundary trailing-separator +crlf+)
79                   (let ((end (- (length string) 2)))
80                     (if (and (<= 0 end)
81                              (string= string +crlf+ :start1 end))
82                         (subseq string 0 end)
83                         string))
84                   boundary))))))
85   t)