Dear Jason,
I've re-read
http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
And indeed you're right that I failed to follow it properly.
Please try this patch and tell me if it works for you on Windows (NB:
I don't have Windows).
—♯ƒ • François-René ÐVB Rideau •Reflection&Cybernethics• http://fare.tunes.org
The last ten percent of any reform is the most difficult to
achieve. Moreover, it is often harmful. — John McCarthy
On Fri, Mar 27, 2015 at 1:42 PM, Jason Miller <ja...@milr.com> wrote:
> Hi,
>
> With $XDG_CONFIG_DIRS unset, (uiop:user-configuration-directories)
> returns only $XDG_CONFIG_HOME/common-lisp/
>
> However, with it set to "/etc/xdg" it returns a list that starts with
> "/etc/xdg/common-lisp"
>
> There are two problems with this:
>
> 1) The XDG Base Directory Specification says that "If $XDG_CONFIG_DIRS is
> either not set or empty, a value equal to /etc/xdg should be used."
>
> 2) My understanding of uiop:user-configuration-directories is that it's
> listed in order of importance, but, from the XDG spec:
>
> "The base directory defined by $XDG_CONFIG_HOME is considered more
> important than any of the base directories defined by
> $XDG_CONFIG_DIRS"
>
> So, what I think is correct is that with $XDG_CONFIG_DIRS set it should
> return a list starting with $XDG_CONFIG_HOME, followed by the lists in
> $XDG_CONFIG_DIRS, and with it not set, should return a list of
> $XDG_CONFIG_HOME followed by /etc/xdg/common-lisp/
>
> Even if that's not correct, due to #1 the current implementation is
> definitely wrong.
>
> Regards,
> Jason
>
From 4c5cc83a3833d2c977bd69a80b65b5ddd1b4968b Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tu...@google.com>
Date: Sat, 28 Mar 2015 03:31:21 -0400
Subject: [PATCH] Fix configuration search paths
Make it more XDG compliant on Unix, and play nicer with Windows.
---
bundle.lisp | 8 +--
output-translations.lisp | 18 ++++--
source-registry.lisp | 39 +++++++------
uiop/configuration.lisp | 142 ++++++++++++++++++++++++++++++-----------------
uiop/os.lisp | 5 ++
uiop/pathname.lisp | 15 +++--
uiop/run-program.lisp | 2 +-
uiop/stream.lisp | 10 ++--
8 files changed, 149 insertions(+), 90 deletions(-)
diff --git a/bundle.lisp b/bundle.lisp
index 72f4a6e..b6d40ed 100644
--- a/bundle.lisp
+++ b/bundle.lisp
@@ -160,10 +160,10 @@ itself.")) ;; operation on a system and its dependencies
((member :dll :lib :shared-library :static-library :program :object :program)
(compile-file-type :type bundle-type))
((member :image) #-allegro "image" #+allegro "dxl")
- ((member :dll :shared-library) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
- ((member :lib :static-library) (cond ((os-unix-p) "a")
- ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
- ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
+ ((member :dll :shared-library) (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
+ ((member :lib :static-library) (os-cond ((os-unix-p) "a")
+ ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
+ ((eql :program) (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
(defun bundle-output-files (o c)
(let ((bundle-type (bundle-type o)))
diff --git a/output-translations.lisp b/output-translations.lisp
index c5d8721..e3cabca 100644
--- a/output-translations.lisp
+++ b/output-translations.lisp
@@ -155,13 +155,23 @@ and the order is by decreasing length of namestring of the source pathname.")
(defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
(defun user-output-translations-pathname (&key (direction :input))
- (in-user-configuration-directory *output-translations-file* :direction direction))
+ (if (eq direction :output)
+ (config-home-pathname "common-lisp" *output-translations-file*)
+ (find-config-pathname "common-lisp" *output-translations-file*)))
(defun system-output-translations-pathname (&key (direction :input))
- (in-system-configuration-directory *output-translations-file* :direction direction))
+ (let ((files (config-system-pathnames "common-lisp" *output-translations-file*)))
+ (if (eq direction :output)
+ (first files)
+ (find-if 'probe-file* files))))
(defun user-output-translations-directory-pathname (&key (direction :input))
- (in-user-configuration-directory *output-translations-directory* :direction direction))
+ (if (eq direction :output)
+ (config-home-pathname "common-lisp" *output-translations-directory*))
+ (find-config-pathname "common-lisp" *output-translations-directory*))
(defun system-output-translations-directory-pathname (&key (direction :input))
- (in-system-configuration-directory *output-translations-directory* :direction direction))
+ (let ((files (config-system-pathnames "common-lisp" *output-translations-directory*)))
+ (if (eq direction :output)
+ (first files)
+ (find-if 'probe-file* files))))
(defun environment-output-translations ()
(getenv "ASDF_OUTPUT_TRANSLATIONS"))
diff --git a/source-registry.lisp b/source-registry.lisp
index 3e6a162..3c56637 100644
--- a/source-registry.lisp
+++ b/source-registry.lisp
@@ -184,34 +184,33 @@ after having found a .asd file? True by default.")
`(:source-registry
(:tree (:home "common-lisp/"))
#+sbcl (:directory (:home ".sbcl/systems/"))
- ,@(loop :for dir :in
- `(,@(when (os-unix-p)
- `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
- (subpathname (user-homedir-pathname) ".local/share/"))))
- ,@(when (os-windows-p)
- (mapcar 'get-folder-path '(:local-appdata :appdata))))
- :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
- :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+ (:directory ,(data-home-pathname "common-lisp" "systems/"))
+ (:tree ,(data-home-pathname "common-lisp" "source/"))
:inherit-configuration))
(defun default-system-source-registry ()
`(:source-registry
- ,@(loop :for dir :in
- `(,@(when (os-unix-p)
- (or (getenv-absolute-directories "XDG_DATA_DIRS")
- '("/usr/local/share" "/usr/share")))
- ,@(when (os-windows-p)
- (list (get-folder-path :common-appdata))))
- :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
- :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+ ,@(loop :for dir :in (data-search-pathnames "common-lisp")
+ :collect `(:directory (,dir "systems/"))
+ :collect `(:tree (,dir "source/")))
:inherit-configuration))
(defun user-source-registry (&key (direction :input))
- (in-user-configuration-directory *source-registry-file* :direction direction))
+ (if (eq direction :output)
+ (config-home-pathname "common-lisp" *source-registry-file*)
+ (find-config-pathname "common-lisp" *source-registry-file*)))
(defun system-source-registry (&key (direction :input))
- (in-system-configuration-directory *source-registry-file* :direction direction))
+ (let ((files (config-system-pathnames "common-lisp" *source-registry-file*)))
+ (if (eq direction :output)
+ (first files)
+ (find-if 'probe-file* files))))
(defun user-source-registry-directory (&key (direction :input))
- (in-user-configuration-directory *source-registry-directory* :direction direction))
+ (if (eq direction :output)
+ (config-home-pathname "common-lisp" *source-registry-directory*))
+ (find-config-pathname "common-lisp" *source-registry-directory*))
(defun system-source-registry-directory (&key (direction :input))
- (in-system-configuration-directory *source-registry-directory* :direction direction))
+ (let ((files (config-system-pathnames "common-lisp" *source-registry-directory*)))
+ (if (eq direction :output)
+ (first files)
+ (find-if 'probe-file* files))))
(defun environment-source-registry ()
(getenv "CL_SOURCE_REGISTRY"))
diff --git a/uiop/configuration.lisp b/uiop/configuration.lisp
index 07e90e6..039438c 100644
--- a/uiop/configuration.lisp
+++ b/uiop/configuration.lisp
@@ -8,12 +8,14 @@
:uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
(:export
#:get-folder-path
- #:user-configuration-directories #:system-configuration-directories
- #:in-first-directory
- #:in-user-configuration-directory #:in-system-configuration-directory
+ #:data-home-pathname #:config-home-pathname #:data-search-pathnames #:config-search-pathnames
+ #:cache-home-pathname #:runtime-dir-pathname #:config-system-pathnames
+ #:clean-search-pathnames #:data-pathnames #:config-pathnames
+ #:find-data-pathname #:find-config-pathname
#:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
#:configuration-inheritance-directive-p
- #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
+ #:report-invalid-form #:invalid-configuration
+ #:*ignored-configuration-form* #:*user-cache*
#:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
#:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
#:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration))
@@ -38,48 +40,89 @@ this function tries to locate the Windows FOLDER for one of
(or #+(and lispworks mswindows) (sys:get-folder-path folder)
;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
(ecase folder
- (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
+ (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA")
+ (subpathname* (getenv-absolute-directory "APPDATA") "Local")))
(:appdata (getenv-absolute-directory "APPDATA"))
(:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
(subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
- (defun user-configuration-directories ()
- "Determine user configuration directories"
- (let ((dirs
- `(,@(when (os-unix-p)
- (cons
- (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
- (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
- :collect (subpathname* dir "common-lisp/"))))
- ,@(when (os-windows-p)
- `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
- ,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
- ,(subpathname (user-homedir-pathname) ".config/common-lisp/"))))
- (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
- :from-end t :test 'equal)))
-
- (defun system-configuration-directories ()
- "Determine system user configuration directories"
- (cond
- ((os-unix-p) '(#p"/etc/common-lisp/"))
- ((os-windows-p)
- (if-let (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/"))
- (list it)))))
+ ;; Support for the XDG Base Directory Specification
+ (defun data-home-pathname (&optional app &rest more)
+ "path for user specific data files"
+ (resolve-location
+ `(,(os-cond
+ ((os-windows-p) (or (get-folder-path :local-appdata)
+ (subpath (get-folder-path :appdata) "Local/")))
+ (t (or (getenv-absolute-directory "XDG_DATA_HOME")
+ (subpathname (user-homedir-pathname) ".local/share/"))))
+ ,app ,more)))
+
+ (defun config-home-pathname (&optional app &rest more)
+ "path for user specific configuration files"
+ (os-cond
+ ((os-windows-p) (apply 'data-home-path app "config/" more))
+ (t (resolve-absolute-location
+ `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
+ (subpath (user-homedir-pathname) ".config/"))
+ ,app ,more)))))
+
+ (defun data-search-pathnames (&optional app &rest more)
+ "the preference-ordered set of additional paths to search for data files"
+ (mapcar #'(lambda (d) (resolve-location `(,d ,app ,more)))
+ (os-cond
+ ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
+ (t (or (getenv-absolute-directories "XDG_DATA_DIRS")
+ (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))))
+
+ (defun config-search-pathnames (&optional app &rest more)
+ "the preference-ordered set of additional base paths to search for configuration files"
+ (os-cond
+ ((os-windows-p) (apply 'data-search-pathnames app "config/" more))
+ (t (mapcar #'(lambda (d) (resolve-location `(,d ,app ,more)))
+ (or (getenv-absolute-directories "XDG_CONFIG_DIRS")
+ (list (parse-unix-namestring '("/etc/xdg/"))))))))
+
+ (defun cache-home-pathname (&optional app &rest more)
+ "the base directory relative to which user specific non-essential data files should be stored"
+ (os-cond
+ ((os-windows-p) (data-home-pathname app "cache" more))
+ (t (resolve-location `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
+ (subpath (user-homedir-pathname) ".cache/")) ,app ,more)))))
+
+ (defun runtime-dir-pathname (&optional app &rest more)
+ "pathname for user-specific non-essential runtime files and other file objects"
+ ;; (such as sockets, named pipes, ...)
+ ;; The XDG spec says that if not provided by the login system, the application should
+ ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL.
+ (os-cond
+ ((not (os-windows-p))
+ (resolve-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,app ,more)))))
- (defun in-first-directory (dirs x &key (direction :input))
+ (defun config-system-pathnames (&optional app &rest more)
"Determine system user configuration directories"
- (loop :with fun = (ecase direction
- ((nil :input :probe) 'probe-file*)
- ((:output :io) 'identity))
- :for dir :in dirs
- :thereis (and dir (funcall fun (subpathname (ensure-directory-pathname dir) x)))))
-
- (defun in-user-configuration-directory (x &key (direction :input))
- "return pathname under user configuration directory, subpathname X"
- (in-first-directory (user-configuration-directories) x :direction direction))
- (defun in-system-configuration-directory (x &key (direction :input))
- "return pathname under system configuration directory, subpathname X"
- (in-first-directory (system-configuration-directories) x :direction direction))
+ (when (os-unix-p) (list (resolve-location `(,(parse-unix-namestring "/etc/") ,app ,more)))))
+
+ (defun clean-search-pathnames (dirs)
+ "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list"
+ (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))
+
+ (defun data-pathnames (&optional app &rest more)
+ "Determine pathnames for user configuration"
+ (clean-search-pathnames
+ (cons (apply 'data-home-pathname app more)
+ (apply 'data-search-pathnames app more))))
+
+ (defun config-pathnames (&optional app &rest more)
+ "Determine pathnames for user configuration"
+ (clean-search-pathnames
+ `(,(apply 'config-home-pathname app more)
+ ,@(apply 'config-search-pathnames app more))))
+
+ (defun find-data-pathname (&optional app &rest more)
+ (find-if 'probe-file* (apply 'data-pathnames app more)))
+
+ (defun find-config-pathname (&optional app &rest more)
+ (find-if 'probe-file* (apply 'config-pathnames app more)))
(defun configuration-inheritance-directive-p (x)
"Is X a configuration inheritance directive?"
@@ -173,6 +216,7 @@ values of TAG include :source-registry and :output-translations."
"Given a designator X for an relative location, resolve it to a pathname"
(ensure-pathname
(etypecase x
+ (null nil)
(pathname x)
(string (parse-unix-namestring
x :ensure-directory ensure-directory))
@@ -210,21 +254,14 @@ directive.")
(defun compute-user-cache ()
"Compute the location of the default user-cache for translate-output objects"
- (setf *user-cache*
- (flet ((try (x &rest sub) (and x `(,x ,@sub))))
- (or
- (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
- (when (os-windows-p)
- (try (or (get-folder-path :local-appdata)
- (get-folder-path :appdata))
- "common-lisp" "cache" :implementation))
- '(:home ".cache" "common-lisp" :implementation)))))
+ (setf *user-cache* (cache-home-pathname "common-lisp" :implementation)))
(register-image-restore-hook 'compute-user-cache)
(defun resolve-absolute-location (x &key ensure-directory wilden)
"Given a designator X for an absolute location, resolve it to a pathname"
(ensure-pathname
(etypecase x
+ (null nil)
(pathname x)
(string
(let ((p #-mcl (parse-namestring x)
@@ -267,9 +304,10 @@ directive.")
;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
(loop* :with dirp = (or directory ensure-directory)
:with (first . rest) = (if (atom x) (list x) x)
- :with path = (resolve-absolute-location
- first :ensure-directory (and (or dirp rest) t)
- :wilden (and wilden (null rest)))
+ :with path = (or (resolve-absolute-location
+ first :ensure-directory (and (or dirp rest) t)
+ :wilden (and wilden (null rest)))
+ (return nil))
:for (element . morep) :on rest
:for dir = (and (or morep dirp) t)
:for wild = (and wilden (not morep))
diff --git a/uiop/os.lisp b/uiop/os.lisp
index 1c5a9d9..052b1a5 100644
--- a/uiop/os.lisp
+++ b/uiop/os.lisp
@@ -7,6 +7,7 @@
(:use :uiop/common-lisp :uiop/package :uiop/utility)
(:export
#:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features
+ #:os-cond
#:getenv #:getenvp ;; environment variables
#:implementation-identifier ;; implementation identifier
#:implementation-type #:*implementation-type*
@@ -73,6 +74,10 @@ except on ABCL where it might change between FASL compilation and runtime."
(return (or o (error "Congratulations for trying ASDF on an operating system~%~
that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
+ (defmacro os-cond (&rest clauses)
+ #+abcl `(cond ,@clauses)
+ #-abcl (loop* :for (test . body) :in clauses :when (eval test) :return `(progn ,@body)))
+
(detect-os))
;;;; Environment variables: getting them, and parsing them.
diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp
index 19cbf13..5e3fabb 100644
--- a/uiop/pathname.lisp
+++ b/uiop/pathname.lisp
@@ -25,7 +25,7 @@
#:split-name-type #:parse-unix-namestring #:unix-namestring
#:split-unix-namestring-directory-components
;; Absolute and relative pathnames
- #:subpathname #:subpathname*
+ #:subpathname #:subpathname* #:subpath #:subpath*
#:ensure-absolute-pathname
#:pathname-root #:pathname-host-pathname
#:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname
@@ -404,9 +404,9 @@ For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
"Coerce NAME into a PATHNAME using standard Unix syntax.
Unix syntax is used whether or not the underlying system is Unix;
-on such non-Unix systems it is only usable but for relative pathnames;
-but especially to manipulate relative pathnames portably, it is of crucial
-to possess a portable pathname syntax independent of the underlying OS.
+on such non-Unix systems it is reliably usable only for relative pathnames.
+This function is especially useful to manipulate relative pathnames portably,
+where it is of crucial to possess a portable pathname syntax independent of the underlying OS.
This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
When given a PATHNAME object, just return it untouched.
@@ -530,6 +530,13 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
(and pathname
(subpathname (ensure-directory-pathname pathname) subpath :type type)))
+ (defun subpath (pathname &rest components)
+ (if (null components) pathname
+ (apply 'subpath (subpathname pathname (first components)) (rest components))))
+
+ (defun subpath* (pathname &rest components)
+ (and pathname (apply 'subpath pathname components)))
+
(defun pathname-root (pathname)
"return the root directory for the host and device of given PATHNAME"
(make-pathname* :directory '(:absolute)
diff --git a/uiop/run-program.lisp b/uiop/run-program.lisp
index 1e43cd0..7fdaf81 100644
--- a/uiop/run-program.lisp
+++ b/uiop/run-program.lisp
@@ -104,7 +104,7 @@ for use within a POSIX Bourne shell, outputing to S."
(defun escape-shell-token (token &optional s)
"Escape a token for the current operating system shell"
- (cond
+ (os-cond
((os-unix-p) (escape-sh-token token s))
((os-windows-p) (escape-windows-token token s))))
diff --git a/uiop/stream.lisp b/uiop/stream.lisp
index 9a6ceef..6c18401 100644
--- a/uiop/stream.lisp
+++ b/uiop/stream.lisp
@@ -277,7 +277,7 @@ and return that"
(defun null-device-pathname ()
"Pathname to a bit bucket device that discards any information written to it
and always returns EOF when read from"
- (cond
+ (os-cond
((os-unix-p) #p"/dev/null")
((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
(t (error "No /dev/null on your OS"))))
@@ -528,13 +528,13 @@ If a string, repeatedly read and evaluate from it, returning the last values."
(with-upgradability ()
(defun default-temporary-directory ()
"Return a default directory to use for temporary files"
- (or
- (when (os-unix-p)
+ (os-cond
+ ((os-unix-p)
(or (getenv-pathname "TMPDIR" :ensure-directory t)
(parse-native-namestring "/tmp/")))
- (when (os-windows-p)
+ ((os-windows-p)
(getenv-pathname "TEMP" :ensure-directory t))
- (subpathname (user-homedir-pathname) "tmp/")))
+ (t (subpathname (user-homedir-pathname) "tmp/"))))
(defvar *temporary-directory* nil "User-configurable location for temporary files")
--
2.2.0.rc0.207.ga3a616c
