cl-smtp-cvs

cl-smtp-cvs@common-lisp.net

43 discussions

[cl-smtp-cvs] CVS cl-smtp
by CVS User jidzikowski 06 Mar '13

06 Mar '13

Update of /project/cl-smtp/cvsroot/cl-smtp In directory tiger.common-lisp.net:/tmp/cvs-serv7745 Modified Files: CHANGELOG cl-smtp.asd cl-smtp.lisp Log Message: Fix bug in smtp-command to return all lines from smtp server --- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2013/01/21 10:01:08 1.22 +++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2013/03/06 14:52:46 1.23 @@ -1,3 +1,9 @@ +Version 20130306.1 +2013.03.06 +Fix smtp-command to return all lines from smtp server +Thanks Jeff Cunningham for the bug report and test +Change cl-smtp.asd, cl-smtp.lisp, CHANGELOG + Version 20130121.1 2013.01.21 New version in cl-smtp.asd --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2013/01/21 10:01:08 1.21 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2013/03/06 14:52:46 1.22 @@ -17,7 +17,7 @@ ;;; Description: cl-smtp ASDF system definition file (asdf:defsystem :cl-smtp - :version "20130121.1" + :version "20130306.1" :perform (load-op :after (op webpage) (pushnew :cl-smtp cl:*features*)) :depends-on (:usocket --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2013/01/21 09:39:26 1.21 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2013/03/06 14:52:46 1.22 @@ -186,7 +186,7 @@ :expected-response-code expected-response-code :response-code code :response-message msgstr)))) - lines)) + (append lines (list msgstr)))) (defun do-with-smtp-mail (host envelope-sender to thunk &key port authentication ssl local-hostname (external-format :utf-8)) (usocket:with-client-socket (socket stream host port

1 0

[cl-smtp-cvs] CVS cl-smtp
by CVS User jidzikowski 21 Jan '13

21 Jan '13

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 @@ </ul> <div class="footer"> - <a href="mailto:jidzikowski (at) common-lisp (dot) net">Jan Idzikowski</a>, 21. Jun 2010. + <a href="mailto:jidzikowski (at) common-lisp (dot) net">Jan Idzikowski</a>, 21. Jan 2013. </div> <div class="check">

1 0

[cl-smtp-cvs] CVS cl-smtp
by CVS User jidzikowski 21 Jan '13

21 Jan '13

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 <mstevens(a)etla.org> +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

1 0

[cl-smtp-cvs] CVS cl-smtp
by CVS User jidzikowski 21 Jan '13

21 Jan '13

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 <mstevens(a)etla.org> --- /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*

1 0

[cl-smtp-cvs] CVS cl-smtp
by CVS User jidzikowski 21 Jan '13

21 Jan '13

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

1 0

[cl-smtp-cvs] CVS cl-smtp
by jidzikowski 08 Sep '10

08 Sep '10

Update of /project/cl-smtp/cvsroot/cl-smtp In directory cl-net:/tmp/cvs-serv8502 Modified Files: CHANGELOG README cl-smtp.asd cl-smtp.lisp package.lisp Log Message: Add write-rfc8822-message, to write a rfc8822 compatible mail to the given stream. Change x-mailer header setting. --- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/09/08 14:49:10 1.19 +++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/09/08 15:02:32 1.20 @@ -1,3 +1,9 @@ +Version 20100908.2 +2010.09.08 +Add write-rfc8822-message, to write a rfc8822 compatible mail. +Change x-mailer header setting. +Change cl-smtp.lisp, cl-smtp.asd, package.lisp, CHANGELOG, README + Version 20100908.1 2010.09.08 Add keyword envelope-sender to send-email, if envelope-sender not set then --- /project/cl-smtp/cvsroot/cl-smtp/README 2010/09/08 14:49:10 1.12 +++ /project/cl-smtp/cvsroot/cl-smtp/README 2010/09/08 15:02:32 1.13 @@ -79,6 +79,21 @@ - external-format : symbol, default :utf-8 ------------------------------------------------ + +(cl-smtp:write-rfc8822-message stream from to subject message + :cc cc :reply-to reply-to + :extra-headers extra-headers + :html-message html-message + :display-name display-name + :attachments attachments + :buffer-size buffer-size + :external-format external-format) + +Writes a rfc8822 compatible email to the stream. + +For arguments see the cl-smtp:send-email documentation. + +------------------------------------------------ CLASS cl-smtp:attachment --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2010/09/08 14:49:10 1.19 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2010/09/08 15:02:32 1.20 @@ -17,7 +17,7 @@ ;;; Description: cl-smtp ASDF system definition file (asdf:defsystem :cl-smtp - :version "20100908.1" + :version "20100908.2" :perform (load-op :after (op webpage) (pushnew :cl-smtp cl:*features*)) :depends-on (:usocket --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2010/09/08 14:49:10 1.19 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2010/09/08 15:02:32 1.20 @@ -18,7 +18,7 @@ (in-package :cl-smtp) -(defparameter *x-mailer* (format nil "(~A ~A)" +(defparameter *x-mailer* (format nil "cl-smtp (~A ~A)" (lisp-implementation-type) (lisp-implementation-version))) @@ -207,70 +207,14 @@ :ssl ssl :local-hostname local-hostname :external-format external-format) - (let* ((boundary (make-random-boundary)) - (html-boundary (if (and attachments html-message) - (make-random-boundary) - boundary)) - (content-type - (format nil "text/plain; charset=~S" - (string-upcase (symbol-name external-format))))) - (send-mail-headers stream - :from from - :to to - :cc cc - :reply-to reply-to - :display-name display-name - :extra-headers extra-headers :subject subject) - (when (or attachments html-message) - (send-multipart-headers stream - :attachment-boundary (when attachments boundary) - :html-boundary html-boundary)) - ;;----------- Send the body Message --------------------------- - ;;--- Send the proper headers depending on plain-text, - ;;--- multi-part or html email - (cond ((and attachments html-message) - ;; if both present, start attachment section, - ;; then define alternative section, - ;; then write alternative header - (progn - (generate-message-header - stream :boundary boundary :include-blank-line? nil) - (generate-multipart-header stream html-boundary - :multipart-type "alternative") - (write-blank-line stream) - (generate-message-header - stream :boundary html-boundary :content-type content-type - :content-disposition "inline" :include-blank-line? nil))) - (attachments - (generate-message-header - stream :boundary boundary - :content-type content-type :content-disposition "inline" - :include-blank-line? nil)) - (html-message - (generate-message-header - stream :boundary html-boundary :content-type content-type - :content-disposition "inline")) - (t - (generate-message-header stream :content-type content-type - :include-blank-line? nil))) - (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)) - ;;---------- Send Attachments ----------------------------------- - (when attachments - (dolist (attachment attachments) - (send-attachment stream attachment boundary buffer-size - external-format)) - (send-end-marker stream boundary))))) + (write-rfc8822-message stream from to subject message + :cc cc :reply-to reply-to + :extra-headers extra-headers + :html-message html-message + :display-name display-name + :attachments attachments + :buffer-size buffer-size + :external-format external-format))) (define-condition no-supported-authentication-method (smtp-error) ((features :initarg :features :reader features)) @@ -407,7 +351,6 @@ "Finish sending an email to the SMTP server connected to on STREAM. The server is expected to be inside of the DATA SMTP command. The connection is then terminated by sending a QUIT command." - ;;(fresh-line stream) (write-to-smtp stream "") (smtp-command stream "." 250) (smtp-command stream "QUIT" 221)) @@ -432,7 +375,7 @@ (write-to-smtp stream (format nil "Subject: ~A" (rfc2045-q-encode-string subject :external-format external-format))) - (write-to-smtp stream (format nil "X-Mailer: cl-smtp~A" + (write-to-smtp stream (format nil "X-Mailer: ~A" (rfc2045-q-encode-string *x-mailer* :external-format external-format))) (when reply-to @@ -455,6 +398,76 @@ :multipart-type "alternative")) (t nil))) +(defun write-rfc8822-message (stream from to subject message + &key cc reply-to extra-headers html-message + display-name attachments buffer-size + (external-format :utf-8)) + (let* ((boundary (make-random-boundary)) + (html-boundary (if (and attachments html-message) + (make-random-boundary) + boundary)) + (content-type + (format nil "text/plain; charset=~S" + (string-upcase (symbol-name external-format))))) + (send-mail-headers stream + :from from + :to to + :cc cc + :reply-to reply-to + :display-name display-name + :extra-headers extra-headers :subject subject) + (when (or attachments html-message) + (send-multipart-headers stream + :attachment-boundary (when attachments boundary) + :html-boundary html-boundary) + (write-blank-line stream)) + ;;----------- Send the body Message --------------------------- + ;;--- Send the proper headers depending on plain-text, + ;;--- multi-part or html email + (cond ((and attachments html-message) + ;; if both present, start attachment section, + ;; then define alternative section, + ;; then write alternative header + (progn + (generate-message-header + stream :boundary boundary :include-blank-line? nil) + (generate-multipart-header stream html-boundary + :multipart-type "alternative") + (write-blank-line stream) + (generate-message-header + stream :boundary html-boundary :content-type content-type + :content-disposition "inline" :include-blank-line? nil))) + (attachments + (generate-message-header + stream :boundary boundary + :content-type content-type :content-disposition "inline" + :include-blank-line? nil)) + (html-message + (generate-message-header + stream :boundary html-boundary :content-type content-type + :content-disposition "inline")) + (t + (generate-message-header stream :content-type content-type + :include-blank-line? nil))) + (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)) + ;;---------- Send Attachments ----------------------------------- + (when attachments + (dolist (attachment attachments) + (send-attachment stream attachment boundary buffer-size + external-format)) + (send-end-marker stream boundary)))) + (defun write-to-smtp (stream command) (print-debug (format nil "to server: ~A" command)) (write-sequence command stream) --- /project/cl-smtp/cvsroot/cl-smtp/package.lisp 2010/05/06 09:24:43 1.2 +++ /project/cl-smtp/cvsroot/cl-smtp/package.lisp 2010/09/08 15:02:32 1.3 @@ -33,7 +33,8 @@ "ATTACHMENT-DATA-PATHNAME" "ATTACHMENT-MIME-TYPE" "RFC2045-Q-ENCODE-STRING" - "RFC2231-ENCODE-STRING")) + "RFC2231-ENCODE-STRING" + "WRITE-RFC8822-MESSAGE")) (in-package :cl-smtp)

1 0

[cl-smtp-cvs] CVS cl-smtp
by jidzikowski 08 Sep '10

08 Sep '10

Update of /project/cl-smtp/cvsroot/cl-smtp In directory cl-net:/tmp/cvs-serv4206 Modified Files: CHANGELOG README cl-smtp.asd cl-smtp.lisp Log Message: Add keyword envelope-sender to send-email, if envelope-sender not set then envelope-sender = from argument. Change x-mailer header setting. ---------------------------------------------------------------------- --- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/06/21 09:06:26 1.18 +++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/09/08 14:49:10 1.19 @@ -1,3 +1,10 @@ +Version 20100908.1 +2010.09.08 +Add keyword envelope-sender to send-email, if envelope-sender not set then +envelope-sender = from argument. +Change x-mailer header setting. +Change cl-smtp.lisp, cl-smtp.asd, CHANGELOG, README + Version 20100621.1 2010.06.21 Rewrite base64-encode-file in attachments.lisp, fixed wrap at column --- /project/cl-smtp/cvsroot/cl-smtp/README 2010/06/21 09:06:26 1.11 +++ /project/cl-smtp/cvsroot/cl-smtp/README 2010/09/08 14:49:10 1.12 @@ -49,6 +49,8 @@ - ssl (or t :starttls :tls) : if t or :STARTTLS: use the STARTTLS functionality if :TLS: use TLS directly - external-format : symbol, default :utf-8 + - envelope-sender : email adress, + if not set then envelope-sender = from ------------------------------------------------ --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2010/06/21 09:06:27 1.18 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2010/09/08 14:49:10 1.19 @@ -17,7 +17,7 @@ ;;; Description: cl-smtp ASDF system definition file (asdf:defsystem :cl-smtp - :version "20100621.1" + :version "20100908.1" :perform (load-op :after (op webpage) (pushnew :cl-smtp cl:*features*)) :depends-on (:usocket --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2010/08/23 15:18:34 1.18 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2010/09/08 14:49:10 1.19 @@ -18,7 +18,7 @@ (in-package :cl-smtp) -(defparameter *x-mailer* (format nil "cl-smtp (~A ~A)" +(defparameter *x-mailer* (format nil "(~A ~A)" (lisp-implementation-type) (lisp-implementation-version))) @@ -143,8 +143,7 @@ :response-message msgstr)))) lines)) -(defun do-with-smtp-mail (host from to thunk &key port authentication ssl - local-hostname (external-format :utf-8)) +(defun do-with-smtp-mail (host envelope-sender to thunk &key port authentication ssl local-hostname (external-format :utf-8)) (usocket:with-client-socket (socket stream host port :element-type '(unsigned-byte 8)) (setf stream (flexi-streams:make-flexi-stream @@ -156,11 +155,11 @@ :authentication authentication :ssl ssl :local-hostname local-hostname))) - (initiate-smtp-mail stream from to) + (initiate-smtp-mail stream envelope-sender to) (funcall thunk stream) (finish-smtp-mail stream)))) -(defmacro with-smtp-mail ((stream-var host from to &key ssl (port (if (eq :tls ssl) 465 25)) authentication local-hostname (external-format :utf-8)) +(defmacro with-smtp-mail ((stream-var host envelope-sender to &key ssl (port (if (eq :tls ssl) 465 25)) authentication local-hostname (external-format :utf-8)) &body body) "Encapsulate a SMTP MAIl conversation. A connection to the SMTP server on HOST and PORT is established and a MAIL command is @@ -168,7 +167,7 @@ recipients. BODY is evaluated with STREAM-VAR being the stream connected to the remote SMTP server. BODY is expected to write the RFC2821 message (headers and body) to STREAM-VAR." - `(do-with-smtp-mail ,host ,from ,to + `(do-with-smtp-mail ,host ,envelope-sender ,to (lambda (,stream-var) ,@body) :port ,port :authentication ,authentication @@ -179,7 +178,7 @@ (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) (external-format :utf-8)) + attachments (buffer-size 256) envelope-sender (external-format :utf-8)) (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 @@ -191,6 +190,7 @@ :buffer-size (if (numberp buffer-size) buffer-size 256) + :envelope-sender (or envelope-sender from) :external-format external-format :ssl ssl)) @@ -199,8 +199,9 @@ reply-to extra-headers html-message display-name authentication attachments buffer-size (local-hostname (usocket::get-host-name)) - (external-format :utf-8)) - (with-smtp-mail (stream host from (append to cc bcc) + (envelope-sender from) + (external-format :utf-8)) + (with-smtp-mail (stream host envelope-sender (append to cc bcc) :port port :authentication authentication :ssl ssl @@ -380,7 +381,7 @@ (smtp-authenticate stream authentication features))) stream) -(defun initiate-smtp-mail (stream from to) +(defun initiate-smtp-mail (stream envelope-sender to) "Initiate an SMTP MAIL command, sending a MAIL FROM command for the email address in FROM and RCPT commands for all receipients in TO, which is expected to be a list. @@ -389,7 +390,7 @@ is signalled. This condition may be handled by the caller in order to send the email anyway." (smtp-command stream - (format nil "MAIL FROM:<~A>" (substitute-return-newline from)) + (format nil "MAIL FROM:<~A>" (substitute-return-newline envelope-sender)) 250) (dolist (address to) (restart-case @@ -406,6 +407,7 @@ "Finish sending an email to the SMTP server connected to on STREAM. The server is expected to be inside of the DATA SMTP command. The connection is then terminated by sending a QUIT command." + ;;(fresh-line stream) (write-to-smtp stream "") (smtp-command stream "." 250) (smtp-command stream "QUIT" 221)) @@ -430,7 +432,7 @@ (write-to-smtp stream (format nil "Subject: ~A" (rfc2045-q-encode-string subject :external-format external-format))) - (write-to-smtp stream (format nil "X-Mailer: ~A" + (write-to-smtp stream (format nil "X-Mailer: cl-smtp~A" (rfc2045-q-encode-string *x-mailer* :external-format external-format))) (when reply-to

1 0

[cl-smtp-cvs] CVS cl-smtp
by jidzikowski 23 Aug '10

23 Aug '10

Update of /project/cl-smtp/cvsroot/cl-smtp In directory cl-net:/tmp/cvs-serv10002 Modified Files: cl-smtp.lisp Log Message: use variable *x-mailer* without any additional text --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2010/06/11 09:48:35 1.17 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2010/08/23 15:18:34 1.18 @@ -18,7 +18,7 @@ (in-package :cl-smtp) -(defparameter *x-mailer* (format nil "(~A ~A)" +(defparameter *x-mailer* (format nil "cl-smtp (~A ~A)" (lisp-implementation-type) (lisp-implementation-version))) @@ -430,7 +430,7 @@ (write-to-smtp stream (format nil "Subject: ~A" (rfc2045-q-encode-string subject :external-format external-format))) - (write-to-smtp stream (format nil "X-Mailer: cl-smtp~A" + (write-to-smtp stream (format nil "X-Mailer: ~A" (rfc2045-q-encode-string *x-mailer* :external-format external-format))) (when reply-to

1 0

[cl-smtp-cvs] CVS cl-smtp
by jidzikowski 23 Aug '10

23 Aug '10

Update of /project/cl-smtp/cvsroot/cl-smtp In directory cl-net:/tmp/cvs-serv9847 Modified Files: index.html Log Message: typing error --- /project/cl-smtp/cvsroot/cl-smtp/index.html 2010/06/21 09:06:27 1.4 +++ /project/cl-smtp/cvsroot/cl-smtp/index.html 2010/08/23 15:16:18 1.5 @@ -18,8 +18,8 @@ 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). +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. @@ -71,7 +71,7 @@ <td class="working">working</td> </tr> <tr> - <td>OpemMCL</td> + <td>OpenMCL</td> <td class="working">working</td> </tr> </table>

1 0

[cl-smtp-cvs] CVS cl-smtp
by jidzikowski 21 Jun '10

21 Jun '10

Update of /project/cl-smtp/cvsroot/cl-smtp In directory cl-net:/tmp/cvs-serv9090 Modified Files: CHANGELOG README cl-smtp.asd index.html tests.lisp Log Message: add test for base64-encode-file, refresh changelog and readme, add new version in cl-smtp.asd --- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/05/06 09:24:43 1.17 +++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/06/21 09:06:26 1.18 @@ -1,3 +1,12 @@ +Version 20100621.1 +2010.06.21 +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. +Change cl-smtp.lisp, attachment.lisp, cl-smtp.asd, CHANGELOG, README + Version 20100505.1 2010.05.05 Rewrite encoding functions, now it is possible to use non ascii characters in --- /project/cl-smtp/cvsroot/cl-smtp/README 2010/05/06 09:24:43 1.10 +++ /project/cl-smtp/cvsroot/cl-smtp/README 2010/06/21 09:06:26 1.11 @@ -45,10 +45,7 @@ proper method is determined automatically. - attachments (Attachment Instance or String or Pathname: attachments to send List of Attachment/String/Pathnames) - - buffer-size (Number default 256): controls how much of a attachment file - is read on each loop before encoding - and transmitting the contents, - the number is interpreted in KB + - buffer-size (Number default 256): is no longer used, will remove in the future - ssl (or t :starttls :tls) : if t or :STARTTLS: use the STARTTLS functionality if :TLS: use TLS directly - external-format : symbol, default :utf-8 --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2010/05/06 09:24:43 1.17 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2010/06/21 09:06:27 1.18 @@ -17,7 +17,7 @@ ;;; Description: cl-smtp ASDF system definition file (asdf:defsystem :cl-smtp - :version "20100505.1" + :version "20100621.1" :perform (load-op :after (op webpage) (pushnew :cl-smtp cl:*features*)) :depends-on (:usocket --- /project/cl-smtp/cvsroot/cl-smtp/index.html 2010/05/06 09:50:40 1.3 +++ /project/cl-smtp/cvsroot/cl-smtp/index.html 2010/06/21 09:06:27 1.4 @@ -17,7 +17,11 @@ CL-SMTP is a simple lisp Networking Library that provides SMTP client protocol, supported LOGIN and PLAIN authentication methods. - New Version [20100505.1] Rewrite encoding functions, now it is possible to use non ascii characters in header values and in attachment filenames. + 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. Documentation see the README file. @@ -85,7 +89,7 @@ </ul> <div class="footer"> - <a href="mailto:jidzikowski (at) common-lisp (dot) net">Jan Idzikowski</a>, 24. May 2005. + <a href="mailto:jidzikowski (at) common-lisp (dot) net">Jan Idzikowski</a>, 21. Jun 2010. </div> <div class="check"> --- /project/cl-smtp/cvsroot/cl-smtp/tests.lisp 2010/05/06 09:25:45 1.1 +++ /project/cl-smtp/cvsroot/cl-smtp/tests.lisp 2010/06/21 09:06:27 1.2 @@ -84,6 +84,21 @@ (assert (equal headerstr tmpstr)) )) +(define-cl-smtp-test "send-attachment-header-2" () + (let* ((boundary (make-random-boundary)) + (p (merge-pathnames "tests.lisp" (get-component-pathname))) + (attachment (make-attachment p + :mime-type "text/plain" + :name "foo\\bar")) + (headerstr (with-output-to-string (s) + (send-attachment-header s boundary attachment :utf-8))) + (returnnewline (format nil (format nil "~C~C" #\Return #\NewLine))) + (tmpstr (format nil "--~A~AContent-type: text/plain;~% name*=UTF-8''foo%5cbar;~% name=\"foo\\\\bar\"~AContent-Disposition: attachment; filename*=UTF-8''foo%5cbar; filename=\"foo\\\\bar\"~AContent-Transfer-Encoding: base64~A~A" + boundary returnnewline returnnewline returnnewline + returnnewline returnnewline))) + (assert (equal headerstr tmpstr)) + )) + (define-cl-smtp-test "mask-dot-1" () (assert (equal (mask-dot (format nil "~C~C.~C~C" #\Return #\NewLine @@ -131,6 +146,32 @@ ende")) ) +(defun file-to-usb8-buffer (file) + (with-open-file (s file :element-type '(unsigned-byte 8)) + (let* ((flength (file-length s)) + (buffer (make-array flength :element-type '(unsigned-byte 8)))) + (loop for i from 0 to flength do + (let ((bchar (read-byte s nil 'EOF))) + (if (eql bchar 'EOF) + (return) + (setf (aref buffer i) bchar)))) + buffer))) + +(define-cl-smtp-test "base64-encode-file" () + (let* ((p (merge-pathnames "tests.lisp" (get-component-pathname))) + (base64str1 (with-output-to-string (s) + (base64-encode-file p s))) + (buffer (file-to-usb8-buffer p)) + (base64str2 + #-allegro + (cl-base64:usb8-array-to-base64-string buffer :columns 0) + #+allegro + (excl:usb8-array-to-base64-string buffer :wrap-at-column nil) + )) + + (assert (string-equal (remove #\Return (remove #\Newline base64str1 :test #'equal) :test #'equal) base64str2)) + )) + (defun run-test (name) (handler-case (let ((test (gethash name *cl-smtp-tests*)))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

cl-smtp-cvs