Update of /project/cl-smtp/cvsroot/cl-smtp In directory cl-net:/tmp/cvs-serv16391

Modified Files: CHANGELOG cl-smtp.lisp Log Message: Fixed encoding errors in header strings

--- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/04/20 10:19:21 1.15 +++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/04/22 10:51:34 1.16 @@ -1,3 +1,9 @@ +Version 20100422.1 +2010.04.22 +Fixed encoding errors in header strings, +new function q-encode-str to encode strings in header +Change cl-smtp.lisp, CHANGELOG + Version 20100420.1 2010.04.20 Fixed error when send more than 1 attachment, --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2008/04/12 19:40:36 1.13 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2010/04/22 10:51:34 1.14 @@ -62,6 +62,28 @@ #+allegro (excl:string-to-base64-string str) #-allegro (cl-base64:string-to-base64-string str))

+(defun q-encode-str (str &key (external-format + (flex:make-external-format :iso-8859-15))) + (let ((line-has-non-ascii nil)) + (with-output-to-string (s) + (loop for c across str do + (cond + ((< 127 (char-code c)) + (unless line-has-non-ascii + (format s "=?~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 c) + :external-format external-format) + do (format s "=~2,'0X" byte))) + (t + (when line-has-non-ascii + (format s "?=") + (setf line-has-non-ascii nil)) + (format s "~C" c)))) + (when line-has-non-ascii + (format s "?="))))) + (define-condition smtp-error (error) ())

@@ -104,7 +126,13 @@ lines))

(defun do-with-smtp-mail (host from to thunk &key port authentication ssl local-hostname) - (usocket:with-client-socket (socket stream host port) + (usocket:with-client-socket (socket stream host port + :element-type '(unsigned-byte 8)) + (setf stream (flexi-streams:make-flexi-stream + stream + :external-format + (flexi-streams:make-external-format + :latin-1 :eol-style :lf))) (let ((stream (smtp-handshake stream :authentication authentication :ssl ssl @@ -155,6 +183,7 @@ :authentication authentication :ssl ssl :local-hostname local-hostname) + (setf (in-header stream) nil) (let* ((boundary (make-random-boundary)) (html-boundary (if (and attachments html-message) (make-random-boundary) @@ -288,9 +317,9 @@ (setf stream #+allegro (socket:make-ssl-client-stream stream) #-allegro - (let ((s stream)) + (let ((s (flexi-streams:flexi-stream-stream stream))) (cl+ssl:make-ssl-client-stream - (cl+ssl:stream-fd stream) + (cl+ssl:stream-fd s) :close-callback (lambda () (close s))))) #-allegro (setf stream (flexi-streams:make-flexi-stream @@ -360,14 +389,16 @@ server connected to on STREAM. The server is expected to have previously accepted the DATA SMTP command." (write-to-smtp stream (format nil "Date: ~A" (get-email-date-string))) - (write-to-smtp stream (format nil "From: ~@[~A <~]~A~@[>~]" - display-name from display-name)) + (if display-name + (write-to-smtp stream (format nil "From: ~A <~A>" + (q-encode-str display-name) from)) + (write-to-smtp stream (format nil "From: ~A" from))) (write-to-smtp stream (format nil "To: ~{ ~a~^,~}" to)) (when cc (write-to-smtp stream (format nil "Cc: ~{ ~a~^,~}" cc))) - (write-to-smtp stream (format nil "Subject: ~A" subject)) + (write-to-smtp stream (format nil "Subject: ~A" (q-encode-str subject))) (write-to-smtp stream (format nil "X-Mailer: cl-smtp ~A" - *x-mailer*)) + (q-encode-str *x-mailer*))) (when reply-to (write-to-smtp stream (format nil "Reply-To: ~A" reply-to))) (when (and extra-headers @@ -388,7 +419,7 @@

(defun write-to-smtp (stream command) (print-debug (format nil "to server: ~A" command)) - (write-string command stream) + (write-sequence command stream) (write-char #\Return stream) (write-char #\NewLine stream) (force-output stream))