git.fiddlerwoaroof.com
Browse code

send-letter/send-smtp/send-smtp-auth mods

dancy authored on 26/01/2006 23:53:27
Showing 4 changed files
mime-parse.cl
History View file @ f6cd6a7
1 1 
new file mode 100644
... ... 
@@ -0,0 +1,503 @@
1 
+;; $Id: mime-parse.cl,v 1.1 2006/01/26 23:53:27 dancy Exp $
2 
+
3 
+(defpackage :net.post-office
4 
+  (:use #:lisp #:excl)
5 
+  (:export
6 
+   #:parse-mime-structure
7 
+   #:mime-dequote
8 
+
9 
+   ;; accessors
10 
+   #:mime-part-headers-size
11 
+   #:mime-part-body-size
12 
+   #:mime-part-lines
13 
+   #:mime-part-position
14 
+   #:mime-part-body-position
15 
+   #:mime-part-message
16 
+
17 
+   ;; class name
18 
+   #:mime-part-parsed
19 
+
20 
+   ))
21 
+
22 
+(in-package :net.post-office)
23 
+
24 
+(eval-when (compile)
25 
+  (declaim (optimize (speed 3))))
26 
+
27 
+;;; MIME structure parser.
28 
+;;; Ref: RFC2045/2046
29 
+
30 
+(defconstant *whitespace* '(#\space #\tab #\return #\newline))
31 
+
32 
+(defclass mime-part-parsed (mime-part)
33 
+  (
34 
+   (headers-size ;; in bytes. Includes the bytes for the blank line
35 
+    :accessor mime-part-headers-size :initform nil)
36 
+   (body-size ;; in bytes.
37 
+    :accessor mime-part-body-size :initform nil)
38 
+   (lines ;; line count of body (for non-multipart types)
39 
+    :accessor mime-part-lines :initform nil)
40 
+   (position ;; file position of start of headers
41 
+    :accessor mime-part-position :initform nil)
42 
+   (body-position ;; file position of start of body
43 
+    :accessor mime-part-body-position :initform nil)
44 
+   (message ;; for message/rfc822 encapsulated message.
45 
+    ;; This will be a mime-part
46 
+    :accessor mime-part-message :initform nil)))
47 
+
48 
+(excl::defresource mime-line
49 
+  :constructor (lambda () (make-array 16000 :element-type 'character
50 
+				      :fill-pointer 0))
51 
+  :reinitializer (lambda (x) (setf (fill-pointer x) 0)))
52 
+
53 
+;; Return values:
54 
+;;  First is the part.
55 
+;;  Second is :eof if end of file was reached or
56 
+;;            :boundary if a boundary was reached
57 
+;;            nil, otherwise
58 
+;;  Third is new position
59 
+(defun parse-mime-structure (stream &key boundary digest (pos 0) mbox)
60 
+  (parse-mime-structure-1 stream boundary digest pos mbox))
61 
+
62 
+(defun parse-mime-structure-1 (stream boundary digest pos mbox)
63 
+  (let ((part (make-instance 'mime-part-parsed)))
64 
+    (setf (mime-part-position part) pos)
65 
+    (setf (mime-part-boundary part) boundary)
66 
+    (multiple-value-bind (headers bytes)
67 
+	(parse-headers stream mbox)
68 
+      (setf (mime-part-headers-size part) bytes)
69 
+      (incf pos bytes)
70 
+      (setf (mime-part-body-position part) pos)
71 
+      (setf (mime-part-headers part) headers)
72 
+
73 
+      (let ((content-type (mime-get-header "content-type" part)))
74 
+	(setf (mime-part-id part) (mime-get-header "Content-Id" part))
75 
+	(setf (mime-part-description part)
76 
+	  (mime-get-header "Content-description" part))
77 
+	(setf (mime-part-encoding part)
78 
+	  (or (mime-get-header "Content-transfer-encoding" part)
79 
+	      "7bit"))
80 
+
81 
+	(multiple-value-bind (type subtype params)
82 
+	    (parse-content-type content-type)
83 
+
84 
+	  (if* (null type)
85 
+	     then
86 
+		  (if* digest
87 
+		     then
88 
+			  (setf (mime-part-type part) "message")
89 
+			  (setf (mime-part-subtype part) "rfc822")
90 
+			  (setf (mime-part-parameters part)
91 
+			    '(("charset" . "us-ascii")))
92 
+			  (mime-parse-message-rfc822 part stream boundary pos
93 
+						     mbox)
94 
+		     else
95 
+			  (setup-text-plain-part part stream boundary pos mbox))
96 
+	     else
97 
+		  (setf (mime-part-type part) type)
98 
+		  (setf (mime-part-subtype part) subtype)
99 
+		  (setf (mime-part-parameters part) params)
100 
+
101 
+		  (cond
102 
+		   ((equalp type "multipart")
103 
+		    (mime-parse-multipart part stream boundary pos mbox))
104 
+		   ((message-rfc822-p type subtype)
105 
+		    (mime-parse-message-rfc822 part stream boundary pos mbox))
106 
+		   (t
107 
+		    (mime-parse-non-multipart part stream boundary pos mbox)))))))))
108 
+
109 
+;; OK if 'string' is nil.
110 
+;; Might return nil
111 
+;; called by parse-mime-structure-1
112 
+(defun parse-content-type (string)
113 
+  (block nil
114 
+    (if (null string)
115 
+	(return))
116 
+    (let ((max (length string))
117 
+	  pos type subtype)
118 
+      (multiple-value-setq (type pos)
119 
+	(mime-get-token string 0 max))
120 
+      (if (string= type "")
121 
+	  (return))
122 
+
123 
+      (setf pos (skip-whitespace string pos max))
124 
+
125 
+      (if (or (>= pos max) (char/= (char string pos) #\/))
126 
+	  (return)) ;; bogus input
127 
+
128 
+      (multiple-value-setq (subtype pos)
129 
+	(mime-get-token string (1+ pos) max))
130 
+
131 
+      (if (string= subtype "")
132 
+	  (return)) ;; bogus input
133 
+
134 
+      (values type subtype (parse-parameters string pos max)))))
135 
+
136 
+;; called by parse-content-type.
137 
+(defun parse-parameters (string pos max)
138 
+  (let (char pairs param value)
139 
+    (while (< pos max)
140 
+      (setf pos (skip-whitespace string pos max))
141 
+      (setf char (char string pos))
142 
+
143 
+      (if (char/= char #\;)
144 
+	  (return))
145 
+
146 
+      (multiple-value-setq (param pos)
147 
+	(mime-get-token string (1+ pos) max))
148 
+      (setf pos (skip-whitespace string pos max))
149 
+      (if (or (>= pos max) (char/= (char string pos) #\=))
150 
+	  (return))
151 
+      (multiple-value-setq (value pos)
152 
+	(mime-get-parameter-value string (1+ pos) max))
153 
+
154 
+      (push (cons param value) pairs))
155 
+    (values (nreverse pairs) pos)))
156 
+
157 
+
158 
+(defconstant *mime-tspecials*
159 
+    '(#\( #\) #\< #\> #\@
160 
+      #\, #\; #\: #\\ #\"
161 
+      #\/ #\[ #\] #\? #\=))
162 
+
163 
+(defun skip-whitespace (string pos max)
164 
+  (declare (optimize (speed 3))
165 
+	   (fixnum pos max))
166 
+  (while (< pos max)
167 
+    (if (not (excl::whitespace-char-p (schar string pos)))
168 
+	(return))
169 
+    (incf pos))
170 
+  pos)
171 
+
172 
+(defun mime-get-parameter-value (string pos max)
173 
+  (setf pos (skip-whitespace string pos max))
174 
+  (if* (>= pos max)
175 
+     then
176 
+	  (values "" pos)
177 
+     else
178 
+	  (if (char= (char string pos) #\")
179 
+	      (mime-get-quoted-string string pos max)
180 
+	    (mime-get-token string pos max))))
181 
+
182 
+(defun mime-get-token (string pos max)
183 
+  (setf pos (skip-whitespace string pos max))
184 
+  (let ((startpos pos)
185 
+	char)
186 
+    (while (< pos max)
187 
+      (setf char (char string pos))
188 
+      (if (or (char= #\space char) (member char *mime-tspecials*))
189 
+	  (return))
190 
+      (incf pos))
191 
+    (values (subseq string startpos pos) pos)))
192 
+
193 
+;; Doesn't attempt to dequote
194 
+(defun mime-get-quoted-string (string pos max)
195 
+  (let ((res (make-string (- max pos)))
196 
+	(outpos 0)
197 
+	char inquote inbackslash)
198 
+    (while (< pos max)
199 
+      (setf char (char string pos))
200 
+
201 
+      (if* (and (char= char #\") (not inbackslash))
202 
+	 then
203 
+	      (if* inquote
204 
+		 then
205 
+		      (setf (schar res outpos) char)
206 
+		      (incf outpos)
207 
+		      (incf pos)
208 
+		      (return))
209 
+	      (setf inquote t))
210 
+
211 
+      (if* inbackslash
212 
+	 then
213 
+	      (setf inbackslash nil)
214 
+	 else
215 
+	      (if (char= char #\\)
216 
+		  (setf inbackslash t)))
217 
+
218 
+      (setf (schar res outpos) char)
219 
+      (incf outpos)
220 
+      (incf pos))
221 
+
222 
+    (values (subseq res 0 outpos) pos)))
223 
+
224 
+(defun mime-dequote (string)
225 
+  (block nil
226 
+    (if (or (string= string "") (char/= (char string 0) #\"))
227 
+	(return string))
228 
+
229 
+    (let* ((max (length string))
230 
+	   (pos 1)
231 
+	   (res (make-string max))
232 
+	   (outpos 0)
233 
+	   char inbackslash)
234 
+
235 
+      (while (< pos max)
236 
+	(setf char (char string pos))
237 
+
238 
+	(if (and (char= char #\") (not inbackslash))
239 
+	    (return))
240 
+
241 
+	(if* (and (not inbackslash) (char= char #\\))
242 
+	   then
243 
+		(setf inbackslash t)
244 
+		(incf pos)
245 
+	   else
246 
+		(setf (schar res outpos) char)
247 
+		(incf outpos)
248 
+		(incf pos)
249 
+		(setf inbackslash nil)))
250 
+
251 
+      (subseq res 0 outpos))))
252 
+
253 
+(defun setup-text-plain-part (part stream boundary pos mbox)
254 
+  (setf (mime-part-type part) "text")
255 
+  (setf (mime-part-subtype part) "plain")
256 
+  (setf (mime-part-parameters part) '(("charset" . "us-ascii")))
257 
+  (mime-parse-non-multipart part stream boundary pos mbox))
258 
+
259 
+(defun mime-parse-non-multipart (part stream boundary pos mbox)
260 
+  (let ((startpos pos))
261 
+    (multiple-value-bind (endpos lines eof pos)
262 
+	(read-until-boundary stream boundary pos mbox)
263 
+
264 
+      (setf (mime-part-lines part) lines)
265 
+      (setf (mime-part-body-position part) startpos)
266 
+      (setf (mime-part-body-size part) (- endpos startpos))
267 
+
268 
+      (values part eof pos))))
269 
+
270 
+(defun mime-parse-message-rfc822 (part stream boundary pos mbox)
271 
+  (let ((startpos pos))
272 
+    (multiple-value-bind (message eof pos)
273 
+	(parse-mime-structure-1 stream boundary nil pos mbox)
274 
+
275 
+      (setf (mime-part-message part) message)
276 
+
277 
+      (setf (mime-part-body-position part) startpos)
278 
+      (setf (mime-part-body-size part) (- pos startpos))
279 
+
280 
+      (values part eof pos))))
281 
+
282 
+
283 
+(defun mime-parse-multipart (part stream parent-boundary pos mbox)
284 
+  (let* ((params (mime-part-parameters part))
285 
+	 (boundary (cdr (assoc "boundary" params :test #'equalp)))
286 
+	 (startpos pos)
287 
+	 parts eof newpart)
288 
+
289 
+    (setf (mime-part-boundary part) parent-boundary)
290 
+
291 
+    ;; If boundary isn't specified.. try to compensate by using our
292 
+    ;; parent's boundary.
293 
+    (if (null boundary)
294 
+	(setf boundary parent-boundary)
295 
+      (setf boundary (mime-dequote boundary)))
296 
+
297 
+    ;; Locate the first boundary.
298 
+    (multiple-value-bind (ignore1 ignore2 ignore3 newpos)
299 
+	(read-until-boundary stream boundary pos mbox)
300 
+      (declare (ignore ignore1 ignore2 ignore3))
301 
+      (setf pos newpos))
302 
+
303 
+    (until eof
304 
+      (multiple-value-setq (newpart eof pos)
305 
+	(parse-mime-structure-1 stream boundary
306 
+				(equalp (mime-part-subtype part) "digest")
307 
+				pos mbox))
308 
+      (push newpart parts))
309 
+
310 
+    (setf (mime-part-parts part) (nreverse parts))
311 
+
312 
+    ;; Discard everything that follows until we reach the parent-boundary.
313 
+    (multiple-value-bind (ignore1 ignore2 eof pos)
314 
+	(read-until-boundary stream parent-boundary pos mbox)
315 
+      (declare (ignore ignore1 ignore2))
316 
+
317 
+      (setf (mime-part-body-size part) (- pos startpos))
318 
+
319 
+      (values part eof pos))))
320 
+;; support
321 
+
322 
+;; Returns headers alist and the number of bytes read.
323 
+(defun parse-headers (stream mbox)
324 
+  (declare (optimize (speed 3) (safety 0)))
325 
+  (let ((count 0) headers colonpos name value)
326 
+    (excl::with-resource (line mime-line)
327 
+      (loop
328 
+	(let ((bytes (mime-read-line line stream mbox)))
329 
+	  (if (null bytes)
330 
+	      (return))
331 
+
332 
+	  (incf count bytes)
333 
+
334 
+	  (mime-line-string-right-trim line)
335 
+	  (if (string= line "")
336 
+	      (return))
337 
+
338 
+	  ;; Continuation line
339 
+	  (if* (and (excl::whitespace-char-p (char line 0)) headers)
340 
+	     then ;; yes
341 
+		  (setf (cdr (car headers))
342 
+		    (concatenate 'string (cdr (car headers)) " "
343 
+				 (string-left-trim *whitespace* line)))
344 
+	     else (setf colonpos (position #\: line))
345 
+		  (if (null colonpos) ;; bogus input
346 
+		      (return))
347 
+		  (setf name
348 
+		    (string-trim *whitespace* (subseq line 0 colonpos)))
349 
+		  (let ((startpos (position-if-not #'excl::whitespace-char-p
350 
+					       line :start (1+ colonpos))))
351 
+		    (setf value
352 
+		      (if* (null startpos)
353 
+			 then ""
354 
+			 else (subseq line startpos))))
355 
+
356 
+		  (push (cons name value) headers)))))
357 
+
358 
+    (values (nreverse headers) count)))
359 
+
360 
+;; Returns: (1) position of the end of the part
361 
+;;          (2) number of lines read
362 
+;;          (3) :eof if EOF, :boundary if close delimiter was seen, else nil
363 
+;;          (4) new stream position (post boundary read)
364 
+(defun read-until-boundary (stream boundary pos mbox)
365 
+  (let ((lines 0)
366 
+	(lastpos pos)
367 
+	bytes delimiter close-delimiter)
368 
+
369 
+    (excl::with-resource (line mime-line)
370 
+
371 
+      (when boundary
372 
+	(setf delimiter (concatenate 'string "--" boundary))
373 
+	(setf close-delimiter (concatenate 'string delimiter "--")))
374 
+
375 
+      (loop
376 
+	(setf bytes (mime-read-line line stream mbox))
377 
+
378 
+	(if (or (null bytes)
379 
+		(and delimiter (prefixp delimiter line)))
380 
+	    (return))
381 
+
382 
+	(incf pos bytes)
383 
+
384 
+	(setf lastpos pos)
385 
+	(incf lines))
386 
+
387 
+      (values lastpos
388 
+	      lines
389 
+	      (cond ((null bytes)
390 
+		     :eof)
391 
+		    ((and close-delimiter (prefixp close-delimiter line))
392 
+		     :boundary)
393 
+		    (t nil))
394 
+	      pos))))
395 
+
396 
+;; Returns values:
397 
+;; Number of characters read, including CR/LFs. Returns nil if EOF.
398 
+(defun mime-read-line (buffer stream mbox)
399 
+  (declare (optimize (speed 3) (safety 0)))
400 
+  (excl::with-underlying-simple-vector (buffer sbuf)
401 
+    (declare (type string sbuf))
402 
+    (let* ((pos 0)
403 
+	   (count 0)
404 
+	   (max (array-dimension buffer 0))
405 
+	   (crlf (eq (eol-convention stream) :dos))
406 
+	   char)
407 
+      (declare (fixnum pos count max))
408 
+      (while (and (< pos max) (setf char (read-char stream nil nil)))
409 
+	(incf count)
410 
+	(when (char= char #\newline)
411 
+	  (if crlf
412 
+	      (incf count)) ;; account for carriage return as well
413 
+	  (return))
414 
+
415 
+	(setf (schar sbuf pos) char)
416 
+	(incf pos))
417 
+
418 
+      (setf (fill-pointer buffer) pos)
419 
+
420 
+      ;; Treat mbox "From " line as EOF
421 
+      (if (and mbox (prefixp "From " buffer))
422 
+	  (setf count 0))
423 
+
424 
+      (if (/= count 0) count))))
425 
+
426 
+(defun mime-line-string-right-trim (line)
427 
+  (let ((pos (position-if-not #'excl::whitespace-char-p line :from-end t)))
428 
+    (if pos
429 
+	(setf (fill-pointer line) (1+ pos)))))
430 
+
431 
+;;; body streams stuff
432 
+
433 
+(defun body-stream-func (outstream instream boundary)
434 
+  (let ((delimiter (if boundary (concatenate 'string "--" boundary)))
435 
+	line)
436 
+
437 
+    (while (setf line (read-line instream nil nil))
438 
+      (if (and delimiter (prefixp delimiter line))
439 
+	  (return))
440 
+
441 
+      (write-line line outstream))))
442 
+
443 
+(defun body-stream-func-with-count (outstream instream count)
444 
+  (declare (optimize (speed 3))
445 
+	   (fixnum count))
446 
+  (let (char)
447 
+    (dotimes (n count)
448 
+      (declare (fixnum n))
449 
+      (setf char (read-char instream nil nil))
450 
+      (if* (null char)
451 
+	 then (return)
452 
+	 else (write-char char outstream)))))
453 
+
454 
+
455 
+(defmacro with-part-body-stream ((sym instream part &key count) &body body)
456 
+  (if* count
457 
+     then
458 
+	  `(with-function-input-stream (,sym #'body-stream-func-with-count
459 
+					     ,instream ,count)
460 
+	     ,@body)
461 
+     else
462 
+	  `(with-function-input-stream (,sym #'body-stream-func
463 
+					     ,instream
464 
+					     (mime-part-boundary ,part))
465 
+	     ,@body)))
466 
+
467 
+;;; testing
468 
+
469 
+#|
470 
+(defun test-parse-mime (file &key (pretty t))
471 
+  (with-open-file (f file)
472 
+    (let ((res     (parse-mime-structure f)))
473 
+      (if pretty
474 
+	  (pprint-rfc822-part res)
475 
+	res))))
476 
+
477 
+(defun pprint-rfc822-part (thing &optional (prefix ""))
478 
+  (if (null thing)
479 
+      (error "Strange. something called pprint-rfc822-part with nil"))
480 
+  (let ((type (mime-part-type thing))
481 
+	(subtype (mime-part-subtype thing)))
482 
+    (format t "~AHEADER ([RFC-2822] header of the message)~%" prefix)
483 
+    (format t "~ATEXT   ([RFC-2822] text body of the message) ~A/~A~%" prefix type subtype)
484 
+
485 
+    (if* (message-rfc822-p type subtype)
486 
+       then ;; XXX .. what should the new prefix be?
487 
+	    (pprint-rfc822-part (mime-part-message thing) prefix)
488 
+     elseif (equalp type "multipart")
489 
+       then (pprint-multipart thing prefix))))
490 
+
491 
+(defun pprint-multipart (thing prefix)
492 
+  (let ((id 1))
493 
+    (dolist (part (mime-part-parts thing))
494 
+      (let ((type (mime-part-type part))
495 
+	    (subtype (mime-part-subtype part)))
496 
+	(format t "~a~a      ~a/~a~%" prefix id type subtype)
497 
+	(if* (message-rfc822-p type subtype)
498 
+	   then (pprint-rfc822-part (mime-part-message part)
499 
+				    (format nil "~a~a." prefix id))
500 
+	 elseif (equalp type "multipart")
501 
+	   then (pprint-multipart part (format nil "~a~a." prefix id)))
502 
+	(incf id)))))
503 
+|#
mime-transfer-encoding.cl
History View file @ f6cd6a7
0 504 
new file mode 100644
... ... 
@@ -0,0 +1,239 @@
1 
+;; $Id: mime-transfer-encoding.cl,v 1.1 2006/01/26 23:53:27 dancy Exp $
2 
+
3 
+(defpackage :net.post-office
4 
+  (:use #:lisp #:excl)
5 
+  (:export
6 
+   #:base64-encode-stream
7 
+   #:qp-encode-stream))
8 
+
9 
+(in-package :net.post-office)
10 
+
11 
+;;; Supported transfer encodings
12 
+
13 
+;; encoders
14 
+
15 
+(defun raw-encode-stream (instream outstream)
16 
+  (declare (optimize (speed 3) (safety 0)))
17 
+  (let ((buf (make-array 4096 :element-type '(unsigned-byte 8)))
18 
+	got)
19 
+    (declare (dynamic-extent buf)
20 
+	     (fixnum got))
21 
+    (while (/= 0 (setf got (read-vector buf instream)))
22 
+      (write-vector buf outstream :end got))))
23 
+
24 
+;; Temporary until this change is made in excl.cl.
25 
+(defparameter excl::*to-base64*
26 
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
27 
+
28 
+;; This should be added to the excl package.
29 
+(defun base64-encode-stream (instream outstream &key (wrap-at 72))
30 
+  (declare (optimize (speed 3)))
31 
+  ;; inbuf _must_ be a size which is a multiple of three.  The
32 
+  ;; encoding code depends on it.  outbuf must be 4/3rds bigger than
33 
+  ;; inbuf.
34 
+  (let ((inbuf (make-array #.(* 3 4096) :element-type '(unsigned-byte 8)))
35 
+	(outbuf (make-array #.(* 4 4096) :element-type 'character))
36 
+	remaining end outpos inpos value)
37 
+    (declare (dynamic-extent inbuf outbuf)
38 
+	     (fixnum remaining outpos end inpos value))
39 
+
40 
+    (macrolet ((outchar (char)
41 
+		 `(progn
42 
+		    (setf (schar outbuf outpos) ,char)
43 
+		    (incf outpos)))
44 
+	       (outchar-base64 (x)
45 
+		 `(outchar (schar excl::*to-base64* (logand ,x 63)))))
46 
+
47 
+      (flet ((read-full-vector (buf stream)
48 
+	       (let ((pos 0)
49 
+		     (max (length buf))
50 
+		     newpos)
51 
+		 (declare (fixnum pos max got newpos))
52 
+		 (while (< pos max)
53 
+		   (setf newpos (read-vector buf stream :start pos))
54 
+		   (if* (= newpos pos)
55 
+		      then (return))
56 
+		   (setf pos newpos))
57 
+		 pos)))
58 
+
59 
+	(while (/= 0 (setf end (read-full-vector inbuf instream)))
60 
+	  (setf remaining end)
61 
+	  (setf inpos 0)
62 
+	  (setf outpos 0)
63 
+	  (while (> remaining 0)
64 
+	    (if* (>= remaining 3)
65 
+	       then (setf value (logior (ash (aref inbuf inpos) 16)
66 
+					(ash (aref inbuf (+ 1 inpos)) 8)
67 
+					(aref inbuf (+ 2 inpos))))
68 
+		    (incf inpos 3)
69 
+		    (decf remaining 3)
70 
+		    (outchar-base64 (ash value -18))
71 
+		    (outchar-base64 (ash value -12))
72 
+		    (outchar-base64 (ash value -6))
73 
+		    (outchar-base64 value)
74 
+	     elseif (= remaining 2)
75 
+	       then (setf value (logior (ash (aref inbuf inpos) 16)
76 
+					(ash (aref inbuf (+ 1 inpos)) 8)))
77 
+		    (incf inpos 2)
78 
+		    (decf remaining 2)
79 
+		    (outchar-base64 (ash value -18))
80 
+		    (outchar-base64 (ash value -12))
81 
+		    (outchar-base64 (ash value -6))
82 
+		    (outchar #\=)
83 
+	       else (setf value (ash (aref inbuf inpos) 16))
84 
+		    (incf inpos)
85 
+		    (decf remaining)
86 
+		    (outchar-base64 (ash value -18))
87 
+		    (outchar-base64 (ash value -12))
88 
+		    (outchar #\=)
89 
+		    (outchar #\=)))
90 
+
91 
+	  ;; generate output.
92 
+	  (if* (null wrap-at)
93 
+	     then (write-string outbuf outstream :end outpos)
94 
+	     else (setf inpos 0)
95 
+		  (while (< inpos outpos)
96 
+		    (let ((len (min (- outpos inpos) wrap-at)))
97 
+		      (write-string outbuf outstream
98 
+				    :start inpos
99 
+				    :end (+ inpos len))
100 
+		      (incf inpos len)
101 
+		      (write-char #\newline outstream)))))))))
102 
+
103 
+(defconstant *qp-hex-digits* "0123456789ABCDEF")
104 
+
105 
+;; wrap-at is not a hard limit but more of a suggestion.  it may be
106 
+;; late by by 3 characters.
107 
+(defun qp-encode-stream (instream outstream &key (wrap-at 72))
108 
+  (declare (optimize (speed 3)))
109 
+  (let ((prev 0)
110 
+	(outcol 0)
111 
+	byte)
112 
+    (declare (fixnum byte prev))
113 
+
114 
+    (macrolet ((whitespace (x)
115 
+		 (let ((xx (gensym)))
116 
+		   `(let ((,xx ,x))
117 
+		      (or (= ,xx 9) (= ,xx 32))))))
118 
+
119 
+      (labels ((check-linewrap ()
120 
+		 (if* (and wrap-at (>= outcol wrap-at))
121 
+		    then (format outstream "=~%" outstream)
122 
+			 (setf outcol 0)))
123 
+	       (check-deferred ()
124 
+		 (if* (and (= prev 13) (/= byte 10))
125 
+		    then ;; previous byte was bare CR.  Handle
126 
+			 (check-linewrap)
127 
+			 (write-string "=0D" outstream)
128 
+			 (incf outcol 3))
129 
+
130 
+		 (if* (whitespace prev)
131 
+		    then (if* (or (= byte 0) (= byte 10) (= byte 13))
132 
+			    then ;; EOF, EOL, probable EOL.  Encode.
133 
+				 (check-linewrap)
134 
+				 (format outstream "=20")
135 
+				 (incf outcol 3)
136 
+			    else ;; Safe to print deferred whitespace
137 
+				 (check-linewrap)
138 
+				 (write-char (code-char prev) outstream)
139 
+				 (incf outcol 1)))))
140 
+
141 
+	(while (setf byte (read-byte instream nil nil))
142 
+	  (check-deferred)
143 
+
144 
+	  (if* (or (and (>= byte 33) (<= byte 60))
145 
+		   (and (>= byte 62) (<= byte 126)))
146 
+	     then (check-linewrap)
147 
+		  (write-char (code-char byte) outstream)
148 
+		  (incf outcol)
149 
+	   elseif (or (= byte 13) (whitespace byte))
150 
+	     thenret ;; defer handling
151 
+	   elseif (= byte 10) ;; LF
152 
+	     then (write-char #\newline outstream)
153 
+		  (setf outcol 0)
154 
+	     else (check-linewrap)
155 
+		  (format outstream "=~c~c"
156 
+			  (schar *qp-hex-digits*
157 
+				 (ash byte -4))
158 
+			  (schar *qp-hex-digits*
159 
+				 (logand byte #xf)))
160 
+		  (incf outcol 3))
161 
+
162 
+	  (setf prev byte))
163 
+
164 
+	;; Handle final deferred data
165 
+	(setf byte 0)
166 
+	(check-deferred)))))
167 
+
168 
+
169 
+#|
170 
+
171 
+(defun mime-decode-transfer-encoding (outstream instream encoding)
172 
+  (cond
173 
+   ((equalp encoding "quoted-printable")
174 
+    (decode-quoted-printable outstream instream))
175 
+   (t
176 
+    (decode-unmodified outstream instream))))
177 
+
178 
+(defmacro with-decoded-transfer-encoding-stream ((sym instream encoding) &body body)
179 
+  `(with-function-input-stream (,sym #'mime-decode-transfer-encoding ,instream
180 
+				     ,encoding)
181 
+     ,@body))
182 
+
183 
+(defun decoded-part-body-stream-func (outstream instream part)
184 
+  (with-part-body-stream (part-body-stream instream part)
185 
+    (mime-decode-transfer-encoding outstream part-body-stream
186 
+				   (mime-part-encoding part))))
187 
+
188 
+(defmacro with-decoded-part-body-stream ((sym instream part) &body body)
189 
+  `(with-function-input-stream (,sym #'decoded-part-body-stream-func
190 
+				     ,instream ,part)
191 
+     ,@body))
192 
+
193 
+
194 
+;; The decoders
195 
+
196 
+(defun decode-unmodified (outstream instream)
197 
+  (let (line)
198 
+    (while (setf line (read-line instream nil nil))
199 
+      (write-line line outstream))))
200 
+
201 
+(defun decode-quoted-printable (outstream instream)
202 
+  (declare (optimize (speed 3)))
203 
+  (let (line max pos char char2 softlinebreak)
204 
+    (while (setf line (read-line instream nil nil))
205 
+      (setf max (length line))
206 
+      (setf pos 0)
207 
+
208 
+      (macrolet ((getchar ()
209 
+		   `(if* (>= pos max)
210 
+		       then (setf softlinebreak t)
211 
+			    (return)
212 
+		       else (prog1 (schar line pos) (incf pos)))))
213 
+
214 
+	(while (< pos max)
215 
+	  (setf char (getchar))
216 
+
217 
+	  (if* (char= char #\=)
218 
+	     then ;; If EOL occurs during the attempt to get the next
219 
+		  ;; two chars, it will be treated as a soft line break.
220 
+		  (setf char (getchar))
221 
+		  (setf char2 (getchar))
222 
+
223 
+		  (let ((value (logior
224 
+				(ash (or (position char *qp-hex-digits*) -1) 4)
225 
+				(or (position char2 *qp-hex-digits*) -1))))
226 
+		    (if* (> value -1)
227 
+		       then
228 
+			    (write-byte value outstream)
229 
+		       else
230 
+			    ;; We got some bogus input.  Leave it untouched
231 
+			    (write-char #\= outstream)
232 
+			    (write-char char outstream)
233 
+			    (write-char char2 outstream)))
234 
+	     else (write-char char outstream)))
235 
+
236 
+	(if* softlinebreak
237 
+	   then (setf softlinebreak nil)
238 
+	   else (write-char #\newline outstream))))))
239 
+|#
mime.cl
History View file @ f6cd6a7
0 240 
new file mode 100644
... ... 
@@ -0,0 +1,611 @@
1 
+;; $Id: mime.cl,v 1.1 2006/01/26 23:53:27 dancy Exp $
2 
+
3 
+(defpackage :net.post-office
4 
+  (:use #:lisp #:excl)
5 
+  (:export
6 
+   ;; functions/methods
7 
+   #:make-mime-part
8 
+   #:mime-part-writer
9 
+   #:mime-part-p
10 
+   #:mime-part-constructed-p
11 
+
12 
+   ;; macros
13 
+   #:mime-get-header
14 
+   #:with-mime-part-constructed-stream
15 
+
16 
+   ;; slot accessors
17 
+   #:mime-part-type
18 
+   #:mime-part-subtype
19 
+   #:mime-part-parameters
20 
+   #:mime-part-id
21 
+   #:mime-part-description
22 
+   #:mime-part-encoding
23 
+   #:mime-part-headers
24 
+   #:mime-part-parts
25 
+   #:mime-part-boundary))
26 
+
27 
+(in-package :net.post-office)
28 
+
29 
+(eval-when (compile load eval)
30 
+  (require :osi)
31 
+  (require :regexp2))
32 
+
33 
+(defclass mime-part ()
34 
+  (
35 
+   (type :accessor mime-part-type :initform nil)
36 
+   (subtype :accessor mime-part-subtype :initform nil)
37 
+   (parameters :accessor mime-part-parameters :initform nil) ;; alist
38 
+   (id :accessor mime-part-id :initform nil)
39 
+   (description :accessor mime-part-description :initform nil)
40 
+   (encoding :accessor mime-part-encoding :initform nil)
41 
+   (headers ;; parsed headers alist
42 
+    :accessor mime-part-headers :initform nil)
43 
+   (parts ;; list of subparts (for multipart types)
44 
+    :accessor mime-part-parts :initform nil)
45 
+   (boundary :accessor mime-part-boundary :initform nil)))
46 
+
47 
+(defclass mime-part-constructed (mime-part)
48 
+  (
49 
+   (source-type :accessor source-type)
50 
+   (source :accessor source)
51 
+   (disposition :accessor disposition :initform nil)
52 
+   (disposition-name :accessor disposition-name :initform nil)))
53 
+
54 
+(defmacro mime-get-header (header part)
55 
+  `(cdr (assoc ,header (mime-part-headers ,part) :test #'equalp)))
56 
+
57 
+(defun message-rfc822-p (type subtype)
58 
+  (and (equalp type "message") (equalp subtype "rfc822")))
59 
+
60 
+(defun multipart-p (part)
61 
+  (equalp (mime-part-type part) "multipart"))
62 
+
63 
+(defun multipart-mixed-p (part)
64 
+  (and (equalp (mime-part-type part) "multipart")
65 
+       (equalp (mime-part-subtype part) "mixed")))
66 
+
67 
+(defun mime-part-p (thing)
68 
+  (typep thing 'mime-part))
69 
+
70 
+(defun mime-part-constructed-p (thing)
71 
+  (typep thing 'mime-part-constructed))
72 
+
73 
+(defun generate-boundary ()
74 
+  (declare (optimize (speed 3)))
75 
+  (let ((hex "01234567890abcdef"))
76 
+    (with-output-to-string (s)
77 
+      (write-string "----------_" s)
78 
+      (dotimes (n 32)
79 
+	(write-char (schar hex (random 16)) s)))))
80 
+
81 
+(defun make-mime-part (&key content-type encoding headers
82 
+			    (attachmentp nil attachmentp-supplied)
83 
+			    name text (start 0) end file
84 
+			    subparts (external-format :default)
85 
+			    parameters charset id description)
86 
+  (let ((part (make-instance 'mime-part-constructed))
87 
+	type subtype multipart textp filepath)
88 
+
89 
+    (if* (and text file)
90 
+       then (error "Only one of :text or :file may be specified"))
91 
+
92 
+    (if* (and text (null end))
93 
+       then (setf end (length text)))
94 
+
95 
+    (when file
96 
+      (if* (streamp file)
97 
+	 then (setf filepath (ignore-errors (namestring file)))
98 
+	 else (setf filepath file)))
99 
+
100 
+    (when (null content-type)
101 
+      (if* filepath
102 
+	 then (setf content-type (lookup-mime-type filepath)))
103 
+
104 
+      (when (null content-type)
105 
+	(setf content-type
106 
+	  (if* subparts
107 
+	     then "multipart/mixed"
108 
+	   elseif file
109 
+	     then "application/octet-stream"
110 
+	   elseif (and text (stringp text))
111 
+	     then "text/plain"
112 
+	     else "application/octet-stream"))))
113 
+
114 
+    (let ((pos (position #\/ content-type)))
115 
+      (if (null pos)
116 
+	  (error "Invalid content-type: ~s" content-type))
117 
+
118 
+      (setf type (subseq content-type 0 pos))
119 
+      (setf subtype (subseq content-type (1+ pos))))
120 
+
121 
+    (setf multipart (equalp type "multipart"))
122 
+    (setf textp (or (equalp type "text") (message-rfc822-p type subtype)))
123 
+
124 
+    (if* (and subparts (not multipart))
125 
+       then (error "subparts may not be specified for non-multipart parts"))
126 
+
127 
+    (if* (and (not multipart) (null text) (null file))
128 
+       then (error "One of :text or :file must be specified"))
129 
+
130 
+    (if* (and (null charset) textp)
131 
+       then (setf charset
132 
+	      (or
133 
+	       (guess-charset-from-ef (find-external-format external-format))
134 
+	       "us-ascii")))
135 
+
136 
+    (when (and (not multipart) (null encoding))
137 
+      (if* textp
138 
+	 then (if* (equalp charset "us-ascii")
139 
+		 then (setf encoding "7bit")
140 
+		 else (setf encoding "quoted-printable"))
141 
+	 else (setf encoding "base64")))
142 
+
143 
+    (setf (mime-part-type part) type)
144 
+    (setf (mime-part-subtype part) subtype)
145 
+    (setf (mime-part-parameters part) parameters)
146 
+    (if* charset
147 
+       then (push (cons "charset" charset) (mime-part-parameters part)))
148 
+    (setf (mime-part-encoding part) encoding)
149 
+    (setf (mime-part-id part) id)
150 
+    (setf (mime-part-description part) description)
151 
+    (setf (mime-part-headers part) headers)
152 
+
153 
+    (if* file
154 
+       then (setf (source part) file)
155 
+	    (if* (streamp file)
156 
+	       then (setf (source-type part) :stream)
157 
+	       else (with-open-file (f file)) ;; make sure we can read it.
158 
+		    (setf (source-type part) :file))
159 
+	    (if* (not attachmentp-supplied)
160 
+	       then (setf attachmentp t))
161 
+       else (setf (source-type part) :usb8)
162 
+	    (setf (source part)
163 
+	      (if* (stringp text)
164 
+		 then (string-to-octets text :null-terminate nil
165 
+					:external-format external-format)
166 
+		 else (subseq text start end))))
167 
+
168 
+    (if* (and (not textp) (not attachmentp) (not multipart))
169 
+       then (setf (disposition part) "inline"))
170 
+
171 
+    (when attachmentp
172 
+      (setf (disposition part) "attachment")
173 
+      (if* (and (null name) file)
174 
+	 then (setf name (excl.osi:basename filepath))))
175 
+
176 
+    (if* name
177 
+       then (setf (disposition-name part) name))
178 
+
179 
+    (if* multipart
180 
+       then (let ((boundary (generate-boundary)))
181 
+	      (setf (mime-part-boundary part) boundary)
182 
+	      (push (cons "boundary" boundary)
183 
+		    (mime-part-parameters part))))
184 
+
185 
+    (setf (mime-part-parts part) subparts)
186 
+
187 
+    part))
188 
+
189 
+(defparameter *ef-nick-to-mime-charset*
190 
+    '((:ascii . "us-ascii")
191 
+      (:iso-2022-jp . "iso-2022-jp")
192 
+      (:koi8-r . "koi8-r")
193 
+      (:shiftjis . "shift_jis")
194 
+      (:euc . "euc-jp")
195 
+      (:gb2312 . "gb2312")
196 
+      (:big5 . "big5")
197 
+      (:utf8 . "utf-8")))
198 
+
199 
+(defun guess-charset-from-ef (ef)
200 
+  (dolist (nick (ef-nicknames (find-external-format ef)))
201 
+    (let ((charset (cdr (assoc nick *ef-nick-to-mime-charset*))))
202 
+      (if charset (return-from guess-charset-from-ef charset))))
203 
+  (let ((ef-name (string-downcase (symbol-name (ef-name (crlf-base-ef ef))))))
204 
+    ;; Try iso-8559-x names.
205 
+    (multiple-value-bind (found ignore suffix)
206 
+	(match-re (load-time-value "^iso8859-(\\d+)-base") ef-name)
207 
+      (declare (ignore ignore))
208 
+      (if found
209 
+	  (return-from guess-charset-from-ef
210 
+	    (format nil "iso-8859-~a" suffix))))
211 
+
212 
+    ;; Try windows- names.
213 
+    (multiple-value-bind (found whole value)
214 
+	(match-re (load-time-value "^(\\d+)-base$") ef-name)
215 
+      (declare (ignore whole))
216 
+      (if found
217 
+	  (return-from guess-charset-from-ef
218 
+	    (format nil "windows-~a" value))))))
219 
+
220 
+(defmethod mime-part-writer ((part mime-part-constructed)
221 
+			     &key (stream *terminal-io*))
222 
+  (mime-part-constructed-writer part stream t))
223 
+
224 
+(defun mime-part-constructed-writer (part stream top-level)
225 
+  (if* top-level
226 
+     then (format stream "MIME-Version: 1.0~%"))
227 
+
228 
+  ;; First dump user-supplied headers.
229 
+  (dolist (h (mime-part-headers part))
230 
+    (format stream "~a: ~a~%" (car h) (cdr h)))
231 
+
232 
+  ;; Now dump headers that are based on class fields.
233 
+
234 
+  (let* ((type (mime-part-type part))
235 
+	 (multipart (equalp type "multipart")))
236 
+    (format stream "Content-Type: ~a/~a" type (mime-part-subtype part))
237 
+    (dolist (param (mime-part-parameters part))
238 
+      (format stream ";~%    ~a=~s" (car param) (cdr param)))
239 
+    (format stream "~%")
240 
+
241 
+    (if* (mime-part-encoding part)
242 
+       then (format stream "Content-Transfer-Encoding: ~a~%"
243 
+		    (mime-part-encoding part)))
244 
+
245 
+    (if* (mime-part-id part)
246 
+       then (format stream "Content-Id: ~a~%" (mime-part-id part)))
247 
+
248 
+    (if* (mime-part-description part)
249 
+       then (format stream "Content-Description: ~a~%"
250 
+		    (mime-part-description part)))
251 
+
252 
+
253 
+    (if* (disposition part)
254 
+       then (format stream "Content-Disposition: ~a" (disposition part))
255 
+	    (if* (disposition-name part)
256 
+	       then (format stream ";~%    filename=~s" (disposition-name part)))
257 
+	    (format stream "~%"))
258 
+
259 
+    (format stream "~%") ;; terminate headers
260 
+
261 
+    (if* multipart
262 
+       then (let ((boundary (mime-part-boundary part)))
263 
+	      (if top-level
264 
+		  (format stream "~
265 
+This is a multi-part message in MIME format.~%"))
266 
+	      (dolist (subpart (mime-part-parts part))
267 
+		(format stream "~%--~a~%" boundary)
268 
+		(mime-part-constructed-writer subpart stream nil))
269 
+	      (format stream "~%--~a--~%" boundary))
270 
+       else (let ((instream (if* (eq (source-type part) :stream)
271 
+			       then (source part)
272 
+			     elseif (eq (source-type part) :file)
273 
+			       then (open (source part))
274 
+			       else (make-buffer-input-stream (source part)))))
275 
+	      (unwind-protect
276 
+		  (let ((encoding (mime-part-encoding part)))
277 
+		    (if* (equalp encoding "base64")
278 
+		       then (base64-encode-stream instream stream)
279 
+		     elseif (equalp encoding "quoted-printable")
280 
+		       then (qp-encode-stream instream stream)
281 
+		       else (raw-encode-stream instream stream)))
282 
+		    ;; cleanup
283 
+		(if* (not (eq (source-type part) :stream))
284 
+		   then (close instream)))))))
285 
+
286 
+(defun mime-part-writer-1 (stream part)
287 
+  (mime-part-writer part :stream stream))
288 
+
289 
+(defmacro with-mime-part-constructed-stream ((stream part) &body body)
290 
+  `(excl::with-function-input-stream (,stream #'mime-part-writer-1 ,part)
291 
+     ,@body))
292 
+
293 
+;; Stuff ripped off from aserve
294 
+
295 
+(defun split-namestring (file)
296 
+  ;; split the namestring into root and tail and then the tail
297 
+  ;; into name and type
298 
+  ;;
299 
+  ;; any of the return value can be nil if the corresponding item
300 
+  ;; isn't present.
301 
+  ;;
302 
+  ;; rules for splitting the tail into name and type components:
303 
+  ;;  if the last period in the tail is at the beginning or end of the
304 
+  ;;  tail, then the name is exactly the tail and type is nil.
305 
+  ;;  Thus .foo and bar.  are just names, no type
306 
+  ;;  but .foo.c  has a name of ".foo" and a type of "c"
307 
+  ;;  Thus if there is a non-nil type then it means that
308 
+  ;;    1. there will be a non nil name as well
309 
+  ;;    2. to reconstruct the filename you need to add a period between
310 
+  ;;       the name and type.
311 
+  ;;
312 
+  (let ((pos (min (or (or (position #\/ file :from-end t) most-positive-fixnum)
313 
+		      #+mswindows (position #\\ file :from-end t))))
314 
+	root
315 
+	tail)
316 
+
317 
+    (if* (equal file "") then (return-from split-namestring nil))
318 
+
319 
+    (if* (and pos (< pos most-positive-fixnum))
320 
+       then ; we have root and tail
321 
+	    (if* (eql pos (1- (length file)))
322 
+	       then ; just have root
323 
+		    (return-from split-namestring
324 
+		      (values file nil nil nil)))
325 
+
326 
+
327 
+	    (setq root (subseq file 0 (1+ pos))
328 
+		  tail (subseq file (1+ pos)))
329 
+       else (setq tail file))
330 
+
331 
+
332 
+    ; split the tail
333 
+    (let ((pos (position #\. tail :from-end t)))
334 
+      (if* (or (null pos)
335 
+	       (zerop pos)
336 
+	       (equal pos (1- (length tail))))
337 
+	 then ; name begins or ends with . so it's not
338 
+	      ; a type separator
339 
+	      (values root tail tail nil)
340 
+	 else ; have all pieces
341 
+	      (values root tail
342 
+		      (subseq tail 0 pos)
343 
+		      (subseq tail (1+ pos)))))))
344 
+
345 
+
346 
+; we can specify either an exact url or one that handles all
347 
+; urls with a common prefix.
348 
+;;
349 
+;; if the prefix is given as a list: e.g. ("ReadMe") then it says that
350 
+;; this mime type applie to file named ReadMe.  Note that file types
351 
+;; are checked first and if no match then a filename match is done.
352 
+;
353 
+(defparameter *file-type-to-mime-type*
354 
+    ;; this list constructed by generate-mime-table in parse.cl
355 
+    '(("application/EDI-Consent") ("application/EDI-X12") ("application/EDIFACT")
356 
+      ("application/activemessage") ("application/andrew-inset" "ez")
357 
+      ("application/applefile") ("application/atomicmail")
358 
+      ("application/batch-SMTP") ("application/beep+xml") ("application/cals-1840")
359 
+      ("application/commonground") ("application/cybercash")
360 
+      ("application/dca-rft") ("application/dec-dx") ("application/dvcs")
361 
+      ("application/eshop") ("application/http") ("application/hyperstudio")
362 
+      ("application/iges") ("application/index") ("application/index.cmd")
363 
+      ("application/index.obj") ("application/index.response")
364 
+      ("application/index.vnd") ("application/iotp") ("application/ipp")
365 
+      ("application/isup") ("application/font-tdpfr")
366 
+      ("application/mac-binhex40" "hqx") ("application/mac-compactpro" "cpt")
367 
+      ("application/macwriteii") ("application/marc") ("application/mathematica")
368 
+      ("application/mathematica-old") ("application/msword" "doc")
369 
+      ("application/news-message-id") ("application/news-transmission")
370 
+      ("application/ocsp-request") ("application/ocsp-response")
371 
+      ("application/octet-stream" "bin" "dms" "lha" "lzh" "exe" "class" "so" "dll"
372 
+       "img" "iso")
373 
+      ("application/ogg" "ogg") ("application/parityfec") ("application/pdf" "pdf")
374 
+      ("application/pgp-encrypted") ("application/pgp-keys")
375 
+      ("application/pgp-signature") ("application/pkcs10")
376 
+      ("application/pkcs7-mime") ("application/pkcs7-signature")
377 
+      ("application/pkix-cert") ("application/pkix-crl") ("application/pkixcmp")
378 
+      ("application/postscript" "ai" "eps" "ps")
379 
+      ("application/prs.alvestrand.titrax-sheet") ("application/prs.cww")
380 
+      ("application/prs.nprend") ("application/qsig")
381 
+      ("application/remote-printing") ("application/riscos")
382 
+      ("application/rtf" "rtf") ("application/sdp") ("application/set-payment")
383 
+      ("application/set-payment-initiation") ("application/set-registration")
384 
+      ("application/set-registration-initiation") ("application/sgml")
385 
+      ("application/sgml-open-catalog") ("application/sieve") ("application/slate")
386 
+      ("application/smil" "smi" "smil") ("application/timestamp-query")
387 
+      ("application/timestamp-reply") ("application/vemmi")
388 
+      ("application/vnd.3M.Post-it-Notes") ("application/vnd.FloGraphIt")
389 
+      ("application/vnd.accpac.simply.aso") ("application/vnd.accpac.simply.imp")
390 
+      ("application/vnd.acucobol") ("application/vnd.aether.imp")
391 
+      ("application/vnd.anser-web-certificate-issue-initiation")
392 
+      ("application/vnd.anser-web-funds-transfer-initiation")
393 
+      ("application/vnd.audiograph") ("application/vnd.businessobjects")
394 
+      ("application/vnd.bmi") ("application/vnd.canon-cpdl")
395 
+      ("application/vnd.canon-lips") ("application/vnd.claymore")
396 
+      ("application/vnd.commerce-battelle") ("application/vnd.commonspace")
397 
+      ("application/vnd.comsocaller") ("application/vnd.contact.cmsg")
398 
+      ("application/vnd.cosmocaller") ("application/vnd.cups-postscript")
399 
+      ("application/vnd.cups-raster") ("application/vnd.cups-raw")
400 
+      ("application/vnd.ctc-posml") ("application/vnd.cybank")
401 
+      ("application/vnd.dna") ("application/vnd.dpgraph") ("application/vnd.dxr")
402 
+      ("application/vnd.ecdis-update") ("application/vnd.ecowin.chart")
403 
+      ("application/vnd.ecowin.filerequest") ("application/vnd.ecowin.fileupdate")
404 
+      ("application/vnd.ecowin.series") ("application/vnd.ecowin.seriesrequest")
405 
+      ("application/vnd.ecowin.seriesupdate") ("application/vnd.enliven")
406 
+      ("application/vnd.epson.esf") ("application/vnd.epson.msf")
407 
+      ("application/vnd.epson.quickanime") ("application/vnd.epson.salt")
408 
+      ("application/vnd.epson.ssf") ("application/vnd.ericsson.quickcall")
409 
+      ("application/vnd.eudora.data") ("application/vnd.fdf")
410 
+      ("application/vnd.ffsns") ("application/vnd.framemaker")
411 
+      ("application/vnd.fsc.weblaunch") ("application/vnd.fujitsu.oasys")
412 
+      ("application/vnd.fujitsu.oasys2") ("application/vnd.fujitsu.oasys3")
413 
+      ("application/vnd.fujitsu.oasysgp") ("application/vnd.fujitsu.oasysprs")
414 
+      ("application/vnd.fujixerox.ddd") ("application/vnd.fujixerox.docuworks")
415 
+      ("application/vnd.fujixerox.docuworks.binder") ("application/vnd.fut-misnet")
416 
+      ("application/vnd.grafeq") ("application/vnd.groove-account")
417 
+      ("application/vnd.groove-identity-message")
418 
+      ("application/vnd.groove-injector") ("application/vnd.groove-tool-message")
419 
+      ("application/vnd.groove-tool-template") ("application/vnd.groove-vcard")
420 
+      ("application/vnd.hhe.lesson-player") ("application/vnd.hp-HPGL")
421 
+      ("application/vnd.hp-PCL") ("application/vnd.hp-PCLXL")
422 
+      ("application/vnd.hp-hpid") ("application/vnd.hp-hps")
423 
+      ("application/vnd.httphone") ("application/vnd.hzn-3d-crossword")
424 
+      ("application/vnd.ibm.afplinedata") ("application/vnd.ibm.MiniPay")
425 
+      ("application/vnd.ibm.modcap") ("application/vnd.informix-visionary")
426 
+      ("application/vnd.intercon.formnet") ("application/vnd.intertrust.digibox")
427 
+      ("application/vnd.intertrust.nncp") ("application/vnd.intu.qbo")
428 
+      ("application/vnd.intu.qfx") ("application/vnd.irepository.package+xml")
429 
+      ("application/vnd.is-xpr") ("application/vnd.japannet-directory-service")
430 
+      ("application/vnd.japannet-jpnstore-wakeup")
431 
+      ("application/vnd.japannet-payment-wakeup")
432 
+      ("application/vnd.japannet-registration")
433 
+      ("application/vnd.japannet-registration-wakeup")
434 
+      ("application/vnd.japannet-setstore-wakeup")
435 
+      ("application/vnd.japannet-verification")
436 
+      ("application/vnd.japannet-verification-wakeup") ("application/vnd.koan")
437 
+      ("application/vnd.lotus-1-2-3") ("application/vnd.lotus-approach")
438 
+      ("application/vnd.lotus-freelance") ("application/vnd.lotus-notes")
439 
+      ("application/vnd.lotus-organizer") ("application/vnd.lotus-screencam")
440 
+      ("application/vnd.lotus-wordpro") ("application/vnd.mcd")
441 
+      ("application/vnd.mediastation.cdkey") ("application/vnd.meridian-slingshot")
442 
+      ("application/vnd.mif" "mif") ("application/vnd.minisoft-hp3000-save")
443 
+      ("application/vnd.mitsubishi.misty-guard.trustweb")
444 
+      ("application/vnd.mobius.daf") ("application/vnd.mobius.dis")
445 
+      ("application/vnd.mobius.msl") ("application/vnd.mobius.plc")
446 
+      ("application/vnd.mobius.txf") ("application/vnd.motorola.flexsuite")
447 
+      ("application/vnd.motorola.flexsuite.adsi")
448 
+      ("application/vnd.motorola.flexsuite.fis")
449 
+      ("application/vnd.motorola.flexsuite.gotap")
450 
+      ("application/vnd.motorola.flexsuite.kmr")
451 
+      ("application/vnd.motorola.flexsuite.ttc")
452 
+      ("application/vnd.motorola.flexsuite.wem")
453 
+      ("application/vnd.mozilla.xul+xml") ("application/vnd.ms-artgalry")
454 
+      ("application/vnd.ms-asf") ("application/vnd.ms-excel" "xls")
455 
+      ("application/vnd.ms-lrm") ("application/vnd.ms-powerpoint" "ppt")
456 
+      ("application/vnd.ms-project") ("application/vnd.ms-tnef")
457 
+      ("application/vnd.ms-works") ("application/vnd.mseq")
458 
+      ("application/vnd.msign") ("application/vnd.music-niff")
459 
+      ("application/vnd.musician") ("application/vnd.netfpx")
460 
+      ("application/vnd.noblenet-directory") ("application/vnd.noblenet-sealer")
461 
+      ("application/vnd.noblenet-web") ("application/vnd.novadigm.EDM")
462 
+      ("application/vnd.novadigm.EDX") ("application/vnd.novadigm.EXT")
463 
+      ("application/vnd.osa.netdeploy") ("application/vnd.palm")
464 
+      ("application/vnd.pg.format") ("application/vnd.pg.osasli")
465 
+      ("application/vnd.powerbuilder6") ("application/vnd.powerbuilder6-s")
466 
+      ("application/vnd.powerbuilder7") ("application/vnd.powerbuilder7-s")
467 
+      ("application/vnd.powerbuilder75") ("application/vnd.powerbuilder75-s")
468 
+      ("application/vnd.previewsystems.box")
469 
+      ("application/vnd.publishare-delta-tree") ("application/vnd.pvi.ptid1")
470 
+      ("application/vnd.pwg-xhtml-print+xml") ("application/vnd.rapid")
471 
+      ("application/vnd.s3sms") ("application/vnd.seemail")
472 
+      ("application/vnd.shana.informed.formdata")
473 
+      ("application/vnd.shana.informed.formtemplate")
474 
+      ("application/vnd.shana.informed.interchange")
475 
+      ("application/vnd.shana.informed.package") ("application/vnd.sss-cod")
476 
+      ("application/vnd.sss-dtf") ("application/vnd.sss-ntf")
477 
+      ("application/vnd.sun.xml.writer" "sxw")
478 
+      ("application/vnd.sun.xml.writer.template" "stw")
479 
+      ("application/vnd.sun.xml.calc" "sxc")
480 
+      ("application/vnd.sun.xml.calc.template" "stc")
481 
+      ("application/vnd.sun.xml.draw" "sxd")
482 
+      ("application/vnd.sun.xml.draw.template" "std")
483 
+      ("application/vnd.sun.xml.impress" "sxi")
484 
+      ("application/vnd.sun.xml.impress.template" "sti")
485 
+      ("application/vnd.sun.xml.writer.global" "sxg")
486 
+      ("application/vnd.sun.xml.math" "sxm") ("application/vnd.street-stream")
487 
+      ("application/vnd.svd") ("application/vnd.swiftview-ics")
488 
+      ("application/vnd.triscape.mxs") ("application/vnd.trueapp")
489 
+      ("application/vnd.truedoc") ("application/vnd.tve-trigger")
490 
+      ("application/vnd.ufdl") ("application/vnd.uplanet.alert")
491 
+      ("application/vnd.uplanet.alert-wbxml")
492 
+      ("application/vnd.uplanet.bearer-choice-wbxml")
493 
+      ("application/vnd.uplanet.bearer-choice") ("application/vnd.uplanet.cacheop")
494 
+      ("application/vnd.uplanet.cacheop-wbxml") ("application/vnd.uplanet.channel")
495 
+      ("application/vnd.uplanet.channel-wbxml") ("application/vnd.uplanet.list")
496 
+      ("application/vnd.uplanet.list-wbxml") ("application/vnd.uplanet.listcmd")
497 
+      ("application/vnd.uplanet.listcmd-wbxml") ("application/vnd.uplanet.signal")
498 
+      ("application/vnd.vcx") ("application/vnd.vectorworks")
499 
+      ("application/vnd.vidsoft.vidconference") ("application/vnd.visio")
500 
+      ("application/vnd.vividence.scriptfile") ("application/vnd.wap.sic")
501 
+      ("application/vnd.wap.slc") ("application/vnd.wap.wbxml" "wbxml")
502 
+      ("application/vnd.wap.wmlc" "wmlc")
503 
+      ("application/vnd.wap.wmlscriptc" "wmlsc") ("application/vnd.webturbo")
504 
+      ("application/vnd.wrq-hp3000-labelled") ("application/vnd.wt.stf")
505 
+      ("application/vnd.xara") ("application/vnd.xfdl")
506 
+      ("application/vnd.yellowriver-custom-menu") ("application/whoispp-query")
507 
+      ("application/whoispp-response") ("application/wita")
508 
+      ("application/wordperfect5.1") ("application/x-bcpio" "bcpio")
509 
+      ("application/x-bittorrent" "torrent") ("application/x-bzip2" "bz2")
510 
+      ("application/x-cdlink" "vcd") ("application/x-chess-pgn" "pgn")
511 
+      ("application/x-compress") ("application/x-cpio" "cpio")
512 
+      ("application/x-csh" "csh") ("application/x-director" "dcr" "dir" "dxr")
513 
+      ("application/x-dvi" "dvi") ("application/x-futuresplash" "spl")
514 
+      ("application/x-gtar" "gtar") ("application/x-gzip" "gz" "tgz")
515 
+      ("application/x-hdf" "hdf") ("application/x-javascript" "js")
516 
+      ("application/x-kword" "kwd" "kwt") ("application/x-kspread" "ksp")
517 
+      ("application/x-kpresenter" "kpr" "kpt") ("application/x-kchart" "chrt")
518 
+      ("application/x-killustrator" "kil")
519 
+      ("application/x-koan" "skp" "skd" "skt" "skm")
520 
+      ("application/x-latex" "latex") ("application/x-netcdf" "nc" "cdf")
521 
+      ("application/x-rpm" "rpm") ("application/x-sh" "sh")
522 
+      ("application/x-shar" "shar") ("application/x-shockwave-flash" "swf")
523 
+      ("application/x-stuffit" "sit") ("application/x-sv4cpio" "sv4cpio")
524 
+      ("application/x-sv4crc" "sv4crc") ("application/x-tar" "tar")
525 
+      ("application/x-tcl" "tcl") ("application/x-tex" "tex")
526 
+      ("application/x-texinfo" "texinfo" "texi")
527 
+      ("application/x-troff" "t" "tr" "roff") ("application/x-troff-man" "man")
528 
+      ("application/x-troff-me" "me") ("application/x-troff-ms" "ms")
529 
+      ("application/x-ustar" "ustar") ("application/x-wais-source" "src")
530 
+      ("application/x400-bp") ("application/xhtml+xml" "xhtml" "xht")
531 
+      ("application/xml") ("application/xml-dtd")
532 
+      ("application/xml-external-parsed-entity") ("application/zip" "zip")
533 
+      ("audio/32kadpcm") ("audio/basic" "au" "snd") ("audio/g.722.1") ("audio/l16")
534 
+      ("audio/midi" "mid" "midi" "kar") ("audio/mp4a-latm") ("audio/mpa-robust")
535 
+      ("audio/mpeg" "mpga" "mp2" "mp3") ("audio/parityfec") ("audio/prs.sid")
536 
+      ("audio/telephone-event") ("audio/tone") ("audio/vnd.cisco.nse")
537 
+      ("audio/vnd.cns.anp1") ("audio/vnd.cns.inf1") ("audio/vnd.digital-winds")
538 
+      ("audio/vnd.everad.plj") ("audio/vnd.lucent.voice") ("audio/vnd.nortel.vbk")
539 
+      ("audio/vnd.nuera.ecelp4800") ("audio/vnd.nuera.ecelp7470")
540 
+      ("audio/vnd.nuera.ecelp9600") ("audio/vnd.octel.sbc") ("audio/vnd.qcelp")
541 
+      ("audio/vnd.rhetorex.32kadpcm") ("audio/vnd.vmx.cvsd")
542 
+      ("audio/x-aiff" "aif" "aiff" "aifc") ("audio/x-mpegurl" "m3u")
543 
+      ("audio/x-pn-realaudio" "ram" "rm") ("audio/x-realaudio" "ra")
544 
+      ("audio/x-wav" "wav") ("chemical/x-pdb" "pdb") ("chemical/x-xyz" "xyz")
545 
+      ("image/bmp" "bmp") ("image/cgm") ("image/g3fax") ("image/gif" "gif")
546 
+      ("image/ief" "ief") ("image/jpeg" "jpeg" "jpg" "jpe") ("image/naplps")
547 
+      ("image/png" "png") ("image/prs.btif") ("image/prs.pti")
548 
+      ("image/tiff" "tiff" "tif") ("image/vnd.cns.inf2")
549 
+      ("image/vnd.djvu" "djvu" "djv") ("image/vnd.dwg") ("image/vnd.dxf")
550 
+      ("image/vnd.fastbidsheet") ("image/vnd.fpx") ("image/vnd.fst")
551 
+      ("image/vnd.fujixerox.edmics-mmr") ("image/vnd.fujixerox.edmics-rlc")
552 
+      ("image/vnd.mix") ("image/vnd.net-fpx") ("image/vnd.svf")
553 
+      ("image/vnd.wap.wbmp" "wbmp") ("image/vnd.xiff") ("image/x-cmu-raster" "ras")
554 
+      ("image/x-portable-anymap" "pnm") ("image/x-portable-bitmap" "pbm")
555 
+      ("image/x-portable-graymap" "pgm") ("image/x-portable-pixmap" "ppm")
556 
+      ("image/x-rgb" "rgb") ("image/x-xbitmap" "xbm") ("image/x-xpixmap" "xpm")
557 
+      ("image/x-xwindowdump" "xwd") ("message/delivery-status")
558 
+      ("message/disposition-notification") ("message/external-body")
559 
+      ("message/http") ("message/news") ("message/partial") ("message/rfc822")
560 
+      ("message/s-http") ("model/iges" "igs" "iges")
561 
+      ("model/mesh" "msh" "mesh" "silo") ("model/vnd.dwf")
562 
+      ("model/vnd.flatland.3dml") ("model/vnd.gdl") ("model/vnd.gs-gdl")
563 
+      ("model/vnd.gtw") ("model/vnd.mts") ("model/vnd.vtu")
564 
+      ("model/vrml" "wrl" "vrml") ("multipart/alternative")
565 
+      ("multipart/appledouble") ("multipart/byteranges") ("multipart/digest")
566 
+      ("multipart/encrypted") ("multipart/form-data") ("multipart/header-set")
567 
+      ("multipart/mixed") ("multipart/parallel") ("multipart/related")
568 
+      ("multipart/report") ("multipart/signed") ("multipart/voice-message")
569 
+      ("text/calendar") ("text/css" "css") ("text/directory") ("text/enriched")
570 
+      ("text/html" "html" "htm") ("text/parityfec") ("text/plain" "asc" "txt")
571 
+      ("text/prs.lines.tag") ("text/rfc822-headers") ("text/richtext" "rtx")
572 
+      ("text/rtf" "rtf") ("text/sgml" "sgml" "sgm")
573 
+      ("text/tab-separated-values" "tsv") ("text/t140") ("text/uri-list")
574 
+      ("text/vnd.DMClientScript") ("text/vnd.IPTC.NITF") ("text/vnd.IPTC.NewsML")
575 
+      ("text/vnd.abc") ("text/vnd.curl") ("text/vnd.flatland.3dml")
576 
+      ("text/vnd.fly") ("text/vnd.fmi.flexstor") ("text/vnd.in3d.3dml")
577 
+      ("text/vnd.in3d.spot") ("text/vnd.latex-z") ("text/vnd.motorola.reflex")
578 
+      ("text/vnd.ms-mediapackage") ("text/vnd.wap.si") ("text/vnd.wap.sl")
579 
+      ("text/vnd.wap.wml" "wml") ("text/vnd.wap.wmlscript" "wmls")
580 
+      ("text/x-setext" "etx") ("text/xml" "xml" "xsl")
581 
+      ("text/xml-external-parsed-entity") ("video/mp4v-es")
582 
+      ("video/mpeg" "mpeg" "mpg" "mpe") ("video/parityfec") ("video/pointer")
583 
+      ("video/quicktime" "qt" "mov") ("video/vnd.fvt") ("video/vnd.motorola.video")
584 
+      ("video/vnd.motorola.videop") ("video/vnd.mpegurl" "mxu") ("video/vnd.mts")
585 
+      ("video/vnd.nokia.interleaved-multimedia") ("video/vnd.vivo")
586 
+      ("video/x-msvideo" "avi") ("video/x-sgi-movie" "movie")
587 
+      ("x-conference/x-cooltalk" "ice")))
588 
+
589 
+(defvar *mime-types* nil)
590 
+
591 
+(defun build-mime-types-table ()
592 
+  (if* (null *mime-types*)
593 
+     then (setf *mime-types* (make-hash-table :test #'equalp))
594 
+	  (dolist (ent *file-type-to-mime-type*)
595 
+	    (dolist (type (cdr ent))
596 
+	      (setf (gethash type *mime-types*) (car ent))))))
597 
+
598 
+
599 
+(build-mime-types-table)  ;; build the table now
600 
+
601 
+;; return mime type if known
602 
+(defmethod lookup-mime-type (filename)
603 
+  (if* (pathnamep filename)
604 
+     then (setq filename (namestring filename)))
605 
+  (multiple-value-bind (root tail name type)
606 
+      (split-namestring filename)
607 
+    (declare (ignore root name))
608 
+    (if* (and type (gethash type *mime-types*))
609 
+       thenret
610 
+     elseif (gethash (list tail) *mime-types*)
611 
+       thenret)))
smtp.cl
History View file @ f6cd6a7
... ... 
@@ -24,7 +24,7 @@
24 24 
 ;; Suite 330, Boston, MA  02111-1307  USA
25 25 
 ;;
26 26 
 ;;
27 
-;; $Id: smtp.cl,v 1.9 2005/08/03 05:17:29 layer Exp $
27 
+;; $Id: smtp.cl,v 1.10 2006/01/26 23:53:27 dancy Exp $
28 28
29 29 
 ;; Description:
30 30 
 ;;   send mail to an smtp server.  See rfc821 for the spec.
... ... 
@@ -57,7 +57,7 @@
57 57 
 ;;    or the final destination).  "from" is the address to be given
58 58 
 ;;    as the sender.  "to" can be a string or a list of strings naming
59 59 
 ;;    recipients.
60 
-;;    "message" is the message to be sent
60 
+;;    "message" is the message to be sent.  It can be a string or a stream.
61 61 
 ;;    cc and bcc can be either be a string or a  list of strings
62 62 
 ;;	naming recipients.  All cc's and bcc's are sent the message
63 63 
 ;;	but the bcc's aren't included in the header created.
... ... 
@@ -73,7 +73,7 @@
73 73 
 ;;    this is like send-letter except that it doesn't build a header.
74 74 
 ;;    the messages should contain a header (and if not then sendmail
75 75 
 ;;    notices this and builds one -- other MTAs may not be that smart).
76 
-;;    The messages ia  list of strings to be concatenated together
76 
+;;    The messages ia  list of strings or streams to be concatenated together
77 77 
 ;;    and sent as one message
78 78 
 ;;
79 79 
 ;;
... ... 
@@ -113,11 +113,30 @@
113 113
114 114 
 (defun send-letter (server from to message
115 115 
 		    &key cc bcc subject reply-to headers
116 
-			 login password)
116 
+			 login password attachments)
117 117 
   ;;
118 118 
   ;; see documentation at the head of this file
119 119 
   ;;
120 
-  (let ((header (make-string-output-stream))
120 
+
121 
+  (if* (mime-part-constructed-p message)
122 
+     then (if* (and (not (multipart-mixed-p message)) attachments)
123 
+	     then (error "~
124 
+attachments are not allowed for non-multipart/mixed messages."))
125 
+     else (let ((part
126 
+		 (if* (streamp message)
127 
+		    then
128 
+			 (make-mime-part :file message)
129 
+		  elseif (stringp message)
130 
+		    then (make-mime-part :text message)
131 
+		    else (error "~
132 
+message must be a string, stream, or mime-part-constructed, not ~s" message))))
133 
+
134 
+	    (setf message
135 
+	      (if* attachments
136 
+		 then (make-mime-part :subparts (list part))
137 
+		 else part))))
138 
+
139 
+  (let ((user-header "")
121 140 
 	(tos (if* (stringp to)
122 141 
 		then (list to)
123 142 
 	      elseif (consp to)
... ... 
@@ -138,19 +157,21 @@
138 157 
 	       elseif (consp bcc)
139 158 
 		 then bcc
140 159 
 		 else (error "bcc should be a string or list, not ~s" bcc))))
141 
-    (format header "From: ~a~c~cTo: "
142 
-	    from
143 
-	    #\return
144 
-	    #\linefeed)
145 
-    (format header "~{ ~a~^,~}~c~c" tos #\return #\linefeed)
160 
+
161 
+    (push (cons "From" from) (mime-part-headers message))
162 
+    (push (cons "To" (list-to-delimited-string tos ", "))
163 
+	  (mime-part-headers message))
164 
+
146 165 
     (if* ccs
147 
-       then (format header "Cc: ~{ ~a~^,~}~c~c" ccs #\return #\linefeed))
166 
+       then
167 
+	    (push (cons "Cc" (list-to-delimited-string ccs ", "))
168 
+		  (mime-part-headers message)))
148 169
149 170 
     (if* subject
150 
-       then (format header "Subject: ~a~c~c" subject #\return #\linefeed))
171 
+       then (push (cons "Subject" subject) (mime-part-headers message)))
151 172
152 173 
     (if* reply-to
153 
-       then (format header "Reply-To: ~a~c~c" reply-to #\return #\linefeed))
174 
+       then (push (cons "Reply-To" reply-to) (mime-part-headers message)))
154 175
155 176 
     (if* headers
156 177 
        then (if* (stringp headers)
... ... 
@@ -158,27 +179,43 @@
158 179 
 	     elseif (consp headers)
159 180 
 	       thenret
160 181 
 	       else (error "Unknown headers format: ~s." headers))
161 
-	    (dolist (h headers)
162 
-	      (format header "~a~c~c" h #\return #\linefeed)))
163 
-
164 
-    (format header "~c~c" #\return #\linefeed)
182 
+	    (setf user-header
183 
+	      (with-output-to-string (header)
184 
+		(dolist (h headers)
185 
+		  (format header "~a~%" h)))))
186 
+
187 
+    (if* attachments
188 
+       then (if (not (consp attachments))
189 
+		(setf attachments (list attachments)))
190 
+
191 
+	    (dolist (attachment attachments)
192 
+	      (if* (mime-part-constructed-p attachment)
193 
+		 thenret
194 
+	       elseif (or (streamp attachment) (stringp attachment)
195 
+			  (pathnamep attachment))
196 
+		 then (setf attachment (make-mime-part :file attachment))
197 
+		 else (error "~
198 
+Attachments must be filenames, streams, or mime-part-constructed, not ~s"
199 
+			     attachment))
200 
+	      (nconc (mime-part-parts message) (list attachment))))
165 201
166 
-    (send-smtp-auth server from (append tos ccs bccs)
167 
-	       login password
168 
-	       (get-output-stream-string header)
169 
-	       message)))
202 
+    (with-mime-part-constructed-stream (s message)
203 
+      (send-smtp-auth server from (append tos ccs bccs)
204 
+		      login password
205 
+		      user-header
206 
+		      s))))
170 207
171 208
172 
-(defun send-smtp(server from to &rest messages)
209 
+(defun send-smtp (server from to &rest messages)
173 210 
   (send-smtp-1 server from to nil nil messages))
174 211
175 212 
 (defun send-smtp-auth (server from to login password &rest messages)
176 213 
   (send-smtp-1 server from to login password messages))
177 
-
214 
+
178 215 
 (defun send-smtp-1 (server from to login password messages)
179 216 
   ;; send the effective concatenation of the messages via
180 217 
   ;; smtp to the mail server
181 
-  ;; Each message should be a string
218 
+  ;; Each message should be a string or a stream.
182 219 
   ;;
183 220 
   ;; 'to' can be a single string or a list of strings.
184 221 
   ;; each string should be in the official rfc822 format  "foo@bar.com"
... ... 
@@ -188,7 +225,7 @@
188 225
189 226 
     (unwind-protect
190 227 
 	(progn
191 
-
228 
+
192 229 
 	  (smtp-command sock "MAIL from:<~a>" from)
193 230 
 	  (response-case (sock msg)
194 231 
 	    (2 ;; cool
... ... 
@@ -219,21 +256,29 @@
219 256
220 257
221 258 
 	  (let ((at-bol t)
222 
-		(prev-ch nil))
259 
+		(prev-ch nil)
260 
+		ch stream)
223 261 
 	    (dolist (message messages)
224 
-	      (dotimes (i (length message))
225 
-		(let ((ch (aref message i)))
226 
-		  (if* (and at-bol (eq ch #\.))
227 
-		     then ; to prevent . from being interpreted as eol
228 
-			  (write-char #\. sock))
229 
-		  (if* (eq ch #\newline)
230 
-		     then (setq at-bol t)
231 
-			  (if* (not (eq prev-ch #\return))
232 
-			     then (write-char #\return sock))
233 
-		     else (setq at-bol nil))
234 
-		  (write-char ch sock)
235 
-		  (setq prev-ch ch)))))
236 
-
262 
+	      (setf stream (if* (streamp message)
263 
+			      then message
264 
+			      else (make-string-input-stream message)))
265 
+	      (unwind-protect
266 
+		  (progn
267 
+		    (while (setf ch (read-char stream nil nil))
268 
+		      (if* (and at-bol (eq ch #\.))
269 
+			 then ;; to prevent . from being interpreted as eol
270 
+			      (write-char #\. sock))
271 
+		      (if* (eq ch #\newline)
272 
+			 then (setq at-bol t)
273 
+			      (if* (not (eq prev-ch #\return))
274 
+				 then (write-char #\return sock))
275 
+			 else (setq at-bol nil))
276 
+		      (write-char ch sock)
277 
+		      (setq prev-ch ch)))
278 
+		;; unwind-protect
279 
+		(if* (not (streamp message))
280 
+		   then (close stream)))))
281 
+
237 282 
 	  (write-char #\return sock) (write-char #\linefeed sock)
238 283 
 	  (write-char #\. sock)
239 284 
 	  (write-char #\return sock) (write-char #\linefeed sock)