Revision: 4621 Author: hans URL: http://bknr.net/trac/changeset/4621 fix automatic lf->crlf conversion in smtp-output-stream. some issues may remain. U deployed/quickhoney/thirdparty/cl-smtp/cl-smtp.lisp U deployed/quickhoney/thirdparty/cl-smtp/smtp-output-stream.lisp Modified: deployed/quickhoney/thirdparty/cl-smtp/cl-smtp.lisp =================================================================== --- deployed/quickhoney/thirdparty/cl-smtp/cl-smtp.lisp 2010-10-20 12:05:40 UTC (rev 4620) +++ deployed/quickhoney/thirdparty/cl-smtp/cl-smtp.lisp 2010-10-23 10:59:18 UTC (rev 4621) @@ -110,7 +110,7 @@ :ssl ssl :local-hostname local-hostname))) (initiate-smtp-mail stream from to) - (funcall thunk (make-instance 'smtp-output-stream :encapsulated-stream stream)) + (funcall thunk (make-instance 'smtp-header-output-stream :encapsulated-stream stream)) (finish-smtp-mail stream)))) (defmacro with-smtp-mail ((stream-var host from to &key ssl (port (if (eq :tls ssl) 465 25)) authentication local-hostname) @@ -376,7 +376,7 @@ (dolist (l extra-headers) (write-to-smtp stream (format nil "~A: ~{~a~^,~}" (car l) (rest l))))) - (write-to-smtp stream "Mime-Version: 1.0")) + (write-to-smtp stream "MIME-Version: 1.0")) (defun send-multipart-headers (stream &key attachment-boundary html-boundary) (cond (attachment-boundary Modified: deployed/quickhoney/thirdparty/cl-smtp/smtp-output-stream.lisp =================================================================== --- deployed/quickhoney/thirdparty/cl-smtp/smtp-output-stream.lisp 2010-10-20 12:05:40 UTC (rev 4620) +++ deployed/quickhoney/thirdparty/cl-smtp/smtp-output-stream.lisp 2010-10-23 10:59:18 UTC (rev 4621) @@ -19,13 +19,16 @@ (defclass smtp-output-stream (trivial-gray-stream-mixin fundamental-character-output-stream) ((encapsulated-stream :initarg :encapsulated-stream - :reader encapsulated-stream) - (in-header - :initform t - :accessor in-header - :documentation - "Currently emitting the header of the message") - (line-has-non-ascii + :reader encapsulated-stream))) + +(defmethod stream-element-type ((stream smtp-output-stream)) + (stream-element-type (encapsulated-stream stream))) + +(defmethod close ((stream smtp-output-stream) &key abort) + (close (encapsulated-stream stream) :abort abort)) + +(defclass smtp-header-output-stream (smtp-output-stream) + ((line-has-non-ascii :initform nil :accessor line-has-non-ascii :documentation @@ -40,48 +43,73 @@ :initarg :external-format :reader external-format))) -(defmethod stream-element-type ((stream smtp-output-stream)) - (stream-element-type (stream stream))) - -(defmethod close ((stream smtp-output-stream) &key abort) - (close (encapsulated-stream stream) :abort abort)) - (defmethod stream-write-char ((stream smtp-output-stream) char) - (with-accessors ((in-header in-header) - (line-has-non-ascii line-has-non-ascii) + (with-accessors ((line-has-non-ascii line-has-non-ascii) (previous-char previous-char) (external-format external-format) (encapsulated-stream encapsulated-stream)) stream - (when in-header - (cond - ;; Newline processing - ((eql char #\Newline) - ;; Finish quoting - (when line-has-non-ascii - (format encapsulated-stream "?=") - (setf line-has-non-ascii nil)) - ;; Test for end of header - (when (eql previous-char #\Newline) - (setf in-header nil))) - ((eql char #\Return) - ;; CR is suppressed here and added before each #\Newline - ) - ;; Handle non-ASCII characters - ((< 127 (char-code char)) - (unless line-has-non-ascii - (format encapsulated-stream "=?~A?Q?" (flex:external-format-name external-format)) - (setf line-has-non-ascii t)) - (loop for byte across (flex:string-to-octets (make-string 1 :initial-element char) - :external-format external-format) - do (format encapsulated-stream "=~2,'0X" byte)))) - (setf previous-char char)) - #+nil(when (eql char #\Newline) - (write-char #\Return encapsulated-stream)) + (cond + ;; Newline processing + ((eql char #\Newline) + ;; Finish quoting + (when line-has-non-ascii + (format encapsulated-stream "?=") + (setf line-has-non-ascii nil)) + ;; Print CR + (write-char #\Return encapsulated-stream) + ;; Test for end of header + (when (eql previous-char #\Newline) + (write-char #\Newline encapsulated-stream) + (change-class stream 'smtp-body-output-stream) + (return-from stream-write-char nil))) + ((eql char #\Return) + ;; CR is suppressed here and added before each #\Newline + ) + ;; Handle non-ASCII characters + ((< 127 (char-code char)) + (unless line-has-non-ascii + (format encapsulated-stream "=?~A?Q?" (flex:external-format-name external-format)) + (setf line-has-non-ascii t)) + (loop for byte across (flex:string-to-octets (make-string 1 :initial-element char) + :external-format external-format) + do (format encapsulated-stream "=~2,'0X" byte)))) + + (unless (eql #\Return char) + (setf previous-char char)) (unless (< 127 (char-code char)) (write-char char encapsulated-stream)))) -(defmethod stream-write-sequence ((stream smtp-output-stream) sequence start end &key) - (if (in-header stream) - (loop for i from start below end - do (stream-write-char stream (elt sequence i))) - (write-sequence sequence (encapsulated-stream stream) :start start :end end))) +(defmethod stream-write-sequence ((stream smtp-header-output-stream) sequence start end &key) + (loop for i from start below end + do (stream-write-char stream (elt sequence i)))) + +(defclass smtp-body-output-stream (smtp-output-stream) + ()) + +(defmethod stream-write-char ((stream smtp-body-output-stream) char) + (case char + (#\Return) + (#\Linefeed + (write-char #\Return (encapsulated-stream stream)) + (write-char #\Linefeed (encapsulated-stream stream))) + (otherwise + (write-char char (encapsulated-stream stream))))) + +(defmethod stream-write-sequence ((stream smtp-body-output-stream) sequence start end &key) + (loop + (let ((linefeed-position (position #\Linefeed sequence :start start :end end))) + (cond + ((>= start end) + (return)) + (linefeed-position + (write-sequence sequence (encapsulated-stream stream) + :start start + :end linefeed-position) + (write-char #\Return (encapsulated-stream stream)) + (write-char #\Linefeed (encapsulated-stream stream)) + (setf start (1+ linefeed-position))) + (t + (write-sequence sequence (encapsulated-stream stream) + :start start + :end end) + (return)))))) \ No newline at end of file