GopherProxy

	tfilesystem.lisp - clic - Clic is an command line interactive client for gopher…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tfilesystem.lisp (36112B)
	---
	1 ;;;; -------------------------------------------------------------------…
	2 ;;;; Portability layer around Common Lisp filesystem access
	3
	4 (uiop/package:define-package :uiop/filesystem
	5 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pat…
	6 (:export
	7 ;; Native namestrings
	8 #:native-namestring #:parse-native-namestring
	9 ;; Probing the filesystem
	10 #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p…
	11 #:directory* #:filter-logical-directory-results #:directory-files #:s…
	12 #:collect-sub*directories
	13 ;; Resolving symlinks somewhat
	14 #:truenamize #:resolve-symlinks #:resolve-symlinks #:resolve-symlin…
	15 ;; merging with cwd
	16 #:get-pathname-defaults #:call-with-current-directory #:with-current-…
	17 ;; Environment pathnames
	18 #:inter-directory-separator #:split-native-pathnames-string
	19 #:getenv-pathname #:getenv-pathnames
	20 #:getenv-absolute-directory #:getenv-absolute-directories
	21 #:lisp-implementation-directory #:lisp-implementation-pathname-p
	22 ;; Simple filesystem operations
	23 #:ensure-all-directories-exist
	24 #:rename-file-overwriting-target
	25 #:delete-file-if-exists #:delete-empty-directory #:delete-directory-t…
	26 (in-package :uiop/filesystem)
	27
	28 ;;; Native namestrings, as seen by the operating system calls rather tha…
	29 (with-upgradability ()
	30 (defun native-namestring (x)
	31 "From a non-wildcard CL pathname, a return namestring suitable for p…
	32 (when x
	33 (let ((p (pathname x)))
	34 #+clozure (with-pathname-defaults () (ccl:native-translated-name…
	35 #+(or cmucl scl) (ext:unix-namestring p nil)
	36 #+sbcl (sb-ext:native-namestring p)
	37 #-(or clozure cmucl sbcl scl)
	38 (os-cond
	39 ((os-unix-p) (unix-namestring p))
	40 (t (namestring p))))))
	41
	42 (defun parse-native-namestring (string &rest constraints &key ensure-d…
	43 "From a native namestring suitable for use by the operating system, …
	44 a CL pathname satisfying all the specified constraints as per ENSURE-PAT…
	45 (check-type string (or string null))
	46 (let* ((pathname
	47 (when string
	48 (with-pathname-defaults ()
	49 #+clozure (ccl:native-to-pathname string)
	50 #+cmucl (uiop/os::parse-unix-namestring* string)
	51 #+sbcl (sb-ext:parse-native-namestring string)
	52 #+scl (lisp::parse-unix-namestring string)
	53 #-(or clozure cmucl sbcl scl)
	54 (os-cond
	55 ((os-unix-p) (parse-unix-namestring string :ensure-dir…
	56 (t (parse-namestring string))))))
	57 (pathname
	58 (if ensure-directory
	59 (and pathname (ensure-directory-pathname pathname))
	60 pathname)))
	61 (apply 'ensure-pathname pathname constraints))))
	62
	63
	64 ;;; Probing the filesystem
	65 (with-upgradability ()
	66 (defun truename* (p)
	67 "Nicer variant of TRUENAME that plays well with NIL, avoids logical …
	68 (when p
	69 (when (stringp p) (setf p (with-pathname-defaults () (parse-namest…
	70 (values
	71 (or (ignore-errors (truename p))
	72 ;; this is here because trying to find the truename of a dire…
	73 ;; a trailing directory separator, causes an error on some li…
	74 #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)…
	75
	76 (defun safe-file-write-date (pathname)
	77 "Safe variant of FILE-WRITE-DATE that may return NIL rather than rai…
	78 ;; If FILE-WRITE-DATE returns NIL, it's possible that
	79 ;; the user or some other agent has deleted an input file.
	80 ;; Also, generated files will not exist at the time planning is done
	81 ;; and calls compute-action-stamp which calls safe-file-write-date.
	82 ;; So it is very possible that we can't get a valid file-write-date,
	83 ;; and we can survive and we will continue the planning
	84 ;; as if the file were very old.
	85 ;; (or should we treat the case in a different, special way?)
	86 (and pathname
	87 (handler-case (file-write-date (physicalize-pathname pathname))
	88 (file-error () nil))))
	89
	90 (defun probe-file* (p &key truename)
	91 "when given a pathname P (designated by a string as per PARSE-NAMEST…
	92 probes the filesystem for a file or directory with given pathname.
	93 If it exists, return its truename if TRUENAME is true,
	94 or the original (parsed) pathname if it is false (the default)."
	95 (values
	96 (ignore-errors
	97 (setf p (funcall 'ensure-pathname p
	98 :namestring :lisp
	99 :ensure-physical t
	100 :ensure-absolute t :defaults 'get-pathname-defaul…
	101 :want-non-wild t
	102 :on-error nil))
	103 (when p
	104 #+allegro
	105 (probe-file p :follow-symlinks truename)
	106 #+gcl
	107 (if truename
	108 (truename* p)
	109 (let ((kind (car (si::stat p))))
	110 (when (eq kind :link)
	111 (setf kind (ignore-errors (car (si::stat (truename* p)))…
	112 (ecase kind
	113 ((nil) nil)
	114 ((:file :link)
	115 (cond
	116 ((file-pathname-p p) p)
	117 ((directory-pathname-p p)
	118 (subpathname p (car (last (pathname-directory p)))))…
	119 (:directory (ensure-directory-pathname p)))))
	120 #+clisp
	121 #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix …
	122 (pp (find-symbol* '#:probe-pathname :ext nil)))
	123 `(if truename
	124 ,(if pp
	125 `(values (,pp p))
	126 '(or (truename* p)
	127 (truename* (ignore-errors (ensure-directory-path…
	128 ,(cond
	129 (fs `(and (,fs p) p))
	130 (pp `(nth-value 1 (,pp p)))
	131 (t '(or (and (truename* p) p)
	132 (if-let (d (ensure-directory-pathname p))
	133 (and (truename* d) d)))))))
	134 #-(or allegro clisp gcl)
	135 (if truename
	136 (probe-file p)
	137 (and
	138 #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p))
	139 #+(and lispworks os-unix) (system:get-file-stat p)
	140 #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
	141 #-(or cmucl (and lispworks os-unix) sbcl scl) (file-write-d…
	142 p))))))
	143
	144 (defun directory-exists-p (x)
	145 "Is X the name of a directory that exists on the filesystem?"
	146 #+allegro
	147 (excl:probe-directory x)
	148 #+clisp
	149 (handler-case (ext:probe-directory x)
	150 (sys::simple-file-error ()
	151 nil))
	152 #-(or allegro clisp)
	153 (let ((p (probe-file* x :truename t)))
	154 (and (directory-pathname-p p) p)))
	155
	156 (defun file-exists-p (x)
	157 "Is X the name of a file that exists on the filesystem?"
	158 (let ((p (probe-file* x :truename t)))
	159 (and (file-pathname-p p) p)))
	160
	161 (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
	162 "Return a list of the entries in a directory by calling DIRECTORY.
	163 Try to override the defaults to not resolving symlinks, if implementatio…
	164 (apply 'directory pathname-spec
	165 (append keys '#.(or #+allegro '(:directories-are-files nil :f…
	166 #+(or clozure digitool) '(:follow-links n…
	167 #+clisp '(:circle t :if-does-not-exist :i…
	168 #+(or cmucl scl) '(:follow-links nil :tru…
	169 #+lispworks '(:link-transparency nil)
	170 #+sbcl (when (find-symbol* :resolve-symli…
	171 '(:resolve-symlinks nil))))))
	172
	173 (defun filter-logical-directory-results (directory entries merger)
	174 "If DIRECTORY isn't a logical pathname, return ENTRIES. If it is,
	175 given ENTRIES in the DIRECTORY, remove the entries which are physical yet
	176 when transformed by MERGER have a different TRUENAME.
	177 Also remove duplicates as may appear with some translation rules.
	178 This function is used as a helper to DIRECTORY-FILES to avoid invalid en…
	179 when using logical-pathnames."
	180 (if (logical-pathname-p directory)
	181 (remove-duplicates ;; on CLISP, querying ~/ will return duplicat…
	182 ;; Try hard to not resolve logical-pathname into physical pathn…
	183 ;; otherwise logical-pathname users/lovers will be disappointed.
	184 ;; If directory* could use some implementation-dependent magic,
	185 ;; we will have logical pathnames already; otherwise,
	186 ;; we only keep pathnames for which specifying the name and
	187 ;; translating the LPN commute.
	188 (loop :for f :in entries
	189 :for p = (or (and (logical-pathname-p f) f)
	190 (let* ((u (ignore-errors (call-function merg…
	191 ;; The first u avoids a cumbersome (truena…
	192 ;; At this point f should already be a tru…
	193 ;; but isn't quite in CLISP, for it doesn'…
	194 (and u (equal (truename* u) (truename* f))…
	195 :when p :collect p)
	196 :test 'pathname-equal)
	197 entries))
	198
	199 (defun directory-files (directory &optional (pattern *wild-file-for-di…
	200 "Return a list of the files in a directory according to the PATTERN.
	201 Subdirectories should NOT be returned.
	202 PATTERN defaults to a pattern carefully chosen based on the implementa…
	203 override the default at your own risk.
	204 DIRECTORY-FILES tries NOT to resolve symlinks if the implementation pe…
	205 but the behavior in presence of symlinks is not portable. Use IOlib to h…
	206 (let ((dir (pathname directory)))
	207 (when (logical-pathname-p dir)
	208 ;; Because of the filtering we do below,
	209 ;; logical pathnames have restrictions on wild patterns.
	210 ;; Not that the results are very portable when you use these pat…
	211 (when (wild-pathname-p dir)
	212 (parameter-error "~S: Invalid wild pattern in logical director…
	213 'directory-files directory))
	214 (unless (member (pathname-directory pattern) '(() (:relative)) :…
	215 (parameter-error "~S: Invalid file pattern ~S for logical dire…
	216 (setf pattern (make-pathname-logical pattern (pathname-host dir)…
	217 (let* ((pat (merge-pathnames* pattern dir))
	218 (entries (ignore-errors (directory* pat))))
	219 (remove-if 'directory-pathname-p
	220 (filter-logical-directory-results
	221 directory entries
	222 #'(lambda (f)
	223 (make-pathname :defaults dir
	224 :name (make-pathname-component-lo…
	225 :type (make-pathname-component-lo…
	226 :version (make-pathname-component…
	227
	228 (defun subdirectories (directory)
	229 "Given a DIRECTORY pathname designator, return a list of the subdire…
	230 The behavior in presence of symlinks is not portable. Use IOlib to handl…
	231 (let* ((directory (ensure-directory-pathname directory))
	232 #-(or abcl cormanlisp genera xcl)
	233 (wild (merge-pathnames*
	234 #-(or abcl allegro cmucl lispworks sbcl scl xcl)
	235 wild-directory
	236 #+(or abcl allegro cmucl lispworks sbcl scl xcl) "."
	237 directory))
	238 (dirs
	239 #-(or abcl cormanlisp genera xcl)
	240 (ignore-errors
	241 (directory* wild . #.(or #+clozure '(:directories t :files…
	242 #+mcl '(:directories t))))
	243 #+(or abcl xcl) (system:list-directory directory)
	244 #+cormanlisp (cl::directory-subdirs directory)
	245 #+genera (handler-case (fs:directory-list directory) (fs:di…
	246 #+(or abcl allegro cmucl genera lispworks sbcl scl xcl)
	247 (dirs (loop :for x :in dirs
	248 :for d = #+(or abcl xcl) (extensions:probe-direct…
	249 #+allegro (excl:probe-directory x)
	250 #+(or cmucl sbcl scl) (directory-pathname-p x)
	251 #+genera (getf (cdr x) :directory)
	252 #+lispworks (lw:file-directory-p x)
	253 :when d :collect #+(or abcl allegro xcl) (ensure-…
	254 #+genera (ensure-directory-pathname (first x))
	255 #+(or cmucl lispworks sbcl scl) x)))
	256 (filter-logical-directory-results
	257 directory dirs
	258 (let ((prefix (or (normalize-pathname-directory-component (pathna…
	259 '(:absolute)))) ; because allegro returns NIL f…
	260 #'(lambda (d)
	261 (let ((dir (normalize-pathname-directory-component (pathnam…
	262 (and (consp dir) (consp (cdr dir))
	263 (make-pathname
	264 :defaults directory :name nil :type nil :version nil
	265 :directory (append prefix (make-pathname-component-…
	266
	267 (defun collect-sub*directories (directory collectp recursep collector)
	268 "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed…
	269 call-function the COLLECTOR function designator on the directory,
	270 and recurse each of its subdirectories on which the RECURSEP returns tru…
	271 This function will thus let you traverse a filesystem hierarchy,
	272 superseding the functionality of CL-FAD:WALK-DIRECTORY.
	273 The behavior in presence of symlinks is not portable. Use IOlib to handl…
	274 (when (call-function collectp directory)
	275 (call-function collector directory)
	276 (dolist (subdir (subdirectories directory))
	277 (when (call-function recursep subdir)
	278 (collect-sub*directories subdir collectp recursep collector)))…
	279
	280 ;;; Resolving symlinks somewhat
	281 (with-upgradability ()
	282 (defun truenamize (pathname)
	283 "Resolve as much of a pathname as possible"
	284 (block nil
	285 (when (typep pathname '(or null logical-pathname)) (return pathnam…
	286 (let ((p pathname))
	287 (unless (absolute-pathname-p p)
	288 (setf p (or (absolute-pathname-p (ensure-absolute-pathname p '…
	289 (return p))))
	290 (when (logical-pathname-p p) (return p))
	291 (let ((found (probe-file* p :truename t)))
	292 (when found (return found)))
	293 (let* ((directory (normalize-pathname-directory-component (pathn…
	294 (up-components (reverse (rest directory)))
	295 (down-components ()))
	296 (assert (eq :absolute (first directory)))
	297 (loop :while up-components :do
	298 (if-let (parent
	299 (ignore-errors
	300 (probe-file* (make-pathname :directory `(:absolute…
	301 :name nil :type nil :v…
	302 (if-let (simplified
	303 (ignore-errors
	304 (merge-pathnames*
	305 (make-pathname :directory `(:relative ,@down-co…
	306 :defaults p)
	307 (ensure-directory-pathname parent))))
	308 (return simplified)))
	309 (push (pop up-components) down-components)
	310 :finally (return p))))))
	311
	312 (defun resolve-symlinks (path)
	313 "Do a best effort at resolving symlinks in PATH, returning a partial…
	314 #-allegro (truenamize path)
	315 #+allegro
	316 (if (physical-pathname-p path)
	317 (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) …
	318 path))
	319
	320 (defvar resolve-symlinks t
	321 "Determine whether or not ASDF resolves symlinks when defining syste…
	322 Defaults to T.")
	323
	324 (defun resolve-symlinks* (path)
	325 "RESOLVE-SYMLINKS in PATH iff RESOLVE-SYMLINKS is T (the default)."
	326 (if resolve-symlinks
	327 (and path (resolve-symlinks path))
	328 path)))
	329
	330
	331 ;;; Check pathname constraints
	332 (with-upgradability ()
	333 (defun ensure-pathname
	334 (pathname &key
	335 on-error
	336 defaults type dot-dot namestring
	337 empty-is-nil
	338 want-pathname
	339 want-logical want-physical ensure-physical
	340 want-relative want-absolute ensure-absolute ensure-sub…
	341 want-non-wild want-wild wilden
	342 want-file want-directory ensure-directory
	343 want-existing ensure-directories-exist
	344 truename resolve-symlinks truenamize
	345 &aux (p pathname)) ;; mutable working copy, preserve original
	346 "Coerces its argument into a PATHNAME,
	347 optionally doing some transformations and checking specified constraints.
	348
	349 If the argument is NIL, then NIL is returned unless the WANT-PATHNAME co…
	350
	351 If the argument is a STRING, it is first converted to a pathname via
	352 PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respe…
	353 depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respe…
	354 or else by using CALL-FUNCTION on the NAMESTRING argument;
	355 if :UNIX is specified (or NIL, the default, which specifies the same thi…
	356 then PARSE-UNIX-NAMESTRING it is called with the keywords
	357 DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and
	358 the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is …
	359
	360 The pathname passed or resulting from parsing the string
	361 is then subjected to all the checks and transformations below are run.
	362
	363 Each non-nil constraint argument can be one of the symbols T, ERROR, CER…
	364 The boolean T is an alias for ERROR.
	365 ERROR means that an error will be raised if the constraint is not satisf…
	366 CERROR means that an continuable error will be raised if the constraint …
	367 IGNORE means just return NIL instead of the pathname.
	368
	369 The ON-ERROR argument, if not NIL, is a function designator (as per CALL…
	370 that will be called with the the following arguments:
	371 a generic format string for ensure pathname, the pathname,
	372 the keyword argument corresponding to the failed check or transformation,
	373 a format string for the reason ENSURE-PATHNAME failed,
	374 and a list with arguments to that format string.
	375 If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
	376 You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
	377
	378 The transformations and constraint checks are done in this order,
	379 which is also the order in the lambda-list:
	380
	381 EMPTY-IS-NIL returns NIL if the argument is an empty string.
	382 WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
	383 Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
	384 WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
	385 WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
	386 ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-…
	387 WANT-RELATIVE checks that pathname has a relative directory component
	388 WANT-ABSOLUTE checks that pathname does have an absolute directory compo…
	389 ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
	390 that the result absolute is an absolute pathname indeed.
	391 ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
	392 WANT-FILE checks that pathname has a non-nil FILE component
	393 WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
	394 ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
	395 any file and type components as being actually a last directory componen…
	396 WANT-NON-WILD checks that pathname is not a wild pathname
	397 WANT-WILD checks that pathname is a wild pathname
	398 WILDEN merges the pathname with */.. if it is not wild
	399 WANT-EXISTING checks that a file (or directory) exists with that pathnam…
	400 ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECT…
	401 TRUENAME replaces the pathname by its truename, or errors if not possibl…
	402 RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolv…
	403 TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
	404 (block nil
	405 (flet ((report-error (keyword description &rest arguments)
	406 (call-function (or on-error 'error)
	407 "Invalid pathname ~S: ~*~?"
	408 pathname keyword description arguments)))
	409 (macrolet ((err (constraint &rest arguments)
	410 `(report-error ',(intern* constraint :keyword) ,@ar…
	411 (check (constraint condition &rest arguments)
	412 `(when ,constraint
	413 (unless ,condition (err ,constraint ,@arguments)…
	414 (transform (transform condition expr)
	415 `(when ,transform
	416 (,@(if condition `(when ,condition) '(progn))
	417 (setf p ,expr)))))
	418 (etypecase p
	419 ((or null pathname))
	420 (string
	421 (when (and (emptyp p) empty-is-nil)
	422 (return-from ensure-pathname nil))
	423 (setf p (case namestring
	424 ((:unix nil)
	425 (parse-unix-namestring
	426 p :defaults defaults :type type :dot-dot dot-dot
	427 :ensure-directory ensure-directory :want-rela…
	428 ((:native)
	429 (parse-native-namestring p))
	430 ((:lisp)
	431 (parse-namestring p))
	432 (t
	433 (call-function namestring p))))))
	434 (etypecase p
	435 (pathname)
	436 (null
	437 (check want-pathname (pathnamep p) "Expected a pathname, no…
	438 (return nil)))
	439 (check want-logical (logical-pathname-p p) "Expected a logical…
	440 (check want-physical (physical-pathname-p p) "Expected a physi…
	441 (transform ensure-physical () (physicalize-pathname p))
	442 (check ensure-physical (physical-pathname-p p) "Could not tran…
	443 (check want-relative (relative-pathname-p p) "Expected a relat…
	444 (check want-absolute (absolute-pathname-p p) "Expected an abso…
	445 (transform ensure-absolute (not (absolute-pathname-p p))
	446 (ensure-absolute-pathname p defaults (list #'report…
	447 (check ensure-absolute (absolute-pathname-p p)
	448 "Could not make into an absolute pathname even after me…
	449 (check ensure-subpath (absolute-pathname-p defaults)
	450 "cannot be checked to be a subpath of non-absolute path…
	451 (check ensure-subpath (subpathp p defaults) "is not a sub path…
	452 (check want-file (file-pathname-p p) "Expected a file pathname…
	453 (check want-directory (directory-pathname-p p) "Expected a dir…
	454 (transform ensure-directory (not (directory-pathname-p p)) (en…
	455 (check want-non-wild (not (wild-pathname-p p)) "Expected a non…
	456 (check want-wild (wild-pathname-p p) "Expected a wildcard path…
	457 (transform wilden (not (wild-pathname-p p)) (wilden p))
	458 (when want-existing
	459 (let ((existing (probe-file* p :truename truename)))
	460 (if existing
	461 (when truename
	462 (return existing))
	463 (err want-existing "Expected an existing pathname"))))
	464 (when ensure-directories-exist (ensure-directories-exist p))
	465 (when truename
	466 (let ((truename (truename* p)))
	467 (if truename
	468 (return truename)
	469 (err truename "Can't get a truename for pathname"))))
	470 (transform resolve-symlinks () (resolve-symlinks p))
	471 (transform truenamize () (truenamize p))
	472 p)))))
	473
	474
	475 ;;; Pathname defaults
	476 (with-upgradability ()
	477 (defun get-pathname-defaults (&optional (defaults *default-pathname-de…
	478 "Find the actual DEFAULTS to use for pathnames, including
	479 resolving them with respect to GETCWD if the DEFAULTS were relative"
	480 (or (absolute-pathname-p defaults)
	481 (merge-pathnames* defaults (getcwd))))
	482
	483 (defun call-with-current-directory (dir thunk)
	484 "call the THUNK in a context where the current directory was changed…
	485 Note that this operation is usually NOT thread-safe."
	486 (if dir
	487 (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-…
	488 (cwd (getcwd))
	489 (default-pathname-defaults dir))
	490 (chdir dir)
	491 (unwind-protect
	492 (funcall thunk)
	493 (chdir cwd)))
	494 (funcall thunk)))
	495
	496 (defmacro with-current-directory ((&optional dir) &body body)
	497 "Call BODY while the POSIX current working directory is set to DIR"
	498 `(call-with-current-directory ,dir #'(lambda () ,@body))))
	499
	500
	501 ;;; Environment pathnames
	502 (with-upgradability ()
	503 (defun inter-directory-separator ()
	504 "What character does the current OS conventionally uses to separate …
	505 (os-cond ((os-unix-p) #\:) (t #\;)))
	506
	507 (defun split-native-pathnames-string (string &rest constraints &key &a…
	508 "Given a string of pathnames specified in native OS syntax, separate…
	509 check constraints and normalize each one as per ENSURE-PATHNAME,
	510 where an empty string denotes NIL."
	511 (loop :for namestring :in (split-string string :separator (string (i…
	512 :collect (unless (emptyp namestring) (apply 'parse-native-name…
	513
	514 (defun getenv-pathname (x &rest constraints &key ensure-directory want…
	515 "Extract a pathname from a user-configured environment variable, as …
	516 check constraints and normalize as per ENSURE-PATHNAME."
	517 ;; For backward compatibility with ASDF 2, want-directory implies en…
	518 (apply 'parse-native-namestring (getenvp x)
	519 :ensure-directory (or ensure-directory want-directory)
	520 :on-error (or on-error
	521 `(error "In (~S ~S), invalid pathname ~~S: ~~…
	522 constraints))
	523 (defun getenv-pathnames (x &rest constraints &key on-error &allow-othe…
	524 "Extract a list of pathname from a user-configured environment varia…
	525 check constraints and normalize each one as per ENSURE-PATHNAME.
	526 Any empty entries in the environment variable X will be returned …
	527 (unless (getf constraints :empty-is-nil t)
	528 (parameter-error "Cannot have EMPTY-IS-NIL false for ~S" 'getenv-p…
	529 (apply 'split-native-pathnames-string (getenvp x)
	530 :on-error (or on-error
	531 `(error "In (~S ~S), invalid pathname ~~S: ~~…
	532 :empty-is-nil t
	533 constraints))
	534 (defun getenv-absolute-directory (x)
	535 "Extract an absolute directory pathname from a user-configured envir…
	536 as per native OS"
	537 (getenv-pathname x :want-absolute t :ensure-directory t))
	538 (defun getenv-absolute-directories (x)
	539 "Extract a list of absolute directories from a user-configured envir…
	540 as per native OS. Any empty entries in the environment variable X will …
	541 NILs."
	542 (getenv-pathnames x :want-absolute t :ensure-directory t))
	543
	544 (defun lisp-implementation-directory (&key truename)
	545 "Where are the system files of the current installation of the CL im…
	546 (declare (ignorable truename))
	547 (let ((dir
	548 #+abcl extensions:lisp-home
	549 #+(or allegro clasp ecl mkcl) #p"SYS:"
	550 #+clisp custom:lib-directory
	551 #+clozure #p"ccl:"
	552 #+cmucl (ignore-errors (pathname-parent-directory-pathname (…
	553 #+gcl system::system-directory
	554 #+lispworks lispworks:lispworks-directory
	555 #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-…
	556 (funcall it)
	557 (getenv-pathname "SBCL_HOME" :ensure-directory t))
	558 #+scl (ignore-errors (pathname-parent-directory-pathname (tr…
	559 #+xcl ext:xcl-home))
	560 (if (and dir truename)
	561 (truename* dir)
	562 dir)))
	563
	564 (defun lisp-implementation-pathname-p (pathname)
	565 "Is the PATHNAME under the current installation of the CL implementa…
	566 ;; Other builtin systems are those under the implementation directory
	567 (and (when pathname
	568 (if-let (impdir (lisp-implementation-directory))
	569 (or (subpathp pathname impdir)
	570 (when resolve-symlinks
	571 (if-let (truename (truename* pathname))
	572 (if-let (trueimpdir (truename* impdir))
	573 (subpathp truename trueimpdir)))))))
	574 t)))
	575
	576
	577 ;;; Simple filesystem operations
	578 (with-upgradability ()
	579 (defun ensure-all-directories-exist (pathnames)
	580 "Ensure that for every pathname in PATHNAMES, we ensure its director…
	581 (dolist (pathname pathnames)
	582 (when pathname
	583 (ensure-directories-exist (physicalize-pathname pathname)))))
	584
	585 (defun delete-file-if-exists (x)
	586 "Delete a file X if it already exists"
	587 (when x (handler-case (delete-file x) (file-error () nil))))
	588
	589 (defun rename-file-overwriting-target (source target)
	590 "Rename a file, overwriting any previous file with the TARGET name,
	591 in an atomic way if the implementation allows."
	592 (let ((source (ensure-pathname source :namestring :lisp :ensure-phys…
	593 (target (ensure-pathname target :namestring :lisp :ensure-phys…
	594 #+clisp ;; in recent enough versions of CLISP, :if-exists :overwri…
	595 (progn (funcall 'require "syscalls")
	596 (symbol-call :posix :copy-file source target :method :renam…
	597 #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atom…
	598 #-clisp
	599 (rename-file source target
	600 #+(or clasp clozure ecl) :if-exists
	601 #+clozure :rename-and-delete #+(or clasp ecl) t)))
	602
	603 (defun delete-empty-directory (directory-pathname)
	604 "Delete an empty directory"
	605 #+(or abcl digitool gcl) (delete-file directory-pathname)
	606 #+allegro (excl:delete-directory directory-pathname)
	607 #+clisp (ext:delete-directory directory-pathname)
	608 #+clozure (ccl::delete-empty-directory directory-pathname)
	609 #+(or cmucl scl) (multiple-value-bind (ok errno)
	610 (unix:unix-rmdir (native-namestring directory-pat…
	611 (unless ok
	612 #+cmucl (error "Error number ~A when trying to de…
	613 errno directory-pathname)
	614 #+scl (error "~@<Error deleting ~S: ~A~@:>"
	615 directory-pathname (unix:get-unix-er…
	616 #+cormanlisp (win32:delete-directory directory-pathname)
	617 #+(or clasp ecl) (si:rmdir directory-pathname)
	618 #+genera (fs:delete-directory directory-pathname)
	619 #+lispworks (lw:delete-directory directory-pathname)
	620 #+mkcl (mkcl:rmdir directory-pathname)
	621 #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
	622 `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
	623 `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir…
	624 #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring …
	625 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl…
	626 (not-implemented-error 'delete-empty-directory "(on your platform)")…
	627
	628 (defun delete-directory-tree (directory-pathname &key (validate nil va…
	629 "Delete a directory including all its recursive contents, aka rm -rf.
	630
	631 To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
	632 a physical non-wildcard directory pathname (not namestring).
	633
	634 If the directory does not exist, the IF-DOES-NOT-EXIST argument specifie…
	635 if it is :ERROR (the default), an error is signaled, whereas if it is :I…
	636
	637 Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME mu…
	638 the validation function designated (as per ENSURE-FUNCTION) by the VALID…
	639 which in practice is thus compulsory, and validates by returning a non-N…
	640 If you're suicidal or extremely confident, just use :VALIDATE T."
	641 (check-type if-does-not-exist (member :error :ignore))
	642 (cond
	643 ((not (and (pathnamep directory-pathname) (directory-pathname-p di…
	644 (physical-pathname-p directory-pathname) (not (wild-pat…
	645 (parameter-error "~S was asked to delete ~S but it is not a physi…
	646 'delete-directory-tree directory-pathname))
	647 ((not validatep)
	648 (parameter-error "~S was asked to delete ~S but was not provided …
	649 'delete-directory-tree directory-pathname))
	650 ((not (call-function validate directory-pathname))
	651 (parameter-error "~S was asked to delete ~S but it is not valid ~…
	652 'delete-directory-tree directory-pathname validate))
	653 ((not (directory-exists-p directory-pathname))
	654 (ecase if-does-not-exist
	655 (:error
	656 (error "~S was asked to delete ~S but the directory does not e…
	657 'delete-directory-tree directory-pathname))
	658 (:ignore nil)))
	659 #-(or allegro cmucl clozure genera sbcl scl)
	660 ((os-unix-p) ;; On Unix, don't recursively walk the directory and …
	661 ;; except on implementations where we can prevent DIRECTORY from …
	662 ;; instead spawn a standard external program to do the dirty work.
	663 (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring …
	664 (t
	665 ;; On supported implementation, call supported system functions
	666 #+allegro (symbol-call :excl.osi :delete-directory-and-files
	667 directory-pathname :if-does-not-exist if-d…
	668 #+clozure (ccl:delete-directory directory-pathname)
	669 #+genera (fs:delete-directory directory-pathname :confirm nil)
	670 #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
	671 `(,dd directory-pathname :recursive t) ;; requires SBC…
	672 '(error "~S requires SBCL 1.0.44 or later" 'delete-dir…
	673 ;; Outside Unix or on CMUCL and SCL that can avoid following syml…
	674 ;; do things the hard way.
	675 #-(or allegro clozure genera sbcl)
	676 (let ((sub*directories
	677 (while-collecting (c)
	678 (collect-sub*directories directory-pathname t t #'c))))
	679 (dolist (d (nreverse sub*directories))
	680 (map () 'delete-file (directory-files d))
	681 (delete-empty-directory d)))))))