From 8270978f70dc8f27e0347d1a6e71a972fead1764 Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" <rpgoldman@gmail.com> Date: Sun, 30 Nov 2014 11:08:40 -0600 Subject: [PATCH] Two fixes for reading configuration directories. 1. Put in place Fare's proposed solution to SPLIT-NATIVE-PATHNAMES-STRING. 2. Check for absolute pathnames in PARSE-NATIVE-NAMESTRING. This was a check whose need was recognized as a side-effect of getting the first bugfix in place. --- uiop/filesystem.lisp | 57 +++++++++++++++++++++++--------------------- 1 file changed, 30 insertions(+), 27 deletions(-) diff --git a/uiop/filesystem.lisp b/uiop/filesystem.lisp index 1ca9e5c6..f2ce53b9 100644 --- a/uiop/filesystem.lisp +++ b/uiop/filesystem.lisp @@ -40,12 +40,15 @@ (if (os-unix-p) (unix-namestring p) (namestring p))))) - (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys) + (defun parse-native-namestring (string &rest constraints &key want-absolute ensure-directory &allow-other-keys) "From a native namestring suitable for use by the operating system, return a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" (check-type string (or string null)) (let* ((pathname (when string + (unless (or (not want-absolute) + (absolute-pathname-p string)) + (error "Invalid pathname ~S: Expected an absolute pathname." string)) (with-pathname-defaults () #+clozure (ccl:native-to-pathname string) #+sbcl (sb-ext:parse-native-namestring string) @@ -333,6 +336,7 @@ Defaults to T.") (pathname &key on-error defaults type dot-dot namestring + empty-is-nil want-pathname want-logical want-physical ensure-physical want-relative want-absolute ensure-absolute ensure-subpath @@ -376,6 +380,7 @@ You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\"). The transformations and constraint checks are done in this order, which is also the order in the lambda-list: +EMPTY-IS-NIL returns NIL if the argument is an empty string. WANT-PATHNAME checks that pathname (after parsing if needed) is not null. Otherwise, if the pathname is NIL, ensure-pathname returns NIL. WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME @@ -415,6 +420,8 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (etypecase p ((or null pathname)) (string + (when (and (emptyp p) empty-is-nil) + (return-from ensure-pathname nil)) (setf p (case namestring ((:unix nil) (parse-unix-namestring @@ -499,21 +506,20 @@ Note that this operation is usually NOT thread-safe." "What character does the current OS conventionally uses to separate directories?" (if (os-unix-p) #\: #\;)) - (defun split-native-pathnames-string (string &rest constraints &key (discard-empty-entries t) &allow-other-keys) - "Given a string of pathnames specified in native OS syntax, separate them in a list, -check constraints and normalize each one as per ENSURE-PATHNAME. - If DISCARD-EMPTY-ENTRIES is T, empty strings will be quietly ignored, otherwise they will -be translated into a NIL return value." - (let ((constraints (copy-list constraints))) - (remf constraints :discard-empty-entries) - - (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) - :if (emptyp namestring) - :unless discard-empty-entries - :collect nil - :end ; unless - :else - :collect (apply 'parse-native-namestring namestring constraints)))) + ;; (defun split-native-pathnames-string (string &rest constraints) + ;; "Given a string of pathnames specified in native OS syntax, separate them in a list, + ;; check constraints and normalize each one as per ENSURE-PATHNAME. + ;; If DISCARD-EMPTY-ENTRIES is T, empty strings will be quietly ignored, otherwise they will + ;; be translated into a NIL return value." + ;; (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) + ;; :collect (apply 'parse-native-namestring namestring constraints))) + + (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys) + "Given a string of pathnames specified in native OS syntax, separate them in a list, +check constraints and normalize each one as per ENSURE-PATHNAME, +where an empty string denotes NIL." ;;; <---- slight change in semantics, but pretty conservative in previously supported cases. + (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) + :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints)))) (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys) "Extract a pathname from a user-configured environment variable, as per native OS, @@ -524,25 +530,23 @@ check constraints and normalize as per ENSURE-PATHNAME." :on-error (or on-error `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) constraints)) - (defun getenv-pathnames (x &rest constraints &key on-error (discard-empty-entries t) &allow-other-keys) + (defun getenv-pathnames (x &rest constraints &key on-error (empty-is-nil t) &allow-other-keys) "Extract a list of pathname from a user-configured environment variable, as per native OS, check constraints and normalize each one as per ENSURE-PATHNAME." - (let ((constraints (copy-list constraints))) - (remf constraints :discard-empty-entries) - (apply 'split-native-pathnames-string (getenvp x) - :on-error (or on-error - `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) - :discard-empty-entries discard-empty-entries - constraints))) + (apply 'split-native-pathnames-string (getenvp x) + :on-error (or on-error + `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) + :empty-is-nil empty-is-nil + constraints)) (defun getenv-absolute-directory (x) "Extract an absolute directory pathname from a user-configured environment variable, as per native OS" (getenv-pathname x :want-absolute t :ensure-directory t)) - (defun getenv-absolute-directories (x &key (discard-empty-entries t)) + (defun getenv-absolute-directories (x &key (empty-is-nil t)) "Extract a list of absolute directories from a user-configured environment variable, as per native OS" (getenv-pathnames x :want-absolute t :ensure-directory t - :discard-empty-entries discard-empty-entries)) + :empty-is-nil empty-is-nil)) (defun lisp-implementation-directory (&key truename) "Where are the system files of the current installation of the CL implementation?" @@ -674,4 +678,3 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (dolist (d (nreverse sub*directories)) (map () 'delete-file (directory-files d)) (delete-empty-directory d))))))) - -- GitLab