Update of /project/cl-smtp/cvsroot/cl-smtp
In directory tiger.common-lisp.net:/tmp/cvs-serv20343
Modified Files:
CHANGELOG cl-smtp.lisp tests.lisp
Log Message:
check message/html-message for non ascii characters,
when found non ascii characters send messge/html-message
encoded quoted-printable
--- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/09/08 15:02:32 1.20
+++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2013/01/21 09:39:26 1.21
@@ -1,3 +1,10 @@
+Version 20130118
+2013.01.18
+Add string-has-non-ascii, rfc2045-q-encode-string-to-stream,
+to send quoted-printable messages
+Change write-rfc8822-message
+Change cl-smtp.lisp, tests.lisp, CHANGELOG
+
Version 20100908.2
2010.09.08
Add write-rfc8822-message, to write a rfc8822 compatible mail.
--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2010/09/08 15:02:32 1.20
+++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2013/01/21 09:39:26 1.21
@@ -56,10 +56,19 @@
(mask str))
resultstr))
-(defun string-to-base64-string (str)
- (declare (ignorable str))
- #+allegro (excl:string-to-base64-string str :wrap-at-column nil)
- #-allegro (cl-base64:string-to-base64-string str))
+(defun string-to-base64-string (str &key (external-format :utf-8)
+ (columns 80))
+ (let ((exformat (flex:make-external-format external-format)))
+ #+allegro (excl:usb8-array-to-base64-string
+ (flex:string-to-octets str :external-format exformat)
+ :wrap-at-column columns)
+ #-allegro (cl-base64:usb8-array-to-base64-string
+ (flex:string-to-octets str :external-format exformat)
+ :columns columns)))
+
+(defun string-has-non-ascii (str)
+ (loop for c across str
+ when (< 127 (char-code c)) do (return t)))
(defun rfc2045-q-encode-string (str &key (external-format :utf-8))
(let ((line-has-non-ascii nil)
@@ -75,7 +84,7 @@
(loop for byte across (flex:string-to-octets
(make-string 1 :initial-element c)
:external-format exformat)
- do (format s "=~2,'0X" byte)))
+ do (format s "~:@(=~2,'0X~)" byte)))
(t
(when line-has-non-ascii
(format s "?=")
@@ -84,6 +93,42 @@
(when line-has-non-ascii
(format s "?=")))))
+(defun rfc2045-q-encode-string-to-stream (str stream
+ &key (external-format :utf-8)
+ (columns 74))
+ (let ((exformat (flex:make-external-format external-format))
+ (last-line-break 0)
+ (len (length str)))
+ (loop for c across str
+ for n from 0 to len
+ for column = (- n last-line-break)
+ for nc = (when (< (+ n 1) len) (elt str (+ n 1)))
+ do
+ (when (>= column columns)
+ (write-char #\= stream)
+ (write-blank-line stream)
+ (setf last-line-break n))
+ (cond
+ ((char= c #\NewLine)
+ (setf last-line-break n)
+ (write-char c stream))
+ ((or (char= c #\Space)
+ (char= c #\Tab))
+ (if (char= nc #\NewLine)
+ (format stream "~:@(=~2,'0X~)" (char-code c))
+ (write-char c stream)))
+ ((or (< 127 (char-code c))
+ (> 33 (char-code c))
+ (char= c #\=))
+ (loop for byte across (flex:string-to-octets
+ (make-string 1 :initial-element c)
+ :external-format exformat)
+ do (format stream "~:@(=~2,'0X~)" byte)))
+ (t
+ (write-char c stream))
+ ))
+ ))
+
(defun substitute-return-newline (str)
"Replace all occurences of \r\n in STR with spaces"
(let ((resultstr ""))
@@ -178,7 +223,8 @@
(defun send-email (host from to subject message
&key ssl (port (if (eq :tls ssl) 465 25)) cc bcc reply-to extra-headers
html-message display-name authentication
- attachments (buffer-size 256) envelope-sender (external-format :utf-8))
+ attachments (buffer-size 256) envelope-sender
+ (external-format :utf-8) local-hostname)
(send-smtp host from (check-arg to "to") subject (mask-dot message)
:port port :cc (check-arg cc "cc") :bcc (check-arg bcc "bcc")
:reply-to reply-to
@@ -192,7 +238,8 @@
256)
:envelope-sender (or envelope-sender from)
:external-format external-format
- :ssl ssl))
+ :ssl ssl
+ :local-hostname (or local-hostname (usocket::get-host-name))))
(defun send-smtp (host from to subject message
&key ssl (port (if (eq :tls ssl) 465 25)) cc bcc
@@ -403,6 +450,9 @@
display-name attachments buffer-size
(external-format :utf-8))
(let* ((boundary (make-random-boundary))
+ (message-transfer-encoding (when (string-has-non-ascii message)
+ "quoted-printable"))
+
(html-boundary (if (and attachments html-message)
(make-random-boundary)
boundary))
@@ -415,7 +465,8 @@
:cc cc
:reply-to reply-to
:display-name display-name
- :extra-headers extra-headers :subject subject)
+ :extra-headers extra-headers :subject subject
+ :external-format external-format)
(when (or attachments html-message)
(send-multipart-headers stream
:attachment-boundary (when attachments boundary)
@@ -436,31 +487,52 @@
(write-blank-line stream)
(generate-message-header
stream :boundary html-boundary :content-type content-type
+ :content-transfer-encoding message-transfer-encoding
:content-disposition "inline" :include-blank-line? nil)))
(attachments
(generate-message-header
stream :boundary boundary
:content-type content-type :content-disposition "inline"
+ :content-transfer-encoding message-transfer-encoding
:include-blank-line? nil))
(html-message
(generate-message-header
stream :boundary html-boundary :content-type content-type
+ :content-transfer-encoding message-transfer-encoding
:content-disposition "inline"))
(t
- (generate-message-header stream :content-type content-type
- :include-blank-line? nil)))
+ (generate-message-header
+ stream :content-type content-type
+ :content-transfer-encoding message-transfer-encoding
+ :include-blank-line? nil)))
+ (write-blank-line stream)
+ (if message-transfer-encoding
+ (progn
+ (print-debug (format nil "to server body quoted-printable: ~A"
+ message))
+ (rfc2045-q-encode-string-to-stream message stream
+ :external-format external-format))
+ (write-to-smtp stream message))
(write-blank-line stream)
- (write-to-smtp stream message)
(write-blank-line stream)
;;---------- Send Html text if needed -------------------------
(when html-message
- (generate-message-header
- stream :boundary html-boundary
- :content-type (format nil "text/html; charset=~S"
- (string-upcase (symbol-name external-format)))
- :content-disposition "inline")
- (write-to-smtp stream html-message)
- (send-end-marker stream html-boundary))
+ (let ((non-ascii-p (string-has-non-ascii html-message)))
+ (generate-message-header
+ stream :boundary html-boundary
+ :content-type (format nil "text/html; charset=~S"
+ (string-upcase (symbol-name external-format)))
+ :content-transfer-encoding (when non-ascii-p "quoted-printable")
+ :content-disposition "inline")
+ (if non-ascii-p
+ (progn
+ (print-debug
+ (format nil "to server html-message quoted-printable: ~A"
+ html-message))
+ (rfc2045-q-encode-string-to-stream
+ html-message stream :external-format external-format))
+ (write-to-smtp stream html-message))
+ (send-end-marker stream html-boundary)))
;;---------- Send Attachments -----------------------------------
(when attachments
(dolist (attachment attachments)
--- /project/cl-smtp/cvsroot/cl-smtp/tests.lisp 2010/06/21 09:06:27 1.2
+++ /project/cl-smtp/cvsroot/cl-smtp/tests.lisp 2013/01/21 09:39:26 1.3
@@ -14,6 +14,51 @@
(defun get-component-pathname ()
(asdf:component-pathname (asdf:find-system "cl-smtp")))
+
+
+(define-cl-smtp-test "rfc2045-q-encode-string-to-stream-1" ()
+ (let* ((str "öüäÖÜÄß")
+ (qstr (with-output-to-string (s)
+ (rfc2045-q-encode-string-to-stream
+ str s :external-format :utf-8))))
+ (assert qstr)
+ (assert (string-equal qstr "=C3=B6=C3=BC=C3=A4=C3=96=C3=9C=C3=84=C3=9F"))))
+
+(define-cl-smtp-test "rfc2045-q-encode-string-to-stream-2" ()
+ (let* ((str "öüäÖÜÄß")
+ (qstr (with-output-to-string (s)
+ (rfc2045-q-encode-string-to-stream
+ str s :external-format :latin-1))))
+ (assert qstr)
+ (assert (string-equal qstr "=F6=FC=E4=D6=DC=C4=DF"))))
+
+(define-cl-smtp-test "rfc2045-q-encode-string-to-stream-3" ()
+ (let* ((str "check if #\= encoded")
+ (qstr (with-output-to-string (s)
+ (rfc2045-q-encode-string-to-stream
+ str s :external-format :latin-1))))
+ (assert qstr)
+ (assert (string-equal qstr "check if #\=3D encoded"))))
+
+(define-cl-smtp-test "rfc2045-q-encode-string-to-stream-4" ()
+ (let* ((str "Müde vom Durchwandern öder Letternwüsten, voll leerer Hirngeburten, in anmaaßendsten Wortnebeln ; überdrüssig ästhetischer Süßler wie grammatischer Wässerer ; entschloß ich mich : Alles, was je schrieb, in Liebe und Haß, als immerfort mitlebend zu behandeln !")
+ (qstr (with-output-to-string (s)
+ (rfc2045-q-encode-string-to-stream
+ str s :external-format :latin-1 :columns 64))))
+ (assert qstr)
+ (assert (string-equal qstr "M=FCde vom Durchwandern =F6der Letternw=FCsten, voll leerer Hirngeburt=
+en, in anmaa=DFendsten Wortnebeln ; =FCberdr=FCssig =E4sthetischer S=FC=DFle=
+r wie grammatischer W=E4sserer ; entschlo=DF ich mich : Alles, was j=
+e schrieb, in Liebe und Ha=DF, als immerfort mitlebend zu behandel=
+n !"
+))))
+
+(define-cl-smtp-test "string-has-non-ascii-1" ()
+ (assert (string-has-non-ascii "test Ü ende")))
+
+(define-cl-smtp-test "string-has-non-ascii-2" ()
+ (assert (not (string-has-non-ascii "test ende"))))
+
(define-cl-smtp-test "rfc2045-q-encode-string-utf-8" ()
(let* ((str "öüäÖÜÄß")
(qstr (rfc2045-q-encode-string str :external-format :utf-8)))
