mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

refactor(3p/lisp/mime4cl): remove be and be*

Browse source 
Seems simple enough to use standard LET and a few parentheses more which
stock emacs can indent probably.

Change-Id: I0137a532186194f62f3a36f9bf05630af1afcdae
Reviewed-on: https://cl.tvl.fyi/c/depot/+/8584
Reviewed-by: sterni <sternenseemann@systemli.org>
Autosubmit: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
This commit is contained in:
sterni 2023-05-18 00:14:11 +02:00 committed by clbot
parent a06e30e73b
commit 02684f3ac6
6 changed files with 94 additions and 117 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
third_party/lisp/mime4cl/address.lisp vendored
View file

@ -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)))))

23
third_party/lisp/mime4cl/endec.lisp vendored
View file

@ -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)

55
third_party/lisp/mime4cl/ex-sclf.lisp vendored
View file

@ -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)))

95
third_party/lisp/mime4cl/mime.lisp vendored
View file

@ -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)."

2
third_party/lisp/mime4cl/streams.lisp vendored
View file

@ -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

2
third_party/lisp/mime4cl/test/temp-file.lisp vendored
View file

@ -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)