25cb0ad32f
Done using
find third_party/lisp/{sclf,mime4cl,npg} \
-name '*.lisp' -or -name '*.asd' \
-exec bash -c 'expand -i -t 8 "$0" | sponge "$0"' {} \;
Change-Id: If84afac9c1d5cbc74e137a5aa0ae61472f0f1e90
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5066
Tested-by: BuildkiteCI
Reviewed-by: sterni <sternenseemann@systemli.org>
404 lines
16 KiB
Common Lisp
404 lines
16 KiB
Common Lisp
;;; 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)))
|