From jdzerins at common-lisp.net Mon Aug 1 10:05:52 2005 From: jdzerins at common-lisp.net (Janis Dzerins) Date: Mon, 1 Aug 2005 12:05:52 +0200 (CEST) Subject: [rfc2388-cvs] CVS update: rfc2388/rfc2388.lisp Message-ID: <20050801100552.C27178815C@common-lisp.net> Update of /project/rfc2388/cvsroot/rfc2388 In directory common-lisp.net:/tmp/cvs-serv27677 Modified Files: rfc2388.lisp Log Message: Fixed CR/LF handling. Date: Mon Aug 1 12:05:49 2005 Author: jdzerins Index: rfc2388/rfc2388.lisp diff -u rfc2388/rfc2388.lisp:1.5 rfc2388/rfc2388.lisp:1.6 --- rfc2388/rfc2388.lisp:1.5 Tue Apr 5 11:25:27 2005 +++ rfc2388/rfc2388.lisp Mon Aug 1 12:05:48 2005 @@ -50,10 +50,8 @@ (let ((length (length boundary))) (unless (<= 1 length 70) (warn "Boundary has invalid length -- must be between 1 and 70, but is: ~S" length)) - (let ((last-char (schar boundary (1- length)))) - (when (or (char= last-char #\space) - (char= last-char #\tab)) - (warn "Boundary has trailing whitespace: ~S" boundary)))) + (when (lwsp-char-p (schar boundary (1- length))) + (warn "Boundary has trailing whitespace: ~S" boundary))) (flet ((run (result) "This one writes everything up to a boundary to RESULT stream, @@ -87,9 +85,9 @@ (setq closed t) (return)) - #-(and) - (format t "~&S:~D BI:~2,'0D CH:~:[~;*~]~S~%" - state 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 @@ -108,13 +106,17 @@ (setq state 3)) (t (write-queued-chars) - (write-char char result) - (setq state 1)))) + (setq leave-char t + state 1)))) (3 ;; first dash in dash-boundary (cond ((char= char #\-) (enqueue-char) (setq state 4)) + ((char= char #\return) + (write-queued-chars) + (enqueue-char) + (setq state 2)) (t (write-queued-chars) (write-char char result) From jdzerins at common-lisp.net Mon Aug 1 16:58:02 2005 From: jdzerins at common-lisp.net (Janis Dzerins) Date: Mon, 1 Aug 2005 18:58:02 +0200 (CEST) Subject: [rfc2388-cvs] CVS update: rfc2388/rfc2388.lisp Message-ID: <20050801165802.886F38815C@common-lisp.net> Update of /project/rfc2388/cvsroot/rfc2388 In directory common-lisp.net:/tmp/cvs-serv21760 Modified Files: rfc2388.lisp Log Message: More fixing. Date: Mon Aug 1 18:58:01 2005 Author: jdzerins Index: rfc2388/rfc2388.lisp diff -u rfc2388/rfc2388.lisp:1.6 rfc2388/rfc2388.lisp:1.7 --- rfc2388/rfc2388.lisp:1.6 Mon Aug 1 12:05:48 2005 +++ rfc2388/rfc2388.lisp Mon Aug 1 18:58:01 2005 @@ -62,6 +62,7 @@ (boundary-length (length boundary)) (closed nil) (queued-chars (make-string 4)) + (queued-dashes 0) (queue-index 0) char (leave-char nil)) @@ -70,7 +71,12 @@ (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))) @@ -86,8 +92,8 @@ (return)) #-(and) - (format t "~&S:~D BI:~2,'0D CH:~:[~;*~]~S~%" - state boundary-index leave-char char) + (format t "~&S:~D QI:~D BI:~2,'0D CH:~:[~;*~]~S~%" + state queue-index boundary-index leave-char char) (case state (1 ;; optional starting CR @@ -109,38 +115,34 @@ (setq leave-char t state 1)))) - (3 ;; first dash in dash-boundary + (3 ;; dashes (cond ((char= char #\-) - (enqueue-char) - (setq state 4)) - ((char= char #\return) - (write-queued-chars) - (enqueue-char) - (setq state 2)) + (incf queued-dashes)) + + ((<= 2 queued-dashes) + (setf leave-char t + state 5)) (t (write-queued-chars) - (write-char char result) - (setq state 1)))) - - (4 ;; second dash in dash-boundary - (cond ((char= char #\-) - (enqueue-char) - (setq state 5)) - (t - (write-queued-chars) - (write-char char result) - (setq state 1)))) + (write-dashes) + (setq leave-char t + state 1)))) (5 ;; boundary (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) - (write-char char result) (setq boundary-index 0 + leave-char t state 1)))) (6 ;; first dash in close-delimiter @@ -375,7 +377,7 @@ (defstruct (content-type (:type list) - (:constructor make-content-type (super sub))) + (:constructor make-content-type (super sub))) super sub) @@ -383,25 +385,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))) @@ -421,19 +423,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) @@ -477,10 +479,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) From jdzerins at common-lisp.net Tue Aug 2 08:46:04 2005 From: jdzerins at common-lisp.net (Janis Dzerins) Date: Tue, 2 Aug 2005 10:46:04 +0200 (CEST) Subject: [rfc2388-cvs] CVS update: rfc2388/test.lisp rfc2388/rfc2388.lisp Message-ID: <20050802084604.3AEFF88526@common-lisp.net> 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) From jdzerins at common-lisp.net Tue Aug 2 09:01:48 2005 From: jdzerins at common-lisp.net (Janis Dzerins) Date: Tue, 2 Aug 2005 11:01:48 +0200 (CEST) Subject: [rfc2388-cvs] CVS update: rfc2388/rfc2388.lisp Message-ID: <20050802090148.2BF8188553@common-lisp.net> Update of /project/rfc2388/cvsroot/rfc2388 In directory common-lisp.net:/tmp/cvs-serv20604 Modified Files: rfc2388.lisp Log Message: Code cleanup (with untabify). Date: Tue Aug 2 11:01:47 2005 Author: jdzerins Index: rfc2388/rfc2388.lisp diff -u rfc2388/rfc2388.lisp:1.8 rfc2388/rfc2388.lisp:1.9 --- rfc2388/rfc2388.lisp:1.8 Tue Aug 2 10:46:00 2005 +++ rfc2388/rfc2388.lisp Tue Aug 2 11:01:47 2005 @@ -50,10 +50,8 @@ (let ((length (length boundary))) (unless (<= 1 length 70) (warn "Boundary has invalid length -- must be between 1 and 70, but is: ~S" length)) - (let ((last-char (schar boundary (1- length)))) - (when (or (char= last-char #\space) - (char= last-char #\tab)) - (warn "Boundary has trailing whitespace: ~S" boundary)))) + (when (lwsp-char-p (schar boundary (1- length))) + (warn "Boundary has trailing whitespace: ~S" boundary))) (flet ((run (result) "This one writes everything up to a boundary to RESULT stream, @@ -87,9 +85,9 @@ (setq closed t) (return)) - #-(and) - (format t "~&S:~D BI:~2,'0D CH:~:[~;*~]~S~%" - state boundary-index leave-char char) + #-(and) + (format t "~&S:~D QI:~D BI:~2,'0D CH:~:[~;*~]~S~%" + state queue-index boundary-index leave-char char) (case state (1 ;; optional starting CR @@ -373,7 +371,7 @@ (defstruct (content-type (:type list) - (:constructor make-content-type (super sub))) + (:constructor make-content-type (super sub))) super sub) @@ -381,25 +379,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))) @@ -419,19 +417,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) @@ -475,10 +473,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)