diff options
Diffstat (limited to 'third_party/lisp')
| -rw-r--r-- | third_party/lisp/mime4cl/address.lisp | 301 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/endec.lisp | 683 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/mime.lisp | 1037 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/mime4cl-tests.asd | 54 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/mime4cl.asd | 53 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/package.lisp | 107 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/streams.lisp | 366 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/address.lisp | 124 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/endec.lisp | 167 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/mime.lisp | 53 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/package.lisp | 28 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/rt.lisp | 254 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/sample1.msg | 86 |
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-- + |