diff options
Diffstat (limited to 'third_party/lisp/mime4cl')
| -rw-r--r-- | third_party/lisp/mime4cl/OWNERS | 4 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/README | 7 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/README.md | 27 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/address.lisp | 34 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/default.nix | 13 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/endec.lisp | 136 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/ex-sclf.lisp | 329 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/mime.lisp | 174 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/package.lisp | 19 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/streams.lisp | 343 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/endec.lisp | 30 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/mime.lisp | 39 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/package.lisp | 2 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/rt.lisp | 20 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/samples/sample1.msg (renamed from third_party/lisp/mime4cl/test/sample1.msg) | 0 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/temp-file.lisp | 72 |
16 files changed, 765 insertions, 484 deletions
diff --git a/third_party/lisp/mime4cl/OWNERS b/third_party/lisp/mime4cl/OWNERS index f16dd105d7..2e95807063 100644 --- a/third_party/lisp/mime4cl/OWNERS +++ b/third_party/lisp/mime4cl/OWNERS @@ -1,3 +1 @@ -inherited: true -owners: - - sterni +sterni diff --git a/third_party/lisp/mime4cl/README b/third_party/lisp/mime4cl/README deleted file mode 100644 index 73f0efbda9..0000000000 --- a/third_party/lisp/mime4cl/README +++ /dev/null @@ -1,7 +0,0 @@ -MIME4CL is a Common Lisp library for dealing with MIME messages. -It has originally been written by Walter C. Pelissero and vendored -into depot as upstream has become inactive and provides no repo -of any kind. Upstream and depot version may diverge. - -Upstream Website: http://wcp.sdf-eu.org/software/#mime4cl -Vendored Tarball: http://wcp.sdf-eu.org/software/mime4cl-20150207T211851.tbz diff --git a/third_party/lisp/mime4cl/README.md b/third_party/lisp/mime4cl/README.md new file mode 100644 index 0000000000..2704d481ed --- /dev/null +++ b/third_party/lisp/mime4cl/README.md @@ -0,0 +1,27 @@ +# mime4cl + +`MIME4CL` is a Common Lisp library for dealing with MIME messages. It was +originally been written by Walter C. Pelissero and vendored into depot +([mime4cl-20150207T211851.tbz](http://wcp.sdf-eu.org/software/mime4cl-20150207T211851.tbz) +to be exact) as upstream has become inactive. Its [original +website](http://wcp.sdf-eu.org/software/#mime4cl) can still be accessed. + +The depot version has since diverged from upstream. Main aims were to improve +performance and reduce code size by relying on third party libraries like +flexi-streams. It is planned to improve encoding handling in the long term. +Currently, the library is being worked on intermittently and not very well +tested—**it may not work as expected**. + +## Differences from the original version + +* `//nix/buildLisp` is used as the build system. ASDF is currently untested and + may be broken. + +* The dependency on [sclf](http://wcp.sdf-eu.org/software/#sclf) has been + eliminated by inlining the relevant parts. + +* `MY-STRING-INPUT-STREAM`, `DELIMITED-INPUT-STREAM`, + `CHARACTER-INPUT-ADAPTER-STREAM`, `BINARY-INPUT-ADAPTER-STREAM` etc. have been + replaced by (thin wrappers around) flexi-streams. In addition to improved + handling of encodings, this allows using `READ-SEQUENCE` via the gray stream + interface. diff --git a/third_party/lisp/mime4cl/address.lisp b/third_party/lisp/mime4cl/address.lisp index 944156916c..42688a595b 100644 --- a/third_party/lisp/mime4cl/address.lisp +++ b/third_party/lisp/mime4cl/address.lisp @@ -1,7 +1,7 @@ ;;; address.lisp --- e-mail address parser ;;; Copyright (C) 2007, 2008, 2009 by Walter C. Pelissero -;;; Copyright (C) 2022 The TVL Authors +;;; Copyright (C) 2022-2023 The TVL Authors ;;; Author: Walter C. Pelissero <walter@pelissero.de> ;;; Project: mime4cl @@ -219,14 +219,14 @@ (not (find c " ()\"[]@.<>:;,"))) (defun read-atext (first-character cursor) - (be string (with-output-to-string (out) - (write-char first-character out) - (loop - for c = (read-char (cursor-stream cursor) nil) - while (and c (atom-component-p c)) - do (write-char c out) - finally (when c - (unread-char c (cursor-stream cursor))))) + (let ((string (with-output-to-string (out) + (write-char first-character out) + (loop + for c = (read-char (cursor-stream cursor) nil) + while (and c (atom-component-p c)) + do (write-char c out) + finally (when c + (unread-char c (cursor-stream cursor))))))) (make-token :type 'atext :value string :position (incf (cursor-position cursor))))) @@ -236,7 +236,7 @@ (make-token :type 'keyword :value (string c) :position (incf (cursor-position cursor))))) - (be in (cursor-stream cursor) + (let ((in (cursor-stream cursor))) (loop for c = (read-char in nil) while c @@ -259,7 +259,7 @@ "Return the list of tokens produced by a lexical analysis of STRING. These are the tokens that would be seen by the parser." (with-input-from-string (stream string) - (be cursor (make-cursor :stream stream) + (let ((cursor (make-cursor :stream stream))) (loop for tokens = (read-next-tokens cursor) until (endp tokens) @@ -282,19 +282,19 @@ addresses only." MAILBOX-GROUPs. If STRING is unparsable return NIL. If NO-GROUPS is true, return a flat list of mailboxes throwing away the group containers, if any." - (be grammar (force define-grammar) + (let ((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)) + (let* ((cursor (make-cursor :stream stream)) + (mailboxes (ignore-errors ; ignore parsing errors + (parse grammar 'address-list cursor)))) (if no-groups (mailboxes-only mailboxes) mailboxes))))) (defun debug-addresses (string) "More or less like PARSE-ADDRESSES, but don't ignore parsing errors." - (be grammar (force define-grammar) + (let ((grammar (force define-grammar))) (with-input-from-string (stream string) - (be cursor (make-cursor :stream stream) + (let ((cursor (make-cursor :stream stream))) (parse grammar 'address-list cursor))))) diff --git a/third_party/lisp/mime4cl/default.nix b/third_party/lisp/mime4cl/default.nix index 9d3d6253f4..af015a257b 100644 --- a/third_party/lisp/mime4cl/default.nix +++ b/third_party/lisp/mime4cl/default.nix @@ -6,13 +6,15 @@ depot.nix.buildLisp.library { name = "mime4cl"; deps = [ - depot.third_party.lisp.babel - depot.third_party.lisp.sclf + depot.third_party.lisp.flexi-streams depot.third_party.lisp.npg depot.third_party.lisp.trivial-gray-streams + depot.third_party.lisp.qbase64 + { sbcl = depot.nix.buildLisp.bundled "sb-posix"; } ]; srcs = [ + ./ex-sclf.lisp ./package.lisp ./endec.lisp ./streams.lisp @@ -29,11 +31,10 @@ depot.nix.buildLisp.library { (pkgs.writeText "nix-samples.lisp" '' (in-package :mime4cl-tests) - ;; missing from the tarball completely - (defvar *samples-directory* (pathname "/this/does/not/exist")) - ;; override auto discovery which doesn't work in store - (defvar *sample1-file* (pathname "${./test/sample1.msg}")) + ;; override auto discovery which doesn't work in the nix store + (defvar *samples-directory* (pathname "${./test/samples}/")) '') + ./test/temp-file.lisp ./test/endec.lisp ./test/address.lisp ./test/mime.lisp diff --git a/third_party/lisp/mime4cl/endec.lisp b/third_party/lisp/mime4cl/endec.lisp index 020c212e5e..2e282c2378 100644 --- a/third_party/lisp/mime4cl/endec.lisp +++ b/third_party/lisp/mime4cl/endec.lisp @@ -1,6 +1,7 @@ ;;; endec.lisp --- encoder/decoder functions ;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero +;;; Copyright (C) 2023 by The TVL Authors ;;; Author: Walter C. Pelissero <walter@pelissero.de> ;;; Project: mime4cl @@ -21,19 +22,21 @@ (in-package :mime4cl) +(defun redirect-stream (in out &key (buffer-size 4096)) + "Consume input stream IN and write all its content to output stream OUT. +The streams' element types need to match." + (let ((buf (make-array buffer-size :element-type (stream-element-type in)))) + (loop for pos = (read-sequence buf in) + while (> pos 0) + do (write-sequence buf out :end pos)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Thank you SBCL for rendering constants totally useless! (defparameter +base64-encode-table+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=") -(defparameter +base64-decode-table+ - (let ((da (make-array 256 :element-type '(unsigned-byte 8) :initial-element 65))) - (dotimes (i 64) - (setf (aref da (char-code (char +base64-encode-table+ i))) i)) - da)) - -(declaim (type (simple-array (unsigned-byte 8)) +base64-decode-table+) - (type simple-string +base64-encode-table+)) +(declaim (type simple-string +base64-encode-table+)) (defvar *base64-line-length* 76 "Maximum length of the encoded base64 line. NIL means it can @@ -161,7 +164,7 @@ It should expect a character as its only argument.")) for byte = (decoder-read-byte decoder) unless byte do (return-from decoder-read-line nil) - do (be c (code-char byte) + do (let ((c (code-char byte))) (cond ((char= c #\return) ;; skip the newline (decoder-read-byte decoder) @@ -198,7 +201,7 @@ value." (save (c) (saveb (char-code c))) (push-next () - (be c (funcall input-function) + (let ((c (funcall input-function))) (declare (type (or null character) c)) (cond ((not c)) ((or (char= c #\space) @@ -206,7 +209,7 @@ value." (save c) (push-next)) ((char= c #\=) - (be c1 (funcall input-function) + (let ((c1 (funcall input-function))) (cond ((not c1) (save #\=)) ((char= c1 #\return) @@ -221,7 +224,7 @@ value." (push-next)) (t ;; hexadecimal sequence: get the 2nd digit - (be c2 (funcall input-function) + (let ((c2 (funcall input-function))) (if c2 (aif (parse-hex c1 c2) (saveb it) @@ -271,10 +274,10 @@ binary output OUT the decoded stream of bytes." (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) + `(let ((,output-sequence (make-array 0 + :element-type '(unsigned-byte 8) + :fill-pointer 0 + :adjustable t))) (make-decoder-loop ,decoder-class ,input-form (vector-push-extend byte ,output-sequence) :parser-errors ,parser-errors) @@ -377,7 +380,7 @@ characters quoted printables encoded." (defun encode-quoted-printable-sequence-to-stream (sequence stream &key (start 0) (end (length sequence))) "Encode the sequence of bytes SEQUENCE and write to STREAM a quoted printable sequence of characters." - (be i start + (let ((i start)) (make-encoder-loop quoted-printable-encoder (when (< i end) (prog1 (elt sequence i) @@ -470,7 +473,7 @@ character stream." (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 + (let ((i start)) (make-encoder-loop base64-encoder (when (< i end) (prog1 (elt sequence i) @@ -483,60 +486,34 @@ return it." (with-output-to-string (out) (encode-base64-sequence-to-stream sequence out :start start :end end))) -(defclass base64-decoder (parsing-decoder) - ((bitstore :initform 0 - :type fixnum) - (bytecount :initform 0 :type fixnum)) - (:documentation - "Class for Base64 decoder input streams.")) - -(defmethod decoder-read-byte ((decoder base64-decoder)) - (declare (optimize (speed 3) (safety 0) (debug 0))) - (with-slots (bitstore bytecount input-function) decoder - (declare (type fixnum bitstore bytecount) - (type function input-function)) - (labels ((in6 () - (loop - for c = (funcall input-function) - when (or (not c) (char= #\= c)) - do (return-from decoder-read-byte nil) - do (be sextet (aref +base64-decode-table+ (char-code c)) - (unless (= sextet 65) ; ignore unrecognised characters - (return sextet))))) - (push6 (sextet) - (declare (type fixnum sextet)) - (setf bitstore - (logior sextet (the fixnum (ash bitstore 6)))))) - (case bytecount - (0 - (setf bitstore (in6)) - (push6 (in6)) - (setf bytecount 1) - (ash bitstore -4)) - (1 - (push6 (in6)) - (setf bytecount 2) - (logand #xFF (ash bitstore -2))) - (2 - (push6 (in6)) - (setf bytecount 0) - (logand #xFF bitstore)))))) - (defun decode-base64-stream (in out &key parser-errors) "Read from IN a stream of characters Base64 encoded and write to OUT a stream of decoded bytes." - (make-decoder-loop base64-decoder - (read-byte in nil) (write-byte byte out) - :parser-errors parser-errors)) + ;; parser-errors are ignored for base64 + (declare (ignore parser-errors)) + (redirect-stream (make-instance 'qbase64:decode-stream + :underlying-stream in) + out)) (defun decode-base64-stream-to-sequence (stream &key parser-errors) - (make-stream-to-sequence-decoder base64-decoder - (read-char stream nil) - :parser-errors parser-errors)) - -(defun decode-base64-string (string &key (start 0) (end (length string)) parser-errors) - (with-input-from-string (in string :start start :end end) - (decode-base64-stream-to-sequence in :parser-errors parser-errors))) + "Read Base64 characters from STREAM and return result of decoding them as a +binary sequence." + ;; parser-errors are ignored for base64 + (declare (ignore parser-errors)) + (let* ((buffered-size 4096) + (dstream (make-instance 'qbase64:decode-stream + :underlying-stream stream)) + (output-seq (make-array buffered-size + :element-type '(unsigned-byte 8) + :adjustable t))) + (loop for cap = (array-dimension output-seq 0) + for pos = (read-sequence output-seq dstream :start (or pos 0)) + if (>= pos cap) + do (adjust-array output-seq (+ cap buffered-size)) + else + do (progn + (adjust-array output-seq pos) + (return output-seq))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -547,25 +524,14 @@ to OUT a stream of decoded bytes." while c do (write-byte (char-code c) out))) -(defun decode-stream (in out encoding &key parser-errors-p) - (gcase (encoding string-equal) - (:quoted-printable - (decode-quoted-printable-stream in out - :parser-errors parser-errors-p)) - (:base64 - (decode-base64-stream in out - :parser-errors parser-errors-p)) - (otherwise - (dump-stream-binary in out)))) - (defun decode-string (string encoding &key parser-errors-p) (gcase (encoding string-equal) (:quoted-printable (decode-quoted-printable-string string :parser-errors parser-errors-p)) (:base64 - (decode-base64-string string - :parser-errors parser-errors-p)) + ;; parser-errors-p is unused in base64 + (qbase64:decode-string string)) (otherwise (map '(vector (unsigned-byte 8)) #'char-code string)))) @@ -649,7 +615,7 @@ method of RFC2047 and return a sequence of bytes." bytes." (gcase (encoding string-equal) ("Q" (decode-quoted-printable-RFC2047-string string :start start :end end)) - ("B" (decode-base64-string string :start start :end end)) + ("B" (qbase64:decode-string (subseq string start end))) (t string))) (defun parse-RFC2047-text (text) @@ -684,13 +650,13 @@ sequence, a charset string indicating the original coding." (defun decode-RFC2047 (text) "Decode TEXT into a fully decoded string. Whenever a non ASCII part is - encountered, try to decode it using babel, otherwise signal an error." + encountered, try to decode it using flexi-streams, otherwise signal an error." (flet ((decode-part (part) (etypecase part - (cons (babel:octets-to-string + (cons (flexi-streams:octets-to-string (car part) - :encoding (babel-encodings:get-character-encoding - (intern (string-upcase (cdr part)) 'keyword)))) + :external-format (flexi-streams:make-external-format + (intern (string-upcase (cdr part)) 'keyword)))) (string part)))) (apply #'concatenate (cons 'string diff --git a/third_party/lisp/mime4cl/ex-sclf.lisp b/third_party/lisp/mime4cl/ex-sclf.lisp new file mode 100644 index 0000000000..1719732fb3 --- /dev/null +++ b/third_party/lisp/mime4cl/ex-sclf.lisp @@ -0,0 +1,329 @@ +;;; ex-sclf.lisp --- subset of sclf used by mime4cl + +;;; Copyright (C) 2005-2010 by Walter C. Pelissero +;;; Copyright (C) 2022-2023 The TVL Authors + +;;; Author: sternenseemann <sternenseemann@systemli.org> +;;; Project: mime4cl +;;; +;;; mime4cl uses sclf for miscellaneous utility functions. sclf's portability +;;; is quite limited. Since mime4cl is the only thing in TVL's depot depending +;;; on sclf, it made more sense to strip down sclf to the extent mime4cl needed +;;; in order to lessen the burden of porting it to other CL implementations +;;; later. +;;; +;;; Eventually it probably makes sense to drop the utilities we don't like and +;;; merge the ones we do like into depot's own utility package, klatre. + +#+cmu (ext:file-comment "$Module: ex-sclf.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(defpackage :mime4cl-ex-sclf + (:use :common-lisp) + (:import-from :sb-posix :stat :stat-size) + + (:export + #:aif + #:awhen + #:aand + #:it + + #:gcase + + #:with-gensyms + + #:split-at + #:split-string-at-char + #:+whitespace+ + #:whitespace-p + #:string-concat + #:s+ + #:string-starts-with + #:string-trim-whitespace + #:string-left-trim-whitespace + #:string-right-trim-whitespace + + #:queue + #:make-queue + #:queue-append + #:queue-pop + #:queue-empty-p + + #:save-file-excursion + #:read-file + + #:file-size + + #:promise + #:make-promise + #:lazy + #:force + #:forced-p + #:deflazy + + #:f++ + + #:week-day->string + #:month->string)) + +(in-package :mime4cl-ex-sclf) + +;; MACRO UTILS + +(defmacro with-gensyms ((&rest symbols) &body body) + "Gensym all SYMBOLS and make them available in BODY. +See also LET-GENSYMS." + `(let ,(mapcar #'(lambda (s) + (list s '(gensym))) symbols) + ,@body)) + +;; CONTROL FLOW + +(defmacro aif (test then &optional else) + `(let ((it ,test)) + (if it + ,then + ,else))) + +(defmacro awhen (test &body then) + `(let ((it ,test)) + (when it + ,@then))) + +(defmacro aand (&rest args) + (cond ((null args) t) + ((null (cdr args)) (car args)) + (t `(aif ,(car args) (aand ,@(cdr args)))))) + +(defmacro gcase ((value &optional (test 'equalp)) &rest cases) + "Generic CASE macro. Match VALUE to CASES as if by the normal CASE +but use TEST as the comparison function, which defaults to EQUALP." + (with-gensyms (val) + `(let ((,val ,value)) + ,(cons 'cond + (mapcar #'(lambda (case-desc) + (destructuring-bind (vals &rest forms) case-desc + `(,(cond ((consp vals) + (cons 'or (mapcar #'(lambda (v) + (list test val v)) + vals))) + ((or (eq vals 'otherwise) + (eq vals t)) + t) + (t (list test val vals))) + ,@forms))) + cases))))) + +;; SEQUENCES + +(defun position-any (bag sequence &rest position-args) + "Find any element of bag in sequence and return its position. +Accept any argument accepted by the POSITION function." + (apply #'position-if #'(lambda (element) + (find element bag)) sequence position-args)) + +(defun split-at (bag sequence &key (start 0) key) + "Split SEQUENCE at occurence of any element from BAG. +Contiguous occurences of elements from BAG are considered atomic; +so no empty sequence is returned." + (let ((len (length sequence))) + (labels ((split-from (start) + (unless (>= start len) + (let ((sep (position-any bag sequence :start start :key key))) + (cond ((not sep) + (list (subseq sequence start))) + ((> sep start) + (cons (subseq sequence start sep) + (split-from (1+ sep)))) + (t + (split-from (1+ start)))))))) + (split-from start)))) + +;; STRINGS + +(defvar +whitespace+ '(#\return #\newline #\tab #\space #\page)) + +(defun whitespace-p (char) + (member char +whitespace+)) + +(defun string-trim-whitespace (string) + (string-trim +whitespace+ string)) + +(defun string-right-trim-whitespace (string) + (string-right-trim +whitespace+ string)) + +(defun string-left-trim-whitespace (string) + (string-left-trim +whitespace+ string)) + +(defun split-string-at-char (string separator &key escape skip-empty) + "Split STRING at SEPARATORs and return a list of the substrings. If +SKIP-EMPTY is true then filter out the empty substrings. If ESCAPE is +not nil then split at SEPARATOR only if it's not preceded by ESCAPE." + (declare (type string string) (type character separator)) + (labels ((next-separator (beg) + (let ((pos (position separator string :start beg))) + (if (and escape + pos + (plusp pos) + (char= escape (char string (1- pos)))) + (next-separator (1+ pos)) + pos))) + (parse (beg) + (cond ((< beg (length string)) + (let* ((end (next-separator beg)) + (substring (subseq string beg end))) + (cond ((and skip-empty (string= "" substring)) + (parse (1+ end))) + ((not end) + (list substring)) + (t + (cons substring (parse (1+ end))))))) + (skip-empty + '()) + (t + (list ""))))) + (parse 0))) + +(defun s+ (&rest strings) + "Return a string which is made of the concatenation of STRINGS." + (apply #'concatenate 'string strings)) + +(defun string-concat (list &optional (separator "")) + "Concatenate the strings in LIST interposing SEPARATOR (default +nothing) between them." + (reduce #'(lambda (&rest args) + (if args + (s+ (car args) separator (cadr args)) + "")) + list)) + +(defun string-starts-with (prefix string &optional (compare #'string=)) + (let ((prefix-length (length prefix))) + (and (>= (length string) prefix-length) + (funcall compare prefix string :end2 prefix-length)))) + +;; QUEUE + +(defstruct queue + first + last) + +(defgeneric queue-append (queue objects)) +(defgeneric queue-pop (queue)) +(defgeneric queue-empty-p (queue)) + +(defmethod queue-append ((queue queue) (objects list)) + (cond ((null (queue-first queue)) + (setf (queue-first queue) objects + (queue-last queue) (last objects))) + (t + (setf (cdr (queue-last queue)) objects + (queue-last queue) (last objects)))) + queue) + +(defmethod queue-append ((queue queue) object) + (queue-append queue (list object))) + +(defmethod queue-pop ((queue queue)) + (prog1 (car (queue-first queue)) + (setf (queue-first queue) (cdr (queue-first queue))))) + +(defmethod queue-empty-p ((queue queue)) + (null (queue-first queue))) + +;; STREAMS + +(defmacro save-file-excursion ((stream &optional position) &body forms) + "Execute FORMS returning, on exit, STREAM to the position it was +before FORMS. Optionally POSITION can be set to the starting offset." + (unless position + (setf position (gensym))) + `(let ((,position (file-position ,stream))) + (unwind-protect (progn ,@forms) + (file-position ,stream ,position)))) + +(defun read-file (pathname &key (element-type 'character) (if-does-not-exist :error) default) + "Read the whole content of file and return it as a sequence which +can be a string, a vector of bytes, or whatever you specify as +ELEMENT-TYPE." + (with-open-file (in pathname + :element-type element-type + :if-does-not-exist (unless (eq :value if-does-not-exist) + :error)) + (if in + (let ((seq (make-array (file-length in) :element-type element-type))) + (read-sequence seq in) + seq) + default))) + +;; FILES + +(defun native-namestring (pathname) + #+sbcl (sb-ext:native-namestring pathname) + #-sbcl (let (#+cmu (lisp::*ignore-wildcards* t)) + (namestring pathname))) + +;; FILE-LENGTH is a bit idiosyncratic in this respect. Besides, Unix +;; allows to get to know the file size without being able to open a +;; file; just ask politely. +(defun file-size (pathname) + #+sbcl (stat-size (unix-stat pathname)) + #-sbcl (error "nyi")) + +;; LAZY + +(defstruct promise + procedure + value) + +(defmacro lazy (form) + `(make-promise :procedure #'(lambda () ,form))) + +(defun forced-p (promise) + (null (promise-procedure promise))) + +(defun force (promise) + (if (forced-p promise) + (promise-value promise) + (prog1 (setf (promise-value promise) + (funcall (promise-procedure promise))) + (setf (promise-procedure promise) nil)))) + +(defmacro deflazy (name value &optional documentation) + `(defparameter ,name (lazy ,value) + ,@(when documentation + (list documentation)))) + +;; FIXNUMS + +(defmacro f++ (x &optional (delta 1)) + "Same as INCF but hopefully optimised for fixnums." + `(setf ,x (+ (the fixnum ,x) (the fixnum ,delta)))) + +;; TIME + +(defun week-day->string (day &optional sunday-first) + "Return the weekday string corresponding to DAY number." + (elt (if sunday-first + #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) + day)) + +(defvar +month-names+ #("January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December")) + +(defun month->string (month) + "Return the month string corresponding to MONTH number." + (elt +month-names+ (1- month))) diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp index 5639aab236..3cdac4b26b 100644 --- a/third_party/lisp/mime4cl/mime.lisp +++ b/third_party/lisp/mime4cl/mime.lisp @@ -1,7 +1,7 @@ ;;; mime4cl.lisp --- MIME primitives for Common Lisp ;;; Copyright (C) 2005-2008, 2010 by Walter C. Pelissero -;;; Copyright (C) 2021 by the TVL Authors +;;; Copyright (C) 2021-2023 by the TVL Authors ;;; Author: Walter C. Pelissero <walter@pelissero.de> ;;; Project: mime4cl @@ -183,14 +183,11 @@ :test #'string=) (mime= (mime-body part1) (mime-body part2)))) -(defun mime-body-stream (mime-part &key (binary t)) - (make-instance (if binary - 'binary-input-adapter-stream - 'character-input-adapter-stream) - :source (mime-body mime-part))) +(defun mime-body-stream (mime-part) + (make-input-adapter (mime-body mime-part))) (defun mime-body-length (mime-part) - (be body (mime-body mime-part) + (let ((body (mime-body mime-part))) ;; here the stream type is missing on purpose, because we may not ;; be able to size the length of a stream (etypecase body @@ -207,8 +204,8 @@ 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)) +(defmacro with-input-from-mime-body-stream ((stream part) &body forms) + `(with-open-stream (,stream (mime-body-stream ,part)) ,@forms)) (defmethod mime= ((part1 mime-bodily-part) (part2 mime-bodily-part)) @@ -302,12 +299,13 @@ semi-colons not within strings or comments." (defun parse-parameter (string) "Given a string like \"foo=bar\" return a pair (\"foo\" . \"bar\"). Return NIL if string is not parsable." - (be equal-position (position #\= string) + ;; TODO(sterni): when-let + (let ((equal-position (position #\= string))) (when equal-position - (be key (subseq string 0 equal-position) + (let ((key (subseq string 0 equal-position))) (if (= equal-position (1- (length string))) (cons key "") - (be value (string-trim-whitespace (subseq string (1+ equal-position))) + (let ((value (string-trim-whitespace (subseq string (1+ equal-position))))) (cons key (if (and (> (length value) 1) (char= #\" (elt value 0))) @@ -316,8 +314,8 @@ semi-colons not within strings or comments." ;; reader (or (ignore-errors (read-from-string value)) (subseq value 1)) - (be end (or (position-if #'whitespace-p value) - (length value)) + (let ((end (or (position-if #'whitespace-p value) + (length value)))) (subseq value 0 end)))))))))) (defun parse-content-type (string) @@ -340,7 +338,7 @@ Example: (\"text\" \"plain\" ((\"charset\" . \"us-ascii\")...))." list. The first element is the layout, the other elements are the optional parameters alist. Example: (\"inline\" (\"filename\" . \"doggy.jpg\"))." - (be parts (split-header-parts string) + (let ((parts (split-header-parts string))) (cons (car parts) (mapcan #'(lambda (parameter-string) (awhen (parse-parameter parameter-string) (list it))) @@ -350,7 +348,7 @@ Example: (\"inline\" (\"filename\" . \"doggy.jpg\"))." "Parse STRING which should be a valid RFC822 message header and return two values: a string of the header name and a string of the header value." - (be colon (position #\: string) + (let ((colon (position #\: string))) (when colon (values (string-trim-whitespace (subseq string 0 colon)) (string-trim-whitespace (subseq string (1+ colon))))))) @@ -419,34 +417,6 @@ each (non-boundary) line or END-PART-FUNCTION at each PART-BOUNDARY." do (last-part) do (process-line line))))) -;; This awkward handling of newlines is due to RFC2046: "The CRLF -;; preceding the boundary delimiter line is conceptually attached to -;; the boundary so that it is possible to have a part that does not -;; end with a CRLF (line break). Body parts that must be considered -;; to end with line breaks, therefore, must have two CRLFs preceding -;; the boundary delimiter line, the first of which is part of the -;; preceding body part, and the second of which is part of the -;; encapsulation boundary". -(defun split-multipart-parts (body-stream part-boundary) - "Read from BODY-STREAM and split MIME parts separated by -PART-BOUNDARY. Return a list of strings." - (let ((part (make-string-output-stream)) - (parts '()) - (beginning-of-part-p t)) - (flet ((output-line (line) - (if beginning-of-part-p - (setf beginning-of-part-p nil) - (terpri part)) - (write-string line part)) - (end-part () - (setf beginning-of-part-p t) - (push (get-output-stream-string part) parts))) - (do-multipart-parts body-stream part-boundary #'output-line #'end-part) - (close part) - ;; the first part is empty or contains all the junk - ;; to the first boundary - (cdr (nreverse parts))))) - (defun index-multipart-parts (body-stream part-boundary) "Read from BODY-STREAM and return the file offset of the MIME parts separated by PART-BOUNDARY." @@ -531,9 +501,9 @@ separated by PART-BOUNDARY." (encode-mime-body (mime-body part) stream)) (defmethod encode-mime-body ((part mime-multipart) stream) - (be boundary (or (get-mime-type-parameter part :boundary) - (setf (get-mime-type-parameter part :boundary) - (choose-boundary (mime-parts part)))) + (let ((boundary (or (get-mime-type-parameter part :boundary) + (setf (get-mime-type-parameter part :boundary) + (choose-boundary (mime-parts part)))))) (dolist (p (mime-parts part)) (format stream "~%--~A~%" boundary) (encode-mime-part p stream)) @@ -588,7 +558,7 @@ found in STREAM." ;; continuation line of a header we don't want to a header we want (loop with headers = '() and skip-header = nil - for line = (be line (read-line stream nil) + for line = (let ((line (read-line stream nil))) ;; skip the Unix "From " header if present (if (string-starts-with "From " line) (read-line stream nil) @@ -641,19 +611,19 @@ found in STREAM." (defgeneric decode-mime-body (part input-stream)) -(defmethod decode-mime-body ((part mime-part) (stream delimited-input-stream)) - (be base (base-stream stream) - (if *lazy-mime-decode* - (setf (mime-body part) - (make-file-portion :data (etypecase base - (my-string-input-stream - (stream-string base)) - (file-stream - (pathname base))) - :encoding (mime-encoding part) - :start (file-position stream) - :end (stream-end stream))) - (call-next-method)))) +(defmethod decode-mime-body ((part mime-part) (stream flexi-stream)) + (let ((base (flexi-stream-root-stream stream))) + (if *lazy-mime-decode* + (setf (mime-body part) + (make-file-portion :data (etypecase base + (vector-stream + (flexi-streams::vector-stream-vector base)) + (file-stream + (pathname base))) + :encoding (mime-encoding part) + :start (flexi-stream-position stream) + :end (flexi-stream-bound stream))) + (call-next-method)))) (defmethod decode-mime-body ((part mime-part) (stream file-stream)) (if *lazy-mime-decode* @@ -663,12 +633,12 @@ found in STREAM." :start (file-position stream))) (call-next-method))) -(defmethod decode-mime-body ((part mime-part) (stream my-string-input-stream)) +(defmethod decode-mime-body ((part mime-part) (stream vector-stream)) (if *lazy-mime-decode* (setf (mime-body part) - (make-file-portion :data (stream-string stream) + (make-file-portion :data (flexi-streams::vector-stream-vector stream) :encoding (mime-encoding part) - :start (file-position stream))) + :start (flexi-streams::vector-stream-index stream))) (call-next-method))) (defmethod decode-mime-body ((part mime-part) stream) @@ -679,19 +649,18 @@ found in STREAM." "Decode STREAM according to PART characteristics and return a list of MIME parts." (save-file-excursion (stream) - (be offsets (index-multipart-parts stream (get-mime-type-parameter part :boundary)) + (let ((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)))) + (let ((*default-type* (if (eq :digest (mime-subtype part)) + '("message" "rfc822" ()) + '("text" "plain" (("charset" . "us-ascii"))))) + (in (make-positioned-flexi-input-stream stream + :position start + :bound end + :ignore-close t))) + (read-mime-part in)))) offsets))))) (defmethod decode-mime-body ((part mime-message) stream) @@ -702,7 +671,7 @@ body." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defconst +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64) +(defvar +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64) "List of known content encodings.") (defun keywordify-encoding (string) @@ -713,11 +682,11 @@ Return STRING itself if STRING is an unkown encoding." string)) (defun header (name headers) - (be elt (assoc name headers :test #'string-equal) + (let ((elt (assoc name headers :test #'string-equal))) (values (cdr elt) (car elt)))) (defun (setf header) (value name headers) - (be entry (assoc name headers :test #'string-equal) + (let ((entry (assoc name headers :test #'string-equal))) (unless entry (error "missing header ~A can't be set" name)) (setf (cdr entry) value))) @@ -729,7 +698,7 @@ guessed from the headers, use the *DEFAULT-TYPE*." (flet ((hdr (what) (header what headers))) (destructuring-bind (type subtype parms) - (or + (or (aand (hdr :content-type) (parse-content-type it)) *default-type*) @@ -755,16 +724,16 @@ guessed from the headers, use the *DEFAULT-TYPE*." (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)) + (let ((headers (read-rfc822-headers stream + '(:mime-version :content-transfer-encoding :content-type + :content-disposition :content-description :content-id)))) (make-mime-part headers stream))) (defun read-mime-message (stream) "Main function to read a MIME message from a stream. It returns a MIME-MESSAGE object." - (be headers (read-rfc822-headers stream) - *default-type* '("text" "plain" (("charset" . "us-ascii"))) + (let ((headers (read-rfc822-headers stream)) + (*default-type* '("text" "plain" (("charset" . "us-ascii"))))) (flet ((hdr (what) (header what headers))) (destructuring-bind (type subtype parms) @@ -782,17 +751,21 @@ returns a MIME-MESSAGE object." msg) (defmethod mime-message ((msg string)) - (with-open-stream (in (make-instance 'my-string-input-stream :string msg)) - (read-mime-message in))) + (mime-message (flexi-streams:string-to-octets msg))) -(defmethod mime-message ((msg stream)) - (read-mime-message msg)) +(defmethod mime-message ((msg vector)) + (with-input-from-sequence (in msg) + (mime-message in))) (defmethod mime-message ((msg pathname)) - (let (#+sbcl(sb-impl::*default-external-format* :latin-1) - #+sbcl(sb-alien::*default-c-string-external-format* :latin-1)) - (with-open-file (in msg) - (read-mime-message in)))) + (with-open-file (in msg :element-type '(unsigned-byte 8)) + (mime-message in))) + +(defmethod mime-message ((msg flexi-stream)) + (read-mime-message msg)) + +(defmethod mime-message ((msg stream)) + (read-mime-message (make-flexi-stream msg))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -815,15 +788,16 @@ returns a MIME-MESSAGE object." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod make-encoded-body-stream ((part mime-bodily-part)) - (be body (mime-body part) + (let ((body (mime-body part))) (make-instance (case (mime-encoding part) (:base64 'base64-encoder-input-stream) (:quoted-printable 'quoted-printable-encoder-input-stream) - (t + (otherwise '8bit-encoder-input-stream)) - :stream (make-instance 'binary-input-adapter-stream :source body)))) + :underlying-stream + (make-input-adapter body)))) (defun choose-boundary (parts &optional default) (labels ((match-in-parts (boundary parts) @@ -855,7 +829,7 @@ returns a MIME-MESSAGE object." ;; fall back method (defmethod mime-part-size ((part mime-part)) - (be body (mime-body part) + (let ((body (mime-body part))) (typecase body (pathname (file-size body)) @@ -882,7 +856,7 @@ returns a MIME-MESSAGE object." (case (mime-subtype part) (:alternative ;; try to choose something simple to print or the first thing - (be parts (mime-parts part) + (let ((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))) @@ -896,7 +870,7 @@ returns a MIME-MESSAGE object." ;; because we don't know which one we should use. Messages written in ;; anything but ASCII will likely be unreadable -wcp11/10/07. (defmethod print-mime-part ((part mime-text) (out stream)) - (be body (mime-body part) + (let ((body (mime-body part))) (etypecase body (string (write-string body out)) @@ -950,8 +924,8 @@ second in MIME.")) (defmethod find-mime-part-by-path ((part mime-multipart) path) (if (null path) part - (be parts (mime-parts part) - part-number (car path) + (let ((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)." @@ -979,7 +953,7 @@ is a string.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod find-mime-text-part (msg) +(defgeneric find-mime-text-part (msg) (:documentation "Return message if it is a text message or first text part. If no suitable text part is found, return NIL.")) diff --git a/third_party/lisp/mime4cl/package.lisp b/third_party/lisp/mime4cl/package.lisp index 5586bdc390..94b9e6b390 100644 --- a/third_party/lisp/mime4cl/package.lisp +++ b/third_party/lisp/mime4cl/package.lisp @@ -23,15 +23,7 @@ (defpackage :mime4cl (:nicknames :mime) - (:use :common-lisp :npg :sclf :trivial-gray-streams) - ;; 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) - (:import-from :babel :octets-to-string) - (:import-from :babel-encodings :get-character-encoding) + (:use :common-lisp :npg :mime4cl-ex-sclf :trivial-gray-streams :flexi-streams) (:export #:*lazy-mime-decode* #:print-mime-part #:read-mime-message @@ -74,11 +66,10 @@ #: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 + #:decode-RFC2047 #:parse-RFC822-header #:read-RFC822-headers #:time-RFC822-string @@ -91,7 +82,6 @@ #:with-input-from-mime-body-stream ;; endec.lisp #:base64-encoder - #:base64-decoder #:null-encoder #:null-decoder #:byte-encoder @@ -107,4 +97,7 @@ ;; 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)) + #:mailbox-group #:mbxg-name #:mbxg-mailboxes + ;; streams.lisp + #:redirect-stream + )) diff --git a/third_party/lisp/mime4cl/streams.lisp b/third_party/lisp/mime4cl/streams.lisp index dcac6ac341..71a32d84e4 100644 --- a/third_party/lisp/mime4cl/streams.lisp +++ b/third_party/lisp/mime4cl/streams.lisp @@ -1,7 +1,7 @@ ;;; streams.lisp --- En/De-coding Streams ;;; Copyright (C) 2012 by Walter C. Pelissero -;;; Copyright (C) 2021-2022 by the TVL Authors +;;; Copyright (C) 2021-2023 by the TVL Authors ;;; Author: Walter C. Pelissero <walter@pelissero.de> ;;; Project: mime4cl @@ -21,9 +21,17 @@ (in-package :mime4cl) +(defun flexi-stream-root-stream (stream) + "Return the non FLEXI-STREAM stream a given chain of FLEXI-STREAMs is based on." + (if (typep stream 'flexi-stream) + (flexi-stream-root-stream (flexi-stream-stream stream)) + stream)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defclass coder-stream-mixin () ((real-stream :type stream - :initarg :stream + :initarg :underlying-stream :reader real-stream) (dont-close :initform nil :initarg :dont-close))) @@ -39,9 +47,12 @@ (defclass coder-output-stream-mixin (fundamental-binary-output-stream coder-stream-mixin) ()) +;; TODO(sterni): temporary, ugly measure to make flexi-streams happy +(defmethod stream-element-type ((stream coder-input-stream-mixin)) + (declare (ignore stream)) + '(unsigned-byte 8)) (defclass quoted-printable-decoder-stream (coder-input-stream-mixin quoted-printable-decoder) ()) -(defclass base64-decoder-stream (coder-input-stream-mixin base64-decoder) ()) (defclass 8bit-decoder-stream (coder-input-stream-mixin 8bit-decoder) ()) (defclass quoted-printable-encoder-stream (coder-output-stream-mixin quoted-printable-encoder) ()) @@ -52,7 +63,7 @@ (defmethod initialize-instance :after ((stream coder-stream-mixin) &key &allow-other-keys) (unless (slot-boundp stream 'real-stream) - (error "REAL-STREAM is unbound. Must provide a :STREAM argument."))) + (error "REAL-STREAM is unbound. Must provide a :UNDERLYING-STREAM argument."))) (defmethod initialize-instance ((stream coder-output-stream-mixin) &key &allow-other-keys) (call-next-method) @@ -119,7 +130,7 @@ in a stream of character.")) (with-slots (encoder buffer-queue real-stream) stream (loop while (queue-empty-p buffer-queue) - do (be byte (read-byte real-stream nil) + do (let ((byte (read-byte real-stream nil))) (if byte (encoder-write-byte encoder byte) (progn @@ -136,220 +147,128 @@ in a stream of character.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defclass input-adapter-stream () - ((source :initarg :source) - (real-stream) - (input-function))) - -(defclass binary-input-adapter-stream (fundamental-binary-input-stream input-adapter-stream) ()) - -(defclass character-input-adapter-stream (fundamental-character-input-stream input-adapter-stream) ()) - -(defmethod stream-element-type ((stream binary-input-adapter-stream)) - '(unsigned-byte 8)) - -(defmethod initialize-instance ((stream input-adapter-stream) &key &allow-other-keys) - (call-next-method) - (assert (slot-boundp stream 'source))) - -(defmethod initialize-instance ((stream binary-input-adapter-stream) &key &allow-other-keys) - (call-next-method) - ;; REAL-STREAM slot is set only if we are going to close it later on - (with-slots (source real-stream input-function) stream - (etypecase source - (string - (setf real-stream (make-string-input-stream source) - input-function #'(lambda () - (awhen (read-char real-stream nil) - (char-code it))))) - ((vector (unsigned-byte 8)) - (be i 0 - (setf input-function #'(lambda () - (when (< i (length source)) - (prog1 (aref source i) - (incf i))))))) - (stream - (assert (input-stream-p source)) - (setf input-function (if (subtypep (stream-element-type source) 'character) - #'(lambda () - (awhen (read-char source nil) - (char-code it))) - #'(lambda () - (read-byte source nil))))) - (pathname - (setf real-stream (open source :element-type '(unsigned-byte 8)) - input-function #'(lambda () - (read-byte real-stream nil)))) - (file-portion - (setf real-stream (open-decoded-file-portion source) - input-function #'(lambda () - (read-byte real-stream nil))))))) - -(defmethod initialize-instance ((stream character-input-adapter-stream) &key &allow-other-keys) - (call-next-method) - ;; REAL-STREAM slot is set only if we are going to close later on - (with-slots (source real-stream input-function) stream - (etypecase source - (string - (setf real-stream (make-string-input-stream source) - input-function #'(lambda () - (read-char real-stream nil)))) - ((vector (unsigned-byte 8)) - (be i 0 - (setf input-function #'(lambda () - (when (< i (length source)) - (prog1 (code-char (aref source i)) - (incf i))))))) - (stream - (assert (input-stream-p source)) - (setf input-function (if (subtypep (stream-element-type source) 'character) - #'(lambda () - (read-char source nil)) - #'(lambda () - (awhen (read-byte source nil) - (code-char it)))))) - (pathname - (setf real-stream (open source :element-type 'character) - input-function #'(lambda () - (read-char real-stream nil)))) - (file-portion - (setf real-stream (open-decoded-file-portion source) - input-function #'(lambda () - (awhen (read-byte real-stream nil) - (code-char it)))))))) - -(defmethod close ((stream input-adapter-stream) &key abort) - (when (slot-boundp stream 'real-stream) - (with-slots (real-stream) stream - (close real-stream :abort abort)))) - -(defmethod stream-read-byte ((stream binary-input-adapter-stream)) - (with-slots (input-function) stream - (or (funcall input-function) - :eof))) - -(defmethod stream-read-char ((stream character-input-adapter-stream)) - (with-slots (input-function) stream - (or (funcall input-function) - :eof))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass delimited-input-stream (fundamental-character-input-stream coder-stream-mixin) - ((start-offset :initarg :start - :initform 0 - :reader stream-start - :type integer) - (end-offset :initarg :end - :initform nil - :reader stream-end - :type (or null integer)) - (current-offset :type integer))) - -(defmethod print-object ((object delimited-input-stream) stream) - (if *print-readably* - (call-next-method) - (with-slots (start-offset end-offset) object - (print-unreadable-object (object stream :type t :identity t) - (format stream "start=~A end=~A" start-offset end-offset))))) - -(defun base-stream (stream) - (if (typep stream 'delimited-input-stream) - (base-stream (real-stream stream)) - stream)) - -(defmethod initialize-instance ((stream delimited-input-stream) &key &allow-other-keys) - (call-next-method) - (unless (slot-boundp stream 'real-stream) - (error "REAL-STREAM is unbound. Must provide a :STREAM argument.")) - (with-slots (start-offset) stream - (file-position stream start-offset))) - -(defmethod (setf stream-file-position) (newval (stream delimited-input-stream)) - (with-slots (current-offset real-stream) stream - (setf current-offset newval) - (call-next-method))) - -(defmethod stream-file-position ((stream delimited-input-stream)) - (slot-value stream 'current-offset)) - -;; Calling file-position with SBCL on every read is quite expensive, since -;; it will invoke lseek each time. This is so expensive that it's faster to -;; /compute/ the amount the stream got advanced by. -;; file-position's behavior however, is quite flexible and it behaves differently -;; not only for different implementation, but also different streams in SBCL. -;; Thus, we should ideally go back to file-position and try to reduce the amount -;; of calls by using read-sequence. -;; TODO(sterni): make decoders use read-sequence and drop offset tracking code -(macrolet ((def-stream-read (name read-fun update-offset-form) - `(defmethod ,name ((stream delimited-input-stream)) - (with-slots (real-stream end-offset current-offset) stream - (let ((el (if (or (not end-offset) - (< current-offset end-offset)) - (or (,read-fun real-stream nil) - :eof) - :eof))) - (setf current-offset ,update-offset-form) - el))))) - - ;; Assume we are using an encoding where < 128 is one byte, in all other cases - ;; it's hard to guess how much file-position will increase - (def-stream-read stream-read-char read-char - (if (or (eq el :eof) (< (char-code el) 128)) - (1+ current-offset) - (file-position real-stream))) - - (def-stream-read stream-read-byte read-byte (1+ current-offset))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass my-string-input-stream (fundamental-character-input-stream coder-stream-mixin) - ((string :initarg :string - :reader stream-string))) - -(defmethod initialize-instance ((stream my-string-input-stream) &key &allow-other-keys) +(defun make-custom-flexi-stream (class stream other-args) + (apply #'make-instance + class + :stream stream + (mapcar (lambda (x) + ;; make-flexi-stream has a discrepancy between :initarg of + ;; make-instance and its &key which we mirror here. + (if (eq x :external-format) :flexi-stream-external-format x)) + other-args))) + +(defclass adapter-flexi-input-stream (flexi-input-stream) + ((ignore-close + :initform nil + :initarg :ignore-close + :documentation + "If T, calling CLOSE on the stream does nothing. +If NIL, the underlying stream is closed.")) + (:documentation "FLEXI-STREAM that does not close the underlying stream on +CLOSE if :IGNORE-CLOSE is T.")) + +(defmethod close ((stream adapter-flexi-input-stream) &key abort) + (declare (ignore abort)) + (with-slots (ignore-close) stream + (unless ignore-close + (call-next-method)))) + +(defun make-input-adapter (source) + (etypecase source + ;; If it's already a stream, we need to make sure it's not closed by the adapter + (stream + (assert (input-stream-p source)) + (if (and (typep source 'adapter-flexi-input-stream) + (slot-value source 'ignore-close)) + source ; already ignores CLOSE + (make-adapter-flexi-input-stream source :ignore-close t))) + ;; TODO(sterni): is this necessary? (maybe with (not *lazy-mime-decode*)?) + (string + (make-input-adapter (string-to-octets source))) + ((vector (unsigned-byte 8)) + (make-in-memory-input-stream source)) + (pathname + (make-flexi-stream (open source :element-type '(unsigned-byte 8)))) + (file-portion + (open-decoded-file-portion source)))) + +(defun make-adapter-flexi-input-stream (stream &rest args) + "Create a ADAPTER-FLEXI-INPUT-STREAM. Accepts the same keyword arguments as +MAKE-FLEXI-STREAM as well as :IGNORE-CLOSE. If T, the underlying stream is not +closed." + (make-custom-flexi-stream 'adapter-flexi-input-stream stream args)) + +(defclass positioned-flexi-input-stream (adapter-flexi-input-stream) + () + (:documentation + "FLEXI-INPUT-STREAM that automatically advances the underlying :STREAM to +the location given by :POSITION. This uses FILE-POSITION internally, so it'll +only works if the underlying stream position is tracked in bytes. Note that +the underlying stream is still advanced, so having multiple instances of +POSITIONED-FLEXI-INPUT-STREAM based with the same underlying stream won't work +reliably. +Also supports :IGNORE-CLOSE of ADAPTER-FLEXI-INPUT-STREAM.")) + +(defmethod initialize-instance ((stream positioned-flexi-input-stream) + &key &allow-other-keys) (call-next-method) - (assert (slot-boundp stream 'string)) - (with-slots (string real-stream) stream - (setf real-stream (make-string-input-stream string)))) - -(defmethod stream-read-char ((stream my-string-input-stream)) - (with-slots (real-stream) stream - (or (read-char real-stream nil) - :eof))) + ;; The :POSITION initarg is only informational for flexi-streams: It assumes + ;; it is were the stream it got is already at and continuously updates it + ;; for querying (via FLEXI-STREAM-POSITION) and bound checking. + ;; Since we have streams that are not positioned correctly, we need to do this + ;; here using FILE-POSITION. Note that assumes the underlying implementation + ;; uses bytes for FILE-POSITION which is not guaranteed (probably some streams + ;; even in SBCL don't). + (file-position (flexi-stream-stream stream) (flexi-stream-position stream))) + +(defun make-positioned-flexi-input-stream (stream &rest args) + "Create a POSITIONED-FLEXI-INPUT-STREAM. Accepts the same keyword arguments as +MAKE-FLEXI-STREAM as well as :IGNORE-CLOSE. Causes the FILE-POSITION of STREAM to +be modified to match the :POSITION argument." + (make-custom-flexi-stream 'positioned-flexi-input-stream stream args)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; TODO(sterni): test correct behavior with END NIL (defstruct file-portion - data ; string or a pathname + data ; string or a pathname encoding start end) -(defun open-file-portion (file-portion) - (be data (file-portion-data file-portion) - (etypecase data - (pathname - (be stream (open data) - (make-instance 'delimited-input-stream - :stream stream - :start (file-portion-start file-portion) - :end (file-portion-end file-portion)))) - (string - (make-instance 'delimited-input-stream - :stream (make-string-input-stream data) - :start (file-portion-start file-portion) - :end (file-portion-end file-portion))) - (stream - (make-instance 'delimited-input-stream - :stream data - :dont-close t - :start (file-portion-start file-portion) - :end (file-portion-end file-portion)))))) - (defun open-decoded-file-portion (file-portion) - (make-instance (case (file-portion-encoding file-portion) - (:quoted-printable 'quoted-printable-decoder-stream) - (:base64 'base64-decoder-stream) - (t '8bit-decoder-stream)) - :stream (open-file-portion file-portion))) + (with-slots (data encoding start end) + file-portion + (let* ((binary-stream + (etypecase data + (pathname + (open data :element-type '(unsigned-byte 8))) + ((vector (unsigned-byte 8)) + (flexi-streams:make-in-memory-input-stream data)) + (stream + ;; TODO(sterni): assert that bytes/flexi-stream + data))) + (params (ccase encoding + ((:quoted-printable :base64) '(:external-format :us-ascii)) + (:8bit '(:element-type (unsigned-byte 8))) + (:7bit '(:external-format :us-ascii)))) + (portion-stream (apply #'make-positioned-flexi-input-stream + binary-stream + :position start + :bound end + ;; if data is a stream we can't have a + ;; FILE-PORTION without modifying it when + ;; reading etc. The least we can do, though, + ;; is forgo destroying it. + :ignore-close (typep data 'stream) + params)) + (needs-decoder-stream (member encoding '(:quoted-printable + :base64)))) + + (if needs-decoder-stream + (make-instance + (ccase encoding + (:quoted-printable 'quoted-printable-decoder-stream) + (:base64 'qbase64:decode-stream)) + :underlying-stream portion-stream) + portion-stream)))) diff --git a/third_party/lisp/mime4cl/test/endec.lisp b/third_party/lisp/mime4cl/test/endec.lisp index 5e8d43a7d4..6b22b3f6a2 100644 --- a/third_party/lisp/mime4cl/test/endec.lisp +++ b/third_party/lisp/mime4cl/test/endec.lisp @@ -103,13 +103,12 @@ line") (deftest base64.3 (map 'string #'code-char - (decode-base64-string "U29tZSByYW5kb20gc3RyaW5nLg==")) + (qbase64:decode-string "U29tZSByYW5kb20gc3RyaW5nLg==")) "Some random string.") (deftest base64.4 (map 'string #'code-char - (decode-base64-string "some rubbish U29tZSByYW5kb20gc3RyaW5nLg== more rubbish" - :start 13 :end 41)) + (qbase64:decode-string "U29tZSByYW5kb20gc3RyaW5nLg==")) "Some random string.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -118,6 +117,26 @@ line") (parse-RFC2047-text "foo bar") ("foo bar")) +;; from RFC2047 section 8 +(deftest RFC2047.2 + (decode-RFC2047 "=?US-ASCII?Q?Keith_Moore?= <moore@cs.utk.edu>") + "Keith Moore <moore@cs.utk.edu>") + +;; from RFC2047 section 8 +(deftest RFC2047.3 + (decode-RFC2047 "=?ISO-8859-1?Q?Olle_J=E4rnefors?=") + "Olle Järnefors") + +;; from RFC2047 section 8 +(deftest RFC2047.4 + (decode-RFC2047 "Nathaniel Borenstein <nsb@thumper.bellcore.com> (=?iso-8859-8?b?7eXs+SDv4SDp7Oj08A==?=)") + "Nathaniel Borenstein <nsb@thumper.bellcore.com> (םולש ןב ילטפנ)") + +;; from RFC2047 section 8 +(deftest RFC2047.5 + (decode-RFC2047 "=?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk>") + "Keld Jørn Simonsen <keld@dkuug.dk>") + (defun perftest-encoder (encoder-class &optional (megs 100)) (declare (optimize (speed 3) (debug 0) (safety 0)) (type fixnum megs)) @@ -139,13 +158,12 @@ line") (declare (optimize (speed 3) (debug 0) (safety 0)) (type fixnum megs)) (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8)) - (let ((sclf:*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*) + (let ((*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*) :type "encoded-data"))) - (sclf:with-temp-file (tmp nil :direction :io) + (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) diff --git a/third_party/lisp/mime4cl/test/mime.lisp b/third_party/lisp/mime4cl/test/mime.lisp index 8d93978599..dbd1dd996d 100644 --- a/third_party/lisp/mime4cl/test/mime.lisp +++ b/third_party/lisp/mime4cl/test/mime.lisp @@ -1,7 +1,7 @@ ;;; mime.lisp --- MIME regression tests ;;; Copyright (C) 2012 by Walter C. Pelissero -;;; Copyright (C) 2021-2022 by the TVL Authors +;;; Copyright (C) 2021-2023 by the TVL Authors ;;; Author: Walter C. Pelissero <walter@pelissero.de> ;;; Project: mime4cl @@ -27,28 +27,15 @@ *load-pathname* #P""))) -(defvar *sample1-file* (make-pathname :defaults #.(or *compile-file-pathname* - *load-pathname*) - :name "sample1" - :type "msg")) - -(deftest mime.1 - (let* ((orig (mime-message *sample1-file*)) - (dup (mime-message (with-output-to-string (out) (encode-mime-part orig out))))) - (mime= orig dup)) - t) - -(deftest mime.2 - (loop - for f in (directory (make-pathname :defaults *samples-directory* - :name :wild - :type "txt")) - do - (format t "~A:~%" f) - (finish-output) - (let* ((orig (mime-message f)) - (dup (mime-message (with-output-to-string (out) (encode-mime-part orig out))))) - (unless (mime= orig dup) - (return nil))) - finally (return t)) - t) +(loop + for f in (directory (make-pathname :defaults *samples-directory* + :name :wild + :type "msg")) + for i from 1 + do + (add-test (intern (format nil "MIME.~A" i)) + `(let* ((orig (mime-message ,f)) + (dup (mime-message + (with-output-to-string (out) (encode-mime-part orig out))))) + (mime= orig dup)) + t)) diff --git a/third_party/lisp/mime4cl/test/package.lisp b/third_party/lisp/mime4cl/test/package.lisp index 6da1fc8fa2..965680448f 100644 --- a/third_party/lisp/mime4cl/test/package.lisp +++ b/third_party/lisp/mime4cl/test/package.lisp @@ -23,5 +23,5 @@ (defpackage :mime4cl-tests (:use :common-lisp - :rtest :mime4cl) + :rtest :mime4cl :mime4cl-ex-sclf) (:export)) diff --git a/third_party/lisp/mime4cl/test/rt.lisp b/third_party/lisp/mime4cl/test/rt.lisp index 06160debbe..3f3aa5c56c 100644 --- a/third_party/lisp/mime4cl/test/rt.lisp +++ b/third_party/lisp/mime4cl/test/rt.lisp @@ -1,5 +1,6 @@ #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | Copyright 2023 by the TVL Authors | | | | Permission to use, copy, modify, and distribute this software and its | | documentation for any purpose and without fee is hereby granted, provided | @@ -20,10 +21,10 @@ |----------------------------------------------------------------------------|# (defpackage #:regression-test - (:nicknames #:rtest #-lispworks #:rt) + (:nicknames #:rtest #-lispworks #:rt) (:use #:cl) (:export #:*do-tests-when-defined* #:*test* #:continue-testing - #:deftest #:do-test #:do-tests #:get-test #:pending-tests + #:deftest #:add-test #:do-test #:do-tests #:get-test #:pending-tests #:rem-all-tests #:rem-test) (:documentation "The MIT regression tester with pfdietz's modifications")) @@ -86,25 +87,28 @@ (defmacro deftest (name form &rest values) `(add-entry '(t ,name ,form .,values))) +(defun add-test (name form &rest values) + (funcall #'add-entry (append (list 't name form) values))) + (defun add-entry (entry) (setq entry (copy-list entry)) (do ((l *entries* (cdr l))) (nil) (when (null (cdr l)) (setf (cdr l) (list entry)) (return nil)) - (when (equal (name (cadr l)) + (when (equal (name (cadr l)) (name entry)) (setf (cadr l) entry) (report-error nil - "Redefining test ~:@(~S~)" - (name entry)) + "Redefining test ~:@(~S~)" + (name entry)) (return nil))) (when *do-tests-when-defined* (do-entry entry)) (setq *test* (name entry))) (defun report-error (error? &rest args) - (cond (*debug* + (cond (*debug* (apply #'format t args) (if error? (throw '*debug* nil))) (error? (apply #'error args)) @@ -184,7 +188,7 @@ (setf (pend entry) (or aborted (not (equalp-with-case r (vals entry))))) - + (when (pend entry) (let ((*print-circle* *print-circle-on-failure*)) (format s "~&Test ~:@(~S~) failed~ @@ -210,7 +214,7 @@ (setf (pend entry) t)) (if (streamp out) (do-entries out) - (with-open-file + (with-open-file (stream out :direction :output) (do-entries stream)))) diff --git a/third_party/lisp/mime4cl/test/sample1.msg b/third_party/lisp/mime4cl/test/samples/sample1.msg index 662a9fab34..662a9fab34 100644 --- a/third_party/lisp/mime4cl/test/sample1.msg +++ b/third_party/lisp/mime4cl/test/samples/sample1.msg diff --git a/third_party/lisp/mime4cl/test/temp-file.lisp b/third_party/lisp/mime4cl/test/temp-file.lisp new file mode 100644 index 0000000000..554f35844b --- /dev/null +++ b/third_party/lisp/mime4cl/test/temp-file.lisp @@ -0,0 +1,72 @@ +;;; temp-file.lisp --- temporary file creation + +;;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero +;;; Copyright (C) 2022 The TVL Authors + +;;; Author: Walter C. Pelissero <walter@pelissero.de> +;;; Project: mime4cl +;;; +;;; Code taken from SCLF + +#+cmu (ext:file-comment "$Module: temp-file.lisp $") + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public License +;;; as published by the Free Software Foundation; either version 2.1 +;;; of the License, or (at your option) any later version. +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free +;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +;;; 02111-1307 USA + +(in-package :mime4cl-tests) + +(defvar *tmp-file-defaults* #P"/tmp/") + +(defun temp-file-name (&optional (default *tmp-file-defaults*)) + "Create a random pathname based on DEFAULT. No effort is made +to make sure that the returned pathname doesn't identify an +already existing file. If missing DEFAULT defaults to +*TMP-FILE-DEFAULTS*." + (make-pathname :defaults default + :name (format nil "~36R" (random #.(expt 36 10))))) + +(defun open-temp-file (&optional default-pathname &rest open-args) + "Open a new temporary file and return a stream to it. This function +makes sure the pathname of the temporary file is unique. OPEN-ARGS +are arguments passed verbatim to OPEN. If OPEN-ARGS specify +the :DIRECTION it should be either :OUTPUT (default) or :IO; +any other value causes an error. If DEFAULT-PATHNAME is specified and +not NIL it's used as defaults to produce the pathname of the temporary +file, otherwise *TMP-FILE-DEFAULTS* is used." + (unless default-pathname + (setf default-pathname *tmp-file-defaults*)) + ;; if :DIRECTION is specified check that it's compatible with the + ;; purpose of this function, otherwise make it default to :OUTPUT + (aif (getf open-args :direction) + (unless (member it '(:output :io)) + (error "Can't create temporary file with open direction ~A." it)) + (setf open-args (append '(:direction :output) + open-args))) + (do* ((name #1=(temp-file-name default-pathname) #1#) + (stream #2=(apply #'open name + :if-exists nil + :if-does-not-exist :create + open-args) #2#)) + (stream stream))) + +(defmacro with-temp-file ((stream &rest open-temp-args) &body body) + "Execute BODY within a dynamic extent where STREAM is bound to +a STREAM open on a unique temporary file name. OPEN-TEMP-ARGS are +passed verbatim to OPEN-TEMP-FILE." + `(let ((,stream (open-temp-file ,@open-temp-args))) + (unwind-protect + (progn ,@body) + (close ,stream) + ;; body may decide to rename the file so we must ignore the errors + (ignore-errors + (delete-file (pathname ,stream)))))) |