about summary refs log tree commit diff
path: root/third_party/lisp/sclf/directory.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'third_party/lisp/sclf/directory.lisp')
-rw-r--r--third_party/lisp/sclf/directory.lisp404
1 files changed, 0 insertions, 404 deletions
diff --git a/third_party/lisp/sclf/directory.lisp b/third_party/lisp/sclf/directory.lisp
deleted file mode 100644
index 3e479c4ac279..000000000000
--- a/third_party/lisp/sclf/directory.lisp
+++ /dev/null
@@ -1,404 +0,0 @@
-;;;  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)))