[rfc2388-cvs] CVS update: rfc2388/test.lisp rfc2388/rfc2388.lisp
Janis Dzerins
jdzerins at common-lisp.net
Tue Aug 2 08:46:04 UTC 2005
Update of /project/rfc2388/cvsroot/rfc2388
In directory common-lisp.net:/tmp/cvs-serv19543
Modified Files:
rfc2388.lisp
Added Files:
test.lisp
Log Message:
Did a bad job with the release 1.0. Reverted back the mess I did, and added the test code.
Date: Tue Aug 2 10:46:03 2005
Author: jdzerins
Index: rfc2388/rfc2388.lisp
diff -u rfc2388/rfc2388.lisp:1.7 rfc2388/rfc2388.lisp:1.8
--- rfc2388/rfc2388.lisp:1.7 Mon Aug 1 18:58:01 2005
+++ rfc2388/rfc2388.lisp Tue Aug 2 10:46:00 2005
@@ -50,8 +50,10 @@
(let ((length (length boundary)))
(unless (<= 1 length 70)
(warn "Boundary has invalid length -- must be between 1 and 70, but is: ~S" length))
- (when (lwsp-char-p (schar boundary (1- length)))
- (warn "Boundary has trailing whitespace: ~S" boundary)))
+ (let ((last-char (schar boundary (1- length))))
+ (when (or (char= last-char #\space)
+ (char= last-char #\tab))
+ (warn "Boundary has trailing whitespace: ~S" boundary))))
(flet ((run (result)
"This one writes everything up to a boundary to RESULT stream,
@@ -62,7 +64,6 @@
(boundary-length (length boundary))
(closed nil)
(queued-chars (make-string 4))
- (queued-dashes 0)
(queue-index 0)
char
(leave-char nil))
@@ -71,12 +72,7 @@
(dotimes (i queue-index)
(write-char (schar queued-chars i) result))
(setf queue-index 0))
-
- (write-dashes ()
- (dotimes (i queued-dashes)
- (write-char #\- result))
- (setf queued-dashes 0))
-
+
(enqueue-char ()
(setf (schar queued-chars queue-index) char)
(incf queue-index)))
@@ -91,9 +87,9 @@
(setq closed t)
(return))
- #-(and)
- (format t "~&S:~D QI:~D BI:~2,'0D CH:~:[~;*~]~S~%"
- state queue-index boundary-index leave-char char)
+ #-(and)
+ (format t "~&S:~D BI:~2,'0D CH:~:[~;*~]~S~%"
+ state boundary-index leave-char char)
(case state
(1 ;; optional starting CR
@@ -115,16 +111,21 @@
(setq leave-char t
state 1))))
- (3 ;; dashes
+ (3 ;; first dash in dash-boundary
+ (cond ((char= char #\-)
+ (enqueue-char)
+ (setq state 4))
+ (t
+ (write-queued-chars)
+ (setq leave-char t
+ state 1))))
+
+ (4 ;; second dash in dash-boundary
(cond ((char= char #\-)
- (incf queued-dashes))
-
- ((<= 2 queued-dashes)
- (setf leave-char t
- state 5))
+ (enqueue-char)
+ (setq state 5))
(t
(write-queued-chars)
- (write-dashes)
(setq leave-char t
state 1))))
@@ -132,14 +133,9 @@
(cond ((char= char (schar boundary boundary-index))
(incf boundary-index)
(when (= boundary-index boundary-length)
- (decf queued-dashes 2)
- (unless (zerop queued-dashes)
- (write-queued-chars)
- (write-dashes))
(setq state 6)))
(t
(write-queued-chars)
- (write-dashes)
(write-sequence boundary result :end boundary-index)
(setq boundary-index 0
leave-char t
@@ -377,7 +373,7 @@
(defstruct (content-type (:type list)
- (:constructor make-content-type (super sub)))
+ (:constructor make-content-type (super sub)))
super
sub)
@@ -385,25 +381,25 @@
(defun parse-content-type (string)
"Returns content-type which is parsed from STRING."
(let ((sep-offset (position #\/ string))
- (type (array-element-type string)))
+ (type (array-element-type string)))
(if (numberp sep-offset)
- (make-content-type (make-array sep-offset
- :element-type type
- :displaced-to string)
- (make-array (- (length string) (incf sep-offset))
- :element-type type
- :displaced-to string
- :displaced-index-offset sep-offset))
- (make-content-type string nil))))
+ (make-content-type (make-array sep-offset
+ :element-type type
+ :displaced-to string)
+ (make-array (- (length string) (incf sep-offset))
+ :element-type type
+ :displaced-to string
+ :displaced-index-offset sep-offset))
+ (make-content-type string nil))))
(defun unparse-content-type (ct)
"Returns content-type CT in string representation."
(let ((super (content-type-super ct))
- (sub (content-type-sub ct)))
+ (sub (content-type-sub ct)))
(cond ((and super sub)
- (concatenate 'string super "/" sub))
- (t (or super "")))))
+ (concatenate 'string super "/" sub))
+ (t (or super "")))))
(defstruct (mime-part (:type list)
(:constructor make-mime-part (contents headers)))
@@ -423,19 +419,19 @@
(return-from parse-mime nil))
(let ((result ())
- content-type-header)
+ content-type-header)
(loop
(let ((headers (loop
- for header = (parse-header input)
- while header
- when (string-equal "CONTENT-TYPE" (header-name header))
- do (setf content-type-header header
- (header-value header) (parse-content-type (header-value header)))
- collect header)))
- (if (and recursive-p
- (string-equal "MULTIPART" (content-type-super (header-value content-type-header))))
- (let ((boundary (cdr (find-parameter "BOUNDARY" (header-parameters content-type-header)))))
- (push (make-mime-part (parse-mime input boundary) headers) result))
+ for header = (parse-header input)
+ while header
+ when (string-equal "CONTENT-TYPE" (header-name header))
+ do (setf content-type-header header
+ (header-value header) (parse-content-type (header-value header)))
+ collect header)))
+ (if (and recursive-p
+ (string-equal "MULTIPART" (content-type-super (header-value content-type-header))))
+ (let ((boundary (cdr (find-parameter "BOUNDARY" (header-parameters content-type-header)))))
+ (push (make-mime-part (parse-mime input boundary) headers) result))
(let ((file-name (get-file-name headers)))
(cond ((and write-content-to-file
file-name)
@@ -479,10 +475,10 @@
"Returns the Content-Type header of mime-part PART."
(let ((header (find-header "CONTENT-TYPE" (mime-part-headers part))))
(if header
- (if as-string
- (or (unparse-content-type (header-value header)) "")
- (header-value header))
- (when as-string ""))))
+ (if as-string
+ (or (unparse-content-type (header-value header)) "")
+ (header-value header))
+ (when as-string ""))))
(defun find-content-disposition-header (headers)
More information about the rfc2388-cvs
mailing list