diff options
Diffstat (limited to 'third_party')
| -rw-r--r-- | third_party/lisp/mime4cl/address.lisp | 34 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/endec.lisp | 23 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/ex-sclf.lisp | 55 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/mime.lisp | 95 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/streams.lisp | 2 | ||||
| -rw-r--r-- | third_party/lisp/mime4cl/test/temp-file.lisp | 2 |
6 files changed, 94 insertions, 117 deletions
diff --git a/third_party/lisp/mime4cl/address.lisp b/third_party/lisp/mime4cl/address.lisp index 944156916c0f..42688a595b26 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/endec.lisp b/third_party/lisp/mime4cl/endec.lisp index c17f4fcf6843..e25a41219793 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 @@ -161,7 +162,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 +199,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 +207,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 +222,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 +272,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 +378,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 +471,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) @@ -500,7 +501,7 @@ return it." 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)) + do (let ((sextet (aref +base64-decode-table+ (char-code c)))) (unless (= sextet 65) ; ignore unrecognised characters (return sextet))))) (push6 (sextet) diff --git a/third_party/lisp/mime4cl/ex-sclf.lisp b/third_party/lisp/mime4cl/ex-sclf.lisp index 8a288cced801..7951b44f4d0f 100644 --- a/third_party/lisp/mime4cl/ex-sclf.lisp +++ b/third_party/lisp/mime4cl/ex-sclf.lisp @@ -1,7 +1,7 @@ ;;; ex-sclf.lisp --- subset of sclf used by mime4cl ;;; Copyright (C) 2005-2010 by Walter C. Pelissero -;;; Copyright (C) 2022 The TVL Authors +;;; Copyright (C) 2022-2023 The TVL Authors ;;; Author: sternenseemann <sternenseemann@systemli.org> ;;; Project: mime4cl @@ -33,9 +33,6 @@ (defpackage :mime4cl-ex-sclf (:use :common-lisp) (:export - #:be - #:be* - #:aif #:awhen #:aand @@ -94,38 +91,16 @@ See also LET-GENSYMS." ;; CONTROL FLOW -(defmacro be (&rest bindings-and-body) - "Less-parenthetic let." - (let ((bindings - (loop - while (and (symbolp (car bindings-and-body)) - (cdr bindings-and-body)) - collect (list (pop bindings-and-body) - (pop bindings-and-body))))) - `(let ,bindings - ,@bindings-and-body))) - -(defmacro be* (&rest bindings-and-body) - "Less-parenthetic let*." - (let ((bindings - (loop - while (and (symbolp (car bindings-and-body)) - (cdr bindings-and-body)) - collect (list (pop bindings-and-body) - (pop bindings-and-body))))) - `(let* ,bindings - ,@bindings-and-body))) - (defmacro aif (test then &optional else) - `(be it ,test - (if it - ,then - ,else))) + `(let ((it ,test)) + (if it + ,then + ,else))) (defmacro awhen (test &body then) - `(be it ,test - (when it - ,@then))) + `(let ((it ,test)) + (when it + ,@then))) (defmacro aand (&rest args) (cond ((null args) t) @@ -136,7 +111,7 @@ See also LET-GENSYMS." "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) - `(be ,val ,value + `(let ((,val ,value)) ,(cons 'cond (mapcar #'(lambda (case-desc) (destructuring-bind (vals &rest forms) case-desc @@ -163,10 +138,10 @@ Accept any argument accepted by the POSITION function." "Split SEQUENCE at occurence of any element from BAG. Contiguous occurences of elements from BAG are considered atomic; so no empty sequence is returned." - (be len (length sequence) + (let ((len (length sequence))) (labels ((split-from (start) (unless (>= start len) - (be sep (position-any bag sequence :start start :key key) + (let ((sep (position-any bag sequence :start start :key key))) (cond ((not sep) (list (subseq sequence start))) ((> sep start) @@ -198,7 +173,7 @@ 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) - (be pos (position separator string :start beg) + (let ((pos (position separator string :start beg))) (if (and escape pos (plusp pos) @@ -235,7 +210,7 @@ nothing) between them." list)) (defun string-starts-with (prefix string &optional (compare #'string=)) - (be prefix-length (length prefix) + (let ((prefix-length (length prefix))) (and (>= (length string) prefix-length) (funcall compare prefix string :end2 prefix-length)))) @@ -275,7 +250,7 @@ nothing) between them." before FORMS. Optionally POSITION can be set to the starting offset." (unless position (setf position (gensym))) - `(be ,position (file-position ,stream) + `(let ((,position (file-position ,stream))) (unwind-protect (progn ,@forms) (file-position ,stream ,position)))) @@ -288,7 +263,7 @@ ELEMENT-TYPE." :if-does-not-exist (unless (eq :value if-does-not-exist) :error)) (if in - (be seq (make-array (file-length in) :element-type element-type) + (let ((seq (make-array (file-length in) :element-type element-type))) (read-sequence seq in) seq) default))) diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp index 3e7d83847e14..3cdac4b26b6f 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 @@ -187,7 +187,7 @@ (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 @@ -299,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))) @@ -313,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) @@ -337,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))) @@ -347,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))))))) @@ -500,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)) @@ -557,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) @@ -611,18 +612,18 @@ found in STREAM." (defgeneric decode-mime-body (part input-stream)) (defmethod decode-mime-body ((part mime-part) (stream flexi-stream)) - (be 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)))) + (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* @@ -648,18 +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-positioned-flexi-input-stream stream - :position start - :bound end - :ignore-close t) - (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) @@ -681,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))) @@ -723,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) @@ -787,7 +788,7 @@ 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) @@ -828,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)) @@ -855,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))) @@ -869,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)) @@ -923,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)." diff --git a/third_party/lisp/mime4cl/streams.lisp b/third_party/lisp/mime4cl/streams.lisp index b9e56cf2d22c..7e9fc16d316f 100644 --- a/third_party/lisp/mime4cl/streams.lisp +++ b/third_party/lisp/mime4cl/streams.lisp @@ -138,7 +138,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 diff --git a/third_party/lisp/mime4cl/test/temp-file.lisp b/third_party/lisp/mime4cl/test/temp-file.lisp index 3e6765806c4e..554f35844b46 100644 --- a/third_party/lisp/mime4cl/test/temp-file.lisp +++ b/third_party/lisp/mime4cl/test/temp-file.lisp @@ -63,7 +63,7 @@ file, otherwise *TMP-FILE-DEFAULTS* is used." "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." - `(be ,stream (open-temp-file ,@open-temp-args) + `(let ((,stream (open-temp-file ,@open-temp-args))) (unwind-protect (progn ,@body) (close ,stream) |