diff options
Diffstat (limited to 'third_party/lisp/mime4cl')
| -rw-r--r-- | third_party/lisp/mime4cl/address.lisp | 130 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/endec.lisp | 540 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/mime.lisp | 644 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/mime4cl-tests.asd | 14 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/package.lisp | 158 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/streams.lisp | 194 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/endec.lisp | 104 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/mime.lisp | 24 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/package.lisp | 2 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/rt.lisp | 172 |
10 files changed, 991 insertions, 991 deletions
diff --git a/third_party/lisp/mime4cl/address.lisp b/third_party/lisp/mime4cl/address.lisp index 9a3bec9b20..4f4cda2434 100644 --- a/third_party/lisp/mime4cl/address.lisp +++ b/third_party/lisp/mime4cl/address.lisp @@ -101,10 +101,10 @@ (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) ".")))) + :user (car address-list) + :host (cadr address-list) + :domain (when (cddr address-list) + (string-concat (cddr address-list) ".")))) (defun populate-grammar () @@ -164,7 +164,7 @@ (deflazy define-grammar (let ((*package* #.*package*) - (*compile-print* (when npg::*debug* t))) + (*compile-print* (when npg::*debug* t))) (reset-grammar) (format t "~&creating e-mail address grammar...~%") (populate-grammar) @@ -183,36 +183,36 @@ (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))))))) + (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)))) + :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)))) + :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)))) + :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) @@ -221,40 +221,40 @@ (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))))) + (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))))) + :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))))) + (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)))))))) + 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 @@ -262,9 +262,9 @@ 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)))) + 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 @@ -273,10 +273,10 @@ 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)) + (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 @@ -286,16 +286,16 @@ 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))))) + 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))))) + (parse grammar 'address-list cursor))))) diff --git a/third_party/lisp/mime4cl/endec.lisp b/third_party/lisp/mime4cl/endec.lisp index f63eb3c22e..9f2f9c51c2 100644 --- a/third_party/lisp/mime4cl/endec.lisp +++ b/third_party/lisp/mime4cl/endec.lisp @@ -33,7 +33,7 @@ da)) (declaim (type (simple-array (unsigned-byte 8)) +base64-decode-table+) - (type simple-string +base64-encode-table+)) + (type simple-string +base64-encode-table+)) (defvar *base64-line-length* 76 "Maximum length of the encoded base64 line. NIL means it can @@ -49,39 +49,39 @@ 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. + :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)) + :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. + :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) + :type fixnum) (line-length :initarg :line-length - :initform nil - :reader encoder-line-length - :type (or fixnum null))) + :initform nil + :reader encoder-line-length + :type (or fixnum null))) (:documentation "Abstract base class for line encoders.")) @@ -126,7 +126,7 @@ It should expect a character as its only argument.")) (defmethod encoder-write-byte ((encoder 8bit-encoder) byte) (funcall (slot-value encoder 'output-function) - (code-char byte)) + (code-char byte)) (values)) (defmethod decoder-read-byte ((decoder 8bit-decoder)) @@ -135,7 +135,7 @@ It should expect a character as its only argument.")) (defmethod encoder-write-byte ((encoder 7bit-encoder) byte) (funcall (slot-value encoder 'output-function) - (code-char (logand #x7F byte))) + (code-char (logand #x7F byte))) (values)) (defmethod decoder-read-byte ((decoder 7bit-decoder)) @@ -146,8 +146,8 @@ It should expect a character as its only argument.")) (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)) + (type fixnum start end) + (type vector sequence)) (loop for i fixnum from start below end for byte = (decoder-read-byte decoder) @@ -162,14 +162,14 @@ It should expect a character as its only argument.")) 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))))))) + (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))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -178,10 +178,10 @@ It should expect a character as its only argument.")) "Parse two characters as hexadecimal and return their combined value." (declare (optimize (speed 3) (safety 0) (debug 0)) - (type character c1 c2)) + (type character c1 c2)) (flet ((digit-value (char) - (or (position char "0123456789ABCDEF") - (return-from parse-hex nil)))) + (or (position char "0123456789ABCDEF") + (return-from parse-hex nil)))) (+ (* 16 (digit-value c1)) (digit-value c2)))) @@ -193,91 +193,91 @@ value." (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)))))) + (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)))))) + (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)))) + 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))) + 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)) + (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) + :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) + (vector-push-extend byte ,output-sequence) + :parser-errors ,parser-errors) ,output-sequence))) (defun decode-quoted-printable-stream-to-sequence (stream &key parser-errors) @@ -295,84 +295,84 @@ return a decoded sequence of bytes." (defclass quoted-printable-encoder (line-encoder) ((line-length :initform *quoted-printable-line-length* - :type (or fixnum null)) + :type (or fixnum null)) (pending-space :initform nil - :type boolean))) + :type boolean))) (defmethod encoder-write-byte ((encoder quoted-printable-encoder) byte) (declare (optimize (speed 3) (safety 0) (debug 0)) - (type (unsigned-byte 8) byte)) + (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)) + (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))))) + (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 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))))) + (>= 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)) + (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"))))) + (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))) + (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 @@ -381,7 +381,7 @@ quoted printable sequence of characters." (make-encoder-loop quoted-printable-encoder (when (< i end) (prog1 (elt sequence i) - (f++ i))) + (f++ i))) (write-char char stream)))) (defun encode-quoted-printable-sequence (sequence &key (start 0) (end (length sequence))) @@ -395,9 +395,9 @@ string and return it." (defclass base64-encoder (line-encoder) ((line-length :initform *base64-line-length*) (bitstore :initform 0 - :type fixnum) + :type fixnum) (bytecount :initform 0 - :type fixnum)) + :type fixnum)) (:documentation "Class for Base64 encoder output streams.")) @@ -406,76 +406,76 @@ string and return it." (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)))) + `(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)) + (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))) + (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 #\=)))) + (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))) + (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))) + (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)))) + (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 @@ -485,7 +485,7 @@ return it." (defclass base64-decoder (parsing-decoder) ((bitstore :initform 0 - :type fixnum) + :type fixnum) (bytecount :initform 0 :type fixnum)) (:documentation "Class for Base64 decoder input streams.")) @@ -494,45 +494,45 @@ return it." (declare (optimize (speed 3) (safety 0) (debug 0))) (with-slots (bitstore bytecount input-function) decoder (declare (type fixnum bitstore bytecount) - (type function input-function)) + (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)))))) + (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)))))) + (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)) + (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)) + (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) @@ -551,10 +551,10 @@ to OUT a stream of decoded bytes." (gcase (encoding string-equal) (:quoted-printable (decode-quoted-printable-stream in out - :parser-errors parser-errors-p)) + :parser-errors parser-errors-p)) (:base64 (decode-base64-stream in out - :parser-errors parser-errors-p)) + :parser-errors parser-errors-p)) (otherwise (dump-stream-binary in out)))) @@ -562,10 +562,10 @@ to OUT a stream of decoded bytes." (gcase (encoding string-equal) (:quoted-printable (decode-quoted-printable-string string - :parser-errors parser-errors-p)) + :parser-errors parser-errors-p)) (:base64 (decode-base64-string string - :parser-errors parser-errors-p)) + :parser-errors parser-errors-p)) (otherwise (map '(vector (unsigned-byte 8)) #'char-code string)))) @@ -573,19 +573,19 @@ to OUT a stream of decoded bytes." (gcase (encoding string-equal) (:quoted-printable (decode-quoted-printable-stream-to-sequence stream - :parser-errors parser-errors-p)) + :parser-errors parser-errors-p)) (:base64 (decode-base64-stream-to-sequence stream - :parser-errors parser-errors-p)) + :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))))) + 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) @@ -595,9 +595,9 @@ to OUT a stream of decoded bytes." (encode-base64-stream in out)) (otherwise (loop - for byte = (read-byte in nil) - while byte - do (write-char (code-char byte) out))))) + 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) @@ -607,8 +607,8 @@ to OUT a stream of decoded bytes." (encode-base64-sequence-to-stream sequence out)) (otherwise (loop - for byte across sequence - do (write-char (code-char byte) out))))) + for byte across sequence + do (write-char (code-char byte) out))))) (defun encode-sequence (sequence encoding) (gcase (encoding string-equal) @@ -625,23 +625,23 @@ to OUT a stream of decoded bytes." "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)) + (type simple-string string)) (loop with output-sequence = (make-array (length string) - :element-type '(unsigned-byte 8) - :fill-pointer 0) + :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))) + (#\= + (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))) @@ -669,15 +669,15 @@ sequence, a charset string indicating the original coding." 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)) + (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)) + (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 index e35ae6bea5..1b1d98bfaf 100644 --- a/third_party/lisp/mime4cl/mime.lisp +++ b/third_party/lisp/mime4cl/mime.lisp @@ -99,15 +99,15 @@ (defclass mime-multipart (mime-part) ((parts :initarg :parts - :accessor mime-parts))) + :accessor mime-parts))) (defclass mime-message (mime-part) ((headers :initarg :headers - :initform '() - :type list - :accessor mime-message-headers) + :initform '() + :type list + :accessor mime-message-headers) (real-message :initarg :body - :accessor mime-body))) + :accessor mime-body))) (defun mime-part-p (object) (typep object 'mime-part)) @@ -120,11 +120,11 @@ (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))))) + (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) @@ -133,18 +133,18 @@ ;; and assign to the body slot. (with-slots (real-message) part (when (and (slot-boundp part 'real-message) - (consp real-message)) + (consp real-message)) (setf real-message - (make-instance 'mime-multipart :parts 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))))))) + :test #'(lambda (x y) + (and (funcall test (car x) (car y)) + (funcall test (cdr x) (cdr y))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -154,24 +154,24 @@ (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)))) + `(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)))) + (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) @@ -180,14 +180,14 @@ (defmethod mime= ((part1 mime-message) (part2 mime-message)) (and (call-next-method) (alist= (mime-message-headers part1) (mime-message-headers part2) - :test #'string=) + :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))) + '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) @@ -202,10 +202,10 @@ (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)))))) + (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)) @@ -214,12 +214,12 @@ (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)))))) + (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)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -238,7 +238,7 @@ (aif (assoc name (mime-type-parameters part) :test #'string-equal) (setf (cdr it) value) (push (cons name value) - (mime-type-parameters part))) + (mime-type-parameters part))) value) (defgeneric get-mime-disposition-parameter (part name) @@ -252,7 +252,7 @@ (aif (assoc name (mime-disposition-parameters part) :test #'string-equal) (setf (cdr it) value) (push (cons name value) - (mime-disposition-parameters part)))) + (mime-disposition-parameters part)))) (defmethod mime-part-file-name ((part mime-part)) "Return the filename associated to mime PART or NIL if the mime @@ -263,7 +263,7 @@ part doesn't have a file 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)) + (get-mime-type-parameter part :name) value)) (defun mime-text-charset (part) (get-mime-type-parameter part :charset)) @@ -272,31 +272,31 @@ part doesn't have a file name." "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 + 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))) + (#\; (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) @@ -305,20 +305,20 @@ semi-colons not within strings or comments." (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)))))))))) + (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 @@ -326,14 +326,14 @@ 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))) + (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)))))))) + (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 @@ -342,9 +342,9 @@ 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))))) + (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 @@ -353,7 +353,7 @@ the header value." (be colon (position #\: string) (when colon (values (string-trim-whitespace (subseq string 0 colon)) - (string-trim-whitespace (subseq string (1+ colon))))))) + (string-trim-whitespace (subseq string (1+ colon))))))) (defvar *default-type* '("text" "plain" (("charset" . "us-ascii"))) @@ -384,40 +384,40 @@ quote messages, for instance.")) "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))) + (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))))) + (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))))) + 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 @@ -431,16 +431,16 @@ each (non-boundary) line or END-PART-FUNCTION at each 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)) + (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))) + (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 @@ -451,20 +451,20 @@ PART-BOUNDARY. Return a list of strings." "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)) + (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))) + (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 @@ -479,19 +479,19 @@ separated by PART-BOUNDARY." (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))) + (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)))) + (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)) @@ -505,19 +505,19 @@ separated by PART-BOUNDARY." (dolist (h (mime-message-headers part)) (unless (stringp (car h)) (setf (car h) - (string-capitalize (car h)))) + (string-capitalize (car h)))) (unless (or (string-starts-with "content-" (car h) #'string-equal) - (string-equal "mime-version" (car h))) + (string-equal "mime-version" (car h))) (format stream "~A: ~A~%" - (car h) (cdr h)))) + (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))) + (boundary (choose-boundary (mime-parts part) original-boundary))) (unless (and original-boundary - (string= boundary original-boundary)) + (string= boundary original-boundary)) (setf (get-mime-type-parameter part :boundary) boundary)) (call-next-method))) @@ -532,8 +532,8 @@ separated by PART-BOUNDARY." (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)))) + (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)) @@ -547,9 +547,9 @@ 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)))) + (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 @@ -560,24 +560,24 @@ time." (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) + (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))))))) + (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 @@ -589,29 +589,29 @@ found in STREAM." (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)) + ;; 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)))) + (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)))) + (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)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -631,35 +631,35 @@ found in 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))) + (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))) + (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))) + (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)))) + (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 @@ -667,24 +667,24 @@ 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))))) + (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))) + (read-mime-message stream))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -713,37 +713,37 @@ Return STRING itself if STRING is an unkown encoding." 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))) + (header what headers))) (destructuring-bind (type subtype parms) - (or - (aand (hdr :content-type) - (parse-content-type it)) - *default-type*) + (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)))) + '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)) + '(:mime-version :content-transfer-encoding :content-type + :content-disposition :content-description :content-id)) (make-mime-part headers stream))) (defun read-mime-message (stream) @@ -752,17 +752,17 @@ returns a MIME-MESSAGE object." (be headers (read-rfc822-headers stream) *default-type* '("text" "plain" (("charset" . "us-ascii"))) (flet ((hdr (what) - (header what headers))) + (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)))))) + (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) @@ -776,7 +776,7 @@ returns a MIME-MESSAGE object." (defmethod mime-message ((msg pathname)) (let (#+sbcl(sb-impl::*default-external-format* :latin-1) - #+sbcl(sb-alien::*default-c-string-external-format* :latin-1)) + #+sbcl(sb-alien::*default-c-string-external-format* :latin-1)) (with-open-file (in msg) (read-mime-message in)))) @@ -791,9 +791,9 @@ returns a MIME-MESSAGE 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)))) + :subtype "octect-stream" + :content-transfer-encoding :base64 + :body (read-file object :element-type '(unsigned-byte 8)))) (defmethod mime-part ((object mime-part)) object) @@ -803,39 +803,39 @@ returns a MIME-MESSAGE 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)))) + (: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))))) + (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))))) + (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))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -870,10 +870,10 @@ returns a MIME-MESSAGE object." ;; 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))) + (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))))) @@ -888,29 +888,29 @@ returns a MIME-MESSAGE object." (write-string body out)) (vector (loop - for byte across body - do (write-char (code-char byte) out))) + 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))))))) + (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)))) + (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 "~&~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))) + (type-of part) (mime-subtype part) (mime-description part) (mime-part-size part))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -929,19 +929,19 @@ second in MIME.")) (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))))) + (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))))) + 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))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -960,8 +960,8 @@ is a string.")) (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)))) + (find-mime-part-by-id p id)) + (mime-parts part)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1038,8 +1038,8 @@ is a string.")) (defmethod map-parts ((function function) (part mime-multipart)) (setf (mime-parts part) (mapcar #'(lambda (p) - (map-parts function p)) - (mime-parts part))) + (map-parts function p)) + (mime-parts part))) part) ;; apply-on-parts is like map-parts but doesn't modify the parts (at least diff --git a/third_party/lisp/mime4cl/mime4cl-tests.asd b/third_party/lisp/mime4cl/mime4cl-tests.asd index e4d983c057..cd6bca2361 100644 --- a/third_party/lisp/mime4cl/mime4cl-tests.asd +++ b/third_party/lisp/mime4cl/mime4cl-tests.asd @@ -24,7 +24,7 @@ (defpackage :mime4cl-tests-system (:use :common-lisp :asdf #+asdfa :asdfa) (:export #:*base-directory* - #:*compilation-epoch*)) + #:*compilation-epoch*)) (in-package :mime4cl-tests-system) @@ -39,12 +39,12 @@ :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")))))) + :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 diff --git a/third_party/lisp/mime4cl/package.lisp b/third_party/lisp/mime4cl/package.lisp index a6e7e7d8ef..fc5d9627f9 100644 --- a/third_party/lisp/mime4cl/package.lisp +++ b/third_party/lisp/mime4cl/package.lisp @@ -23,86 +23,86 @@ (defpackage :mime4cl (:nicknames :mime) (:use :common-lisp :npg :sclf - ;; for Gray streams - #+cmu :extensions #+sbcl :sb-gray) + ;; 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) + #: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 - #:find-mime-text-part - #: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)) + #: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 + #:find-mime-text-part + #: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 index 64c7adeec5..087207ce53 100644 --- a/third_party/lisp/mime4cl/streams.lisp +++ b/third_party/lisp/mime4cl/streams.lisp @@ -32,36 +32,36 @@ (stream-file-position stream position)) (defvar *original-file-position-function* (prog1 - (symbol-function 'file-position) + (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))) + (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)) + (setf start 0)) (unless end - (setf end (length seq))) + (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)))) + 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) + :initarg :stream + :reader real-stream) (dont-close :initform nil - :initarg :dont-close))) + :initarg :dont-close))) (defmethod stream-file-position ((stream coder-stream-mixin) &optional position) (apply #'file-position (remove nil (list (slot-value stream 'real-stream) @@ -91,15 +91,15 @@ (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)))))) + #'(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))))) + #'(lambda () + (read-char (slot-value stream 'real-stream) nil))))) (defmethod stream-read-byte ((stream coder-input-stream-mixin)) (or (decoder-read-byte stream) @@ -136,36 +136,36 @@ in a stream of character.")) (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)))))) + (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)))))) + (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))))) + (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))) + (code-char it) + :eof))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -192,31 +192,31 @@ in a stream of character.")) (etypecase source (string (setf real-stream (make-string-input-stream source) - input-function #'(lambda () - (awhen (read-char real-stream nil) - (char-code it))))) + 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))))))) + (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))))) + #'(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)))) + 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))))))) + input-function #'(lambda () + (read-byte real-stream nil))))))) (defmethod initialize-instance ((stream character-input-adapter-stream) &key &allow-other-keys) (call-next-method) @@ -225,31 +225,31 @@ in a stream of character.")) (etypecase source (string (setf real-stream (make-string-input-stream source) - input-function #'(lambda () - (read-char real-stream nil)))) + 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))))))) + (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)))))) + #'(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)))) + 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)))))))) + 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) @@ -259,31 +259,31 @@ in a stream of character.")) (defmethod stream-read-byte ((stream binary-input-adapter-stream)) (with-slots (input-function) stream (or (funcall input-function) - :eof))) + :eof))) (defmethod stream-read-char ((stream character-input-adapter-stream)) (with-slots (input-function) stream (or (funcall input-function) - :eof))) + :eof))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass delimited-input-stream (fundamental-character-input-stream coder-stream-mixin) ((start-offset :initarg :start - :initform 0 - :reader stream-start - :type integer) + :initform 0 + :reader stream-start + :type integer) (end-offset :initarg :end - :initform nil - :reader stream-end - :type (or null integer)))) + :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))))) + (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) @@ -301,24 +301,24 @@ in a stream of character.")) (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))) + (< (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))) + (< (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))) + :reader stream-string))) (defmethod initialize-instance ((stream my-string-input-stream) &key &allow-other-keys) (call-next-method) @@ -329,7 +329,7 @@ in a stream of character.")) (defmethod stream-read-char ((stream my-string-input-stream)) (with-slots (real-stream) stream (or (read-char real-stream nil) - :eof))) + :eof))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -344,25 +344,25 @@ in a stream of character.")) (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)))) + (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-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)))))) + :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))) + (: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/endec.lisp b/third_party/lisp/mime4cl/test/endec.lisp index 7b6763c990..86d358a50c 100644 --- a/third_party/lisp/mime4cl/test/endec.lisp +++ b/third_party/lisp/mime4cl/test/endec.lisp @@ -24,66 +24,66 @@ (deftest quoted-printable.1 (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code - "Français, Español, böse, skøl")) + "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) + "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")) + (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)) + (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")) + (decode-quoted-printable-string "this = wrong")) "this = wrong") (deftest quoted-printable.6 (map 'string #'code-char - (decode-quoted-printable-string "this is wrong=")) + (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")) + (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 = 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 = 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 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")) "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 + "please read the next line")) "please read the next =20 line") @@ -93,24 +93,24 @@ line") (deftest base64.1 (let ((*base64-line-length* nil)) (encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code - "Some random string."))) + "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)) + "Some random string.") :start 5 :end 11)) "cmFuZG9t") (deftest base64.3 (map 'string #'code-char - (decode-base64-string "U29tZSByYW5kb20gc3RyaW5nLg==")) + (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)) + (decode-base64-string "some rubbish U29tZSByYW5kb20gc3RyaW5nLg== more rubbish" + :start 13 :end 41)) "Some random string.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -121,47 +121,47 @@ line") (defun perftest-encoder (encoder-class &optional (megs 100)) (declare (optimize (speed 3) (debug 0) (safety 0)) - (type fixnum megs)) + (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)))))) + (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)))))) + (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)) + (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"))) + :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))))))) + (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 index 1488f927fc..4d5b104218 100644 --- a/third_party/lisp/mime4cl/test/mime.lisp +++ b/third_party/lisp/mime4cl/test/mime.lisp @@ -25,9 +25,9 @@ (defvar *samples-directory* (merge-pathnames (make-pathname :directory '(:relative "samples")) - #.(or *compile-file-pathname* - *load-pathname* - #P""))) + #.(or *compile-file-pathname* + *load-pathname* + #P""))) (defvar *sample1-file* (make-pathname :defaults #.(or *compile-file-pathname* *load-pathname*) @@ -36,21 +36,21 @@ (deftest mime.1 (let* ((orig (mime-message *sample1-file*)) - (dup (mime-message (with-output-to-string (out) (encode-mime-part orig out))))) + (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")) + :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))) + (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 index bde0bf25d5..d3d921e1e4 100644 --- a/third_party/lisp/mime4cl/test/package.lisp +++ b/third_party/lisp/mime4cl/test/package.lisp @@ -24,5 +24,5 @@ (defpackage :mime4cl-tests (:use :common-lisp - :rtest :mime4cl) + :rtest :mime4cl) (:export)) diff --git a/third_party/lisp/mime4cl/test/rt.lisp b/third_party/lisp/mime4cl/test/rt.lisp index d4dd2aedb6..06160debbe 100644 --- a/third_party/lisp/mime4cl/test/rt.lisp +++ b/third_party/lisp/mime4cl/test/rt.lisp @@ -23,8 +23,8 @@ (: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) + #: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) @@ -45,7 +45,7 @@ "A list of test names that are expected to fail.") (defstruct (entry (:conc-name nil) - (:type list)) + (:type list)) pend name form) (defmacro vals (entry) `(cdddr ,entry)) @@ -75,12 +75,12 @@ (defun get-entry (name) (let ((entry (find name (cdr *entries*) - :key #'name - :test #'equal))) + :key #'name + :test #'equal))) (when (null entry) (report-error t "~%No test with name ~:@(~S~)." - name)) + name)) entry)) (defmacro deftest (name form &rest values) @@ -93,7 +93,7 @@ (setf (cdr l) (list entry)) (return nil)) (when (equal (name (cadr l)) - (name entry)) + (name entry)) (setf (cadr l) entry) (report-error nil "Redefining test ~:@(~S~)" @@ -105,10 +105,10 @@ (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)))) + (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))) @@ -119,84 +119,84 @@ ((eq x y) t) ((consp x) (and (consp y) - (equalp-with-case (car x) (car y)) - (equalp-with-case (cdr x) (cdr y)))) + (equalp-with-case (car x) (car y)) + (equalp-with-case (cdr x) (cdr y)))) ((and (typep x 'array) - (= (array-rank x) 0)) + (= (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)))))) + (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)))) + (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)))))) + (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*)) + (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) + ;; (*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 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))))) + (or aborted + (not (equalp-with-case r (vals entry))))) (when (pend entry) - (let ((*print-circle* *print-circle-on-failure*)) - (format s "~&Test ~:@(~S~) failed~ + (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: ~ + *test* (form entry) + (length (vals entry)) + (vals entry)) + (format s "Actual value~P: ~ ~{~S~^~%~15t~}.~%" - (length r) r))))) + (length r) r))))) (when (not (pend entry)) *test*)) (defun continue-testing () @@ -205,50 +205,50 @@ (do-entries *standard-output*))) (defun do-tests (&optional - (out *standard-output*)) + (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)))) + (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*))) + :key #'pend) + (length (cdr *entries*))) (dolist (entry (cdr *entries*)) (when (pend entry) (format s "~@[~<~%~:; ~:@(~S~)~>~]" - (do-entry entry s)))) + (do-entry entry s)))) (let ((pending (pending-tests)) - (expected-table (make-hash-table :test #'equal))) + (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))) + (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 ~ + (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: ~ + (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))) - )) + (length new-failures) + new-failures))) + )) (null pending)))) |