[cl-smtp-cvs] CVS cl-smtp
jidzikowski
jidzikowski at common-lisp.net
Tue Apr 4 13:04:40 UTC 2006
Update of /project/cl-smtp/cvsroot/cl-smtp
In directory clnet:/tmp/cvs-serv10601
Modified Files:
CHANGELOG README cl-smtp.asd cl-smtp.lisp
Added Files:
attachments.lisp
Log Message:
add support for send attachments, thanks Brian Sorg for the
implementation
new keywords: attachments and buffer-size added to send-email /
send-smtp
----------------------------------------------------------------------
--- /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2005/12/20 14:37:51 1.4
+++ /project/cl-smtp/cvsroot/cl-smtp/CHANGELOG 2006/04/04 13:04:40 1.5
@@ -1,3 +1,9 @@
+Version 20060404.1
+2006-04-04
+"ADD" support for attachment, thanks Brian Sorg for the implementation
+Added attachments.lisp
+Change cl-smtp.asd cl-smtp.lisp README
+
Version 20051220.1
2005-12-20
"ADD" win32 support for clisp
--- /project/cl-smtp/cvsroot/cl-smtp/README 2005/12/20 14:37:52 1.3
+++ /project/cl-smtp/cvsroot/cl-smtp/README 2006/04/04 13:04:40 1.4
@@ -2,7 +2,9 @@
CL-SMTP is a simple lisp smtp client.
It works in ACL, SBCL, CMUCL, OPENMCL, LISPWORKS and CLISP.
-new with authentication support for PLAIN and LOGIN authentication method
+new with support for send attachments, thanks Brian Sorg for the implementation
+
+with authentication support for PLAIN and LOGIN authentication method
used CL-BASE64 package
@@ -32,6 +34,12 @@
- authentication (Cons) : list with 3 elements
(:method "username" "password")
method is a keyword :plain or :login
+ - attachments (String or Pathname: attachments to send
+ Cons of 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 interpretted in KB
Returns nil or error with message
--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2005/12/20 14:44:06 1.5
+++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.asd 2006/04/04 13:04:40 1.6
@@ -26,7 +26,7 @@
(in-package :cl-smtp)
(asdf:defsystem :cl-smtp
- :version "20051220.1"
+ :version "20060404.1"
:depends-on
#-allegro (:cl-base64)
#+allegro ()
@@ -42,4 +42,10 @@
#+cmu("cmucl")
#+clisp("clisp")
#+openmcl("openmcl")
+ #+lispworks("lispworks"))
+ (:file "attachments" :depends-on #+sbcl("sbcl")
+ #+allegro("acl")
+ #+cmu("cmucl")
+ #+clisp("clisp")
+ #+openmcl("openmcl")
#+lispworks("lispworks"))))
--- /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2005/12/20 14:37:52 1.4
+++ /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp 2006/04/04 13:04:40 1.5
@@ -29,7 +29,8 @@
(defun check-arg (arg name)
(cond
- ((stringp arg)
+ ((or (stringp arg)
+ (pathnamep arg))
(list arg))
((listp arg)
arg)
@@ -65,19 +66,25 @@
(defun send-email (host from to subject message
&key (port 25) cc bcc reply-to extra-headers
- display-name authentication)
+ display-name authentication
+ attachments (buffer-size 256))
(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
:extra-headers extra-headers
:display-name display-name
- :authentication authentication))
+ :authentication authentication
+ :attachments (check-arg attachments "attachments")
+ :buffer-size (if (numberp buffer-size)
+ buffer-size
+ 256)))
(defun send-smtp (host from to subject message
&key (port 25) cc bcc reply-to extra-headers
- display-name authentication)
- (let ((sock (socket-stream (make-smtp-socket host port))))
+ display-name authentication attachments buffer-size)
+ (let ((sock (socket-stream (make-smtp-socket host port)))
+ (boundary (make-random-boundary)))
(unwind-protect
(progn
(open-smtp-connection sock :authentication authentication)
@@ -111,10 +118,19 @@
(dolist (l extra-headers)
(write-to-smtp sock
(format nil "~A: ~{~a~^,~}" (car l) (rest l)))))
- (write-to-smtp sock "Mime-Version: 1.0")
+ (write-to-smtp sock "Mime-Version: 1.0")
+ (when attachments
+ (generate-multipart-header sock boundary))
(write-char #\Return sock)
(write-char #\NewLine sock)
+ (when attachments
+ (setq message (wrap-message-with-multipart-dividers
+ message boundary)))
(write-to-smtp sock message)
+ (when attachments
+ (dolist (attachment attachments)
+ (send-attachment sock attachment boundary buffer-size))
+ (send-attachments-end-marker sock boundary))
(write-char #\. sock)
(write-char #\Return sock)
(write-char #\NewLine sock)
--- /project/cl-smtp/cvsroot/cl-smtp/attachments.lisp 2006/04/04 13:04:40 NONE
+++ /project/cl-smtp/cvsroot/cl-smtp/attachments.lisp 2006/04/04 13:04:40 1.1
;;; -*- mode: Lisp -*-
;;; This file is part of CL-SMTP, the Lisp SMTP Client
;;; Copyright (C) 2004/2005 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
;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; Lisp Lesser GNU General Public License for more details.
;;; File: attachments.lisp
;;; Description: encoding and transmitting login to include a mime attachment
;;;
;;; Contributed by Brian Sorg
;;;
;;; Thanks to David Cooper for make-random-boundary
;;;
(in-package :cl-smtp)
;;; Addition to allow for sending mime attachments along with the smtp message
;;---- Initialize array of possible boundary characters to make start of attachments
(defparameter *boundary-chars*
(let* ((chars (list #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
#\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
#\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z
#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
(arr (make-array (length chars))))
(dotimes (i (length chars) arr)
(setf (aref arr i) (pop chars)))))
(defun make-random-boundary (&optional (length 50) (boundary-chars *boundary-chars*))
(let ((boundary (make-string length))
(chars-length (length boundary-chars)))
(dotimes (i length boundary)
(setf (aref boundary i) (svref *boundary-chars* (random chars-length))))))
(defun generate-multipart-header (sock boundary)
(write-to-smtp sock
(format nil "Content-type: multipart/mixed;~%~tBoundary=\"~a\""
boundary)))
(defun wrap-message-with-multipart-dividers (message boundary)
(concatenate 'string (format nil "--~a~%" boundary)
(format nil "Content-type: text/plain~%")
(format nil "Content-Disposition: inline~%")
(format nil "~%")
message (format nil "~%")))
(defun send-attachment (sock attachment boundary buffer-size)
(print-debug (format nil "Sending attachment: ~a" attachment))
(when (probe-file attachment)
(let ((name (file-namestring attachment)))
(send-attachment-header sock boundary name)
(base64-encode-file attachment sock :buffer-size buffer-size)
)))
(defun send-attachment-header (sock boundary name)
(write-to-smtp sock
(format nil "~%--~a~%Content-type: application/octet-stream;~%~tname=\"~a\"~%Content-Transfer-Encoding: base64~%Content-Disposition: attachment; filename=\"~a\"~%"
boundary
name
name)))
(defun send-attachments-end-marker (sock boundary)
(write-to-smtp sock
(format nil "~%--~a--~%" boundary)))
(defun base64-encode-file (file-in sock
&key
(buffer-size 256) ;; in KB
(wrap-at-column 76))
(let* ((max-buffer-size (* buffer-size 1024))
(byte-count 0)
(buffer (make-array max-buffer-size
:element-type '(unsigned-byte 8))))
(when (probe-file file-in)
;;-- open filein ---------
(with-open-file (strm-in file-in
:element-type '(unsigned-byte 8))
(loop
(setq byte-count 0)
;; read a portion of the file into the buffer
(setq byte-count (dotimes (i max-buffer-size max-buffer-size)
(let ((bchar (read-byte strm-in nil 'EOF)))
(if (eql bchar 'EOF)
(return i)
(setf (aref buffer i) bchar)))))
(print-debug (format nil "~%** Byte Count ~a~%" byte-count))
;; encode the buffer and write out to stream
(cl-base64:usb8-array-to-base64-stream
(if (< byte-count max-buffer-size)
(trimmed-buffer byte-count buffer)
buffer)
sock :columns wrap-at-column)
(force-output sock)
;;-- when finished reading exit do loop
(when (< byte-count max-buffer-size)
(return)))))))
(defun trimmed-buffer (byte-count buffer)
"Creates an array the length of byte-count and copies contents of buffer into it.
Needed in Lispworks, Lispworks initialized all elements of the buffer array when it was made, allegro doesn't
seem to have this behavior"
(let ((trimmed-buffer (make-array byte-count :element-type '(unsigned-byte 8))))
(dotimes (i byte-count trimmed-buffer)
(setf (aref trimmed-buffer i) (aref buffer i)))))
More information about the Cl-smtp-cvs
mailing list