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))
