chore: remove sclf from the tree

SCLF is quite a big utility library (almost 3€ LOC) with limited
portability (CMUCL, SBCL and CLISP to an extent). Continuing to maintain
it is an unnecessary burden, as depot only uses a fraction of it which
is now inlined into the respective users (mime4cl and mblog).

In the future trimming down ex-sclf.lisp may make sense either by
refactoring the code that uses it or by moving interesting utilities
into e.g. klatre.

Change-Id: I2e73825b6bfa372e97847f25c30731a5aad4a1b5
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5922
Tested-by: BuildkiteCI
Autosubmit: sterni <sternenseemann@systemli.org>
Reviewed-by: sterni <sternenseemann@systemli.org>

third_party/lisp/mime4cl/default.nix

@@ -7,12 +7,12 @@ depot.nix.buildLisp.library {
 
   deps = [
     depot.third_party.lisp.babel
-    depot.third_party.lisp.sclf
     depot.third_party.lisp.npg
     depot.third_party.lisp.trivial-gray-streams
   ];
 
   srcs = [
+    ./ex-sclf.lisp
     ./package.lisp
     ./endec.lisp
     ./streams.lisp
@@ -34,6 +34,7 @@ depot.nix.buildLisp.library {
         ;; override auto discovery which doesn't work in store
         (defvar *sample1-file* (pathname "${./test/sample1.msg}"))
       '')
+      ./test/temp-file.lisp
       ./test/endec.lisp
       ./test/address.lisp
       ./test/mime.lisp

third_party/lisp/mime4cl/ex-sclf.lisp

@@ -0,0 +1,393 @@
+;;; ex-sclf.lisp --- subset of sclf used by mime4cl
+
+;;;  Copyright (C) 2005-2010 by Walter C. Pelissero
+;;;  Copyright (C) 2022 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)
+  (:export
+   #:be
+   #:be*
+
+   #: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
+
+   #:unix-file-stat
+   #:unix-stat
+   #: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 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)))
+
+(defmacro awhen (test &body then)
+  `(be 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)
+    `(be ,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."
+  (be len (length sequence)
+    (labels ((split-from (start)
+               (unless (>= start len)
+                 (be 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)
+             (be 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=))
+  (be 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)))
+  `(be ,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
+        (be 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)))
+
+(defstruct (unix-file-stat (:conc-name stat-))
+  device
+  inode
+  links
+  atime
+  mtime
+  ctime
+  size
+  blksize
+  blocks
+  uid
+  gid
+  mode)
+
+(defun unix-stat (pathname)
+  ;; this could be different depending on the unix systems
+  (multiple-value-bind (ok? device inode mode links uid gid rdev
+                            size atime mtime ctime
+                            blksize blocks)
+      (#+cmu unix:unix-lstat
+       #+sbcl sb-unix:unix-lstat
+       ;; TODO(sterni): ECL, CCL
+       (if (stringp pathname)
+           pathname
+           (native-namestring pathname)))
+    (declare (ignore rdev))
+    (when ok?
+      (make-unix-file-stat :device device
+                           :inode inode
+                           :links links
+                           :atime atime
+                           :mtime mtime
+                           :ctime ctime
+                           :size size
+                           :blksize blksize
+                           :blocks blocks
+                           :uid uid
+                           :gid gid
+                           :mode mode))))
+
+;; 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)
+  (stat-size (unix-stat pathname)))
+
+;; 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)))

third_party/lisp/mime4cl/mime.lisp

@@ -702,7 +702,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)

third_party/lisp/mime4cl/package.lisp

@@ -23,13 +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)
+  (:use :common-lisp :npg :mime4cl-ex-sclf :trivial-gray-streams)
   (:import-from :babel :octets-to-string)
   (:import-from :babel-encodings :get-character-encoding)
   (:export #:*lazy-mime-decode*

third_party/lisp/mime4cl/test/endec.lisp

@@ -139,9 +139,9 @@ 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

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

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."
+  `(be ,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))))))