From jidzikowski at common-lisp.net Mon Jan 21 09:39:26 2013 From: jidzikowski at common-lisp.net (CVS User jidzikowski) Date: Mon, 21 Jan 2013 01:39:26 -0800 Subject: [cl-smtp-cvs] CVS cl-smtp Message-ID: 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))) From jidzikowski at common-lisp.net Mon Jan 21 09:49:14 2013 From: jidzikowski at common-lisp.net (CVS User jidzikowski) Date: Mon, 21 Jan 2013 01:49:14 -0800 Subject: [cl-smtp-cvs] CVS cl-smtp Message-ID: Update of /project/cl-smtp/cvsroot/cl-smtp In directory tiger.common-lisp.net:/tmp/cvs-serv23150 Modified Files: README Log Message: Patch to improve the spelling a bit in README for cl-smtp. Thanks Michael Stevens --- /project/cl-smtp/cvsroot/cl-smtp/README 2010/09/08 15:02:32 1.13 +++ /project/cl-smtp/cvsroot/cl-smtp/README 2013/01/21 09:49:14 1.14 @@ -26,9 +26,9 @@ Returns nil or error with message arguments: - - host (String) : hostname or ip-adress of the smtpserver - - from (String) : email adress - - to (String or List of Strings) : email adress + - host (String) : hostname or ip-address of the smtpserver + - from (String) : email address + - to (String or List of Strings) : email address - subject (String) : subject text - message (String) : message body keywords: @@ -125,7 +125,7 @@ For debug output set the parameter *debug* to t (default nil) (setf cl-smtp::*debug* t) -CL-SMTP set automaticly the Date header and the X-Mailer header. +CL-SMTP set automatically the Date header and the X-Mailer header. X-Mailer: cl-smtp ((lisp-implementation-type) (lisp-implementation-version)) You can change this with setting the parameter *x-mailer* From jidzikowski at common-lisp.net Mon Jan 21 10:01:08 2013 From: jidzikowski at common-lisp.net (CVS User jidzikowski) Date: Mon, 21 Jan 2013 02:01:08 -0800 Subject: [cl-smtp-cvs] CVS cl-smtp Message-ID: Update of /project/cl-smtp/cvsroot/cl-smtp In directory tiger.common-lisp.net:/tmp/cvs-serv25711 Modified Files: CHANGELOG cl-smtp.asd Log Message: change version in cl-smpt.asd --- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2013/01/21 09:39:26 1.21 +++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2013/01/21 10:01:08 1.22 @@ -1,4 +1,11 @@ -Version 20130118 +Version 20130121.1 +2013.01.21 +New version in cl-smtp.asd +Add patch to improve the spelling a bit in README for cl-smtp. +Thanks Michael Stevens +Change cl-smtp.asd, CHANGELOG, README + +Version 20130118.1 2013.01.18 Add string-has-non-ascii, rfc2045-q-encode-string-to-stream, to send quoted-printable messages --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2010/09/08 15:02:32 1.20 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2013/01/21 10:01:08 1.21 @@ -17,7 +17,7 @@ ;;; Description: cl-smtp ASDF system definition file (asdf:defsystem :cl-smtp - :version "20100908.2" + :version "20130121.1" :perform (load-op :after (op webpage) (pushnew :cl-smtp cl:*features*)) :depends-on (:usocket From jidzikowski at common-lisp.net Mon Jan 21 10:07:29 2013 From: jidzikowski at common-lisp.net (CVS User jidzikowski) Date: Mon, 21 Jan 2013 02:07:29 -0800 Subject: [cl-smtp-cvs] CVS cl-smtp Message-ID: Update of /project/cl-smtp/cvsroot/cl-smtp In directory tiger.common-lisp.net:/tmp/cvs-serv26158 Modified Files: index.html Log Message: update index.html --- /project/cl-smtp/cvsroot/cl-smtp/index.html 2010/08/23 15:16:18 1.5 +++ /project/cl-smtp/cvsroot/cl-smtp/index.html 2013/01/21 10:07:29 1.6 @@ -17,11 +17,7 @@

CL-SMTP is a simple lisp Networking Library that provides SMTP client protocol, supported LOGIN and PLAIN authentication methods.

-

New Version [20100621.1] Rewrite base64-encode-file in attachments.lisp, fixed wrap at column -and add #\Return#\Newline after each column, ignore keyword buffer-size.
-Fixed string-to-base64-string allegro part in cl-smtp.lisp (wrap-at-column nil).
-Fixed finish-smtp-mail in cl-smtp, not use fresh-line on stream, send #\Return#\Newline. -Add test for base64-encode-file.

+

New Version [20130121.1] Check message/html-message for non ascii characters and send message/html-message encoded quoted-printable when found non ascii characters.

Documentation see the README file.

@@ -89,7 +85,7 @@
- Jan Idzikowski, 21. Jun 2010. + Jan Idzikowski, 21. Jan 2013.