Skip to content
Snippets Groups Projects
Commit 8270978f authored by Robert P. Goldman's avatar Robert P. Goldman
Browse files

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.
parent d81f4485
No related branches found
No related tags found
No related merge requests found
...@@ -40,12 +40,15 @@ ...@@ -40,12 +40,15 @@
(if (os-unix-p) (unix-namestring p) (if (os-unix-p) (unix-namestring p)
(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 "From a native namestring suitable for use by the operating system, return
a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
(check-type string (or string null)) (check-type string (or string null))
(let* ((pathname (let* ((pathname
(when string (when string
(unless (or (not want-absolute)
(absolute-pathname-p string))
(error "Invalid pathname ~S: Expected an absolute pathname." string))
(with-pathname-defaults () (with-pathname-defaults ()
#+clozure (ccl:native-to-pathname string) #+clozure (ccl:native-to-pathname string)
#+sbcl (sb-ext:parse-native-namestring string) #+sbcl (sb-ext:parse-native-namestring string)
...@@ -333,6 +336,7 @@ Defaults to T.") ...@@ -333,6 +336,7 @@ Defaults to T.")
(pathname &key (pathname &key
on-error on-error
defaults type dot-dot namestring defaults type dot-dot namestring
empty-is-nil
want-pathname want-pathname
want-logical want-physical ensure-physical want-logical want-physical ensure-physical
want-relative want-absolute ensure-absolute ensure-subpath want-relative want-absolute ensure-absolute ensure-subpath
...@@ -376,6 +380,7 @@ You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\"). ...@@ -376,6 +380,7 @@ You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
The transformations and constraint checks are done in this order, The transformations and constraint checks are done in this order,
which is also the order in the lambda-list: 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. WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
Otherwise, if the pathname is NIL, ensure-pathname returns NIL. Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
...@@ -415,6 +420,8 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." ...@@ -415,6 +420,8 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
(etypecase p (etypecase p
((or null pathname)) ((or null pathname))
(string (string
(when (and (emptyp p) empty-is-nil)
(return-from ensure-pathname nil))
(setf p (case namestring (setf p (case namestring
((:unix nil) ((:unix nil)
(parse-unix-namestring (parse-unix-namestring
...@@ -499,21 +506,20 @@ Note that this operation is usually NOT thread-safe." ...@@ -499,21 +506,20 @@ Note that this operation is usually NOT thread-safe."
"What character does the current OS conventionally uses to separate directories?" "What character does the current OS conventionally uses to separate directories?"
(if (os-unix-p) #\: #\;)) (if (os-unix-p) #\: #\;))
(defun split-native-pathnames-string (string &rest constraints &key (discard-empty-entries t) &allow-other-keys) ;; (defun split-native-pathnames-string (string &rest constraints)
"Given a string of pathnames specified in native OS syntax, separate them in a list, ;; "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. ;; 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 ;; If DISCARD-EMPTY-ENTRIES is T, empty strings will be quietly ignored, otherwise they will
be translated into a NIL return value." ;; be translated into a NIL return value."
(let ((constraints (copy-list constraints))) ;; (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
(remf constraints :discard-empty-entries) ;; :collect (apply 'parse-native-namestring namestring constraints)))
(loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
:if (emptyp namestring) "Given a string of pathnames specified in native OS syntax, separate them in a list,
:unless discard-empty-entries check constraints and normalize each one as per ENSURE-PATHNAME,
:collect nil where an empty string denotes NIL." ;;; <---- slight change in semantics, but pretty conservative in previously supported cases.
:end ; unless (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
:else :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints))))
:collect (apply 'parse-native-namestring namestring constraints))))
(defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys) (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, "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." ...@@ -524,25 +530,23 @@ check constraints and normalize as per ENSURE-PATHNAME."
:on-error (or on-error :on-error (or on-error
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
constraints)) 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, "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." check constraints and normalize each one as per ENSURE-PATHNAME."
(let ((constraints (copy-list constraints))) (apply 'split-native-pathnames-string (getenvp x)
(remf constraints :discard-empty-entries) :on-error (or on-error
(apply 'split-native-pathnames-string (getenvp x) `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
:on-error (or on-error :empty-is-nil empty-is-nil
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) constraints))
:discard-empty-entries discard-empty-entries
constraints)))
(defun getenv-absolute-directory (x) (defun getenv-absolute-directory (x)
"Extract an absolute directory pathname from a user-configured environment variable, "Extract an absolute directory pathname from a user-configured environment variable,
as per native OS" as per native OS"
(getenv-pathname x :want-absolute t :ensure-directory t)) (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, "Extract a list of absolute directories from a user-configured environment variable,
as per native OS" as per native OS"
(getenv-pathnames x :want-absolute t :ensure-directory t (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) (defun lisp-implementation-directory (&key truename)
"Where are the system files of the current installation of the CL implementation?" "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." ...@@ -674,4 +678,3 @@ If you're suicidal or extremely confident, just use :VALIDATE T."
(dolist (d (nreverse sub*directories)) (dolist (d (nreverse sub*directories))
(map () 'delete-file (directory-files d)) (map () 'delete-file (directory-files d))
(delete-empty-directory d))))))) (delete-empty-directory d)))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment