May 2010 - cl-smtp-cvs@common-lisp.net - mailman3.common-lisp.net

[cl-smtp-cvs] CVS cl-smtp
by jidzikowski 06 May '10

06 May '10

Update of /project/cl-smtp/cvsroot/cl-smtp In directory cl-net:/tmp/cvs-serv28424 Modified Files: index.html Log Message: update index.html --- /project/cl-smtp/cvsroot/cl-smtp/index.html 2008/04/12 19:40:36 1.2 +++ /project/cl-smtp/cvsroot/cl-smtp/index.html 2010/05/06 09:50:40 1.3 @@ -17,7 +17,9 @@ <p>CL-SMTP is a simple lisp Networking Library that provides SMTP client protocol, supported LOGIN and PLAIN authentication methods.</p> - <p><b>New Version</b> [20071018.1] Reverted the non allegro base64 functionality in attachment.lisp, now it is used cl-base64 again. Thanks Attila Lendvai for the bug report.</p> + <p><b>New Version</b> [20100505.1] Rewrite encoding functions, now it is possible to use non ascii characters in header values and in attachment filenames.</p> + + <p><b>Documentation</b> see the README file.</p> <h3>Download</h3> @@ -32,7 +34,7 @@ <h3>Portability</h3> - <p>CL-SMTP requires USOCKET and CL-BASE64 (CL-BASE64 isn't a requirement on ACL)</p> + <p>CL-SMTP requires USOCKET, FLEXI-STREAMS, TRIVIAL-GRAY-STREAMS, CL+SSL and CL-BASE64 (CL+SSL and CL-BASE64 isn't a requirement on ACL)</p> <p>It works in all implementations supported by its dependencies (Allegro, SBCL, CMU CL, OpenMCL, Lispworks, CLISP and ECL).</p> <p>Test results for Linux/x86/amd64:</p> <table cellspacing="0" cellpadding="2" border="1">

1 0

[cl-smtp-cvs] CVS cl-smtp
by jidzikowski 06 May '10

06 May '10

Update of /project/cl-smtp/cvsroot/cl-smtp In directory cl-net:/tmp/cvs-serv1502 Added Files: tests.lisp Log Message: add tests for encoding functions --- /project/cl-smtp/cvsroot/cl-smtp/tests.lisp 2010/05/06 09:25:45 NONE +++ /project/cl-smtp/cvsroot/cl-smtp/tests.lisp 2010/05/06 09:25:45 1.1 ;; -*- mode: common-lisp; coding: utf-8 -*- (in-package :cl-smtp) (defparameter *cl-smtp-tests* (make-hash-table :test 'equal)) (defmacro define-cl-smtp-test (name (&rest args) &body body) (let ((tmpname (gensym (string name)))) `(progn (defun ,tmpname (,@(mapcar #'car args)) ,@body) (setf (gethash ,(string-downcase name) *cl-smtp-tests*) (list #',tmpname ,args))))) (defun get-component-pathname () (asdf:component-pathname (asdf:find-system "cl-smtp"))) (define-cl-smtp-test "rfc2045-q-encode-string-utf-8" () (let* ((str "öüäÖÜÄß") (qstr (rfc2045-q-encode-string str :external-format :utf-8))) (assert qstr) (assert (string-equal qstr "=?UTF-8?Q?=C3=B6=C3=BC=C3=A4=C3=96=C3=9C=C3=84=C3=9F?=")))) (define-cl-smtp-test "escape-rfc822-quoted-string" () (assert (equal (escape-rfc822-quoted-string "test end") "test end")) (assert (equal (escape-rfc822-quoted-string "test\\end") "test\\\\end")) (assert (equal (escape-rfc822-quoted-string "test\"end") "test\\\"end")) (assert (equal (escape-rfc822-quoted-string (format nil "test~%end")) (format nil "test\\~%end"))) (assert (equal (escape-rfc822-quoted-string (format nil "test~cend" #\Return)) (format nil "test\\~cend" #\Return))) (assert (equal (escape-rfc822-quoted-string "test/end") "test/end")) (assert (equal (escape-rfc822-quoted-string "test end\\") "test end\\\\")) (assert (equal (escape-rfc822-quoted-string (format nil "~%test end\\")) (format nil "\\~%test end\\\\")))) (define-cl-smtp-test "rfc2231-encode-string-utf-8" () (let* ((str "öüäÖÜÄß") (qstr (rfc2231-encode-string str :external-format :utf-8))) (assert qstr) (assert (string-equal qstr "UTF-8''%C3%B6%C3%BC%C3%A4%C3%96%C3%9C%C3%84%C3%9F")) )) (define-cl-smtp-test "make-attachment-1" () (let* ((p (merge-pathnames "tests.lisp" (get-component-pathname))) (attachment (make-attachment p))) (assert (equal (attachment-name attachment) (file-namestring p))) (assert (equal (attachment-mime-type attachment) "text/plain")) (assert (equal (attachment-data-pathname attachment) p)) )) (define-cl-smtp-test "make-attachment-2" () (let* ((p (merge-pathnames "tests.lisp" (get-component-pathname))) (attachment p)) (assert (equal (attachment-name attachment) (file-namestring p))) (assert (equal (attachment-mime-type attachment) "text/plain")) (assert (equal (attachment-data-pathname attachment) p)) )) (define-cl-smtp-test "make-attachment-3" () (let* ((p (namestring (merge-pathnames "tests.lisp" (get-component-pathname)))) (attachment p)) (assert (equal (attachment-name attachment) (file-namestring p))) (assert (equal (attachment-mime-type attachment) "text/plain")) (assert (equal (attachment-data-pathname attachment) p)) )) (define-cl-smtp-test "send-attachment-header-1" () (let* ((boundary (make-random-boundary)) (p (merge-pathnames "tests.lisp" (get-component-pathname))) (attachment (make-attachment p)) (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''tests.lisp;~% name=\"tests.lisp\"~AContent-Disposition: attachment; filename*=UTF-8''tests.lisp; filename=\"tests.lisp\"~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 #\Return #\NewLine)) (format nil "~C~C..~C~C" #\Return #\NewLine #\Return #\NewLine))) (assert (equal (mask-dot (format nil "~C~C..~C~C" #\Return #\NewLine #\Return #\NewLine)) (format nil "~C~C..~C~C" #\Return #\NewLine #\Return #\NewLine))) (assert (equal (mask-dot (format nil "~C~C~C~C" #\Return #\NewLine #\Return #\NewLine)) (format nil "~C~C~C~C" #\Return #\NewLine #\Return #\NewLine))) (assert (equal (mask-dot (format nil "~C.~C.~C.~C" #\Return #\NewLine #\Return #\NewLine)) (format nil "~C.~C.~C.~C" #\Return #\NewLine #\Return #\NewLine)))) (define-cl-smtp-test "substitute-return-newline" () (assert (equal (substitute-return-newline (format nil "start~Aende" *return-newline*)) "start ende")) (assert (equal (substitute-return-newline (format nil "start~Aweiter~Aende" *return-newline* *return-newline*)) "start weiter ende")) (assert (equal (substitute-return-newline (format nil "~Astart~Aweiter~Aende~A" *return-newline* *return-newline* *return-newline* *return-newline*)) " start weiter ende ")) (assert (equal (substitute-return-newline (format nil "start~A~Aende" *return-newline* *return-newline*)) "start ende")) (assert (equal (substitute-return-newline (format nil "start~A~A~Aende" *return-newline* *return-newline* *return-newline*)) "start ende")) (assert (equal (substitute-return-newline (format nil "start~A~%~A~Aende" *return-newline* *return-newline* *return-newline*)) "start ende")) ) (defun run-test (name) (handler-case (let ((test (gethash name *cl-smtp-tests*))) (format t "~%run test: ~S ~@[(~A)~]~%" name (cadr test)) (apply (car test) (cadr test)) (format t "pass~%") t) (simple-error (c) (format t "failed: ~A" c) nil))) (defun run-tests () (let ((n (hash-table-count *cl-smtp-tests*)) (pass 0)) (format t "~%run ~D cl-smtp-tests~%~%" (hash-table-count *cl-smtp-tests*)) (maphash #'(lambda (k v) (declare (ignore v)) (when (run-test k) (incf pass))) *cl-smtp-tests*) (format t "~%pass: ~D | failed: ~D~%~%" pass (- n pass))))

1 0

[cl-smtp-cvs] CVS cl-smtp
by jidzikowski 06 May '10

06 May '10

Update of /project/cl-smtp/cvsroot/cl-smtp In directory cl-net:/tmp/cvs-serv31991 Modified Files: CHANGELOG README attachments.lisp cl-smtp.asd cl-smtp.lisp mime-types.lisp package.lisp Removed Files: smtp-output-stream.lisp Log Message: Rewrite encoding functions, now it is possible to use non ascii characters in header values and in attachment filenames. New keyword argument external-format (default :utf-8). New class attachment, with slots attachment-name and attachment-mime-type, and a constructor function make-attachment. Rename q-encode-str to rfc2045-q-encode-string. Add rfc2231-encode-string to encode non ascii characters in attachment filenames. --- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/04/22 10:51:34 1.16 +++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2010/05/06 09:24:43 1.17 @@ -1,7 +1,23 @@ +Version 20100505.1 +2010.05.05 +Rewrite encoding functions, now it is possible to use non ascii characters in +header values and in attachment filenames. +New keyword argument external-format (default :utf-8). +New class attachment, with slots attachment-name and +attachment-mime-type, and a constructor function make-attachment. +Rename q-encode-str to rfc2045-q-encode-string. +Add rfc2231-encode-string to encode non ascii characters +in attachment filenames. +Add tests for encoding functions, see tests.lisp. +Change cl-smtp.lisp, attachment.lisp, package.lisp, + cl-smtp.asd, CHANGELOG, README +Add tests.lisp +Remove smtp-output-stream.lisp + Version 20100422.1 2010.04.22 Fixed encoding errors in header strings, -new function q-encode-str to encode strings in header +new function q-encode-str to encode strings in header. Change cl-smtp.lisp, CHANGELOG Version 20100420.1 --- /project/cl-smtp/cvsroot/cl-smtp/README 2008/04/02 18:02:28 1.9 +++ /project/cl-smtp/cvsroot/cl-smtp/README 2010/05/06 09:24:43 1.10 @@ -21,14 +21,17 @@ (cl-smtp:send-email host from to subject message &key (port 25) cc bcc reply-to extra-headers html-message authentication attachments (buffer-size 256) ssl) +Send email. - Arguments: +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 - subject (String) : subject text - message (String) : message body - keywords: + keywords: - cc (String or List of Strings) : email adress carbon copy - bcc (String or List of Strings): email adress blind carbon copy - reply-to (String) : email adress @@ -40,16 +43,70 @@ method is a keyword :plain or :login If the method is not specified, the proper method is determined automatically. - - attachments (String or Pathname: attachments to send - List of String/Pathnames) + - 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 - ssl (or t :starttls :tls) : if t or :STARTTLS: use the STARTTLS functionality if :TLS: use TLS directly + - external-format : symbol, default :utf-8 -Returns nil or error with message +------------------------------------------------ + +(cl-smtp:rfc2045-q-encode-string str &key (external-format :utf8)) + +Decodes a string to an quoted-printable string. + +Returns quoted-printable string + + arguments: + - str : the string to encode + keywords: + - external-format : symbol, default :utf-8 + +------------------------------------------------ + +(cl-smtp:rfc2231-encode-string str &key (external-format :utf8)) + +Decodes a string to an rfc2231 encode string. + +Returns rfc2231 encode string + + arguments: + - str : the string to encode + keywords: + - external-format : symbol, default :utf-8 + +------------------------------------------------ +CLASS +cl-smtp:attachment + + - accessor: attachment-name : string + - accessor: attachment-data-pathname : pathname + - accessor: attachment-mime-type : string (mime-type) + +It is now possible to send a file under a different name. +See cl-smtp:make-attachment. +------------------------------------------------ + +(cl-smtp:make-attachment data-pathname + &key (name (file-namestring data-pathname)) + (mime-type (lookup-mime-type name))) + +Create a instance of cl-smtp:attachment. + +Returns cl-smtp:attachment + + arguments: + - data-pathname : pathname + keywords: + - name : string, + default (file-namestring data-pathname) + - mime-type : string, + default (lookup-mime-type name) +------------------------------------------------ For debug output set the parameter *debug* to t (default nil) (setf cl-smtp::*debug* t) --- /project/cl-smtp/cvsroot/cl-smtp/attachments.lisp 2010/04/20 10:10:58 1.7 +++ /project/cl-smtp/cvsroot/cl-smtp/attachments.lisp 2010/05/06 09:24:43 1.8 @@ -3,7 +3,7 @@ ;;; This file is part of CL-SMTP, the Lisp SMTP Client -;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski +;;; Copyright (C) 2004/2005/2006/2007/2008/2009/2010 Jan Idzikowski ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the Lisp Lesser General Public License @@ -69,24 +69,91 @@ content-transfer-encoding))) (when include-blank-line? (write-blank-line sock))) -(defun send-attachment-header (sock boundary name) - - (generate-message-header - sock - :boundary boundary - :content-type (format nil "~a;~%~tname=\"~a\"" (lookup-mime-type name) name) - :content-transfer-encoding "base64" - :content-disposition (format nil "attachment; filename=\"~a\"" name))) +(defun escape-rfc822-quoted-string (str) + (with-output-to-string (s) + (loop + for c across str do + (when (find (char-code c) '(10 13 92 34)) + (write-char #\\ s)) + (write-char c s)))) + +(defun rfc2231-encode-string (string &key (external-format :utf-8)) + (with-output-to-string (s) + (format s "~A''" (string-upcase (symbol-name external-format))) + (loop for n across (string-to-octets string + :external-format external-format) + for c = (code-char n) + do (cond ((or (char<= #\0 c #\9) + (char<= #\a c #\z) + (char<= #\A c #\Z) + (find c "$-_.!*'()," :test #'char=)) + (write-char c s)) + ((char= c #\Space) + (write-char #\+ s)) + (t (format s "%~2,'0x" (char-code c))))))) + +(defun send-attachment-header (sock boundary attachment external-format) + (let ((quoted-name + (escape-rfc822-quoted-string + (rfc2045-q-encode-string (attachment-name attachment) + :external-format external-format))) + (quoted-name* + (escape-rfc822-quoted-string + (rfc2231-encode-string (attachment-name attachment) + :external-format external-format)))) + (generate-message-header + sock + :boundary boundary + :content-type (format nil "~A;~%~tname*=~A;~%~tname=~S" + (attachment-mime-type attachment) + quoted-name* quoted-name) + :content-transfer-encoding "base64" + :content-disposition (format nil "attachment; filename*=~A; filename=~S" + quoted-name* quoted-name)))) (defun send-end-marker (sock boundary) ;; Note the -- at beginning and end of boundary is required (write-to-smtp sock (format nil "~%--~a--~%" boundary))) -(defun send-attachment (sock attachment boundary buffer-size) - (when (probe-file attachment) - (let ((name (file-namestring attachment))) - (send-attachment-header sock boundary name) - (base64-encode-file attachment sock :buffer-size buffer-size)))) +(defclass attachment () + ((name :initarg :name + :accessor attachment-name) + (data-pathname :initarg :data-pathname + :accessor attachment-data-pathname) + (mime-type :initarg :mime-type + :accessor attachment-mime-type))) + +(defun make-attachment (data-pathname + &key (name (file-namestring data-pathname)) + (mime-type (lookup-mime-type name))) + (make-instance 'attachment + :data-pathname data-pathname + :name name + :mime-type mime-type)) + +(defmethod attachment-name ((attachment pathname)) + (file-namestring attachment)) + +(defmethod attachment-data-pathname ((attachment pathname)) + attachment) + +(defmethod attachment-mime-type ((attachment pathname)) + (lookup-mime-type (namestring attachment))) + +(defmethod attachment-name ((attachment string)) + (file-namestring attachment)) + +(defmethod attachment-data-pathname ((attachment string)) + attachment) + +(defmethod attachment-mime-type ((attachment string)) + (lookup-mime-type attachment)) + +(defun send-attachment (sock attachment boundary buffer-size external-format) + (send-attachment-header sock boundary attachment external-format) + (base64-encode-file (attachment-data-pathname attachment) + sock + :buffer-size buffer-size)) (defun base64-encode-file (file-in sock &key --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2008/04/17 08:33:55 1.16 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2010/05/06 09:24:43 1.17 @@ -2,7 +2,7 @@ ;;; This file is part of CL-SMTP, the Lisp SMTP Client -;;; Copyright (C) 2004/2005/2006/2007/2008 Jan Idzikowski +;;; Copyright (C) 2004/2005/2006/2007/2008/2009/2010 Jan Idzikowski ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the Lisp Lesser General Public License @@ -17,7 +17,7 @@ ;;; Description: cl-smtp ASDF system definition file (asdf:defsystem :cl-smtp - :version "20080417.1" + :version "20100505.1" :perform (load-op :after (op webpage) (pushnew :cl-smtp cl:*features*)) :depends-on (:usocket @@ -29,5 +29,5 @@ :components ((:file "package") (:file "attachments") (:file "cl-smtp") - (:file "smtp-output-stream") - (:file "mime-types"))) + (:file "mime-types") + (:file "tests"))) --- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2010/04/22 10:51:34 1.14 +++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2010/05/06 09:24:43 1.15 @@ -2,7 +2,7 @@ ;;; This file is part of CL-SMTP, the Lisp SMTP Client -;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski +;;; Copyright (C) 2004/2005/2006/2007/2008/2009/2010 Jan Idzikowski ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the Lisp Lesser General Public License @@ -18,8 +18,6 @@ (in-package :cl-smtp) -(defparameter *content-type* "text/plain; charset=ISO-8859-1") - (defparameter *x-mailer* (format nil "(~A ~A)" (lisp-implementation-type) (lisp-implementation-version))) @@ -38,7 +36,8 @@ (defvar *line-with-one-dot* #.(format nil "~C~C.~C~C" #\Return #\NewLine #\Return #\NewLine)) (defvar *line-with-two-dots* #.(format nil "~C~C..~C~C" #\Return #\NewLine - #\Return #\NewLine))) + #\Return #\NewLine)) + (defvar *return-newline* #.(format nil "~C~C" #\Return #\NewLine))) (defun mask-dot (str) "Replace all occurences of \r\n.\r\n in STR with \r\n..\r\n" @@ -62,19 +61,20 @@ #+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)) +(defun rfc2045-q-encode-string (str &key (external-format :utf-8)) + (let ((line-has-non-ascii nil) + (exformat (flex:make-external-format external-format))) (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)) + (format s "=?~A?Q?" + (string-upcase (symbol-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) + :external-format exformat) do (format s "=~2,'0X" byte))) (t (when line-has-non-ascii @@ -84,6 +84,23 @@ (when line-has-non-ascii (format s "?="))))) +(defun substitute-return-newline (str) + "Replace all occurences of \r\n in STR with spaces" + (let ((resultstr "")) + (labels ((mask (tempstr) + (let ((n (search *return-newline* tempstr))) + (cond + (n + (setf resultstr (concatenate 'string resultstr + (subseq tempstr 0 n) + " ")) + (mask (subseq tempstr (+ n 2)))) + (t + (setf resultstr (concatenate 'string resultstr + tempstr))))))) + (mask str)) + resultstr)) + (define-condition smtp-error (error) ()) @@ -94,9 +111,10 @@ (response-message :initarg :response-message :reader response-message)) (:report (lambda (condition stream) (print-unreadable-object (condition stream :type t) - (format stream "a command failed:~%command: ~S expected: ~A response: ~A" + (format stream "a command failed:~%command: ~S expected: ~A response-code: ~A response-message: ~A" (command condition) (expected-response-code condition) + (response-code condition) (response-message condition)))))) (define-condition rcpt-failed (smtp-protocol-error) @@ -125,23 +143,24 @@ :response-message msgstr)))) 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 (external-format :utf-8)) (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))) + stream + :external-format + (flexi-streams:make-external-format + external-format :eol-style :lf))) (let ((stream (smtp-handshake stream :authentication authentication :ssl ssl :local-hostname local-hostname))) (initiate-smtp-mail stream from to) - (funcall thunk (make-instance 'smtp-output-stream :encapsulated-stream stream)) + (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) +(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)) &body body) "Encapsulate a SMTP MAIl conversation. A connection to the SMTP server on HOST and PORT is established and a MAIL command is @@ -154,12 +173,13 @@ :port ,port :authentication ,authentication :ssl ,ssl - :local-hostname ,local-hostname)) + :local-hostname ,local-hostname + :external-format ,external-format)) (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)) + attachments (buffer-size 256) (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 @@ -171,23 +191,28 @@ :buffer-size (if (numberp buffer-size) buffer-size 256) + :external-format external-format :ssl ssl)) (defun send-smtp (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 - (local-hostname (usocket::get-host-name))) + (local-hostname (usocket::get-host-name)) + (external-format :utf-8)) (with-smtp-mail (stream host from (append to cc bcc) :port port :authentication authentication :ssl ssl - :local-hostname local-hostname) - (setf (in-header stream) nil) + :local-hostname local-hostname + :external-format external-format) (let* ((boundary (make-random-boundary)) (html-boundary (if (and attachments html-message) (make-random-boundary) - boundary))) + boundary)) + (content-type + (format nil "text/plain; charset=~S" + (string-upcase (symbol-name external-format))))) (send-mail-headers stream :from from :to to @@ -213,19 +238,19 @@ :multipart-type "alternative") (write-blank-line stream) (generate-message-header - stream :boundary html-boundary :content-type *content-type* + 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" + :content-type content-type :content-disposition "inline" :include-blank-line? nil)) (html-message (generate-message-header - stream :boundary html-boundary :content-type *content-type* + stream :boundary html-boundary :content-type content-type :content-disposition "inline")) (t - (generate-message-header stream :content-type *content-type* + (generate-message-header stream :content-type content-type :include-blank-line? nil))) (write-blank-line stream) (write-to-smtp stream message) @@ -234,14 +259,16 @@ (when html-message (generate-message-header stream :boundary html-boundary - :content-type "text/html; charset=ISO-8859-1" + :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)) + (send-attachment stream attachment boundary buffer-size + external-format)) (send-end-marker stream boundary))))) (define-condition no-supported-authentication-method (smtp-error) @@ -300,7 +327,7 @@ ;; Read the initial greeting from the SMTP server (smtp-command stream nil 220) (smtp-command stream (format nil "HELO ~A" - (usocket::get-host-name)) + (usocket::get-host-name)) 250) (return-from smtp-handshake stream)) @@ -362,11 +389,12 @@ 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>" from) + (format nil "MAIL FROM:<~A>" (substitute-return-newline from)) 250) (dolist (address to) (restart-case - (smtp-command stream (format nil "RCPT TO:<~A>" address) + (smtp-command stream (format nil "RCPT TO:<~A>" + (substitute-return-newline address)) 250 :condition-class 'rcpt-failed :condition-arguments (list :recipient address)) @@ -384,23 +412,31 @@ (defun send-mail-headers (stream &key from to cc reply-to - extra-headers display-name subject) + extra-headers display-name subject + (external-format :utf-8)) "Send email headers according to the given arguments to the SMTP 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))) (if display-name (write-to-smtp stream (format nil "From: ~A <~A>" - (q-encode-str display-name) from)) + (rfc2045-q-encode-string + display-name :external-format external-format) + 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" (q-encode-str subject))) - (write-to-smtp stream (format nil "X-Mailer: cl-smtp ~A" - (q-encode-str *x-mailer*))) + (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" + (rfc2045-q-encode-string + *x-mailer* :external-format external-format))) (when reply-to - (write-to-smtp stream (format nil "Reply-To: ~A" reply-to))) + (write-to-smtp stream (format nil "Reply-To: ~A" + (rfc2045-q-encode-string + reply-to :external-format external-format)))) (when (and extra-headers (listp extra-headers)) (dolist (l extra-headers) --- /project/cl-smtp/cvsroot/cl-smtp/mime-types.lisp 2007/11/03 23:53:29 1.1 +++ /project/cl-smtp/cvsroot/cl-smtp/mime-types.lisp 2010/05/06 09:24:43 1.2 @@ -3,7 +3,7 @@ ;;; This file is part of CL-SMTP, the Lisp SMTP Client -;;; Copyright (C) 2004/2005/2006/2007 Jan Idzikowski +;;; Copyright (C) 2004/2005/2006/2007/2008/2009/2010 Jan Idzikowski ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the Lisp Lesser General Public License --- /project/cl-smtp/cvsroot/cl-smtp/package.lisp 2008/04/02 19:39:59 1.1 +++ /project/cl-smtp/cvsroot/cl-smtp/package.lisp 2010/05/06 09:24:43 1.2 @@ -26,7 +26,14 @@ "SMTP-PROTOCOL-ERROR" "NO-SUPPORTED-AUTHENTICATION-METHOD" "RCPT-FAILED" - "IGNORE-RECIPIENT")) + "IGNORE-RECIPIENT" + "ATTACHMENT" + "MAKE-ATTACHMENT" + "ATTACHMENT-NAME" + "ATTACHMENT-DATA-PATHNAME" + "ATTACHMENT-MIME-TYPE" + "RFC2045-Q-ENCODE-STRING" + "RFC2231-ENCODE-STRING")) (in-package :cl-smtp)

1 0