Commit 19f2d569 authored by Jan Idzikowski's avatar Jan Idzikowski
Browse files

Fixed encoding errors in header strings

parent 4dd11e1f
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 Version 20100420.1
2010.04.20 2010.04.20
Fixed error when send more than 1 attachment, Fixed error when send more than 1 attachment,
......
...@@ -62,6 +62,28 @@ ...@@ -62,6 +62,28 @@
#+allegro (excl:string-to-base64-string str) #+allegro (excl:string-to-base64-string str)
#-allegro (cl-base64: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) (define-condition smtp-error (error)
()) ())
...@@ -104,7 +126,13 @@ ...@@ -104,7 +126,13 @@
lines)) lines))
(defun do-with-smtp-mail (host from to thunk &key port authentication ssl local-hostname) (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 (let ((stream (smtp-handshake stream
:authentication authentication :authentication authentication
:ssl ssl :ssl ssl
...@@ -155,6 +183,7 @@ ...@@ -155,6 +183,7 @@
:authentication authentication :authentication authentication
:ssl ssl :ssl ssl
:local-hostname local-hostname) :local-hostname local-hostname)
(setf (in-header stream) nil)
(let* ((boundary (make-random-boundary)) (let* ((boundary (make-random-boundary))
(html-boundary (if (and attachments html-message) (html-boundary (if (and attachments html-message)
(make-random-boundary) (make-random-boundary)
...@@ -288,9 +317,9 @@ ...@@ -288,9 +317,9 @@
(setf stream (setf stream
#+allegro (socket:make-ssl-client-stream stream) #+allegro (socket:make-ssl-client-stream stream)
#-allegro #-allegro
(let ((s stream)) (let ((s (flexi-streams:flexi-stream-stream stream)))
(cl+ssl:make-ssl-client-stream (cl+ssl:make-ssl-client-stream
(cl+ssl:stream-fd stream) (cl+ssl:stream-fd s)
:close-callback (lambda () (close s))))) :close-callback (lambda () (close s)))))
#-allegro #-allegro
(setf stream (flexi-streams:make-flexi-stream (setf stream (flexi-streams:make-flexi-stream
...@@ -360,14 +389,16 @@ ...@@ -360,14 +389,16 @@
server connected to on STREAM. The server is expected to have server connected to on STREAM. The server is expected to have
previously accepted the DATA SMTP command." previously accepted the DATA SMTP command."
(write-to-smtp stream (format nil "Date: ~A" (get-email-date-string))) (write-to-smtp stream (format nil "Date: ~A" (get-email-date-string)))
(write-to-smtp stream (format nil "From: ~@[~A <~]~A~@[>~]" (if display-name
display-name from 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)) (write-to-smtp stream (format nil "To: ~{ ~a~^,~}" to))
(when cc (when cc
(write-to-smtp stream (format nil "Cc: ~{ ~a~^,~}" 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" (write-to-smtp stream (format nil "X-Mailer: cl-smtp ~A"
*x-mailer*)) (q-encode-str *x-mailer*)))
(when reply-to (when reply-to
(write-to-smtp stream (format nil "Reply-To: ~A" reply-to))) (write-to-smtp stream (format nil "Reply-To: ~A" reply-to)))
(when (and extra-headers (when (and extra-headers
...@@ -388,7 +419,7 @@ ...@@ -388,7 +419,7 @@
(defun write-to-smtp (stream command) (defun write-to-smtp (stream command)
(print-debug (format nil "to server: ~A" command)) (print-debug (format nil "to server: ~A" command))
(write-string command stream) (write-sequence command stream)
(write-char #\Return stream) (write-char #\Return stream)
(write-char #\NewLine stream) (write-char #\NewLine stream)
(force-output stream)) (force-output stream))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment