Re: Bug in UIOP XDG implementation

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@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@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