[bknr-cvs] hans changed trunk/thirdparty/cl-smtp/
BKNR Commits
bknr at bknr.net
Sat Oct 23 11:04:20 UTC 2010
Revision: 4622
Author: hans
URL: http://bknr.net/trac/changeset/4622
fix automatic lf->crlf conversion in smtp-output-stream. some issues may remain.
U trunk/thirdparty/cl-smtp/cl-smtp.lisp
U trunk/thirdparty/cl-smtp/smtp-output-stream.lisp
Modified: trunk/thirdparty/cl-smtp/cl-smtp.lisp
===================================================================
--- trunk/thirdparty/cl-smtp/cl-smtp.lisp 2010-10-23 10:59:18 UTC (rev 4621)
+++ trunk/thirdparty/cl-smtp/cl-smtp.lisp 2010-10-23 11:04:20 UTC (rev 4622)
@@ -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: trunk/thirdparty/cl-smtp/smtp-output-stream.lisp
===================================================================
--- trunk/thirdparty/cl-smtp/smtp-output-stream.lisp 2010-10-23 10:59:18 UTC (rev 4621)
+++ trunk/thirdparty/cl-smtp/smtp-output-stream.lisp 2010-10-23 11:04:20 UTC (rev 4622)
@@ -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
More information about the Bknr-cvs
mailing list