From ba7a0af917da82580a1dccc7c024375c7405ce30 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Tue, 28 Apr 2015 08:47:50 -0700
Subject: [PATCH] configuration: Adopt XDG wholesale, even on Windows. Rename
 functions accordingly.

---
 output-translations.lisp  |  12 ++--
 source-registry.lisp      |  18 +++---
 uiop/backward-driver.lisp |  10 ++--
 uiop/configuration.lisp   | 117 ++++++++++++++++++--------------------
 4 files changed, 76 insertions(+), 81 deletions(-)

diff --git a/output-translations.lisp b/output-translations.lisp
index aeb6773e..9ba06ca7 100644
--- a/output-translations.lisp
+++ b/output-translations.lisp
@@ -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:
       :enable-user-cache))
 
-  (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
-  (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
+  (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
+  (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))
 
   (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))
-    (find-preferred-file (config-system-pathnames "common-lisp" *output-translations-file*)
+    (find-preferred-file (system-config-pathnames *output-translations-file*)
                          :direction direction))
   (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))
-    (find-preferred-file (config-system-pathnames "common-lisp" *output-translations-directory*)
+    (find-preferred-file (system-config-pathnames *output-translations-directory*)
                          :direction direction))
   (defun environment-output-translations ()
     (getenv "ASDF_OUTPUT_TRANSLATIONS"))
diff --git a/source-registry.lisp b/source-registry.lisp
index a8c49db2..91bf043f 100644
--- a/source-registry.lisp
+++ b/source-registry.lisp
@@ -170,8 +170,8 @@ after having found a .asd file? True by default.")
       default-system-source-registry)
     "List of default source registries" "3.1.0.102")
 
-  (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
-  (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
+  (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf"))
+  (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/"))
 
   (defun wrapping-source-registry ()
     `(:source-registry
@@ -184,24 +184,24 @@ after having found a .asd file? True by default.")
     `(:source-registry
       (:tree (:home "common-lisp/"))
       #+sbcl (:directory (:home ".sbcl/systems/"))
-      (:directory ,(data-home-pathname "common-lisp" "systems/"))
-      (:tree ,(data-home-pathname "common-lisp" "source/"))
+      (:directory ,(xdg-data-home "common-lisp/systems/"))
+      (:tree ,(xdg-data-home "common-lisp/source/"))
       :inherit-configuration))
   (defun default-system-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 `(:tree (,dir "source/")))
       :inherit-configuration))
   (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))
-    (find-preferred-file (config-system-pathnames "common-lisp" *source-registry-file*)
+    (find-preferred-file (system-config-pathnames *source-registry-file*)
                          :direction direction))
   (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))
-    (find-preferred-file (config-system-pathnames "common-lisp" *source-registry-directory*)
+    (find-preferred-file (system-config-pathnames *source-registry-directory*)
                          :direction direction))
   (defun environment-source-registry ()
     (getenv "CL_SOURCE_REGISTRY"))
diff --git a/uiop/backward-driver.lisp b/uiop/backward-driver.lisp
index 1f67d91c..b2bc3019 100644
--- a/uiop/backward-driver.lisp
+++ b/uiop/backward-driver.lisp
@@ -45,12 +45,12 @@
   (defun user-configuration-directories ()
     "Return the current user's list of user configuration directories
 for configuring common-lisp.
-    DEPRECATED. Use uiop:config-pathnames instead."
-    (config-pathnames "common-lisp"))
+    DEPRECATED. Use uiop:xdg-config-pathnames instead."
+    (xdg-config-pathnames "common-lisp"))
   (defun system-configuration-directories ()
     "Return the list of system configuration directories for common-lisp.
     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))
     "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).
@@ -64,8 +64,8 @@ first element of DIRS that exists. DEPRECATED."
   (defun in-user-configuration-directory (x &key (direction :input))
     "Return the file named X in the user configuration directory for common-lisp.
 DEPRECATED."
-    (find-config-pathname "common-lisp" x direction))
+    (xdg-config-pathname "common-lisp" x direction))
   (defun in-system-configuration-directory (x &key (direction :input))
     "Return the pathname for the file named X under the system configuration directory
 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)))
diff --git a/uiop/configuration.lisp b/uiop/configuration.lisp
index 776475aa..ce7c32a9 100644
--- a/uiop/configuration.lisp
+++ b/uiop/configuration.lisp
@@ -10,10 +10,10 @@
    #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver
    #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem
    #:get-folder-path
-   #: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-preferred-file #:find-data-pathname #:find-config-pathname
+   #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs
+   #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames
+   #:clean-search-pathnames #:xdg-data-pathnames #:xdg-config-pathnames
+   #:find-preferred-file #:xdg-data-pathname #:xdg-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*
@@ -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
         (ecase folder
           (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA")
-                              (subpathname* (getenv-absolute-directory "APPDATA") "Local")))
+                              (subpathname* (get-folder-path :appdata) "Local")))
           (:appdata (getenv-absolute-directory "APPDATA"))
           (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
                                (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
 
   ;; 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"
-    (resolve-location
-     `(,(os-cond
-         ((os-windows-p) (or (get-folder-path :local-appdata)
-                             (subpathname* (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)
+    (resolve-absolute-location
+     `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
+            (os-cond
+             ((os-windows-p) (get-folder-path :local-appdata))
+             (t (subpathname (user-homedir-pathname) ".local/share/"))))
+       ,more)))
+
+  (defun xdg-config-home (&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")
-                (subpathname (user-homedir-pathname) ".config/"))
-           ,app ,more)))))
+    (resolve-absolute-location
+     `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
+            (os-cond
+             ((os-windows-p) (xdg-data-home "config/"))
+             (t (subpathname (user-homedir-pathname) ".config/"))))
+       ,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"
-    (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/" "/opt/local/share/" "/usr/share/")))))))
+    (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
+            (or (getenv-absolute-directories "XDG_DATA_DIRS")
+                (os-cond
+                 ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
+                 (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"
-    (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")
-                    (mapcar 'parse-unix-namestring
-                            (list "/etc/xdg/"
-                                  "/usr/local/etc/"
-                                  "/opt/local/etc/")))))))
-
-  (defun cache-home-pathname (&optional app &rest more)
+    (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
+            (or (getenv-absolute-directories "XDG_CONFIG_DIRS")
+                (os-cond
+                 ((os-windows-p) (xdg-data-dirs "config/" more))
+                 (t (mapcar 'parse-unix-namestring '("/etc/xdg/")))))))
+
+  (defun xdg-cache-home (&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")
-                                 (subpathname* (user-homedir-pathname) ".cache/")) ,app ,more)))))
+    (resolve-absolute-location
+     `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
+            (os-cond
+             ((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"
     ;; (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)))))
+    (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more)))
 
-  (defun config-system-pathnames (&optional app &rest more)
+  (defun system-config-pathnames (&rest more)
     "Determine system user configuration directories"
     (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)
     "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)
+  (defun xdg-data-pathnames (&rest more)
     "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
 for storing all application configurations."
     (clean-search-pathnames
-     `(,(data-home-pathname app more)
-       ,@(data-search-pathnames app more))))
+     `(,(xdg-data-home more)
+       ,@(xdg-data-dirs more))))
 
-  (defun config-pathnames (&optional app &rest more)
-    "Return a list of pathnames for application configuration. Without the APP argument,
-returns pathnames for directories that contain all of the configuration information."
+  (defun xdg-config-pathnames (&rest more)
+    "Return a list of pathnames for application configuration."
     (clean-search-pathnames
-     `(,(config-home-pathname app more)
-       ,@(config-search-pathnames app more))))
+     `(,(xdg-config-home more)
+       ,@(xdg-config-dirs more))))
 
   ;; FIXME: AFAICT although this says "find FILE," it is often used to find a DIRECTORY.
   (defun find-preferred-file (files &key (direction :input))
@@ -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)."
     (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files))
 
-  (defun find-data-pathname (&optional app more (direction :input))
-    (find-preferred-file (data-pathnames app more) :direction direction))
+  (defun xdg-data-pathname (&optional more (direction :input))
+    (find-preferred-file (xdg-data-pathnames more) :direction direction))
 
-  (defun find-config-pathname (&optional app more (direction :input))
-    (find-preferred-file (config-pathnames app more) :direction direction))
+  (defun xdg-config-pathname (&optional more (direction :input))
+    (find-preferred-file (xdg-config-pathnames more) :direction direction))
 
   (defun compute-user-cache ()
     "Compute (and return) the location of the default user-cache for translate-output
 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))
-- 
GitLab