Bug in UIOP XDG implementation
Jason Miller
jason at milr.com
Sat Mar 28 22:42:49 UTC 2015
Hi Faré,
The only windows machine I have is running XP, will that be sufficient?
-Jason
On 03:34 Sat 28 Mar , Faré wrote:
> 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 <jason at 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 <tunes at 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 , at 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 , at clauses)
> + #-abcl (loop* :for (test . body) :in clauses :when (eval test) :return `(progn , at 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
>
More information about the asdf-devel
mailing list