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>

13 files changed, 3313 insertions, 0 deletions

diff --git a/third_party/lisp/mime4cl/address.lisp b/third_party/lisp/mime4cl/address.lisp
new file mode 100644
index 000000000000..9a3bec9b2078
--- /dev/null
+++ b/third_party/lisp/mime4cl/address.lisp
@@ -0,0 +1,301 @@
+;;;  address.lisp --- e-mail address parser
+
+;;;  Copyright (C) 2007, 2008, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+#+cmu (ext:file-comment "$Module: address.lisp $")
+
+;;; 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
+
+;;;  Although not MIME specific, this parser is often useful together
+;;;  with the MIME primitives.  It should be able to parse the address
+;;;  syntax described in RFC2822 excluding the obsolete syntax (see
+;;;  RFC822).  Have a look at the test suite to get an idea of what
+;;;  kind of addresses it can parse.
+
+(in-package :mime4cl)
+
+(defstruct (mailbox (:conc-name mbx-))
+  description
+  user
+  host
+  domain)
+
+(defstruct (mailbox-group (:conc-name mbxg-))
+  name
+  mailboxes)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun write-mailbox-domain-name (addr &optional (stream *standard-output*))
+  (when (eq :internet (mbx-domain addr))
+    (write-char #\[ stream))
+  (write-string (mbx-host addr) stream)
+  (when (eq :internet (mbx-domain addr))
+    (write-char #\] stream))
+  (when (stringp (mbx-domain addr))
+    (write-char #\. stream)
+    (write-string (mbx-domain addr) stream)))
+
+(defun write-mailbox-address (addr &optional (stream *standard-output*))
+  (write-string (mbx-user addr) stream)
+  (when (mbx-host addr)
+    (write-char #\@ stream)
+    (write-mailbox-domain-name addr stream)))
+
+(defmethod mbx-domain-name ((MBX mailbox))
+  "Return the complete domain name string of MBX, in the form
+\"host.domain\"."
+  (with-output-to-string (out)
+    (write-mailbox-domain-name mbx out)))
+
+(defmethod mbx-address ((mbx mailbox))
+  "Return the e-mail address string of MBX, in the form
+\"user@host.domain\"."
+  (with-output-to-string (out)
+    (write-mailbox-address mbx out)))
+
+(defun write-mailbox (addr &optional (stream *standard-output*))
+  (awhen (mbx-description addr)
+    (write it :stream stream :readably t)
+    (write-string " <" stream))
+  (write-mailbox-address addr stream)
+  (awhen (mbx-description addr)
+    (write-char #\> stream)))
+
+(defun write-mailbox-group (grp &optional (stream *standard-output*))
+  (write-string (mbxg-name grp) stream)
+  (write-string ": " stream)
+  (loop
+     for mailboxes on (mbxg-mailboxes grp)
+     for mailbox = (car mailboxes)
+     do (write-mailbox mailbox stream)
+     unless (endp (cdr mailboxes))
+     do (write-string ", " stream))
+  (write-char #\; stream))
+
+(defmethod print-object ((mbx mailbox) stream)
+  (if (or *print-readably* *print-escape*)
+      (call-next-method)
+      (write-mailbox mbx stream)))
+
+(defmethod print-object ((grp mailbox-group) stream)
+  (if (or *print-readably* *print-escape*)
+      (call-next-method)
+      (write-mailbox-group grp stream)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun parser-make-mailbox (description address-list)
+  (make-mailbox :description description
+		:user (car address-list)
+		:host (cadr address-list)
+		:domain (when (cddr address-list)
+			  (string-concat (cddr address-list) "."))))
+
+
+(defun populate-grammar ()
+  (defrule address-list
+      := (+ address ","))
+
+  (defrule address
+      := mailbox
+      := group)
+
+  (defrule mailbox
+      := display-name? angle-addr comment?
+      :reduce (parser-make-mailbox (or display-name comment) angle-addr)
+      := addr-spec comment?
+      :reduce (parser-make-mailbox comment addr-spec))
+
+  (defrule angle-addr
+      := "<" addr-spec ">")
+
+  (defrule group
+      := display-name ":" mailbox-list ";"
+      :reduce (make-mailbox-group :name display-name :mailboxes mailbox-list))
+
+  (defrule display-name
+      := phrase
+      :reduce (string-concat phrase " "))
+
+  (defrule phrase
+      := word+)
+
+  (defrule word
+      := atext
+      := string)
+
+  (defrule mailbox-list
+      := (+ mailbox ","))
+
+  (defrule addr-spec
+      := local-part "@" domain :reduce (cons local-part domain))
+
+  (defrule local-part
+      := dot-atom :reduce (string-concat dot-atom ".")
+      := string)
+
+  (defrule domain
+      := dot-atom
+      := domain-literal :reduce (list domain-literal :internet))
+
+  ;; actually, according to the RFC, dot-atoms don't allow spaces in
+  ;; between but these rules do
+  (defrule dot-atom
+      := (+ atom "."))
+
+  (defrule atom
+      := atext+
+      :reduce (apply #'concatenate 'string atext)))
+
+(deflazy define-grammar
+  (let ((*package* #.*package*)
+	(*compile-print* (when npg::*debug* t)))
+    (reset-grammar)
+    (format t "~&creating e-mail address grammar...~%")
+    (populate-grammar)
+    (let ((grammar (npg:generate-grammar #'string=)))
+      (reset-grammar)
+      (npg:print-grammar-figures grammar)
+      grammar)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The lexical analyser
+
+(defstruct cursor
+  stream
+  (position 0))
+
+(defun read-delimited-string (stream end-char &key nesting-start-char (escape-char #\\))
+  (labels ((collect ()
+	     (with-output-to-string (out)
+	       (loop
+		  for c = (read-char stream nil)
+		  while (and c (not (char= c end-char)))
+		  do (cond ((char= c escape-char)
+			    (awhen (read-char stream nil)
+			      (write-char it out)))
+			   ((and nesting-start-char
+				 (char= c nesting-start-char))
+			    (write-char nesting-start-char out)
+			    (write-string (collect) out)
+			    (write-char end-char out))
+			   (t (write-char c out)))))))
+    (collect)))
+
+
+(defun read-string (cursor)
+  (make-token :type 'string
+	      :value (read-delimited-string (cursor-stream cursor) #\")
+	      :position (incf (cursor-position cursor))))
+
+(defun read-domain-literal (cursor)
+  (make-token :type 'domain-literal
+	      :value (read-delimited-string (cursor-stream cursor) #\])
+	      :position (incf (cursor-position cursor))))
+
+(defun read-comment (cursor)
+  (make-token :type 'comment
+	      :value (read-delimited-string (cursor-stream cursor) #\) :nesting-start-char #\()
+	      :position (incf (cursor-position cursor))))
+
+(declaim (inline atom-component-p))
+(defun atom-component-p (c)
+  (declare (type character c))
+  (not (find c " ()\"[]@.<>:;,")))
+
+(defun read-atext (first-character cursor)
+  (be string (with-output-to-string (out)
+	       (write-char first-character out)
+	       (loop
+		  for c = (read-char (cursor-stream cursor) nil)
+		  while (and c (atom-component-p c))
+		  do (write-char c out)
+		  finally (when c
+			    (unread-char c (cursor-stream cursor)))))
+    (make-token :type 'atext
+		:value string
+		:position (incf (cursor-position cursor)))))
+
+(defmethod read-next-tokens ((cursor cursor))
+  (flet ((make-keyword (c)
+	   (make-token :type 'keyword
+		       :value (string c)
+		       :position (incf (cursor-position cursor)))))
+    (be in (cursor-stream cursor)
+      (loop
+	 for c = (read-char in nil)
+	 while c
+	 unless (whitespace-p c)
+	 return (list
+		 (cond ((char= #\( c)
+			(read-comment cursor))
+		       ((char= #\" c)
+			(read-string cursor))
+		       ((char= #\[ c)
+			(read-domain-literal cursor))
+		       ((find c "@.<>:;,")
+			(make-keyword c))
+		       (t
+			;; anything else is considered a text atom even
+			;; though it's just a single character
+			(read-atext c cursor))))))))
+
+(defun analyse-string (string)
+  "Return the list of tokens produced by a lexical analysis of
+STRING.  These are the tokens that would be seen by the parser."
+  (with-input-from-string (stream string)
+    (be cursor (make-cursor :stream stream)
+      (loop
+	 for tokens = (read-next-tokens cursor)
+	 until (endp tokens)
+	 append tokens))))
+
+(defun mailboxes-only (list-of-mailboxes-and-groups)
+  "Return a flat list of MAILBOX-ADDRESSes from
+LIST-OF-MAILBOXES-AND-GROUPS, which is the kind of list returned
+by PARSE-ADDRESSES.  This turns out to be useful when your
+program is not interested in mailbox groups and expects the user
+addresses only."
+  (mapcan #'(lambda (mbx)
+	      (if (typep mbx 'mailbox-group)
+		  (mbxg-mailboxes mbx)
+		  (list mbx)))
+	  list-of-mailboxes-and-groups))
+
+(defun parse-addresses (string &key no-groups)
+  "Parse STRING and return a list of MAILBOX-ADDRESSes or
+MAILBOX-GROUPs.  If STRING is unparsable return NIL.  If
+NO-GROUPS is true, return a flat list of mailboxes throwing away
+the group containers, if any."
+  (be grammar (force define-grammar)
+    (with-input-from-string (stream string)
+      (be* cursor (make-cursor :stream stream)
+	   mailboxes (ignore-errors	; ignore parsing errors
+		       (parse grammar 'address-list cursor))
+	(if no-groups
+	    (mailboxes-only mailboxes)
+	    mailboxes)))))
+
+(defun debug-addresses (string)
+  "More or less like PARSE-ADDRESSES, but don't ignore parsing errors."
+  (be grammar (force define-grammar)
+    (with-input-from-string (stream string)
+      (be cursor (make-cursor :stream stream)
+	(parse grammar 'address-list cursor)))))
+
diff --git a/third_party/lisp/mime4cl/endec.lisp b/third_party/lisp/mime4cl/endec.lisp
new file mode 100644
index 000000000000..f63eb3c22e1d
--- /dev/null
+++ b/third_party/lisp/mime4cl/endec.lisp
@@ -0,0 +1,683 @@
+;;;  endec.lisp --- encoder/decoder functions
+
+;;;  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)
+
+
+;; Thank you SBCL for rendering constants totally useless!
+(defparameter +base64-encode-table+
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")
+
+(defparameter +base64-decode-table+
+  (let ((da (make-array 256 :element-type '(unsigned-byte 8) :initial-element 65)))
+    (dotimes (i 64)
+      (setf (aref da (char-code (char +base64-encode-table+ i))) i))
+    da))
+
+(declaim (type (simple-array (unsigned-byte 8)) +base64-decode-table+)
+	 (type simple-string +base64-encode-table+))
+
+(defvar *base64-line-length* 76
+  "Maximum length of the encoded base64 line.  NIL means it can
+be of unlimited length \(no line breaks will be done by the
+encoding function).")
+
+(defvar *quoted-printable-line-length* 72
+  "Maximum length of the encoded quoted printable line.  NIL
+means it can be of unlimited length \(no line breaks will be done
+by the encoding function).")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass decoder ()
+  ((input-function :initarg :input-function
+		   :reader decoder-input-function
+		   :type function
+		   :documentation
+		   "Function is called repeatedly by the decoder methods to get the next character.
+It should return a character os NIL (indicating EOF)."))
+  (:documentation
+   "Abstract base class for decoders."))
+
+(defclass parsing-decoder (decoder)
+  ((parser-errors :initform nil
+		  :initarg :parser-errors
+		  :reader decoder-parser-errors
+		  :type boolean))
+  (:documentation
+   "Abstract base class for decoders that do parsing."))
+
+(defclass encoder ()
+  ((output-function :initarg :output-function
+		    :reader encoder-output-function
+		    :type function
+		    :documentation
+		    "Function is called repeatedly by the encoder methods to output a character.
+It should expect a character as its only argument."))
+  (:documentation
+   "Abstract base class for encoders."))
+
+(defclass line-encoder (encoder)
+  ((column :initform 0
+	   :type fixnum)
+   (line-length :initarg :line-length
+		:initform nil
+		:reader encoder-line-length
+		:type (or fixnum null)))
+  (:documentation
+   "Abstract base class for line encoders."))
+
+(defclass 8bit-decoder (decoder)
+  ()
+  (:documentation
+   "Class for decoders that do nothing."))
+
+(defclass 8bit-encoder (encoder)
+  ()
+  (:documentation
+   "Class for encoders that do nothing."))
+
+(defclass 7bit-decoder (decoder)
+  ()
+  (:documentation
+   "Class for decoders that do nothing."))
+
+(defclass 7bit-encoder (encoder)
+  ()
+  (:documentation
+   "Class for encoders that do nothing."))
+
+(defclass byte-decoder (decoder)
+  ()
+  (:documentation
+   "Class for decoders that turns chars to bytes."))
+
+(defclass byte-encoder (encoder)
+  ()
+  (:documentation
+   "Class for encoders that turns bytes to chars."))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric encoder-write-byte (encoder byte))
+(defgeneric encoder-finish-output (encoder))
+(defgeneric decoder-read-byte (decoder))
+
+(defmethod encoder-finish-output ((encoder encoder))
+  (values))
+
+(defmethod encoder-write-byte ((encoder 8bit-encoder) byte)
+  (funcall (slot-value encoder 'output-function)
+	   (code-char byte))
+  (values))
+
+(defmethod decoder-read-byte ((decoder 8bit-decoder))
+  (awhen (funcall (slot-value decoder 'input-function))
+    (char-code it)))
+
+(defmethod encoder-write-byte ((encoder 7bit-encoder) byte)
+  (funcall (slot-value encoder 'output-function)
+	   (code-char (logand #x7F byte)))
+  (values))
+
+(defmethod decoder-read-byte ((decoder 7bit-decoder))
+  (awhen (funcall (slot-value decoder 'input-function))
+    (logand #x7F (char-code it))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun decoder-read-sequence (sequence decoder &key (start 0) (end (length sequence)))
+  (declare (optimize (speed 3) (safety 0) (debug 0))
+	   (type fixnum start end)
+	   (type vector sequence))
+  (loop
+     for i fixnum from start below end
+     for byte = (decoder-read-byte decoder)
+     while byte
+     do (setf (aref sequence i) byte)
+     finally (return i)))
+
+(defun decoder-read-line (decoder)
+  (with-output-to-string (str)
+    (loop
+       for byte = (decoder-read-byte decoder)
+       unless byte
+       do (return-from decoder-read-line nil)
+       do (be c (code-char byte)
+	    (cond ((char= c #\return)
+		   ;; skip the newline
+		   (decoder-read-byte decoder)
+		   (return nil))
+		  ((char= c #\newline)
+		   ;; the #\return was missing
+		   (return nil))
+		  (t (write-char c str)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declaim (inline parse-hex))
+(defun parse-hex (c1 c2)
+  "Parse two characters as hexadecimal and return their combined
+value."
+  (declare (optimize (speed 3) (safety 0) (debug 0))
+	   (type character c1 c2))
+  (flet ((digit-value (char)
+	   (or (position char "0123456789ABCDEF")
+	       (return-from parse-hex nil))))
+    (+ (* 16 (digit-value c1))
+       (digit-value c2))))
+
+(defclass quoted-printable-decoder (parsing-decoder)
+  ((saved-bytes :initform (make-queue))))
+
+(defmethod decoder-read-byte ((decoder quoted-printable-decoder))
+  (declare (optimize (speed 3) (safety 0) (debug 0)))
+  (with-slots (input-function saved-bytes parser-errors) decoder
+    (declare (type function input-function))
+    (labels ((saveb (b)
+	       (queue-append saved-bytes b)
+	       (values))
+	     (save (c)
+	       (saveb (char-code c)))
+	     (push-next ()
+	       (be c (funcall input-function)
+		 (declare (type (or null character) c))
+		 (cond ((not c))
+		       ((or (char= c #\space)
+			    (char= c #\tab))
+			(save c)
+			(push-next))
+		       ((char= c #\=)
+			(be c1 (funcall input-function)
+			  (cond ((not c1)
+				 (save #\=))
+				((char= c1 #\return)
+				 ;; soft line break: skip the next
+				 ;; character which we assume to be a
+				 ;; newline (pity if it isn't)
+				 (funcall input-function)
+				 (push-next))
+				((char= c1 #\newline)
+				 ;; soft line break: the #\return is
+				 ;; missing, but we are tolerant
+				 (push-next))
+				(t
+				 ;; hexadecimal sequence: get the 2nd digit
+				 (be c2 (funcall input-function)
+				   (if c2
+				       (aif (parse-hex c1 c2)
+					    (saveb it)
+					    (if parser-errors
+						(error "invalid hex sequence ~A~A" c1 c2)
+						(progn
+						  (save #\=)
+						  (save c1)
+						  (save c2))))
+				       (progn
+					 (save c)
+					 (save c1))))))))
+		       (t
+			(save c))))))
+      (or (queue-pop saved-bytes)
+	  (progn
+	    (push-next)
+	    (queue-pop saved-bytes))))))
+
+(defmacro make-encoder-loop (encoder-class input-form output-form)
+  (with-gensyms (encoder byte)
+    `(loop
+	with ,encoder = (make-instance ',encoder-class
+				       :output-function #'(lambda (char) ,output-form))
+	for ,byte = ,input-form
+	while ,byte
+	do (encoder-write-byte ,encoder ,byte)
+	finally (encoder-finish-output ,encoder))))
+
+(defmacro make-decoder-loop (decoder-class input-form output-form &key parser-errors)
+  (with-gensyms (decoder)
+    `(loop
+	with ,decoder = (make-instance ',decoder-class
+				       :input-function #'(lambda () ,input-form)
+				       :parser-errors ,parser-errors)
+	for byte = (decoder-read-byte ,decoder)
+	while byte
+	do ,output-form)))
+
+(defun decode-quoted-printable-stream (in out &key parser-errors)
+  "Read from stream IN a quoted printable text and write to
+binary output OUT the decoded stream of bytes."
+  (make-decoder-loop quoted-printable-decoder
+		     (read-byte in nil) (write-byte byte out)
+		     :parser-errors parser-errors))
+
+(defmacro make-stream-to-sequence-decoder (decoder-class input-form &key parser-errors)
+  "Decode the character stream STREAM and return a sequence of bytes."
+  (with-gensyms (output-sequence)
+    `(be ,output-sequence (make-array 0
+				      :element-type '(unsigned-byte 8)
+				      :fill-pointer 0
+				      :adjustable t)
+       (make-decoder-loop ,decoder-class ,input-form
+			  (vector-push-extend byte ,output-sequence)
+			  :parser-errors ,parser-errors)
+       ,output-sequence)))
+
+(defun decode-quoted-printable-stream-to-sequence (stream &key parser-errors)
+  "Read from STREAM a quoted printable text and return a vector of
+bytes."
+  (make-stream-to-sequence-decoder quoted-printable-decoder
+    (read-char stream nil)
+    :parser-errors parser-errors))
+
+(defun decode-quoted-printable-string (string &key (start 0) (end (length string)) parser-errors)
+  "Decode STRING as quoted printable sequence of characters and
+return a decoded sequence of bytes."
+  (with-input-from-string (in string :start start :end end)
+    (decode-quoted-printable-stream-to-sequence in :parser-errors parser-errors)))
+
+(defclass quoted-printable-encoder (line-encoder)
+  ((line-length :initform *quoted-printable-line-length*
+		:type (or fixnum null))
+   (pending-space :initform nil
+		  :type boolean)))
+
+(defmethod encoder-write-byte ((encoder quoted-printable-encoder) byte)
+  (declare (optimize (speed 3) (safety 0) (debug 0))
+	   (type (unsigned-byte 8) byte))
+  (with-slots (output-function column pending-space line-length) encoder
+    (declare (type function output-function)
+	     (type fixnum column)
+	     (type (or fixnum null) line-length)
+	     (type boolean pending-space))
+    (labels ((out (c)
+	       (funcall output-function c)
+	       (values))
+	     (outs (str)
+	       (declare (type simple-string str))
+	       (loop
+		  for c across str
+		  do (out c))
+	       (values))
+	     (out2hex (x)
+	       (declare (type fixnum x))
+	       (multiple-value-bind (a b) (truncate x 16)
+		 (out (digit-char a 16))
+		 (out (digit-char b 16)))))
+      (cond ((= byte #.(char-code #\newline))
+	     (when pending-space
+	       (outs "=20")
+	       (setf pending-space nil))
+	     (out #\newline)
+	     (setf column 0))
+	    ((= byte #.(char-code #\space))
+	     (if pending-space
+		 (progn
+		   (out #\space)
+		   (f++ column))
+		 (setf pending-space t)))
+	    (t
+	     (when pending-space
+	       (out #\space)
+	       (f++ column)
+	       (setf pending-space nil))
+	     (cond ((or (< byte 32)
+			(= byte #.(char-code #\=))
+			(> byte 126))
+		    (out #\=)
+		    (out2hex byte)
+		    (f++ column 3))
+		   (t
+		    (out (code-char byte))
+		    (f++ column)))))
+      (when (and line-length
+		 (>= column line-length))
+	;; soft line break
+	(outs #.(coerce '(#\= #\newline) 'string))
+	(setf column 0)))))
+
+(defmethod encoder-finish-output ((encoder quoted-printable-encoder))
+  (declare (optimize (speed 3) (safety 0) (debug 0)))
+  (with-slots (pending-space output-function) encoder
+    (declare (type boolean pending-space)
+	     (type function output-function))
+    (when pending-space
+      (flet ((outs (s)
+	       (declare (type simple-string s))
+	       (loop
+		  for c across s
+		  do (funcall output-function c))))
+	(setf pending-space nil)
+	(outs "=20")))))
+
+(defun encode-quoted-printable-stream (in out)
+  "Read from IN a stream of bytes and write to OUT a stream of
+characters quoted printables encoded."
+  (make-encoder-loop quoted-printable-encoder
+		     (read-byte in nil)
+		     (write-char char out)))
+
+(defun encode-quoted-printable-sequence-to-stream (sequence stream &key (start 0) (end (length sequence)))
+  "Encode the sequence of bytes SEQUENCE and write to STREAM a
+quoted printable sequence of characters."
+  (be i start
+    (make-encoder-loop quoted-printable-encoder
+     (when (< i end)
+       (prog1 (elt sequence i)
+	 (f++ i)))
+     (write-char char stream))))
+
+(defun encode-quoted-printable-sequence (sequence &key (start 0) (end (length sequence)))
+  "Encode the sequence of bytes SEQUENCE into a quoted printable
+string and return it."
+  (with-output-to-string (out)
+    (encode-quoted-printable-sequence-to-stream sequence out :start start :end end)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass base64-encoder (line-encoder)
+  ((line-length :initform *base64-line-length*)
+   (bitstore :initform 0
+	     :type fixnum)
+   (bytecount :initform 0
+	      :type fixnum))
+  (:documentation
+   "Class for Base64 encoder output streams."))
+
+
+(eval-when (:load-toplevel :compile-toplevel)
+  (unless (> most-positive-fixnum (expt 2 (* 8 3)))))
+
+(macrolet ((with-encoder (encoder &body forms)
+	     `(with-slots (bitstore line-length column bytecount output-function) ,encoder
+		(declare (type fixnum column)
+			 (type fixnum bitstore bytecount)
+			 (type (or fixnum null) line-length)
+			 (type function output-function))
+		(labels ((emitr (i b)
+			   (declare (type fixnum i b))
+			   (unless (zerop i)
+			     (emitr (1- i) (ash b -6)))
+			   (emitc
+			    (char +base64-encode-table+ (logand b #x3F)))
+			   (values))
+			 (out (c)
+			   (funcall output-function c))
+			 (eol ()
+			   (progn
+			     (out #\return)
+			     (out #\newline)))
+			 (emitc (char)
+			   (out char)
+			   (f++ column)
+			   (when (and line-length
+				      (>= column line-length))
+			     (setf column 0)
+			     (eol))))
+		  (declare (inline out eol emitc)
+			   (ignorable (function emitr) (function out) (function eol) (function emitc)))
+		  ,@forms))))
+  ;; For this function to work correctly, the FIXNUM must be at least
+  ;; 24 bits.
+  (defmethod encoder-write-byte ((encoder base64-encoder) byte)
+    (declare (optimize (speed 3) (safety 0) (debug 0))
+	     (type (unsigned-byte 8) byte))
+    (with-encoder encoder
+      (setf bitstore (logior byte (the fixnum (ash bitstore 8))))
+      (f++ bytecount)
+      (when (= 3 bytecount)
+	(emitr 3 bitstore)
+	(setf bitstore 0
+	      bytecount 0)))
+    (values))
+
+  (defmethod encoder-finish-output ((encoder base64-encoder))
+    (with-encoder encoder
+      (unless (zerop bytecount)
+	(multiple-value-bind (saved6 rest) (truncate (* bytecount 8) 6)
+	  (setf bitstore (ash bitstore (- 6 rest)))
+	  (emitr saved6 bitstore)
+	  (dotimes (x (- 3 saved6))
+	    (emitc #\=))))
+      (when (and line-length
+		 (not (zerop column)))
+	(eol)))
+    (values)))
+
+(defun encode-base64-stream (in out)
+  "Read a byte stream from IN and write to OUT the encoded Base64
+character stream."
+  (make-encoder-loop base64-encoder (read-byte in nil)
+		     (write-char char out)))
+
+(defun encode-base64-sequence-to-stream (sequence stream &key (start 0) (end (length sequence)))
+  "Encode the sequence of bytes SEQUENCE and write to STREAM the
+Base64 character sequence."
+  (be i start
+    (make-encoder-loop base64-encoder
+		       (when (< i end)
+			 (prog1 (elt sequence i)
+			   (incf i)))
+		       (write-char char stream))))
+
+(defun encode-base64-sequence (sequence &key (start 0) (end (length sequence)))
+  "Encode the sequence of bytes SEQUENCE into a Base64 string and
+return it."
+  (with-output-to-string (out)
+    (encode-base64-sequence-to-stream sequence out :start start :end end)))
+
+(defclass base64-decoder (parsing-decoder)
+  ((bitstore :initform 0
+	     :type fixnum)
+   (bytecount :initform 0 :type fixnum))
+  (:documentation
+   "Class for Base64 decoder input streams."))
+
+(defmethod decoder-read-byte ((decoder base64-decoder))
+  (declare (optimize (speed 3) (safety 0) (debug 0)))
+  (with-slots (bitstore bytecount input-function) decoder
+    (declare (type fixnum bitstore bytecount)
+	     (type function input-function))
+    (labels ((in6 ()
+	       (loop
+		  for c = (funcall input-function)
+		  when (or (not c) (char= #\= c))
+		  do (return-from decoder-read-byte nil)
+		  do (be sextet (aref +base64-decode-table+ (char-code c))
+		       (unless (= sextet 65) ; ignore unrecognised characters
+			 (return sextet)))))
+	     (push6 (sextet)
+	       (declare (type fixnum sextet))
+	       (setf bitstore
+		     (logior sextet (the fixnum (ash bitstore 6))))))
+      (case bytecount
+	(0
+	 (setf bitstore (in6))
+	 (push6 (in6))
+	 (setf bytecount 1)
+	 (ash bitstore -4))
+	(1
+	 (push6 (in6))
+	 (setf bytecount 2)
+	 (logand #xFF (ash bitstore -2)))
+	(2
+	 (push6 (in6))
+	 (setf bytecount 0)
+	 (logand #xFF bitstore))))))
+
+(defun decode-base64-stream (in out &key parser-errors)
+  "Read from IN a stream of characters Base64 encoded and write
+to OUT a stream of decoded bytes."
+  (make-decoder-loop base64-decoder
+		     (read-byte in nil) (write-byte byte out)
+		     :parser-errors parser-errors))
+
+(defun decode-base64-stream-to-sequence (stream &key parser-errors)
+  (make-stream-to-sequence-decoder base64-decoder
+				   (read-char stream nil)
+				   :parser-errors parser-errors))
+
+(defun decode-base64-string (string &key (start 0) (end (length string)) parser-errors)
+  (with-input-from-string (in string :start start :end end)
+    (decode-base64-stream-to-sequence in :parser-errors parser-errors)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun dump-stream-binary (in out)
+  "Write content of IN character stream to OUT binary stream."
+  (loop
+     for c = (read-char in nil)
+     while c
+     do (write-byte (char-code c) out)))
+
+(defun decode-stream (in out encoding &key parser-errors-p)
+  (gcase (encoding string-equal)
+    (:quoted-printable
+     (decode-quoted-printable-stream in out
+				     :parser-errors parser-errors-p))
+    (:base64
+     (decode-base64-stream in out
+			   :parser-errors parser-errors-p))
+    (otherwise
+     (dump-stream-binary in out))))
+
+(defun decode-string (string encoding &key parser-errors-p)
+  (gcase (encoding string-equal)
+    (:quoted-printable
+     (decode-quoted-printable-string string
+				     :parser-errors parser-errors-p))
+    (:base64
+     (decode-base64-string string
+			   :parser-errors parser-errors-p))
+    (otherwise
+     (map '(vector (unsigned-byte 8)) #'char-code string))))
+
+(defun decode-stream-to-sequence (stream encoding &key parser-errors-p)
+  (gcase (encoding string-equal)
+    (:quoted-printable
+     (decode-quoted-printable-stream-to-sequence stream
+						 :parser-errors parser-errors-p))
+    (:base64
+     (decode-base64-stream-to-sequence stream
+				       :parser-errors parser-errors-p))
+    (otherwise
+     (loop
+	with output-sequence = (make-array 0 :fill-pointer 0
+					   :element-type '(unsigned-byte 8)
+					   :adjustable t)
+	for c = (read-char stream nil)
+	while c
+	do (vector-push-extend (char-code c) output-sequence)
+	finally (return output-sequence)))))
+
+(defun encode-stream (in out encoding)
+  (gcase (encoding string-equal)
+    (:quoted-printable
+     (encode-quoted-printable-stream in out))
+    (:base64
+     (encode-base64-stream in out))
+    (otherwise
+     (loop
+	for byte = (read-byte in nil)
+	while byte
+	do (write-char (code-char byte) out)))))
+
+(defun encode-sequence-to-stream (sequence out encoding)
+  (gcase (encoding string-equal)
+    (:quoted-printable
+     (encode-quoted-printable-sequence-to-stream sequence out))
+    (:base64
+     (encode-base64-sequence-to-stream sequence out))
+    (otherwise
+     (loop
+	for byte across sequence
+	do (write-char (code-char byte) out)))))
+
+(defun encode-sequence (sequence encoding)
+  (gcase (encoding string-equal)
+    (:quoted-printable
+     (encode-quoted-printable-sequence sequence))
+    (:base64
+     (encode-base64-sequence sequence))
+    (otherwise
+     (map 'string #'code-char sequence))))
+
+;; This is similar to decode-quoted-printable-string but #\_ is used
+;; instead of space
+(defun decode-quoted-printable-RFC2047-string (string &key (start 0) (end (length string)))
+  "Decode a string encoded according to the quoted printable
+method of RFC2047 and return a sequence of bytes."
+  (declare (optimize (speed 3) (debug 0) (safety 0))
+	   (type simple-string string))
+  (loop
+     with output-sequence = (make-array (length string)
+					:element-type '(unsigned-byte 8)
+					:fill-pointer 0)
+     for i fixnum from start by 1 below end
+     for c = (char string i)
+     do (case c
+	  (#\=
+	   (vector-push-extend (or (parse-hex (char string (1+ i)) (char string (+ 2 i)))
+				   ;; the char code was malformed
+				   #.(char-code #\?))
+			       output-sequence)
+	   (f++ i 2))
+	  (#\_ (vector-push-extend #.(char-code #\space) output-sequence))
+	  (otherwise
+	   (vector-push-extend (char-code c) output-sequence)))
+       finally (return output-sequence)))
+
+(defun decode-RFC2047-string (encoding string &key (start 0) (end (length string)))
+  "Decode STRING according to RFC2047 and return a sequence of
+bytes."
+  (gcase (encoding string-equal)
+    ("Q" (decode-quoted-printable-RFC2047-string string :start start :end end))
+    ("B" (decode-base64-string string :start start :end end))
+    (t string)))
+
+(defun parse-RFC2047-text (text)
+  "Parse the string TEXT according to RFC2047 rules and return a list
+of pairs and strings.  The strings are the bits interposed between the
+actually encoded text.  The pairs are composed of: a decoded byte
+sequence, a charset string indicating the original coding."
+  (loop
+     with result = '()
+     with previous-end = 0
+     for start = (search "=?" text :start2 previous-end)
+     while start
+     for first-? = (position #\? text :start (+ 2 start))
+     while first-?
+     for second-? = (position #\? text :start (1+ first-?))
+     while second-?
+     for end = (search "?=" text :start2 (1+ second-?))
+     while end
+     do (let ((charset (string-upcase (subseq text (+ 2 start) first-?)))
+	      (encoding (subseq text (1+ first-?) second-?)))
+	  (unless (= previous-end start)
+	    (push (subseq text previous-end start)
+		  result))
+	  (setf previous-end (+ end 2))
+	  (push (cons (decode-RFC2047-string encoding text :start (1+ second-?) :end end)
+		      charset)
+		result))
+     finally (unless (= previous-end (length text))
+	       (push (subseq text previous-end (length text))
+		     result))
+       (return (nreverse result))))
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))
diff --git a/third_party/lisp/mime4cl/mime4cl-tests.asd b/third_party/lisp/mime4cl/mime4cl-tests.asd
new file mode 100644
index 000000000000..e4d983c05760
--- /dev/null
+++ b/third_party/lisp/mime4cl/mime4cl-tests.asd
@@ -0,0 +1,54 @@
+;;;  mime4cl-tests.asd --- system description for the regression tests
+
+;;;  Copyright (C) 2006, 2007, 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
+
+#-(or sbcl cmu)
+(warn "This code hasn't been tested on your Lisp system.")
+
+(defpackage :mime4cl-tests-system
+  (:use :common-lisp :asdf #+asdfa :asdfa)
+  (:export #:*base-directory*
+	   #:*compilation-epoch*))
+
+(in-package :mime4cl-tests-system)
+
+(defsystem mime4cl-tests
+    :name "MIME4CL-tests"
+    :author "Walter C. Pelissero <walter@pelissero.de>"
+    :maintainer "Walter C. Pelissero <walter@pelissero.de>"
+    :description "Test suite for the MIME4CL library"
+    :long-description
+    "These regression tests require rt.lisp from MIT.  It is included."
+    :licence "LGPL"
+    :depends-on (:mime4cl)
+    :components
+    ((:module test
+	      :components
+	      ((:file "rt")
+	       (:file "package" :depends-on ("rt"))
+	       (:file "endec" :depends-on ("rt" "package"))
+	       (:file "address" :depends-on ("rt" "package"))
+	       (:file "mime" :depends-on ("rt" "package"))))))
+
+;; when loading this form the regression-test, the package is yet to
+;; be loaded so we cannot use rt:do-tests directly or we would get a
+;; reader error (unknown package)
+(defmethod perform ((o test-op) (c (eql (find-system :mime4cl-tests))))
+  (or (funcall (intern "DO-TESTS" "REGRESSION-TEST"))
+      (error "test-op failed")))
diff --git a/third_party/lisp/mime4cl/mime4cl.asd b/third_party/lisp/mime4cl/mime4cl.asd
new file mode 100644
index 000000000000..2761a00d5283
--- /dev/null
+++ b/third_party/lisp/mime4cl/mime4cl.asd
@@ -0,0 +1,53 @@
+;;;  mime4cl.asd --- system definition
+
+;;;  Copyright (C) 2005-2007, 2010 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2, or (at
+;;; your option) any later version.
+;;; This program 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
+;;; General Public License for more details.
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; see the file COPYING.  If not, write to
+;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA 02111-1307, USA.
+
+(in-package :cl-user)
+
+#+(and cmu (not gray-streams))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (ext:without-package-locks
+    (load "library:subsystems/gray-streams-library")))
+
+(defpackage :mime4cl-system
+  (:use :common-lisp :asdf))
+
+(in-package :mime4cl-system)
+
+(defsystem mime4cl
+    :name "MIME4CL"
+    :author "Walter C. Pelissero <walter@pelissero.de>"
+    :maintainer "Walter C. Pelissero <walter@pelissero.de>"
+    ;; :version "0.0"
+    :description "MIME primitives for Common Lisp"
+    :long-description
+    "A collection of Common Lisp primitives to forge and handle
+MIME mail contents."
+    :licence "LGPL"
+    :depends-on (:npg :sclf)
+    :components
+    ((:file "package")
+     (:file "mime" :depends-on ("package" "endec" "streams"))
+     (:file "endec" :depends-on ("package"))
+     (:file "streams" :depends-on ("package" "endec"))
+     (:file "address" :depends-on ("package"))))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'mime4cl))))
+  (oos 'load-op 'mime4cl-tests)
+  (oos 'test-op 'mime4cl-tests :force t))
diff --git a/third_party/lisp/mime4cl/package.lisp b/third_party/lisp/mime4cl/package.lisp
new file mode 100644
index 000000000000..c1b94f21d7f2
--- /dev/null
+++ b/third_party/lisp/mime4cl/package.lisp
@@ -0,0 +1,107 @@
+;;;  package.lisp --- package declaration
+
+;;;  Copyright (C) 2005-2007, 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 :cl-user)
+
+(defpackage :mime4cl
+  (:nicknames :mime)
+  (:use :common-lisp :npg :sclf
+	;; for Gray streams
+	#+cmu :extensions #+sbcl :sb-gray)
+  ;; this is stuff that comes from SCLF and clashes with CMUCL's EXT
+  ;; package
+  (:shadowing-import-from :sclf
+			  #:process-wait
+			  #:process-alive-p
+			  #:run-program)
+  (:export #:*lazy-mime-decode*
+	   #:print-mime-part
+	   #:read-mime-message
+	   #:mime-part
+	   #:mime-text
+	   #:mime-binary
+	   #:mime-id
+	   #:mime-image
+	   #:mime-message
+	   #:mime-multipart
+	   #:mime-audio
+	   #:mime-unknown-part
+	   #:get-mime-disposition-parameter
+	   #:get-mime-type-parameter
+	   #:mime-disposition
+	   #:mime-disposition-parameters
+	   #:mime-encoding
+	   #:mime-application
+	   #:mime-video
+	   #:mime-description
+	   #:mime-part-size
+	   #:mime-subtype
+	   #:mime-body
+	   #:mime-body-stream
+	   #:mime-body-length
+	   #:mime-parts
+	   #:mime-part-p
+	   #:mime-type
+	   #:mime-type-string
+	   #:mime-type-parameters
+	   #:mime-message-headers
+	   #:mime=
+	   #:find-mime-part-by-path
+	   #:find-mime-part-by-id
+	   #:encode-mime-part
+	   #:encode-mime-body
+	   #:decode-quoted-printable-stream
+	   #:decode-quoted-printable-string
+	   #:encode-quoted-printable-stream
+	   #:encode-quoted-printable-sequence
+	   #:decode-base64-stream
+	   #:decode-base64-string
+	   #:encode-base64-stream
+	   #:encode-base64-sequence
+	   #:parse-RFC2047-text
+	   #:parse-RFC822-header
+	   #:read-RFC822-headers
+	   #:time-RFC822-string
+	   #:parse-RFC822-date
+	   #:map-parts
+	   #:do-parts
+	   #:apply-on-parts
+	   #:mime-part-file-name
+	   #:mime-text-charset
+	   #:with-input-from-mime-body-stream
+	   ;; endec.lisp
+	   #:base64-encoder
+	   #:base64-decoder
+	   #:null-encoder
+	   #:null-decoder
+	   #:byte-encoder
+	   #:byte-decoder
+	   #:quoted-printable-encoder
+	   #:quoted-printable-decoder
+	   #:encoder-write-byte
+	   #:encoder-finish-output
+	   #:decoder-read-byte
+	   #:decoder-read-sequence
+	   #:*base64-line-length*
+	   #:*quoted-printable-line-length*
+	   ;; address.lisp
+	   #:parse-addresses #:mailboxes-only
+	   #:mailbox #:mbx-description #:mbx-user #:mbx-host #:mbx-domain #:mbx-domain-name #:mbx-address
+	   #:mailbox-group #:mbxg-name #:mbxg-mailboxes))
diff --git a/third_party/lisp/mime4cl/streams.lisp b/third_party/lisp/mime4cl/streams.lisp
new file mode 100644
index 000000000000..4b3da19a9905
--- /dev/null
+++ b/third_party/lisp/mime4cl/streams.lisp
@@ -0,0 +1,366 @@
+ ;;; eds.lisp --- En/De-coding Streams
+
+ ;;; Copyright (C) 2012 by Walter C. Pelissero
+
+ ;;; Author: Walter C. Pelissero <walter@pelissero.de>
+ ;;; Project: mime4cl
+
+#+cmu (ext:file-comment "$Module: eds.lisp")
+
+;;; 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)
+
+#+cmu
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  ;; CMUCL doesn't provide the STREAM-FILE-POSITION method in its
+  ;; implementation of Gray streams.  We patch it in ourselves.
+  (defgeneric stream-file-position (stream &optional position))
+  (defun my-file-position (stream &optional position)
+    (stream-file-position stream position))
+  (defvar *original-file-position-function*
+    (prog1
+	(symbol-function 'file-position)
+      (setf (symbol-function 'file-position) (symbol-function 'my-file-position))))
+  (defmethod stream-file-position (stream &optional position)
+    (if position
+	(funcall *original-file-position-function* stream position)
+	(funcall *original-file-position-function* stream)))
+
+  ;; oddly CMUCL doesn't seem to provide a default for STREAM-READ-SEQUENCE
+  (defmacro make-read-sequence (stream-type element-reader)
+    `(defmethod stream-read-sequence ((stream ,stream-type) seq &optional start end)
+       (unless start
+	 (setf start 0))
+       (unless end
+	 (setf end (length seq)))
+       (loop
+	  for i from start below end
+	  for b = (,element-reader stream)
+	  until (eq b :eof)
+	  do (setf (elt seq i) b)
+	  finally (return i))))
+
+  (make-read-sequence fundamental-binary-input-stream stream-read-byte)
+  (make-read-sequence fundamental-character-input-stream stream-read-char))
+
+(defclass coder-stream-mixin ()
+  ((real-stream :type stream
+		:initarg :stream
+		:reader real-stream)
+   (dont-close :initform nil
+	       :initarg :dont-close)))
+
+(defmethod stream-file-position ((stream coder-stream-mixin) &optional position)
+  (file-position (slot-value stream 'real-stream) position))
+
+(defclass coder-input-stream-mixin (fundamental-binary-input-stream coder-stream-mixin)
+  ())
+(defclass coder-output-stream-mixin (fundamental-binary-output-stream coder-stream-mixin)
+  ())
+
+
+(defclass quoted-printable-decoder-stream (coder-input-stream-mixin quoted-printable-decoder) ())
+(defclass base64-decoder-stream (coder-input-stream-mixin base64-decoder) ())
+(defclass 8bit-decoder-stream (coder-input-stream-mixin 8bit-decoder) ())
+
+(defclass quoted-printable-encoder-stream (coder-output-stream-mixin quoted-printable-encoder) ())
+(defclass base64-encoder-stream (coder-output-stream-mixin base64-encoder) ())
+(defclass 8bit-encoder-stream (coder-output-stream-mixin 8bit-encoder) ())
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod initialize-instance :after ((stream coder-stream-mixin) &key &allow-other-keys)
+  (unless (slot-boundp stream 'real-stream)
+    (error "REAL-STREAM is unbound.  Must provide a :STREAM argument.")))
+
+(defmethod initialize-instance ((stream coder-output-stream-mixin) &key &allow-other-keys)
+  (call-next-method)
+  (unless (slot-boundp stream 'output-function)
+    (setf (slot-value stream 'output-function)
+	  #'(lambda (char)
+	      (write-char char (slot-value stream 'real-stream))))))
+
+(defmethod initialize-instance ((stream coder-input-stream-mixin) &key &allow-other-keys)
+  (call-next-method)
+  (unless (slot-boundp stream 'input-function)
+    (setf (slot-value stream 'input-function)
+	  #'(lambda ()
+	      (read-char (slot-value stream 'real-stream) nil)))))
+
+(defmethod stream-read-byte ((stream coder-input-stream-mixin))
+  (or (decoder-read-byte stream)
+      :eof))
+
+(defmethod stream-write-byte ((stream coder-output-stream-mixin) byte)
+  (encoder-write-byte stream byte))
+
+(defmethod close ((stream coder-stream-mixin) &key abort)
+  (with-slots (real-stream dont-close) stream
+    (unless dont-close
+      (close real-stream :abort abort))))
+
+(defmethod close ((stream coder-output-stream-mixin) &key abort)
+  (unless abort
+    (encoder-finish-output stream))
+  (call-next-method))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass encoder-input-stream (fundamental-character-input-stream coder-stream-mixin)
+  ((encoder)
+   (buffer-queue :initform (make-queue)))
+  (:documentation
+   "This is the base class for encoders with the direction swapped. It
+reads from REAL-STREAM a stream of bytes, encodes it and returnes it
+in a stream of character."))
+
+(defclass quoted-printable-encoder-input-stream (encoder-input-stream) ())
+(defclass base64-encoder-input-stream (encoder-input-stream) ())
+(defclass 8bit-encoder-input-stream (fundamental-character-input-stream coder-stream-mixin) ())
+
+(defmethod initialize-instance ((stream quoted-printable-encoder-input-stream) &key &allow-other-keys)
+  (call-next-method)
+  (with-slots (encoder buffer-queue) stream
+    (setf encoder
+	  (make-instance 'quoted-printable-encoder
+			 :output-function #'(lambda (char)
+					      (queue-append buffer-queue char))))))
+
+(defmethod initialize-instance ((stream base64-encoder-input-stream) &key &allow-other-keys)
+  (call-next-method)
+  (with-slots (encoder buffer-queue) stream
+    (setf encoder
+	  (make-instance 'base64-encoder
+			 :output-function #'(lambda (char)
+					      (queue-append buffer-queue char))))))
+
+(defmethod stream-read-char ((stream encoder-input-stream))
+  (with-slots (encoder buffer-queue real-stream) stream
+    (loop
+       while (queue-empty-p buffer-queue)
+       do (be byte (read-byte real-stream nil)
+	    (if byte
+		(encoder-write-byte encoder byte)
+		(progn
+		  (encoder-finish-output encoder)
+		  (queue-append buffer-queue :eof)))))
+    (queue-pop buffer-queue)))
+
+
+(defmethod stream-read-char ((stream 8bit-encoder-input-stream))
+  (with-slots (real-stream) stream
+    (aif (read-byte real-stream nil)
+	 (code-char it)
+	 :eof)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass input-adapter-stream ()
+  ((source :initarg :source)
+   (real-stream)
+   (input-function)))
+
+(defclass binary-input-adapter-stream (fundamental-binary-input-stream input-adapter-stream) ())
+
+(defclass character-input-adapter-stream (fundamental-character-input-stream input-adapter-stream) ())
+
+(defmethod stream-element-type ((stream binary-input-adapter-stream))
+  '(unsigned-byte 8))
+
+(defmethod initialize-instance ((stream input-adapter-stream) &key &allow-other-keys)
+  (call-next-method)
+  (assert (slot-boundp stream 'source)))
+
+(defmethod initialize-instance ((stream binary-input-adapter-stream) &key &allow-other-keys)
+  (call-next-method)
+  ;; REAL-STREAM slot is set only if we are going to close it later on
+  (with-slots (source real-stream input-function) stream
+    (etypecase source
+      (string
+       (setf real-stream (make-string-input-stream source)
+	     input-function #'(lambda ()
+				(awhen (read-char real-stream nil)
+				  (char-code it)))))
+      ((vector (unsigned-byte 8))
+       (be i 0
+	 (setf input-function #'(lambda ()
+				  (when (< i (length source))
+				    (prog1 (aref source i)
+				      (incf i)))))))
+      (stream
+       (assert (input-stream-p source))
+       (setf input-function (if (subtypep (stream-element-type source) 'character)
+				#'(lambda ()
+				    (awhen (read-char source nil)
+				      (char-code it)))
+				#'(lambda ()
+				    (read-byte source nil)))))
+      (pathname
+       (setf real-stream (open source :element-type '(unsigned-byte 8))
+	     input-function #'(lambda ()
+				(read-byte real-stream nil))))
+      (file-portion
+       (setf real-stream (open-decoded-file-portion source)
+	     input-function #'(lambda ()
+				(read-byte real-stream nil)))))))
+
+(defmethod initialize-instance ((stream character-input-adapter-stream) &key &allow-other-keys)
+  (call-next-method)
+  ;; REAL-STREAM slot is set only if we are going to close later on
+  (with-slots (source real-stream input-function) stream
+    (etypecase source
+      (string
+       (setf real-stream (make-string-input-stream source)
+	     input-function #'(lambda ()
+				(read-char real-stream nil))))
+      ((vector (unsigned-byte 8))
+       (be i 0
+	 (setf input-function #'(lambda ()
+				  (when (< i (length source))
+				    (prog1 (code-char (aref source i))
+				      (incf i)))))))
+      (stream
+       (assert (input-stream-p source))
+       (setf input-function (if (subtypep (stream-element-type source) 'character)
+				#'(lambda ()
+				    (read-char source nil))
+				#'(lambda ()
+				    (awhen (read-byte source nil)
+				      (code-char it))))))
+      (pathname
+       (setf real-stream (open source :element-type 'character)
+	     input-function #'(lambda ()
+				(read-char real-stream nil))))
+      (file-portion
+       (setf real-stream (open-decoded-file-portion source)
+	     input-function #'(lambda ()
+				(awhen (read-byte real-stream nil)
+				  (code-char it))))))))
+
+(defmethod close ((stream input-adapter-stream) &key abort)
+  (when (slot-boundp stream 'real-stream)
+    (with-slots (real-stream) stream
+      (close real-stream :abort abort))))
+
+(defmethod stream-read-byte ((stream binary-input-adapter-stream))
+  (with-slots (input-function) stream
+    (or (funcall input-function)
+	:eof)))
+
+(defmethod stream-read-char ((stream character-input-adapter-stream))
+  (with-slots (input-function) stream
+    (or (funcall input-function)
+	:eof)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass delimited-input-stream (fundamental-character-input-stream coder-stream-mixin)
+  ((start-offset :initarg :start
+		 :initform 0
+		 :reader stream-start
+		 :type integer)
+   (end-offset :initarg :end
+	       :initform nil
+	       :reader stream-end
+	       :type (or null integer))))
+
+(defmethod print-object ((object delimited-input-stream) stream)
+  (if *print-readably*
+      (call-next-method)
+      (with-slots (start-offset end-offset) object
+	(print-unreadable-object (object stream :type t :identity t)
+	  (format stream "start=~A end=~A" start-offset end-offset)))))
+
+(defun base-stream (stream)
+  (if (typep stream 'delimited-input-stream)
+      (base-stream (real-stream stream))
+      stream))
+
+(defmethod initialize-instance ((stream delimited-input-stream) &key &allow-other-keys)
+  (call-next-method)
+  (unless (slot-boundp stream 'real-stream)
+    (error "REAL-STREAM is unbound.  Must provide a :STREAM argument."))
+  (with-slots (start-offset) stream
+    (when start-offset
+      (file-position stream start-offset))))
+
+(defmethod stream-read-char ((stream delimited-input-stream))
+  (with-slots (real-stream end-offset) stream
+    (if (or (not end-offset)
+	    (< (file-position real-stream) end-offset))
+	(or (read-char real-stream nil)
+	    :eof)
+	:eof)))
+
+#+(OR)(defmethod stream-read-byte ((stream delimited-input-stream))
+  (with-slots (real-stream end-offset) stream
+    (if (or (not end-offset)
+	    (< (file-position real-stream) end-offset))
+	(or (read-byte real-stream nil)
+	    :eof)
+	:eof)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass my-string-input-stream (fundamental-character-input-stream coder-stream-mixin)
+  ((string :initarg :string
+	   :reader stream-string)))
+
+(defmethod initialize-instance ((stream my-string-input-stream) &key &allow-other-keys)
+  (call-next-method)
+  (assert (slot-boundp stream 'string))
+  (with-slots (string real-stream) stream
+    (setf real-stream (make-string-input-stream string))))
+
+(defmethod stream-read-char ((stream my-string-input-stream))
+  (with-slots (real-stream) stream
+    (or (read-char real-stream nil)
+	:eof)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defstruct file-portion
+  data					;  string or a pathname
+  encoding
+  start
+  end)
+
+(defun open-file-portion (file-portion)
+  (be data (file-portion-data file-portion)
+    (etypecase data
+      (pathname
+       (be stream (open data)
+	 (make-instance 'delimited-input-stream
+			:stream stream
+			:start (file-portion-start file-portion)
+			:end (file-portion-end file-portion))))
+      (string
+       (make-instance 'delimited-input-stream
+		      :stream (make-string-input-stream data)
+		      :start (file-portion-start file-portion)
+		      :end (file-portion-end file-portion)))
+      (stream
+       (make-instance 'delimited-input-stream
+		      :stream data
+		      :dont-close t
+		      :start (file-portion-start file-portion)
+		      :end (file-portion-end file-portion))))))
+
+(defun open-decoded-file-portion (file-portion)
+  (make-instance (case (file-portion-encoding file-portion)
+		   (:quoted-printable 'quoted-printable-decoder-stream)
+		   (:base64 'base64-decoder-stream)
+		   (t '8bit-decoder-stream))
+		 :stream (open-file-portion file-portion)))
diff --git a/third_party/lisp/mime4cl/test/address.lisp b/third_party/lisp/mime4cl/test/address.lisp
new file mode 100644
index 000000000000..aaa2d231f11c
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/address.lisp
@@ -0,0 +1,124 @@
+;;;  address.lisp --- tests for the e-mail address parser
+
+;;;  Copyright (C) 2007, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+#+cmu (ext:file-comment "$Module: address.lisp $")
+
+;;; 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-tests)
+
+(defun test-parsing (string)
+  (format nil "~{~A~^, ~}" (parse-addresses string)))
+
+(deftest address-parse-simple.1
+    (test-parsing "foo@bar")
+  "foo@bar")
+
+(deftest address-parse-simple.2
+    (test-parsing "foo@bar.com")
+  "foo@bar.com")
+
+(deftest address-parse-simple.3
+    (test-parsing "foo@bar.baz.com")
+  "foo@bar.baz.com")
+
+(deftest address-parse-simple.4
+    (test-parsing "foo.ooo@bar.baz.com")
+  "foo.ooo@bar.baz.com")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest address-parse-simple-commented.1
+    (test-parsing "foo@bar (Some Comment)")
+  "\"Some Comment\" <foo@bar>")
+
+(deftest address-parse-simple-commented.2
+    (test-parsing "foo@bar (Some, Comment)")
+  "\"Some, Comment\" <foo@bar>")
+
+(deftest address-parse-simple-commented.3
+    (test-parsing "foo@bar (Some Comment (yes, indeed))")
+  "\"Some Comment (yes, indeed)\" <foo@bar>")
+
+(deftest address-parse-simple-commented.4
+    (test-parsing "foo.bar@host.complicated.domain.net (Some Comment (yes, indeed))")
+  "\"Some Comment (yes, indeed)\" <foo.bar@host.complicated.domain.net>")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest address-parse-angle.1
+    (test-parsing "<foo@bar.baz.net>")
+  "foo@bar.baz.net")
+
+(deftest address-parse-angle.2
+    (test-parsing "My far far friend <foo@bar.baz.net>")
+  "\"My far far friend\" <foo@bar.baz.net>")
+
+(deftest address-parse-angle.3
+    (test-parsing "\"someone, I don't like\" <foo@bar.baz.net>")
+  "\"someone, I don't like\" <foo@bar.baz.net>")
+
+(deftest address-parse-angle.4
+    (test-parsing "\"this could (be a comment)\" <foo@bar.net>")
+  "\"this could (be a comment)\" <foo@bar.net>")
+
+(deftest address-parse-angle.5
+    (test-parsing "don't be fooled <foo@bar.net>")
+  "\"don't be fooled\" <foo@bar.net>")
+
+(deftest address-parse-angle.6
+    (test-parsing "<foo@bar>")
+  "foo@bar")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest address-parse-domain-literal.1
+    (test-parsing "<foo@[bar]>")
+  "foo@[bar]")
+
+(deftest address-parse-domain-literal.2
+    (test-parsing "<foo@[bar.net]>")
+  "foo@[bar.net]")
+
+(deftest address-parse-domain-literal.3
+    (test-parsing "<foo@[10.0.0.2]>")
+  "foo@[10.0.0.2]")
+
+(deftest address-parse-domain-literal.4
+    (test-parsing "<foo.bar@[10.0.0.2]>")
+  "foo.bar@[10.0.0.2]")
+
+(deftest address-parse-domain-literal.5
+    (test-parsing "somewhere unkown <foo.bar@[10.0.0.2]>")
+  "\"somewhere unkown\" <foo.bar@[10.0.0.2]>")
+
+(deftest address-parse-domain-literal.6
+    (test-parsing "\"Some--One\" <foo.bar@[10.0.0.23]>")
+  "\"Some--One\" <foo.bar@[10.0.0.23]>")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest address-parse-group.1
+    (test-parsing "friends:john@bar.in.soho, jack@pub.round.the.corner, jim@[10.0.1.2];")
+  "friends: john@bar.in.soho, jack@pub.round.the.corner, jim@[10.0.1.2];")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest address-parse-mixed.1
+    (test-parsing "Foo BAR <foo@bar.com>, \"John, Smith (that one!)\" <john.smith@host.domain.org>, friends:john@bar,jack@pub;, foo.bar.baz@wow.mail.mine, dont.bark@me (Fierce Dog)")
+  "\"Foo BAR\" <foo@bar.com>, \"John, Smith (that one!)\" <john.smith@host.domain.org>, friends: john@bar, jack@pub;, foo.bar.baz@wow.mail.mine, \"Fierce Dog\" <dont.bark@me>")
diff --git a/third_party/lisp/mime4cl/test/endec.lisp b/third_party/lisp/mime4cl/test/endec.lisp
new file mode 100644
index 000000000000..7b6763c99035
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/endec.lisp
@@ -0,0 +1,167 @@
+;;;  endec.lisp --- test suite for the MIME encoder/decoder functions
+
+;;;  Copyright (C) 2006, 2007, 2009, 2010 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+#+cmu (ext:file-comment "$Module: endec.lisp $")
+
+;;; 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-tests)
+
+(deftest quoted-printable.1
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "Français, Español, böse, skøl"))
+  "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l")
+
+(deftest quoted-printable.2
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "Français, Español, böse, skøl")
+				      :start 10 :end 17)
+  "Espa=F1ol")
+
+(deftest quoted-printable.3
+    (map 'string #'code-char
+	 (decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l"))
+  "Français, Español, böse, skøl")
+
+(deftest quoted-printable.4
+    (map 'string #'code-char
+	 (decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l"
+					 :start 12 :end 21))
+  "Español")
+
+(deftest quoted-printable.5
+    (map 'string #'code-char
+	 (decode-quoted-printable-string "this = wrong"))
+  "this = wrong")
+
+(deftest quoted-printable.6
+    (map 'string #'code-char
+	 (decode-quoted-printable-string "this is wrong="))
+  "this is wrong=")
+
+(deftest quoted-printable.7
+    (map 'string #'code-char
+	 (decode-quoted-printable-string "this is wrong=1"))
+  "this is wrong=1")
+
+(deftest quoted-printable.8
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "x = x + 1"))
+  "x =3D x + 1")
+
+(deftest quoted-printable.9
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "x = x + 1   "))
+  "x =3D x + 1  =20")
+
+(deftest quoted-printable.10
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "this string is very very very very very very very very very very very very very very very very very very very very long"))
+  "this string is very very very very very very very very very very very ve=
+ry very very very very very very very very long")
+
+(deftest quoted-printable.11
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "this string is very very                                                                                  very very long"))
+  "this string is very very                                                =
+                                  very very long")
+
+(deftest quoted-printable.12
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "please read the next   
+line"))
+  "please read the next  =20
+line")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest base64.1
+    (let ((*base64-line-length* nil))
+      (encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code
+				   "Some random string.")))
+  "U29tZSByYW5kb20gc3RyaW5nLg==")
+
+(deftest base64.2
+    (let ((*base64-line-length* nil))
+      (encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code
+				   "Some random string.") :start 5 :end 11))
+  "cmFuZG9t")
+
+(deftest base64.3
+    (map 'string #'code-char
+	 (decode-base64-string "U29tZSByYW5kb20gc3RyaW5nLg=="))
+  "Some random string.")
+
+(deftest base64.4
+    (map 'string #'code-char
+	 (decode-base64-string "some rubbish U29tZSByYW5kb20gc3RyaW5nLg== more rubbish"
+			       :start 13 :end 41))
+  "Some random string.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest RFC2047.1
+    (parse-RFC2047-text "foo bar")
+  ("foo bar"))
+
+(defun perftest-encoder (encoder-class &optional (megs 100))
+  (declare (optimize (speed 3) (debug 0) (safety 0))
+	   (type fixnum megs))
+  (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8))
+    (let* ((meg (* 1024 1024))
+	   (buffer (make-sequence '(vector (unsigned-byte 8)) meg))
+	   (encoder (make-instance encoder-class
+				   :output-function #'(lambda (c) (declare (ignore c))))))
+      (declare (type fixnum meg))
+      (time
+       (progn
+	 (dotimes (x megs)
+	   (read-sequence buffer in)
+	   (dotimes (i meg)
+	     (mime4cl:encoder-write-byte encoder (aref buffer i))))
+	 (mime4cl:encoder-finish-output encoder))))))
+
+(defun perftest-decoder (decoder-class &optional (megs 100))
+  (declare (optimize (speed 3) (debug 0) (safety 0))
+	   (type fixnum megs))
+  (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8))
+    (let ((sclf:*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*)
+						   :type "encoded-data")))
+      (sclf:with-temp-file (tmp nil :direction :io)
+	(let* ((meg (* 1024 1024))
+	       (buffer (make-sequence '(vector (unsigned-byte 8)) meg))
+	       (encoder-class (ecase decoder-class
+				(mime4cl:base64-decoder 'mime4cl:base64-encoder)
+				(mime4cl:quoted-printable-decoder 'mime4cl:quoted-printable-encoder)))
+	       (encoder (make-instance encoder-class
+				       :output-function #'(lambda (c)
+							    (write-char c tmp))))
+	       (decoder (make-instance decoder-class
+				       :input-function #'(lambda ()
+							   (read-char tmp nil)))))
+	  (declare (type fixnum meg))
+	  (dotimes (x megs)
+	    (read-sequence buffer in)
+	    (dotimes (i meg)
+	      (mime4cl:encoder-write-byte encoder (aref buffer i))))
+	  (mime4cl:encoder-finish-output encoder)
+	  (file-position tmp 0)
+	  (time
+	   (loop
+	      for b = (mime4cl:decoder-read-byte decoder)
+	      while b)))))))
diff --git a/third_party/lisp/mime4cl/test/mime.lisp b/third_party/lisp/mime4cl/test/mime.lisp
new file mode 100644
index 000000000000..d1a56b0c0433
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/mime.lisp
@@ -0,0 +1,53 @@
+ ;;; mime.lisp --- MIME regression tests
+
+ ;;; Copyright (C) 2012 by Walter C. Pelissero
+
+ ;;; Author: Walter C. Pelissero <walter@pelissero.de>
+ ;;; Project: mime4cl
+
+#+cmu (ext:file-comment "$Module: mime.lisp")
+
+;;; 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-tests)
+
+(defvar *samples-directory*
+  (merge-pathnames (make-pathname :directory '(:relative "samples"))
+		   #.(or *compile-file-pathname*
+			 *load-pathname*
+			 #P"")))
+
+(deftest mime.1
+    (let* ((orig (mime-message (make-pathname :defaults #.(or *compile-file-pathname*
+							   *load-pathname*)
+					   :name "sample1"
+					   :type "msg")))
+	   (dup (mime-message (with-output-to-string (out) (encode-mime-part orig out)))))
+      (mime= orig dup))
+  t)
+
+(deftest mime.2
+    (loop
+       for f in (directory (make-pathname :defaults *samples-directory*
+					  :name :wild
+					  :type "txt"))
+       do
+	 (format t "~A:~%" f)
+	 (finish-output)
+	 (let* ((orig (mime-message f))
+		(dup (mime-message (with-output-to-string (out) (encode-mime-part orig out)))))
+	   (unless (mime= orig dup)
+	     (return nil)))
+       finally (return t))
+  t)
diff --git a/third_party/lisp/mime4cl/test/package.lisp b/third_party/lisp/mime4cl/test/package.lisp
new file mode 100644
index 000000000000..bde0bf25d5b1
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/package.lisp
@@ -0,0 +1,28 @@
+;;;  package.lisp --- package description for the regression tests
+
+;;;  Copyright (C) 2006, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+#+cmu (ext:file-comment "$Module: package.lisp $")
+
+;;; 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
+
+(cl:in-package :common-lisp)
+
+(defpackage :mime4cl-tests
+  (:use :common-lisp
+	:rtest :mime4cl)
+  (:export))
diff --git a/third_party/lisp/mime4cl/test/rt.lisp b/third_party/lisp/mime4cl/test/rt.lisp
new file mode 100644
index 000000000000..d4dd2aedb677
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/rt.lisp
@@ -0,0 +1,254 @@
+#|----------------------------------------------------------------------------|
+ | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
+ |                                                                            |
+ | Permission  to  use,  copy, modify, and distribute this software  and  its |
+ | documentation for any purpose  and without fee is hereby granted, provided |
+ | that this copyright  and  permission  notice  appear  in  all  copies  and |
+ | supporting  documentation,  and  that  the  name  of M.I.T. not be used in |
+ | advertising or  publicity  pertaining  to  distribution  of  the  software |
+ | without   specific,   written   prior   permission.      M.I.T.  makes  no |
+ | representations  about  the  suitability of this software for any purpose. |
+ | It is provided "as is" without express or implied warranty.                |
+ |                                                                            |
+ |  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,  INCLUDING  |
+ |  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL  |
+ |  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL  DAMAGES  OR  |
+ |  ANY  DAMAGES  WHATSOEVER  RESULTING  FROM  LOSS OF USE, DATA OR PROFITS,  |
+ |  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER  TORTIOUS  ACTION,  |
+ |  ARISING  OUT  OF  OR  IN  CONNECTION WITH THE USE OR PERFORMANCE OF THIS  |
+ |  SOFTWARE.                                                                 |
+ |----------------------------------------------------------------------------|#
+
+(defpackage #:regression-test
+  (:nicknames #:rtest #-lispworks #:rt) 
+  (:use #:cl)
+  (:export #:*do-tests-when-defined* #:*test* #:continue-testing
+	   #:deftest #:do-test #:do-tests #:get-test #:pending-tests
+	   #:rem-all-tests #:rem-test)
+  (:documentation "The MIT regression tester with pfdietz's modifications"))
+
+(in-package :regression-test)
+
+(defvar *test* nil "Current test name")
+(defvar *do-tests-when-defined* nil)
+(defvar *entries* '(nil) "Test database")
+(defvar *in-test* nil "Used by TEST")
+(defvar *debug* nil "For debugging")
+(defvar *catch-errors* t
+  "When true, causes errors in a test to be caught.")
+(defvar *print-circle-on-failure* nil
+  "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
+(defvar *compile-tests* nil
+  "When true, compile the tests before running them.")
+(defvar *optimization-settings* '((safety 3)))
+(defvar *expected-failures* nil
+  "A list of test names that are expected to fail.")
+
+(defstruct (entry (:conc-name nil)
+		  (:type list))
+  pend name form)
+
+(defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry) `(cdr ,entry))
+
+(defun pending-tests ()
+  (do ((l (cdr *entries*) (cdr l))
+       (r nil))
+      ((null l) (nreverse r))
+    (when (pend (car l))
+      (push (name (car l)) r))))
+
+(defun rem-all-tests ()
+  (setq *entries* (list nil))
+  nil)
+
+(defun rem-test (&optional (name *test*))
+  (do ((l *entries* (cdr l)))
+      ((null (cdr l)) nil)
+    (when (equal (name (cadr l)) name)
+      (setf (cdr l) (cddr l))
+      (return name))))
+
+(defun get-test (&optional (name *test*))
+  (defn (get-entry name)))
+
+(defun get-entry (name)
+  (let ((entry (find name (cdr *entries*)
+		     :key #'name
+		     :test #'equal)))
+    (when (null entry)
+      (report-error t
+        "~%No test with name ~:@(~S~)."
+	name))
+    entry))
+
+(defmacro deftest (name form &rest values)
+  `(add-entry '(t ,name ,form .,values)))
+
+(defun add-entry (entry)
+  (setq entry (copy-list entry))
+  (do ((l *entries* (cdr l))) (nil)
+    (when (null (cdr l))
+      (setf (cdr l) (list entry))
+      (return nil))
+    (when (equal (name (cadr l)) 
+		 (name entry))
+      (setf (cadr l) entry)
+      (report-error nil
+        "Redefining test ~:@(~S~)"
+        (name entry))
+      (return nil)))
+  (when *do-tests-when-defined*
+    (do-entry entry))
+  (setq *test* (name entry)))
+
+(defun report-error (error? &rest args)
+  (cond (*debug* 
+	 (apply #'format t args)
+	 (if error? (throw '*debug* nil)))
+	(error? (apply #'error args))
+	(t (apply #'warn args))))
+
+(defun do-test (&optional (name *test*))
+  (do-entry (get-entry name)))
+
+(defun equalp-with-case (x y)
+  "Like EQUALP, but doesn't do case conversion of characters."
+  (cond
+   ((eq x y) t)
+   ((consp x)
+    (and (consp y)
+	 (equalp-with-case (car x) (car y))
+	 (equalp-with-case (cdr x) (cdr y))))
+   ((and (typep x 'array)
+	 (= (array-rank x) 0))
+    (equalp-with-case (aref x) (aref y)))
+   ((typep x 'vector)
+    (and (typep y 'vector)
+	 (let ((x-len (length x))
+	       (y-len (length y)))
+	   (and (eql x-len y-len)
+		(loop
+		 for e1 across x
+		 for e2 across y
+		 always (equalp-with-case e1 e2))))))
+   ((and (typep x 'array)
+	 (typep y 'array)
+	 (not (equal (array-dimensions x)
+		     (array-dimensions y))))
+    nil)
+   ((typep x 'array)
+    (and (typep y 'array)
+	 (let ((size (array-total-size x)))
+	   (loop for i from 0 below size
+		 always (equalp-with-case (row-major-aref x i)
+					  (row-major-aref y i))))))
+   (t (eql x y))))
+
+(defun do-entry (entry &optional
+		       (s *standard-output*))
+  (catch '*in-test*
+    (setq *test* (name entry))
+    (setf (pend entry) t)
+    (let* ((*in-test* t)
+	   ;; (*break-on-warnings* t)
+	   (aborted nil)
+	   r)
+      ;; (declare (special *break-on-warnings*))
+
+      (block aborted
+	(setf r
+	      (flet ((%do
+		      ()
+		      (if *compile-tests*
+			  (multiple-value-list
+			   (funcall (compile
+				     nil
+				     `(lambda ()
+					(declare
+					 (optimize ,@*optimization-settings*))
+					,(form entry)))))
+			(multiple-value-list
+			 (eval (form entry))))))
+		(if *catch-errors*
+		    (handler-bind
+			((style-warning #'muffle-warning)
+			 (error #'(lambda (c)
+				    (setf aborted t)
+				    (setf r (list c))
+				    (return-from aborted nil))))
+		      (%do))
+		  (%do)))))
+
+      (setf (pend entry)
+	    (or aborted
+		(not (equalp-with-case r (vals entry)))))
+      
+      (when (pend entry)
+	(let ((*print-circle* *print-circle-on-failure*))
+	  (format s "~&Test ~:@(~S~) failed~
+                   ~%Form: ~S~
+                   ~%Expected value~P: ~
+                      ~{~S~^~%~17t~}~%"
+		  *test* (form entry)
+		  (length (vals entry))
+		  (vals entry))
+	  (format s "Actual value~P: ~
+                      ~{~S~^~%~15t~}.~%"
+		  (length r) r)))))
+  (when (not (pend entry)) *test*))
+
+(defun continue-testing ()
+  (if *in-test*
+      (throw '*in-test* nil)
+      (do-entries *standard-output*)))
+
+(defun do-tests (&optional
+		 (out *standard-output*))
+  (dolist (entry (cdr *entries*))
+    (setf (pend entry) t))
+  (if (streamp out)
+      (do-entries out)
+      (with-open-file 
+	  (stream out :direction :output)
+	(do-entries stream))))
+
+(defun do-entries (s)
+  (format s "~&Doing ~A pending test~:P ~
+             of ~A tests total.~%"
+          (count t (cdr *entries*)
+		 :key #'pend)
+	  (length (cdr *entries*)))
+  (dolist (entry (cdr *entries*))
+    (when (pend entry)
+      (format s "~@[~<~%~:; ~:@(~S~)~>~]"
+	      (do-entry entry s))))
+  (let ((pending (pending-tests))
+	(expected-table (make-hash-table :test #'equal)))
+    (dolist (ex *expected-failures*)
+      (setf (gethash ex expected-table) t))
+    (let ((new-failures
+	   (loop for pend in pending
+		 unless (gethash pend expected-table)
+		 collect pend)))
+      (if (null pending)
+	  (format s "~&No tests failed.")
+	(progn
+	  (format s "~&~A out of ~A ~
+                   total tests failed: ~
+                   ~:@(~{~<~%   ~1:;~S~>~
+                         ~^, ~}~)."
+		  (length pending)
+		  (length (cdr *entries*))
+		  pending)
+	  (if (null new-failures)
+	      (format s "~&No unexpected failures.")
+	    (when *expected-failures*
+	      (format s "~&~A unexpected failures: ~
+                   ~:@(~{~<~%   ~1:;~S~>~
+                         ~^, ~}~)."
+		    (length new-failures)
+		    new-failures)))
+	  ))
+      (null pending))))
diff --git a/third_party/lisp/mime4cl/test/sample1.msg b/third_party/lisp/mime4cl/test/sample1.msg
new file mode 100644
index 000000000000..662a9fab341e
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/sample1.msg
@@ -0,0 +1,86 @@
+From wcp@scylla.home.lan Fri Feb 17 11:02:28 2012
+Status: RO
+X-VM-v5-Data: ([nil nil nil nil nil nil nil nil nil]
+	["1133" "Friday" "17" "February" "2012" "11:02:27" "+0100" "Walter C. Pelissero" "walter@pelissero.de" nil "56" "test" "^From:" nil nil "2" nil nil nil nil nil nil nil nil nil nil]
+	nil)
+X-Clpmr-Processed: 2012-02-17T11:02:31
+X-Clpmr-Version: 2011-10-23T12:55:20, SBCL 1.0.49
+Received: from scylla.home.lan (localhost [127.0.0.1])
+	by scylla.home.lan (8.14.5/8.14.5) with ESMTP id q1HA2Sik004513
+	for <wcp@scylla.home.lan>; Fri, 17 Feb 2012 11:02:28 +0100 (CET)
+	(envelope-from wcp@scylla.home.lan)
+Received: (from wcp@localhost)
+	by scylla.home.lan (8.14.5/8.14.5/Submit) id q1HA2SqU004512;
+	Fri, 17 Feb 2012 11:02:28 +0100 (CET)
+	(envelope-from wcp)
+Message-ID: <20286.9651.890757.323027@scylla.home.lan>
+X-Mailer: VM 8.1.1 under 23.3.1 (amd64-portbld-freebsd8.2)
+Reply-To: walter@pelissero.de
+X-Attribution: WP
+X-For-Spammers: blacklistme@pelissero.de
+X-MArch-Processing-Time: 0.552s
+MIME-Version: 1.0
+Content-Type: multipart/mixed; boundary="615CiWUaGO"
+Content-Transfer-Encoding: 7BIT
+From: walter@pelissero.de (Walter C. Pelissero)
+To: wcp@scylla.home.lan
+Subject: test
+Date: Fri, 17 Feb 2012 11:02:27 +0100
+
+
+--615CiWUaGO
+Content-Type: text/plain; charset="us-ascii"
+Content-Transfer-Encoding: 7BIT
+Content-Description: message body text
+
+Hereafter three attachments.
+
+The first:
+
+--615CiWUaGO
+Content-Type: application/octet-stream; name="attach1"
+Content-Transfer-Encoding: BASE64
+Content-Disposition: attachment; filename="attach1"
+
+YXR0YWNoMQo=

+
+--615CiWUaGO
+Content-Type: text/plain; charset="us-ascii"
+Content-Transfer-Encoding: 7BIT
+Content-Description: message body text
+
+
+The second:
+
+--615CiWUaGO
+Content-Type: application/octet-stream; name="attach2"
+Content-Transfer-Encoding: BASE64
+Content-Disposition: attachment; filename="attach2"
+
+YXR0YWNoMgo=

+
+--615CiWUaGO
+Content-Type: text/plain; charset="us-ascii"
+Content-Transfer-Encoding: 7BIT
+Content-Description: message body text
+
+
+The third:
+
+--615CiWUaGO
+Content-Type: application/octet-stream; name="attach3"
+Content-Transfer-Encoding: BASE64
+Content-Disposition: attachment; filename="attach3"
+
+YXR0YWNoMwo=

+
+--615CiWUaGO
+Content-Type: text/plain; charset="us-ascii"
+Content-Transfer-Encoding: 7BIT
+Content-Description: .signature
+
+
+-- 
+http://pelissero.de
+--615CiWUaGO--
+