diff options
Diffstat (limited to 'third_party/lisp/sclf/directory.lisp')
| -rw-r--r-- | third_party/lisp/sclf/directory.lisp | 404 |
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 0000000000..3e479c4ac2 --- /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))) |