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