[cl-smtp-devel] Attachment content type patch

[Richard Newman]

Adds the ability to specify the MIME type of an attachment by  
providing (attachment content-type) instead of attachment in the  
attachments list.

-R


Index: attachments.lisp
===================================================================
RCS file: /project/cl-smtp/cvsroot/cl-smtp/attachments.lisp,v
retrieving revision 1.1
diff -u -r1.1 attachments.lisp
--- attachments.lisp    4 Apr 2006 13:04:40 -0000       1.1
+++ attachments.lisp    16 Aug 2006 07:01:13 -0000
@@ -56,21 +56,22 @@
                 (format nil "~%")
                 message (format nil "~%")))
-(defun send-attachment (sock attachment boundary buffer-size)
+(defun send-attachment (sock attachment boundary buffer-size  
&optional content-type)
    (print-debug (format nil "Sending attachment: ~a" attachment))
    (when (probe-file attachment)
      (let ((name (file-namestring attachment)))
-      (send-attachment-header sock boundary name)
+      (send-attachment-header sock boundary name content-type)
        (base64-encode-file attachment sock :buffer-size buffer-size)
        )))
-(defun send-attachment-header (sock boundary name)
+(defun send-attachment-header (sock boundary name &optional content- 
type)
    (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)))
+                 (format nil "~%--~a~%Content-type: ~a;~%~tname=\"~a 
\"~%Content-Transfer-Encoding: base64~%Content-Disposition:  
attachment; filename=\"~a\"~%"
+                   boundary
+                   (or content-type "application/octet-stream")
+                   name
+                   name)))
(defun send-attachments-end-marker (sock boundary)
    (write-to-smtp sock
Index: cl-smtp.lisp
===================================================================
RCS file: /project/cl-smtp/cvsroot/cl-smtp/cl-smtp.lisp,v
retrieving revision 1.5
diff -u -r1.5 cl-smtp.lisp
--- cl-smtp.lisp        4 Apr 2006 13:04:40 -0000       1.5
+++ cl-smtp.lisp        16 Aug 2006 07:01:13 -0000
@@ -83,6 +83,9 @@
(defun send-smtp (host from to subject message
                   &key (port 25) cc bcc reply-to extra-headers
                        display-name authentication attachments  
buffer-size)
+  "ATTACHMENTS is a list of either values or conses. If an  
attachment is a cons,
+   then it is of the form (attachment content-type); otherwise, the  
default
+   octet-stream content-type is used."
    (let ((sock (socket-stream (make-smtp-socket host port)))
         (boundary (make-random-boundary)))
      (unwind-protect
@@ -129,7 +132,9 @@
           (write-to-smtp sock message)
           (when attachments
              (dolist (attachment attachments)
-              (send-attachment sock attachment boundary buffer-size))
+              (if (consp attachment)
+                (send-attachment sock (car attachment) boundary  
buffer-size (cadr attachment))
+                (send-attachment sock attachment boundary buffer- 
size)))
              (send-attachments-end-marker sock boundary))
           (write-char #\. sock)
           (write-char #\Return sock)