1 files changed, 404 insertions, 0 deletions
diff --git a/third_party/lisp/sclf/directory.lisp b/third_party/lisp/sclf/directory.lisp
new file mode 100644
index 000000000000..4684a8e7056a
--- /dev/null
+++ b/third_party/lisp/sclf/directory.lisp
@@ -0,0 +1,404 @@
+;;;  directory.lisp --- filesystem directory access
+
+;;;  Copyright (C) 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero
+;;;  Copyright (C) 2021 by the TVL Authors
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: sclf
+
+#+cmu (ext:file-comment "$Module: directory.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
+
+
+(cl:in-package :sclf)
+
+(defun pathname-as-directory (pathname)
+  "Converts PATHNAME to directory form and return it."
+  (setf pathname (pathname pathname))
+  (if (pathname-name pathname)
+      (make-pathname :directory (append (or (pathname-directory pathname)
+					    '(:relative))
+					(list (file-namestring pathname)))
+		     :name nil
+		     :type nil
+		     :defaults pathname)
+      pathname))
+
+(defun d+ (path &rest rest)
+  "Concatenate directory pathname parts and return a pathname."
+  (make-pathname :defaults path
+		 :directory (append (pathname-directory path) rest)))
+
+(defun delete-directory (pathname)
+  "Remove directory PATHNAME.  Return PATHNAME."
+  #+cmu (multiple-value-bind (done errno)
+	     (unix:unix-rmdir (namestring pathname))
+	   (unless done
+	     (error "Unable to delete directory ~A (errno=~A)"
+		    pathname errno)))
+  #+sbcl (sb-posix:rmdir pathname)
+  #+lispworks (lw:delete-directory pathname)
+  #-(or cmu sbcl)
+  (error "DELETE-DIRECTORY not implemented for you lisp system.")
+  pathname)
+
+(defun list-directory (pathname &key truenamep)
+  "List content of directory PATHNAME.  If TRUENAMEP is true don't try
+to follow symbolic links."
+  #-(or sbcl cmu) (declare (ignore truenamep))
+  (let (#+cmu (lisp::*ignore-wildcards* t))
+    (directory (make-pathname :defaults (pathname-as-directory pathname)
+			      :name :wild
+			      :type :wild
+			      :version :wild)
+	       #+cmu :truenamep #+cmu truenamep
+	       #+sbcl :resolve-symlinks #+sbcl truenamep)))
+
+(defun traverse-directory-tree (root-pathname proc &key truenamep test depth-first)
+  "Call PROC on all pathnames under ROOT-PATHNAME, both files and
+directories.  Unless TRUENAMEP is true, this function doesn't try
+to lookup the truename of files, as finding the truename may be a
+superfluous and noxious activity expecially when you expect
+broken symbolic links in your filesystem."
+  (check-type root-pathname pathname)
+  (check-type proc (or function symbol))
+  (check-type test (or function symbol null))
+  (labels ((ls (dir)
+	     (declare (type pathname dir))
+	     (list-directory dir :truenamep truenamep))
+	   (traverse? (file)
+	     (declare (type pathname file))
+	     (and (not (pathname-name file))
+		  (or truenamep
+		      (not (symbolic-link-p file)))
+		  (or (not test)
+		      (funcall test file))))
+	   (traverse-pre-order (dir)
+	     (declare (type pathname dir))
+	     (loop
+		for file in (ls dir)
+		do (funcall proc file)
+		when (traverse? file)
+		do (traverse-pre-order file)))
+	   (traverse-post-order (dir)
+	     (declare (type pathname dir))
+	     (loop
+		for file in (ls dir)
+		when (traverse? file)
+		do (traverse-post-order file)
+		do (funcall proc file))))
+    (if depth-first
+	(traverse-post-order root-pathname)
+	(traverse-pre-order root-pathname))
+    (values)))
+
+(defmacro do-directory-tree ((file root-pathname &key truenamep test depth-first) &body body)
+  "Call TRAVERSE-DIRECTORY-TREE with BODY es procedure."
+  `(traverse-directory-tree ,root-pathname
+			    #'(lambda (,file)
+				,@body)
+			    :truenamep ,truenamep
+			    :test ,test
+			    :depth-first ,depth-first))
+
+(defun empty-directory-p (pathname)
+  (and (directory-p pathname)
+       (endp (list-directory pathname))))
+
+(defun remove-empty-directories (root)
+  (do-directory-tree (pathname root :depth-first t)
+    (when (empty-directory-p pathname)
+      (delete-directory pathname))))
+
+(defun map-directory-tree (pathname function)
+  "Apply FUNCTION to every file in a directory tree starting from
+PATHNAME.  Return the list of results."
+  (be return-list '()
+    (do-directory-tree (directory-entry pathname)
+      (push (funcall function directory-entry) return-list))
+    (nreverse return-list)))
+
+(defun find-files (root-pathname matcher-function &key truenamep)
+  "In the directory tree rooted at ROOT-PATHNAME, find files that
+when the pathname is applied to MATCHER-FUNCTION will return
+true.  Return the list of files found.  Unless TRUENAMEP is true
+this function doesn't try to lookup the truename of
+files. Finding the truename may be a superfluous and noxious
+activity expecially when you expect broken symbolic links in your
+filesystem.  (This may not apply to your particular lisp
+system.)"
+  (be files '()
+    (do-directory-tree (file root-pathname :truenamep truenamep)
+      (when (funcall matcher-function file)
+	(push file files)))
+    (nreverse files)))
+
+(defun delete-directory-tree (pathname)
+  "Recursively delete PATHNAME and all the directory structure below
+it.
+
+WARNING: depending on the way the DIRECTORY function is implemented on
+your Lisp system this function may follow Unix symbolic links and thus
+delete files outside the PATHNAME hierarchy.  Check this before using
+this function in your programs."
+  (if (pathname-name pathname)
+      (delete-file pathname)
+      (progn
+	(dolist (file (list-directory pathname))
+	  (delete-directory-tree file))
+	(delete-directory pathname))))
+
+(defun make-directory (pathname &optional (mode #o777))
+  "Create a new directory in the filesystem.  Permissions MODE
+will be assigned to it.  Return PATHNAME."
+  #+cmu (multiple-value-bind (done errno)
+	    (unix:unix-mkdir (native-namestring pathname) mode)
+	  (unless done
+	    (error "Unable to create directory ~A (errno=~A)." pathname errno)))
+  #+sbcl (sb-posix:mkdir pathname mode)
+  #-(or cmu sbcl)
+  (error "MAKE-DIRECTORY is not implemented for this Lisp system.")
+  pathname)
+
+;; At least on SBCL/CMUCL + Unix + NFS this function is faster than
+;; ENSURE-DIRECTORIES-EXIST, because it doesn't check all the pathname
+;; components starting from the root; it proceeds from the leaf and
+;; crawls the directory tree upward only if necessary."
+(defun ensure-directory (pathname &key verbose (mode #o777))
+  "Just like ENSURE-DIRECTORIES-EXIST but, in some situations,
+it's faster."
+  (labels ((ensure (path)
+	     (unless (probe-file path)
+	       (be* tail (last (pathname-directory path) 2)
+		    last (cdr tail)
+		 (setf (cdr tail) nil)
+		 (unwind-protect
+		      (ensure path)
+		   (setf (cdr tail) last))
+		 (make-directory path mode)
+		 (when verbose
+		   (format t "Created ~S~%" path))))))
+    (ensure (make-pathname :defaults pathname
+			   :name nil :type nil
+			   :version nil))))
+
+(defun make-temp-directory (&optional (default-pathname *tmp-file-defaults*) (mode #o777))
+  "Create a new directory and return its pathname.
+If DEFAULT-PATHNAME is specified and not NIL it's used as
+defaults to produce the pathname of the directory.  Return the
+pathname of the temporary directory."
+  (loop
+     for name = (pathname-as-directory (temp-file-name default-pathname))
+     when (ignore-errors (make-directory name mode))
+     return name))
+
+(defmacro with-temp-directory ((path &rest make-temp-directory-args) &body body)
+  "Execute BODY with PATH bound to the pathname of a new unique
+temporary directory.  On exit of BODY the directory tree starting from
+PATH will be automatically removed from the filesystem.  Return what
+BODY returns.  BODY is _not_ executed within the PATH directory; the
+working directory is never changed."
+  `(be ,path (make-temp-directory ,@make-temp-directory-args)
+     (unwind-protect
+	  (progn ,@body)
+       (delete-directory-tree ,path))))
+
+(defun current-directory ()
+  "Return the pathname of the current directory."
+  (truename (make-pathname :directory '(:relative))))
+
+(defun ensure-home-translations ()
+  "Ensure that the logical pathname translations for the host \"home\"
+are defined."
+  ;; CMUCL already defines a HOME translation of its own and gets
+  ;; angry if we try to redefine it
+  #-cmu
+  (be home (user-homedir-pathname)
+    ;; we should discard and replace whatever has been defined in any
+    ;; rc file during compilation
+    (setf (logical-pathname-translations "home")
+	  (list
+	   (list "**;*.*.*"
+		 (make-pathname :defaults home
+				:directory (append (pathname-directory home)
+						   '(:wild-inferiors))
+				:name :wild
+				:type :wild))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun parse-native-namestring (string &optional host (defaults *default-pathname-defaults*)
+				&key (start 0) end junk-allowed)
+  #+sbcl (sb-ext:parse-native-namestring string host defaults
+					 :start start
+					 :end end
+					 :junk-allowed junk-allowed)
+  #-sbcl (let (#+cmu(lisp::*ignore-wildcards* t))
+	   (parse-namestring string host defaults
+			     :start start
+			     :end end
+			     :junk-allowed junk-allowed)))
+
+(defun native-namestring (pathname)
+  #+sbcl (sb-ext:native-namestring pathname)
+  #-sbcl (let (#+cmu (lisp::*ignore-wildcards* t))
+	   (namestring pathname)))
+
+(defun native-file-namestring (pathname)
+  #+sbcl (sb-ext:native-namestring
+	  (make-pathname :name (pathname-name pathname)
+			 :type (pathname-type pathname)))
+  #+cmu (be lisp::*ignore-wildcards* t
+	  (file-namestring pathname)))
+
+(defun native-pathname (thing)
+  #+sbcl (sb-ext:native-pathname thing)
+  #+cmu (be lisp::*ignore-wildcards* t
+	  (pathname thing)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun bits-set-p (x bits)
+  (= (logand x bits)
+     bits))
+
+(defun directory-p (pathname)
+  "Return true if PATHNAME names a directory on the filesystem."
+  #-clisp (awhen (unix-stat (native-namestring pathname))
+	    (bits-set-p (stat-mode it)
+			#+sbcl sb-posix:s-ifdir
+			#+cmu unix:s-ifdir))
+  #+clisp (ext:probe-directory (pathname-as-directory pathname)))
+
+(defun regular-file-p (pathname)
+  "Return true if PATHNAME names a regular file on the filesystem."
+  #-(or sbcl cmu) (error "don't know how to check whether a file might be a regular file")
+  (awhen (unix-stat (native-namestring pathname))
+    (bits-set-p (stat-mode it)
+		#+sbcl sb-posix:s-ifreg
+		#+cmu unix:s-ifreg)))
+
+(defun file-readable-p (pathname)
+  #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:r_ok)
+  #+cmu (unix:unix-access (native-namestring pathname) unix:r_ok)
+  #-(or sbcl cmu) (error "don't know how to check whether a file might be readable"))
+
+(defun file-writable-p (pathname)
+  #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:w_ok)
+  #+cmu (unix:unix-access (native-namestring pathname) unix:w_ok)
+  #-(or sbcl cmu) (error "don't know how to check whether a file might be writable"))
+
+(defun file-executable-p (pathname)
+  #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:x_ok)
+  #+cmu (unix:unix-access (native-namestring pathname) unix:x_ok)
+  #-(or sbcl cmu) (error "don't know how to check whether a file might be executable"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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
+       (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))))
+
+(defun stat-modification-time (stat)
+  "Return the modification time of the STAT structure as Lisp
+Universal Time, which is not the same as the Unix time."
+  (unix->universal-time (stat-mtime stat)))
+
+(defun stat-creation-time (stat)
+  "Return the creation time of the STAT structure as Lisp
+Universal Time, which is not the same as the Unix time."
+  (unix->universal-time (stat-ctime stat)))
+
+(defun file-modification-time (file)
+  "Return the modification time of FILE as Lisp Universal Time, which
+is not the same as the Unix time."
+  (awhen (unix-stat file)
+    (stat-modification-time it)))
+
+(defun file-creation-time (file)
+  "Return the creation time of FILE as Lisp Universal Time, which
+is not the same as the Unix time."
+  (awhen (unix-stat file)
+    (stat-creation-time it)))
+
+(defun read-symbolic-link (symlink)
+  "Return the pathname the SYMLINK points to.  That is, it's
+contents."
+  #+sbcl (sb-posix:readlink (native-namestring symlink))
+  #+cmu (unix:unix-readlink (native-namestring symlink)))
+
+;; 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)))
+
+(defun symbolic-link-p (pathname)
+  #-(or sbcl cmu) (error "don't know hot to test for symbolic links.")
+  (aand (unix-stat pathname)
+	(bits-set-p (stat-mode it)
+		    #+sbcl sb-posix:s-iflnk
+		    #+cmu unix:s-iflnk)))
+
+(defun broken-link-p (pathname)
+ (when (symbolic-link-p pathname)
+   #+cmu (not (ignore-errors (truename pathname)))
+   ;; On a broken symlink SBCL returns the link path without resolving
+   ;; the link itself.  De gustibus non est disputandum.
+   #+sbcl (equalp pathname (probe-file pathname))))
+
+(defun move-file (old new)
+  "Just like RENAME-FILE, but doesn't carry on to NEW file the type of
+OLD file, if NEW doesn't specify one.  It does what most people would
+expect from a rename function, which RENAME-FILE doesn't do.
+So (MOVE-FILE \"foo.bar\" \"foo\") does rename foo.bar to foo, losing
+the \"bar\" type; RENAME-FILE wouldn't allow you that."
+  #+sbcl (sb-posix:rename (native-namestring old) (native-namestring new))
+  #+cmu (unix:unix-rename (native-namestring old) (native-namestring new)))