chore(3p/lisp): import mime4cl source tarball r/2814

Used http://wcp.sdf-eu.org/software/mime4cl-20150207T211851.tbz (sha256
5a914669bba7561efe59a4fd0817204c07ad2add98b03ae206ef185ac04affb3).
Importing seems sensible since there's no upstream repo nor has their
been a release since 2015.

This is just an import commit, so the changes made to make it build are
more discoverable as their own commit.

Change-Id: I2ff28c3c7433abdf7857204bc89eaf9edc0b1cbc
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3378
Tested-by: BuildkiteCI
Reviewed-by: grfn <grfn@gws.fyi>

1 files changed, 1037 insertions, 0 deletions

diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp
new file mode 100644
index 000000000000..25c972f086b3
--- /dev/null
+++ b/third_party/lisp/mime4cl/mime.lisp
@@ -0,0 +1,1037 @@
+;;;  mime4cl.lisp --- MIME primitives for Common Lisp
+
+;;;  Copyright (C) 2005-2008, 2010 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; 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 GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :mime4cl)
+
+(defclass mime-part ()
+  ((subtype
+    :type (or string null)
+    :initarg :subtype
+    :accessor mime-subtype
+    ;; some mime types don't require a subtype
+    :initform nil)
+   (type-parameters
+    :type list
+    :initarg :type-parameters
+    :initform '()
+    :accessor mime-type-parameters)
+   (version
+    :type (or string null)
+    :initarg :mime-version
+    :initform "1.0"
+    :accessor mime-version)
+   (id
+    :initform nil
+    :initarg :id
+    :reader mime-id)
+   (description
+    :initform nil
+    :initarg :description
+    :accessor mime-description)
+   (encoding
+    :initform :7bit
+    :initarg :encoding
+    :reader mime-encoding
+    :documentation
+    "It's supposed to be either:
+  :7BIT, :8BIT, :BINARY, :QUOTED-PRINTABLE, :BASE64, a
+  X-token or an ietf-token (whatever that means).")
+   (disposition
+    :type (or string null)
+    :initarg :disposition
+    :initform nil
+    :accessor mime-disposition)
+   (disposition-parameters
+    :type list
+    :initarg :disposition-parameters
+    :initform '()
+    :accessor mime-disposition-parameters))
+  (:documentation
+   "Abstract base class for all types of MIME parts."))
+
+(defclass mime-bodily-part (mime-part)
+  ((body
+    :initarg :body
+    :accessor mime-body))
+  (:documentation
+   "Abstract base class for MIME parts with a body."))
+
+(defclass mime-unknown-part (mime-bodily-part)
+  ((type
+    :initarg :type
+    :reader mime-type
+    :documentation
+    "The original type string from the MIME header."))
+  (:documentation
+   "MIME part unknown to this library.  Accepted but not handled."))
+
+(defclass mime-text (mime-bodily-part) ())
+
+;; This turns out to be handy when making methods specialised
+;; non-textual attachments.
+(defclass mime-binary (mime-bodily-part) ())
+
+(defclass mime-image (mime-binary) ())
+
+(defclass mime-audio (mime-binary) ())
+
+(defclass mime-video (mime-binary) ())
+
+(defclass mime-application (mime-binary) ())
+
+(defclass mime-multipart (mime-part)
+  ((parts :initarg :parts
+	  :accessor mime-parts)))
+
+(defclass mime-message (mime-part)
+  ((headers :initarg :headers
+	    :initform '()
+	    :type list
+	    :accessor mime-message-headers)
+   (real-message :initarg :body
+		 :accessor mime-body)))
+
+(defun mime-part-p (object)
+  (typep object 'mime-part))
+
+(defmethod initialize-instance ((part mime-multipart) &key &allow-other-keys)
+  (call-next-method)
+  ;; The initialization argument of the PARTS slot of a mime-multipart
+  ;; is expected to be a list of mime-parts.  Thus, we implicitly
+  ;; create the mime parts using the arguments found in this list.
+  (with-slots (parts) part
+    (when (slot-boundp part 'parts)
+      (setf parts
+	    (mapcar #'(lambda (subpart)
+			(if (mime-part-p subpart)
+			    subpart
+			    (apply #'make-instance subpart)))
+		    parts)))))
+
+(defmethod initialize-instance ((part mime-message) &key &allow-other-keys)
+  (call-next-method)
+  ;; Allow a list of mime parts to be specified as body of a
+  ;; mime-message.  In that case we implicitly create a mime-multipart
+  ;; and assign to the body slot.
+  (with-slots (real-message) part
+    (when (and (slot-boundp part 'real-message)
+	       (consp real-message))
+      (setf real-message
+	    (make-instance 'mime-multipart :parts real-message)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun alist= (alist1 alist2 &key (test #'eql))
+  (null
+   (set-difference alist1 alist2
+		   :test #'(lambda (x y)
+			     (and (funcall test (car x) (car y))
+				  (funcall test (cdr x) (cdr y)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric mime= (mime1 mime2)
+  (:documentation
+   "Return true if MIME1 and MIME2 have equivalent structure and identical bodies (as for EQ)."))
+
+(defmethod mime= ((part1 mime-part) (part2 mime-part))
+  (macrolet ((null-or (compare x y)
+	       `(or (and (not ,x)
+			 (not ,y))
+		    (and ,x ,y
+			 (,compare ,x ,y))))
+	     (cmp-slot (compare reader)
+	       `(null-or ,compare (,reader part1) (,reader part2))))
+    (and (eq (class-of part1) (class-of part2))
+	 (cmp-slot string-equal mime-subtype)
+	 (alist= (mime-type-parameters part1)
+		 (mime-type-parameters part2)
+		 :test #'string-equal)
+	 (cmp-slot string= mime-id)
+	 (cmp-slot string= mime-description)
+	 (cmp-slot eq mime-encoding)
+	 (cmp-slot equal mime-disposition)
+	 (alist= (mime-disposition-parameters part1)
+		 (mime-disposition-parameters part2)
+		 :test #'string-equal))))
+
+(defmethod mime= ((part1 mime-multipart) (part2 mime-multipart))
+  (and (call-next-method)
+       (every #'mime= (mime-parts part1) (mime-parts part2))))
+
+(defmethod mime= ((part1 mime-message) (part2 mime-message))
+  (and (call-next-method)
+       (alist= (mime-message-headers part1) (mime-message-headers part2)
+	       :test #'string=)
+       (mime= (mime-body part1) (mime-body part2))))
+
+(defun mime-body-stream (mime-part &key (binary t))
+  (make-instance (if binary
+		     'binary-input-adapter-stream
+		     'character-input-adapter-stream)
+		 :source (mime-body mime-part)))
+
+(defun mime-body-length (mime-part)
+  (be body (mime-body mime-part)
+    ;; here the stream type is missing on purpose, because we may not
+    ;; be able to size the length of a stream
+    (etypecase body
+      (string
+       (length body))
+      (vector
+       (length body))
+      (pathname
+       (file-size body))
+      (file-portion
+       (with-open-stream (in (open-decoded-file-portion body))
+	 (loop
+	    for byte = (read-byte in nil)
+	    while byte
+	    count byte))))))
+
+(defmacro with-input-from-mime-body-stream ((stream part &key (binary t)) &body forms)
+  `(with-open-stream (,stream (mime-body-stream ,part :binary ,binary))
+     ,@forms))
+
+(defmethod mime= ((part1 mime-bodily-part) (part2 mime-bodily-part))
+  (and (call-next-method)
+       (with-input-from-mime-body-stream (in1 part1)
+	 (with-input-from-mime-body-stream (in2 part2)
+	   (loop
+	      for b1 = (read-byte in1 nil)
+	      for b2 = (read-byte in2 nil)
+	      always (eq b1 b2)
+	      while (and b1 b2))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric get-mime-type-parameter (part name)
+  (:documentation
+   "Return the MIME type parameter associated to NAME of PART."))
+
+(defgeneric (setf get-mime-type-parameter) (value part name)
+  (:documentation
+   "Set the MIME type parameter associated to NAME of PART."))
+
+(defmethod get-mime-type-parameter ((part mime-part) name)
+  (cdr (assoc name (mime-type-parameters part) :test #'string-equal)))
+
+(defmethod (setf get-mime-type-parameter) (value part name)
+  (aif (assoc name (mime-type-parameters part) :test #'string-equal)
+       (setf (cdr it) value)
+       (push (cons name value)
+	     (mime-type-parameters part)))
+  value)
+
+(defgeneric get-mime-disposition-parameter (part name)
+  (:documentation
+   "Return the MIME disposition parameter associated to NAME of PART."))
+
+(defmethod get-mime-disposition-parameter ((part mime-part) name)
+  (cdr (assoc name (mime-disposition-parameters part) :test #'string-equal)))
+
+(defmethod (setf get-mime-disposition-parameter) (value part name)
+  (aif (assoc name (mime-disposition-parameters part) :test #'string-equal)
+       (setf (cdr it) value)
+       (push (cons name value)
+	     (mime-disposition-parameters part))))
+
+(defmethod mime-part-file-name ((part mime-part))
+  "Return the filename associated to mime PART or NIL if the mime
+part doesn't have a file name."
+  (or (get-mime-disposition-parameter part :filename)
+      (get-mime-type-parameter part :name)))
+
+(defmethod (setf mime-part-file-name) (value (part mime-part))
+  "Set the filename associated to mime PART."
+  (setf (get-mime-disposition-parameter part :filename) value
+	(get-mime-type-parameter part :name) value))
+
+(defun mime-text-charset (part)
+  (get-mime-type-parameter part :charset))
+
+(defun split-header-parts (string)
+  "Split parts of a MIME headers.  These are divided by
+semi-colons not within strings or comments."
+  (labels ((skip-comment (pos)
+	     (loop
+		while (< pos (length string))
+		do (case (elt string pos)
+		     (#\( (setf pos (skip-comment (1+ pos))))
+		     (#\\ (incf pos 2))
+		     (#\) (return (1+ pos)))
+		     (otherwise (incf pos)))
+		finally (return pos)))
+	   (skip-string (pos)
+	     (loop
+		while (< pos (length string))
+		do (case (elt string pos)
+		     (#\\ (incf pos 2))
+		     (#\" (return (1+ pos)))
+		     (otherwise (incf pos)))
+		finally (return pos))))
+    (loop
+       with start = 0 and i = 0 and parts = '()
+       while (< i (length string))
+       do (case (elt string i)
+	    (#\; (push (subseq string start i) parts)
+		 (setf start (incf i)))
+	    (#\" (setf i (skip-string i)))
+	    (#\( (setf i (skip-comment (1+ i))))
+	    (otherwise (incf i)))
+       finally (return (mapcar #'string-trim-whitespace (nreverse (cons (subseq string start) parts)))))))
+
+(defun parse-parameter (string)
+  "Given a string like \"foo=bar\" return a pair (\"foo\" .
+\"bar\").  Return NIL if string is not parsable."
+  (be equal-position (position #\= string)
+    (when equal-position
+      (be key (subseq string  0 equal-position)
+	(if (= equal-position (1- (length string)))
+	    (cons key "")
+	    (be value (string-trim-whitespace (subseq string (1+ equal-position)))
+	      (cons key
+		    (if (and (> (length value) 1)
+			     (char= #\" (elt value 0)))
+			;; the syntax of a RFC822 string is more or
+			;; less the same as the Lisp one: use the Lisp
+			;; reader
+			(or (ignore-errors (read-from-string value))
+			    (subseq value 1))
+			(be end (or (position-if #'whitespace-p value)
+				    (length value))
+			  (subseq value 0 end))))))))))
+
+(defun parse-content-type (string)
+  "Parse string as a Content-Type MIME header and return a list
+of three elements.  The first is the type, the second is the
+subtype and the third is an alist of parameters and their values.
+Example: (\"text\" \"plain\" ((\"charset\" . \"us-ascii\")...))."
+  (let* ((parts (split-header-parts string))
+	 (content-type-string (car parts))
+	 (slash (position #\/ content-type-string)))
+    ;; You'd be amazed to know how many MUA can't produce an RFC
+    ;; compliant message.
+    (when slash
+      (let ((type (subseq content-type-string 0 slash))
+	    (subtype (subseq content-type-string (1+ slash))))
+	(list type subtype (remove nil (mapcar #'parse-parameter (cdr parts))))))))
+
+(defun parse-content-disposition (string)
+  "Parse string as a Content-Disposition MIME header and return a
+list.  The first element is the layout, the other elements are
+the optional parameters alist.
+Example: (\"inline\" (\"filename\" . \"doggy.jpg\"))."
+  (be parts (split-header-parts string)
+    (cons (car parts) (mapcan #'(lambda (parameter-string)
+				  (awhen (parse-parameter parameter-string)
+				    (list it)))
+			      (cdr parts)))))
+
+(defun parse-RFC822-header (string)
+  "Parse STRING which should be a valid RFC822 message header and
+return two values: a string of the header name and a string of
+the header value."
+  (be colon (position #\: string)
+    (when colon
+      (values (string-trim-whitespace (subseq string 0 colon))
+	      (string-trim-whitespace (subseq string (1+ colon)))))))
+
+
+(defvar *default-type* '("text" "plain" (("charset" . "us-ascii")))
+  "Internal special variable that contains the default MIME type at
+any given time of the parsing phase.  There are MIME container parts
+that may change this.")
+
+(defvar *mime-types*
+  '((:text mime-text)
+    (:image mime-image)
+    (:audio mime-audio)
+    (:video mime-video)
+    (:application mime-application)
+    (:multipart mime-multipart)
+    (:message mime-message)))
+
+(defgeneric mime-part-size (part)
+  (:documentation
+   "Return the size in bytes of the body of a MIME part."))
+
+(defgeneric print-mime-part (part stream)
+  (:documentation
+   "Output to STREAM one of the possible human-readable representation
+of mime PART.  Binary parts are omitted.  This function can be used to
+quote messages, for instance."))
+
+(defun do-multipart-parts (body-stream part-boundary contents-function end-part-function)
+  "Read through BODY-STREAM.  Call CONTENTS-FUNCTION at
+each (non-boundary) line or END-PART-FUNCTION at each PART-BOUNDARY."
+  (let* ((boundary (s+ "--" part-boundary))
+	 (boundary-length (length boundary)))
+    (labels ((output-line (line)
+	       (funcall contents-function line))
+	     (end-part ()
+	       (funcall end-part-function))
+	     (last-part ()
+	       (end-part)
+	       (return-from do-multipart-parts))
+	     (process-line (line)
+	       (cond ((not (string-starts-with boundary line))
+		      ;; normal line
+		      (output-line line))
+		     ((and (= (length (string-trim-whitespace line))
+			      (+ 2 boundary-length))
+			   (string= "--" line :start2 boundary-length))
+		      ;; end of the last part
+		      (last-part))
+		     ;; according to RFC2046 "the boundary may be followed
+		     ;; by zero or more characters of linear whitespace"
+		     ((= (length (string-trim-whitespace line)) boundary-length)
+		      ;; beginning of the next part
+		      (end-part))
+		     (t
+		      ;; the line boundary is followed by some
+		      ;; garbage; we treat it as a normal line
+		      (output-line line)))))
+      (loop
+	 for line = (read-line body-stream nil)
+	 ;; we should never reach the end of a proper multipart MIME
+	 ;; stream, but we don't want to be fooled by corrupted ones,
+	 ;; so we check for EOF
+	 unless line
+	 do (last-part)
+	 do (process-line line)))))
+
+;; This awkward handling of newlines is due to RFC2046: "The CRLF
+;; preceding the boundary delimiter line is conceptually attached to
+;; the boundary so that it is possible to have a part that does not
+;; end with a CRLF (line break).  Body parts that must be considered
+;; to end with line breaks, therefore, must have two CRLFs preceding
+;; the boundary delimiter line, the first of which is part of the
+;; preceding body part, and the second of which is part of the
+;; encapsulation boundary".
+(defun split-multipart-parts (body-stream part-boundary)
+  "Read from BODY-STREAM and split MIME parts separated by
+PART-BOUNDARY.  Return a list of strings."
+  (let ((part (make-string-output-stream))
+	(parts '())
+	(beginning-of-part-p t))
+    (flet ((output-line (line)
+	     (if beginning-of-part-p
+		 (setf beginning-of-part-p nil)
+		 (terpri part))
+	     (write-string line part))
+	   (end-part ()
+	     (setf beginning-of-part-p t)
+	     (push (get-output-stream-string part) parts)))
+      (do-multipart-parts body-stream part-boundary #'output-line #'end-part)
+      (close part)
+      ;; the first part is empty or contains all the junk
+      ;; to the first boundary
+      (cdr (nreverse parts)))))
+
+(defun index-multipart-parts (body-stream part-boundary)
+  "Read from BODY-STREAM and return the file offset of the MIME parts
+separated by PART-BOUNDARY."
+  (let ((parts '())
+	(start 0)
+	(len 0)
+	(beginning-of-part-p t))
+    (flet ((sum-chars (line)
+	     (incf len (length line))
+	     ;; account for the #\newline
+	     (if beginning-of-part-p
+		 (setf beginning-of-part-p nil)
+		 (incf len)))
+	   (end-part ()
+	     (setf beginning-of-part-p t)
+	     (push (cons start (+ start len)) parts)
+	     (setf start (file-position body-stream)
+		   len 0)))
+      (do-multipart-parts body-stream part-boundary #'sum-chars #'end-part)
+      ;; the first part is all the stuff up to the first boundary;
+      ;; just junk
+      (cdr (nreverse parts)))))
+
+(defgeneric encode-mime-part (part stream))
+(defgeneric encode-mime-body (part stream))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun write-mime-header (part stream)
+  (when (mime-version part)
+    (format stream "~&MIME-Version: ~A~%" (mime-version part)))
+  (format stream "~&Content-Type: ~A~:{; ~A=~S~}~%" (mime-type-string part)
+	  (mapcar #'(lambda (pair)
+		      (list (car pair) (cdr pair)))
+		  (mime-type-parameters part)))
+  (awhen (mime-encoding part)
+    (format stream "Content-Transfer-Encoding: ~A~%" it))
+  (awhen (mime-description part)
+    (format stream "Content-Description: ~A~%" it))
+  (when (mime-disposition part)
+    (format stream "Content-Disposition: ~A~:{; ~A=~S~}~%"
+	    (mime-disposition part)
+	    (mapcar #'(lambda (pair)
+			(list (car pair) (cdr pair)))
+		    (mime-disposition-parameters part))))
+  (awhen (mime-id part)
+    (format stream "Content-ID: ~A~%" it))
+  (terpri stream))
+
+(defmethod encode-mime-part ((part mime-part) stream)
+  (write-mime-header part stream)
+  (encode-mime-body part stream))
+
+(defmethod encode-mime-part ((part mime-message) stream)
+  ;; tricky: we have to mix the MIME headers with the message headers
+  (dolist (h (mime-message-headers part))
+    (unless (stringp (car h))
+      (setf (car h)
+	    (string-capitalize (car h))))
+    (unless (or (string-starts-with "content-" (car h) #'string-equal)
+		(string-equal "mime-version" (car h)))
+      (format stream "~A: ~A~%"
+	      (car h) (cdr h))))
+  (encode-mime-part (mime-body part) stream))
+
+(defmethod encode-mime-part ((part mime-multipart) stream)
+  ;; choose a boundary if not already set
+  (let* ((original-boundary (get-mime-type-parameter part :boundary))
+	 (boundary (choose-boundary (mime-parts part) original-boundary)))
+    (unless (and original-boundary
+		 (string= boundary original-boundary))
+      (setf (get-mime-type-parameter part :boundary) boundary))
+    (call-next-method)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod encode-mime-body ((part mime-part) stream)
+  (with-input-from-mime-body-stream (in part)
+    (encode-stream in stream (mime-encoding part))))
+
+(defmethod encode-mime-body ((part mime-message) stream)
+  (encode-mime-body (mime-body part) stream))
+
+(defmethod encode-mime-body ((part mime-multipart) stream)
+  (be boundary (or (get-mime-type-parameter part :boundary)
+		   (setf (get-mime-type-parameter part :boundary)
+			 (choose-boundary (mime-parts part))))
+    (dolist (p (mime-parts part))
+      (format stream "~%--~A~%" boundary)
+      (encode-mime-part p stream))
+    (format stream "~%--~A--~%" boundary)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun time-RFC822-string (&optional (epoch (get-universal-time)))
+  "Return a string describing the current time according to
+the RFC822."
+  (multiple-value-bind (ss mm hh day month year week-day dst tz) (decode-universal-time epoch)
+    (declare (ignore dst))
+    (format nil "~A, ~A ~A ~2,'0D ~2,'0D:~2,'0D:~2,'0D ~:[-~;+~]~2,'0D~2,'0D"
+	    (subseq (week-day->string week-day) 0 3)
+	    day (subseq (month->string month) 0 3) (mod year 100) hh mm ss
+	    (plusp tz) (abs (truncate tz)) (mod (* 60 tz) 60))))
+
+(defun parse-RFC822-date (date-string)
+  "Parse a RFC822 compliant date string and return an universal
+time."
+  ;; if we can't parse it, just return NIL
+  (ignore-errors
+    ;; skip the optional DoW
+    (awhen (position #\, date-string)
+      (setf date-string (subseq date-string (1+ it))))
+    (destructuring-bind (day month year time &optional tz &rest rubbish)
+	(split-at '(#\space #\tab) date-string)
+      (declare (ignore rubbish))
+      (destructuring-bind (hh mm &optional ss) (split-string-at-char time #\:)
+	(encode-universal-time
+	 (if ss
+	     (read-from-string ss)
+	     0)
+	 (read-from-string mm)
+	 (read-from-string hh)
+	 (read-from-string day)
+	 (1+ (position month
+		       '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
+			 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+		       :test #'string-equal))
+	 (read-from-string year)
+	 (when (and tz (or (char= #\+ (elt tz 0))
+			   (char= #\- (elt tz 0))))
+	   (/ (read-from-string tz) 100)))))))
+
+(defun read-RFC822-headers (stream &optional required-headers)
+  "Read RFC822 compliant headers from STREAM and return them in a
+alist of keyword and string pairs.  REQUIRED-HEADERS is a list of
+header names we are interested in; if NIL return all headers
+found in STREAM."
+  ;; the skip-header variable is to avoid the mistake of appending a
+  ;; continuation line of a header we don't want to a header we want
+  (loop
+     with headers = '() and skip-header = nil
+     for line = (be line (read-line stream nil)
+		  ;; skip the Unix "From " header if present
+		  (if (string-starts-with "From " line)
+		      (read-line stream nil)
+		      line))
+     then (read-line stream nil)
+     while (and line
+		(not (zerop (length line))))
+     do (if (whitespace-p (elt line 0))
+	    (unless (or skip-header
+			(null headers))
+	      (setf (cdar headers) (s+ (cdar headers) '(#\newline) line)))
+	    (multiple-value-bind (name value) (parse-RFC822-header line)
+	      ;; the line contained rubbish instead of an header: we
+	      ;; play nice and return as we were at the end of the
+	      ;; headers
+	      (unless name
+		(return (nreverse headers)))
+	      (if (or (null required-headers)
+		      (member name required-headers :test #'string-equal))
+		  (progn
+		    (push (cons name value) headers)
+		    (setf skip-header nil))
+		  (setf skip-header t))))
+     finally (return (nreverse headers))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric mime-message (thing)
+  (:documentation
+   "Convert THING to a MIME-MESSAGE object."))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar *lazy-mime-decode* t
+  "If true don't  decode mime bodies in memory.")
+
+(defgeneric decode-mime-body (part input-stream))
+
+(defmethod decode-mime-body ((part mime-part) (stream delimited-input-stream))
+ (be base (base-stream stream)
+   (if *lazy-mime-decode*
+       (setf (mime-body part)
+	     (make-file-portion :data (etypecase base
+					(my-string-input-stream
+					 (stream-string base))
+					(file-stream
+					 (pathname base)))
+				:encoding (mime-encoding part)
+				:start (file-position stream)
+				:end (stream-end stream)))
+       (call-next-method))))
+
+(defmethod decode-mime-body ((part mime-part) (stream file-stream))
+  (if *lazy-mime-decode*
+      (setf (mime-body part)
+	    (make-file-portion :data (pathname stream)
+			       :encoding (mime-encoding part)
+			       :start (file-position stream)))
+      (call-next-method)))
+
+(defmethod decode-mime-body ((part mime-part) (stream my-string-input-stream))
+  (if *lazy-mime-decode*
+      (setf (mime-body part)
+	    (make-file-portion :data (stream-string stream)
+			       :encoding (mime-encoding part)
+			       :start (file-position stream)))
+      (call-next-method)))
+
+(defmethod decode-mime-body ((part mime-part) stream)
+  (setf (mime-body part)
+	(decode-stream-to-sequence stream (mime-encoding part))))
+
+(defmethod decode-mime-body ((part mime-multipart) stream)
+  "Decode STREAM according to PART characteristics and return a
+list of MIME parts."
+  (save-file-excursion (stream)
+    (be offsets (index-multipart-parts stream (get-mime-type-parameter part :boundary))
+      (setf (mime-parts part)
+	    (mapcar #'(lambda (p)
+			(destructuring-bind (start . end) p
+			  (be *default-type* (if (eq :digest (mime-subtype part))
+						 '("message" "rfc822" ())
+						 '("text" "plain" (("charset" . "us-ascii"))))
+			      in (make-instance 'delimited-input-stream
+						:stream stream
+						:dont-close t
+						:start start
+						:end end)
+			      (read-mime-part in))))
+		    offsets)))))
+
+(defmethod decode-mime-body ((part mime-message) stream)
+  "Read from STREAM the body of PART.  Return the decoded MIME
+body."
+  (setf (mime-body part)
+	(read-mime-message stream)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64)
+  "List of known content encodings.")
+
+(defun keywordify-encoding (string)
+  "Return a keyword for a content transfer encoding string.
+Return STRING itself if STRING is an unkown encoding."
+  (aif (member string +known-encodings+ :test #'string-equal)
+       (car it)
+       string))
+
+(defun header (name headers)
+  (be elt (assoc name headers :test #'string-equal)
+    (values (cdr elt) (car elt))))
+
+(defun (setf header) (value name headers)
+  (be entry (assoc name headers :test #'string-equal)
+    (unless entry
+      (error "missing header ~A can't be set" name))
+    (setf (cdr entry) value)))
+
+(defun make-mime-part (headers stream)
+  "Create a MIME-PART object based on HEADERS and a body which
+has to be read from STREAM.  If the mime part type can't be
+guessed from the headers, use the *DEFAULT-TYPE*."
+  (flet ((hdr (what)
+	   (header what headers)))
+    (destructuring-bind (type subtype parms)
+	(or 
+	 (aand (hdr :content-type)
+	       (parse-content-type it))
+	 *default-type*)
+      (let* ((class (or (cadr (assoc type *mime-types* :test #'string-equal))
+			'mime-unknown-part))
+	     (disp (aif (hdr :content-disposition)
+			(parse-content-disposition it)
+			(values nil nil)))
+	     (part (make-instance class
+				  :type (hdr :content-type)
+				  :subtype subtype
+				  :type-parameters parms
+				  :disposition (car disp)
+				  :disposition-parameters (cdr disp)
+				  :mime-version (hdr :mime-version)
+				  :encoding (keywordify-encoding
+					     (hdr :content-transfer-encoding))
+				  :description (hdr :content-description)
+				  :id (hdr :content-id)
+				  :allow-other-keys t)))
+	(decode-mime-body part stream)
+	part))))
+
+(defun read-mime-part (stream)
+  "Read mime part from STREAM.  Return a MIME-PART object."
+  (be headers (read-rfc822-headers stream
+				   '(:mime-version :content-transfer-encoding :content-type
+				     :content-disposition :content-description :content-id))
+    (make-mime-part headers stream)))
+
+(defun read-mime-message (stream)
+  "Main function to read a MIME message from a stream.  It
+returns a MIME-MESSAGE object."
+  (be headers (read-rfc822-headers stream)
+      *default-type* '("text" "plain" (("charset" . "us-ascii")))
+    (flet ((hdr (what)
+	     (header what headers)))
+      (destructuring-bind (type subtype parms)
+	  (or (aand (hdr :content-type)
+		    (parse-content-type it))
+	      *default-type*)
+	(declare (ignore type subtype))
+	(make-instance 'mime-message
+		       :headers headers
+		       ;; this is just for easy access
+		       :type-parameters parms
+		       :body (make-mime-part headers stream))))))
+
+(defmethod mime-message ((msg mime-message))
+  msg)
+
+(defmethod mime-message ((msg string))
+  (with-open-stream (in (make-instance 'my-string-input-stream :string msg))
+    (read-mime-message in)))
+
+(defmethod mime-message ((msg stream))
+  (read-mime-message msg))
+
+(defmethod mime-message ((msg pathname))
+  (let (#+sbcl(sb-impl::*default-external-format* :latin-1)
+	#+sbcl(sb-alien::*default-c-string-external-format* :latin-1))
+    (with-open-file (in msg)
+      (read-mime-message in))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric mime-part (object)
+  (:documentation
+   "Promote object, if necessary, to MIME-PART."))
+
+(defmethod mime-part ((object string))
+  (make-instance 'mime-text :subtype "plain" :body object))
+
+(defmethod mime-part ((object pathname))
+  (make-instance 'mime-application
+		 :subtype "octect-stream"
+		 :content-transfer-encoding :base64
+		 :body (read-file object :element-type '(unsigned-byte 8))))
+
+(defmethod mime-part ((object mime-part))
+  object)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod make-encoded-body-stream ((part mime-bodily-part))
+  (be body (mime-body part)
+    (make-instance (case (mime-encoding part)
+		     (:base64
+		      'base64-encoder-input-stream)
+		     (:quoted-printable
+		      'quoted-printable-encoder-input-stream)
+		     (t
+		      '8bit-encoder-input-stream))
+		   :stream (make-instance 'binary-input-adapter-stream :source body))))
+
+(defun choose-boundary (parts &optional default)
+  (labels ((match-in-parts (boundary parts)
+	     (loop
+		for p in parts
+		thereis (typecase p
+			  (mime-multipart
+			   (match-in-parts boundary (mime-parts p)))
+			  (mime-bodily-part
+			   (match-in-body p boundary)))))
+	   (match-in-body (part boundary)
+	     (with-open-stream (in (make-encoded-body-stream part))
+	       (loop
+		  for line = (read-line in nil)
+		  while line
+		  when (string= line boundary)
+		  return t
+		  finally (return nil)))))
+    (do ((boundary (if default
+		       (format nil "--~A" default)
+		       #1=(format nil "--~{~36R~}"
+				  (loop
+				     for i from 0 below 20
+				     collect (random 36))))
+		   #1#))
+	((not (match-in-parts boundary parts)) (subseq boundary 2)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; fall back method
+(defmethod mime-part-size ((part mime-part))
+  (be body (mime-body part)
+    (typecase body
+      (pathname
+       (file-size body))
+      (string
+       (length body))
+      (vector
+       (length body))
+      (t nil))))
+
+(defmethod mime-part-size ((part mime-multipart))
+  (loop
+     for p in (mime-parts part)
+     for size = (mime-part-size p)
+     unless size
+     return nil
+     sum size))
+
+(defmethod mime-part-size ((part mime-message))
+  (mime-part-size (mime-body part)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod print-mime-part ((part mime-multipart) (out stream))
+  (case (mime-subtype part)
+    (:alternative
+     ;; try to choose something simple to print or the first thing
+     (be parts (mime-parts part)
+       (print-mime-part (or (find-if #'(lambda (part)
+					 (and (eq (class-of part) (find-class 'mime-text))
+					      (eq (mime-subtype part) :plain)))
+				     parts)
+			    (car parts)) out)))
+    (otherwise
+     (dolist (subpart (mime-parts part))
+       (print-mime-part subpart out)))))
+
+;; This is WRONG.  Here we don't use any special character encoding
+;; because we don't know which one we should use.  Messages written in
+;; anything but ASCII will likely be unreadable -wcp11/10/07.
+(defmethod print-mime-part ((part mime-text) (out stream))
+  (be body (mime-body part)
+    (etypecase body
+      (string
+       (write-string body out))
+      (vector
+       (loop
+	  for byte across body
+	  do (write-char (code-char byte) out)))
+      (pathname
+       (with-open-file (in body)
+	 (loop
+	    for c = (read-char in nil)
+	    while c
+	    do (write-char c out)))))))
+
+(defmethod print-mime-part ((part mime-message) (out stream))
+  (flet ((hdr (name)
+	   (multiple-value-bind (value tag)
+	       (header name (mime-message-headers part))
+	     (cons tag value))))
+    (dolist (h (mapcar #'hdr '("from" "subject" "to" "date" "x-march-archive-id")))
+      (when h
+	(format out "~&~A: ~A" (car h) (cdr h))))
+    (format out "~2%")
+    (print-mime-part (mime-body part) out)))
+
+(defmethod print-mime-part ((part mime-part) (out stream))
+  (format out "~&[ ~A subtype=~A ~@[description=~S ~]~@[size=~A~] ]~%"
+	  (type-of part) (mime-subtype part) (mime-description part) (mime-part-size part)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric find-mime-part-by-path (mime path)
+  (:documentation
+   "Return a subpart of MIME identified by PATH, which is a list of
+integers.  For example '(2 3 1) is the first part of the third of the
+second in MIME."))
+
+(defmethod find-mime-part-by-path ((part mime-part) path)
+  (if (null path)
+      part
+      (error "~S doesn't have subparts" part)))
+
+(defmethod find-mime-part-by-path ((part mime-message) path)
+  (if (null path)
+      part
+      (if (= 1 (car path))
+	  (find-mime-part-by-path (mime-body part) (cdr path))
+	  (error "~S may have just one subpart, but part ~D was requested (parts are enumerated base 1)."
+		 part (car path)))))
+
+(defmethod find-mime-part-by-path ((part mime-multipart) path)
+  (if (null path)
+      part
+      (be parts (mime-parts part)
+	  part-number (car path)
+	(if (<= 1 part-number (length parts))
+	    (find-mime-part-by-path (nth (1- (car path)) (mime-parts part)) (cdr path))
+	    (error "~S has just ~D subparts, but part ~D was requested (parts are enumerated base 1)."
+		   part (length parts) part-number)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric find-mime-part-by-id (part id)
+  (:documentation
+   "Return a subpart of PAR, whose Content-ID is the same as ID, which
+is a string."))
+
+(defmethod find-mime-part-by-id ((part mime-part) id)
+  (when (string= id (mime-id part))
+    part))
+
+(defmethod find-mime-part-by-id ((part mime-message) id)
+  (find-mime-part-by-id (mime-body part) id))
+
+(defmethod find-mime-part-by-id ((part mime-multipart) id)
+  (or (call-next-method)
+      (some #'(lambda (p)
+		(find-mime-part-by-id p id))
+	    (mime-parts part))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric mime-type-string (mime-part)
+  (:documentation
+   "Return the string describing the MIME part."))
+
+(defmethod mime-type-string ((part mime-unknown-part))
+  (mime-type part))
+
+(defmethod mime-type-string ((part mime-text))
+  (format nil "text/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-image))
+  (format nil "image/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-audio))
+  (format nil "audio/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-video))
+  (format nil "video/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-application))
+  (format nil "application/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-multipart))
+  (format nil "multipart/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-message))
+  (format nil "message/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-unknown-part))
+  (mime-type part))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric map-parts (function mime-part)
+  (:documentation
+   "Recursively map FUNCTION to MIME-PART or its components."))
+
+;; Here we wrongly assume that we'll never want to replace messages
+;; and multiparts altogether.  If you need to do so you have to write
+;; your own mapping functions.
+
+(defmethod map-parts ((function function) (part mime-part))
+  (funcall function part))
+
+(defmethod map-parts ((function function) (part mime-message))
+  (setf (mime-body part) (map-parts function (mime-body part)))
+  part)
+
+(defmethod map-parts ((function function) (part mime-multipart))
+  (setf (mime-parts part) (mapcar #'(lambda (p)
+				      (map-parts function p))
+				  (mime-parts part)))
+  part)
+
+;; apply-on-parts is like map-parts but doesn't modify the parts (at least
+;; not implicitly)
+
+(defgeneric apply-on-parts (function part))
+
+(defmethod apply-on-parts ((function function) (part mime-part))
+  (funcall function part))
+
+(defmethod apply-on-parts ((function function) (part mime-multipart))
+  (dolist (p (mime-parts part))
+    (apply-on-parts function p)))
+
+(defmethod apply-on-parts ((function function) (part mime-message))
+  (apply-on-parts function (mime-body part)))
+
+(defmacro do-parts ((var mime-part) &body body)
+  `(apply-on-parts #'(lambda (,var) ,@body) ,mime-part))