Commit ba7a0af9 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

configuration: Adopt XDG wholesale, even on Windows.

Rename functions accordingly.
parent c43c16b3
...@@ -151,18 +151,18 @@ and the order is by decreasing length of namestring of the source pathname.") ...@@ -151,18 +151,18 @@ and the order is by decreasing length of namestring of the source pathname.")
;; We enable the user cache by default, and here is the place we do: ;; We enable the user cache by default, and here is the place we do:
:enable-user-cache)) :enable-user-cache))
(defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf")) (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
(defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/")) (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))
(defun user-output-translations-pathname (&key (direction :input)) (defun user-output-translations-pathname (&key (direction :input))
(find-config-pathname "common-lisp" *output-translations-file* direction)) (xdg-config-pathname *output-translations-file* direction))
(defun system-output-translations-pathname (&key (direction :input)) (defun system-output-translations-pathname (&key (direction :input))
(find-preferred-file (config-system-pathnames "common-lisp" *output-translations-file*) (find-preferred-file (system-config-pathnames *output-translations-file*)
:direction direction)) :direction direction))
(defun user-output-translations-directory-pathname (&key (direction :input)) (defun user-output-translations-directory-pathname (&key (direction :input))
(find-config-pathname "common-lisp" *output-translations-directory* direction)) (xdg-config-pathname *output-translations-directory* direction))
(defun system-output-translations-directory-pathname (&key (direction :input)) (defun system-output-translations-directory-pathname (&key (direction :input))
(find-preferred-file (config-system-pathnames "common-lisp" *output-translations-directory*) (find-preferred-file (system-config-pathnames *output-translations-directory*)
:direction direction)) :direction direction))
(defun environment-output-translations () (defun environment-output-translations ()
(getenv "ASDF_OUTPUT_TRANSLATIONS")) (getenv "ASDF_OUTPUT_TRANSLATIONS"))
......
...@@ -170,8 +170,8 @@ after having found a .asd file? True by default.") ...@@ -170,8 +170,8 @@ after having found a .asd file? True by default.")
default-system-source-registry) default-system-source-registry)
"List of default source registries" "3.1.0.102") "List of default source registries" "3.1.0.102")
(defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf")) (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf"))
(defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/")) (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/"))
(defun wrapping-source-registry () (defun wrapping-source-registry ()
`(:source-registry `(:source-registry
...@@ -184,24 +184,24 @@ after having found a .asd file? True by default.") ...@@ -184,24 +184,24 @@ after having found a .asd file? True by default.")
`(:source-registry `(:source-registry
(:tree (:home "common-lisp/")) (:tree (:home "common-lisp/"))
#+sbcl (:directory (:home ".sbcl/systems/")) #+sbcl (:directory (:home ".sbcl/systems/"))
(:directory ,(data-home-pathname "common-lisp" "systems/")) (:directory ,(xdg-data-home "common-lisp/systems/"))
(:tree ,(data-home-pathname "common-lisp" "source/")) (:tree ,(xdg-data-home "common-lisp/source/"))
:inherit-configuration)) :inherit-configuration))
(defun default-system-source-registry () (defun default-system-source-registry ()
`(:source-registry `(:source-registry
,@(loop :for dir :in (data-search-pathnames "common-lisp") ,@(loop :for dir :in (xdg-data-dirs "common-lisp/")
:collect `(:directory (,dir "systems/")) :collect `(:directory (,dir "systems/"))
:collect `(:tree (,dir "source/"))) :collect `(:tree (,dir "source/")))
:inherit-configuration)) :inherit-configuration))
(defun user-source-registry (&key (direction :input)) (defun user-source-registry (&key (direction :input))
(find-config-pathname "common-lisp" *source-registry-file* direction)) (xdg-config-pathname *source-registry-file* direction))
(defun system-source-registry (&key (direction :input)) (defun system-source-registry (&key (direction :input))
(find-preferred-file (config-system-pathnames "common-lisp" *source-registry-file*) (find-preferred-file (system-config-pathnames *source-registry-file*)
:direction direction)) :direction direction))
(defun user-source-registry-directory (&key (direction :input)) (defun user-source-registry-directory (&key (direction :input))
(find-config-pathname "common-lisp" *source-registry-directory* direction)) (xdg-config-pathname *source-registry-directory* direction))
(defun system-source-registry-directory (&key (direction :input)) (defun system-source-registry-directory (&key (direction :input))
(find-preferred-file (config-system-pathnames "common-lisp" *source-registry-directory*) (find-preferred-file (system-config-pathnames *source-registry-directory*)
:direction direction)) :direction direction))
(defun environment-source-registry () (defun environment-source-registry ()
(getenv "CL_SOURCE_REGISTRY")) (getenv "CL_SOURCE_REGISTRY"))
......
...@@ -45,12 +45,12 @@ ...@@ -45,12 +45,12 @@
(defun user-configuration-directories () (defun user-configuration-directories ()
"Return the current user's list of user configuration directories "Return the current user's list of user configuration directories
for configuring common-lisp. for configuring common-lisp.
DEPRECATED. Use uiop:config-pathnames instead." DEPRECATED. Use uiop:xdg-config-pathnames instead."
(config-pathnames "common-lisp")) (xdg-config-pathnames "common-lisp"))
(defun system-configuration-directories () (defun system-configuration-directories ()
"Return the list of system configuration directories for common-lisp. "Return the list of system configuration directories for common-lisp.
DEPRECATED. Use uiop:config-system-pathnames instead." DEPRECATED. Use uiop:config-system-pathnames instead."
(config-system-pathnames "common-lisp")) (system-config-pathnames "common-lisp"))
(defun in-first-directory (dirs x &key (direction :input)) (defun in-first-directory (dirs x &key (direction :input))
"Finds the first appropriate file named X in the list of DIRS for I/O "Finds the first appropriate file named X in the list of DIRS for I/O
in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE). in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE).
...@@ -64,8 +64,8 @@ first element of DIRS that exists. DEPRECATED." ...@@ -64,8 +64,8 @@ first element of DIRS that exists. DEPRECATED."
(defun in-user-configuration-directory (x &key (direction :input)) (defun in-user-configuration-directory (x &key (direction :input))
"Return the file named X in the user configuration directory for common-lisp. "Return the file named X in the user configuration directory for common-lisp.
DEPRECATED." DEPRECATED."
(find-config-pathname "common-lisp" x direction)) (xdg-config-pathname "common-lisp" x direction))
(defun in-system-configuration-directory (x &key (direction :input)) (defun in-system-configuration-directory (x &key (direction :input))
"Return the pathname for the file named X under the system configuration directory "Return the pathname for the file named X under the system configuration directory
for common-lisp. DEPRECATED." for common-lisp. DEPRECATED."
(find-preferred-file (config-system-pathnames "common-lisp" x) :direction direction))) (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction)))
...@@ -10,10 +10,10 @@ ...@@ -10,10 +10,10 @@
#:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver
#:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem
#:get-folder-path #:get-folder-path
#:data-home-pathname #:config-home-pathname #:data-search-pathnames #:config-search-pathnames #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs
#:cache-home-pathname #:runtime-dir-pathname #:config-system-pathnames #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames
#:clean-search-pathnames #:data-pathnames #:config-pathnames #:clean-search-pathnames #:xdg-data-pathnames #:xdg-config-pathnames
#:find-preferred-file #:find-data-pathname #:find-config-pathname #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname
#:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
#:configuration-inheritance-directive-p #:configuration-inheritance-directive-p
#:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache* #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
...@@ -269,89 +269,84 @@ this function tries to locate the Windows FOLDER for one of ...@@ -269,89 +269,84 @@ this function tries to locate the Windows FOLDER for one of
;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
(ecase folder (ecase folder
(:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA") (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA")
(subpathname* (getenv-absolute-directory "APPDATA") "Local"))) (subpathname* (get-folder-path :appdata) "Local")))
(:appdata (getenv-absolute-directory "APPDATA")) (:appdata (getenv-absolute-directory "APPDATA"))
(:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
(subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
;; Support for the XDG Base Directory Specification ;; Support for the XDG Base Directory Specification
(defun data-home-pathname (&optional app &rest more) (defun xdg-data-home (&rest more)
"path for user specific data files" "path for user specific data files"
(resolve-location (resolve-absolute-location
`(,(os-cond `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
((os-windows-p) (or (get-folder-path :local-appdata) (os-cond
(subpathname* (get-folder-path :appdata) "Local/"))) ((os-windows-p) (get-folder-path :local-appdata))
(t (or (getenv-absolute-directory "XDG_DATA_HOME") (t (subpathname (user-homedir-pathname) ".local/share/"))))
(subpathname (user-homedir-pathname) ".local/share/")))) ,more)))
,app ,more)))
(defun xdg-config-home (&rest more)
(defun config-home-pathname (&optional app &rest more)
"path for user specific configuration files" "path for user specific configuration files"
(os-cond (resolve-absolute-location
((os-windows-p) (apply 'data-home-path app "config/" more)) `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
(t (resolve-absolute-location (os-cond
`(,(or (getenv-absolute-directory "XDG_CONFIG_HOME") ((os-windows-p) (xdg-data-home "config/"))
(subpathname (user-homedir-pathname) ".config/")) (t (subpathname (user-homedir-pathname) ".config/"))))
,app ,more))))) ,more)))
(defun data-search-pathnames (&optional app &rest more) (defun xdg-data-dirs (&rest more)
"the preference-ordered set of additional paths to search for data files" "the preference-ordered set of additional paths to search for data files"
(mapcar #'(lambda (d) (resolve-location `(,d ,app ,more))) (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
(os-cond (or (getenv-absolute-directories "XDG_DATA_DIRS")
((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata))) (os-cond
(t (or (getenv-absolute-directories "XDG_DATA_DIRS") ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
(mapcar 'parse-unix-namestring '("/usr/local/share/" "/opt/local/share/" "/usr/share/"))))))) (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))))
(defun config-search-pathnames (&optional app &rest more) (defun xdg-config-dirs (&rest more)
"the preference-ordered set of additional base paths to search for configuration files" "the preference-ordered set of additional base paths to search for configuration files"
(os-cond (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
((os-windows-p) (apply 'data-search-pathnames app "config/" more)) (or (getenv-absolute-directories "XDG_CONFIG_DIRS")
(t (mapcar #'(lambda (d) (resolve-location `(,d ,app ,more))) (os-cond
(or (getenv-absolute-directories "XDG_CONFIG_DIRS") ((os-windows-p) (xdg-data-dirs "config/" more))
(mapcar 'parse-unix-namestring (t (mapcar 'parse-unix-namestring '("/etc/xdg/")))))))
(list "/etc/xdg/"
"/usr/local/etc/" (defun xdg-cache-home (&rest more)
"/opt/local/etc/")))))))
(defun cache-home-pathname (&optional app &rest more)
"the base directory relative to which user specific non-essential data files should be stored" "the base directory relative to which user specific non-essential data files should be stored"
(os-cond (resolve-absolute-location
((os-windows-p) (data-home-pathname app "cache" more)) `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
(t (resolve-location `(,(or (getenv-absolute-directory "XDG_CACHE_HOME") (os-cond
(subpathname* (user-homedir-pathname) ".cache/")) ,app ,more))))) ((os-windows-p) (xdg-data-home "cache"))
(t (subpathname* (user-homedir-pathname) ".cache/"))))
,more)))
(defun runtime-dir-pathname (&optional app &rest more) (defun xdg-runtime-dir (&rest more)
"pathname for user-specific non-essential runtime files and other file objects" "pathname for user-specific non-essential runtime files and other file objects"
;; (such as sockets, named pipes, ...) ;; (such as sockets, named pipes, ...)
;; The XDG spec says that if not provided by the login system, the application should ;; 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. ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL.
(os-cond (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more)))
((not (os-windows-p))
(resolve-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,app ,more)))))
(defun config-system-pathnames (&optional app &rest more) (defun system-config-pathnames (&rest more)
"Determine system user configuration directories" "Determine system user configuration directories"
(os-cond (os-cond
((os-unix-p) (list (resolve-location `(,(parse-unix-namestring "/etc/") ,app ,more)))))) ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more))))))
(defun clean-search-pathnames (dirs) (defun clean-search-pathnames (dirs)
"Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list" "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)) (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))
(defun data-pathnames (&optional app &rest more) (defun xdg-data-pathnames (&rest more)
"Return a list of absolute pathnames for application data directories. With APP, "Return a list of absolute pathnames for application data directories. With APP,
returns directory for data for that application, without APP, returns the set of directories returns directory for data for that application, without APP, returns the set of directories
for storing all application configurations." for storing all application configurations."
(clean-search-pathnames (clean-search-pathnames
`(,(data-home-pathname app more) `(,(xdg-data-home more)
,@(data-search-pathnames app more)))) ,@(xdg-data-dirs more))))
(defun config-pathnames (&optional app &rest more) (defun xdg-config-pathnames (&rest more)
"Return a list of pathnames for application configuration. Without the APP argument, "Return a list of pathnames for application configuration."
returns pathnames for directories that contain all of the configuration information."
(clean-search-pathnames (clean-search-pathnames
`(,(config-home-pathname app more) `(,(xdg-config-home more)
,@(config-search-pathnames app more)))) ,@(xdg-config-dirs more))))
;; FIXME: AFAICT although this says "find FILE," it is often used to find a DIRECTORY. ;; FIXME: AFAICT although this says "find FILE," it is often used to find a DIRECTORY.
(defun find-preferred-file (files &key (direction :input)) (defun find-preferred-file (files &key (direction :input))
...@@ -359,14 +354,14 @@ returns pathnames for directories that contain all of the configuration informat ...@@ -359,14 +354,14 @@ returns pathnames for directories that contain all of the configuration informat
or just the first one (for direction :output or :io)." or just the first one (for direction :output or :io)."
(find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files)) (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files))
(defun find-data-pathname (&optional app more (direction :input)) (defun xdg-data-pathname (&optional more (direction :input))
(find-preferred-file (data-pathnames app more) :direction direction)) (find-preferred-file (xdg-data-pathnames more) :direction direction))
(defun find-config-pathname (&optional app more (direction :input)) (defun xdg-config-pathname (&optional more (direction :input))
(find-preferred-file (config-pathnames app more) :direction direction)) (find-preferred-file (xdg-config-pathnames more) :direction direction))
(defun compute-user-cache () (defun compute-user-cache ()
"Compute (and return) the location of the default user-cache for translate-output "Compute (and return) the location of the default user-cache for translate-output
objects. Side-effects for cached file location computation." objects. Side-effects for cached file location computation."
(setf *user-cache* (cache-home-pathname "common-lisp" :implementation))) (setf *user-cache* (xdg-cache-home "common-lisp" :implementation)))
(register-image-restore-hook 'compute-user-cache)) (register-image-restore-hook 'compute-user-cache))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment