Commit a237921f authored by Robert Goldman's avatar Robert Goldman
Browse files

Merge branch 'launchpad-1437480'

Pull in topic branch for fixing launchpad-1437480. Involved substantial
re-examination and refactoring of the configuration file functions in
UIOP.

* launchpad-1437480:
  Provide more doc for MORE arguments in pathname functions.
  Fix funcall in IN-USER-CONFIGURATION-DIRECTORY
  Update some comments, docstrings, and a test.
  Documentation changes and one function renaming.
  configuration: Adopt XDG wholesale, even on Windows. Rename functions accordingly.
  Comment tweak.
  Use os-cond in more places.
  Remove FIXME: asdf-pathname-test doesn't use its own package anymore.
  Revised docstrings.
  Add new pathnames.
  config-search-pathnames fix and edited docstrings.
  Fix XDG support and make Windows happier
parents b09e8d51 98f05a73
......@@ -174,14 +174,16 @@ Going forward, we recommend new users should be using the source-registry.
:truename truename))
(return file))
#-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
(when (and (os-windows-p) (physical-pathname-p defaults))
(let ((shortcut
(make-pathname
:defaults defaults :case :local
:name (strcat name ".asd")
:type "lnk")))
(when (probe-file* shortcut)
(ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))
(os-cond
((os-windows-p)
(when (physical-pathname-p defaults)
(let ((shortcut
(make-pathname
:defaults defaults :case :local
:name (strcat name ".asd")
:type "lnk")))
(when (probe-file* shortcut)
(ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))))
(defun sysdef-central-registry-search (system)
(let ((name (primary-system-name system))
......
......@@ -151,17 +151,19 @@ 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))
(in-user-configuration-directory *output-translations-file* :direction direction))
(xdg-config-pathname *output-translations-file* direction))
(defun system-output-translations-pathname (&key (direction :input))
(in-system-configuration-directory *output-translations-file* :direction direction))
(find-preferred-file (system-config-pathnames *output-translations-file*)
:direction direction))
(defun user-output-translations-directory-pathname (&key (direction :input))
(in-user-configuration-directory *output-translations-directory* :direction direction))
(xdg-config-pathname *output-translations-directory* direction))
(defun system-output-translations-directory-pathname (&key (direction :input))
(in-system-configuration-directory *output-translations-directory* :direction direction))
(find-preferred-file (system-config-pathnames *output-translations-directory*)
:direction direction))
(defun environment-output-translations ()
(getenv "ASDF_OUTPUT_TRANSLATIONS"))
......@@ -195,12 +197,10 @@ and the order is by decreasing length of namestring of the source pathname.")
((location-function-p dst)
(funcall collect
(list trusrc (ensure-function (second dst)))))
((eq dst t)
((typep dst 'boolean)
(funcall collect (list trusrc t)))
(t
(let* ((trudst (if dst
(resolve-location dst :ensure-directory t :wilden t)
trusrc)))
(let* ((trudst (resolve-location dst :ensure-directory t :wilden t)))
(funcall collect (list trudst t))
(funcall collect (list trusrc trudst)))))))))))
......
......@@ -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,34 +184,25 @@ 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 ,(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
`(,@(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 (xdg-data-dirs "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))
(xdg-config-pathname *source-registry-file* direction))
(defun system-source-registry (&key (direction :input))
(in-system-configuration-directory *source-registry-file* :direction direction))
(find-preferred-file (system-config-pathnames *source-registry-file*)
:direction direction))
(defun user-source-registry-directory (&key (direction :input))
(in-user-configuration-directory *source-registry-directory* :direction direction))
(xdg-config-pathname *source-registry-directory* direction))
(defun system-source-registry-directory (&key (direction :input))
(in-system-configuration-directory *source-registry-directory* :direction direction))
(find-preferred-file (system-config-pathnames *source-registry-directory*)
:direction direction))
(defun environment-source-registry ()
(getenv "CL_SOURCE_REGISTRY"))
......
;;; -*- Lisp -*-
(defpackage :asdf-pathname-test (:use :asdf :uiop :uiop/common-lisp :asdf/cache :asdf-test))
(in-package :asdf-pathname-test)
(eval-when (:compile-toplevel :load-toplevel :execute)
#-(or xcl gcl) (push :asdf-test-logical-pathname *features*)
#+xcl (push :buggy-untyped-file *features*))
......@@ -419,12 +416,9 @@
(clear-system "test-system")))
(defun test-pathname-parsing ()
#-(or allegro clisp clozure ecl lispworks mkcl sbcl cmu)
(progn
;; FIXME: unable to get DBG to load in this file. [2014/11/30:rpg]
(format t "Can't test pathname parsing: this lisp lacks SETENV support.")
t)
#+(or allegro clisp clozure ecl lispworks mkcl sbcl cmu)
#-(or allegro clisp clozure cmu ecl lispworks mkcl sbcl)
(DBG "Can't test pathname parsing: this lisp lacks SETENV support.")
#+(or allegro clisp clozure cmu ecl lispworks mkcl sbcl)
(let ((old-config (uiop:getenvp "XDG_CONFIG_DIRS"))
(old-home-config (uiop:getenvp "XDG_CONFIG_HOME")))
(unwind-protect
......@@ -432,13 +426,13 @@
(setf (uiop:getenv "XDG_CONFIG_DIRS") "/foo:prismatic")
(multiple-value-bind (ret err)
(ignore-errors
(uiop:user-configuration-directories))
(uiop:xdg-config-pathnames))
(assert (and (not ret) err)))
(setf (uiop:getenv "XDG_CONFIG_DIRS") "/foo:")
(setf (uiop:getenv "XDG_CONFIG_HOME") "")
(multiple-value-bind (ret err)
(ignore-errors
(uiop:user-configuration-directories))
(uiop:xdg-config-pathnames))
(assert (not err))
(assert (= (length ret) 2))))
(when old-config
......
......@@ -6,11 +6,12 @@
(:recycle :uiop/backward-driver :asdf/backward-driver :asdf)
(:use :uiop/common-lisp :uiop/package :uiop/utility
:uiop/pathname :uiop/stream :uiop/os :uiop/image
:uiop/run-program :uiop/lisp-build
:uiop/configuration)
:uiop/run-program :uiop/lisp-build :uiop/configuration)
(:export
#:coerce-pathname #:component-name-to-pathname-components
#+(or clasp ecl mkcl) #:compile-file-keeping-object
#:user-configuration-directories #:system-configuration-directories
#:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory
))
(in-package :uiop/backward-driver)
......@@ -38,4 +39,33 @@
(values relabs path filename)))
#+(or clasp ecl mkcl)
(defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)))
(defun compile-file-keeping-object (&rest args) (apply #'compile-file* args))
;; Backward compatibility for ASDF 2.27 to 3.1.4
(defun user-configuration-directories ()
"Return the current user's list of user configuration directories
for configuring 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."
(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).
If direction is :INPUT or :PROBE, will return the first extant file named
X in one of the DIRS.
If direction is :OUTPUT or :IO, will simply return the file named X in the
first element of DIRS that exists. DEPRECATED."
(find-preferred-file
(mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir) x)) dirs)
:direction direction))
(defun in-user-configuration-directory (x &key (direction :input))
"Return the file named X in the user configuration directory for common-lisp.
DEPRECATED."
(xdg-config-pathname (format nil "common-lisp/~a/" 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 (system-config-pathnames "common-lisp" x) :direction direction)))
......@@ -7,10 +7,13 @@
(:use :uiop/common-lisp :uiop/utility
:uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
(:export
#: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
#:user-configuration-directories #:system-configuration-directories
#:in-first-directory
#:in-user-configuration-directory #:in-system-configuration-directory
#:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs
#:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames
#:filter-pathname-set #: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*
......@@ -31,56 +34,6 @@
(list* (condition-form c) (condition-location c)
(condition-arguments c))))))
(defun get-folder-path (folder)
"Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
this function tries to locate the Windows FOLDER for one of
:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA."
(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"))
(: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)))))
(defun in-first-directory (dirs x &key (direction :input))
"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))
(defun configuration-inheritance-directive-p (x)
"Is X a configuration inheritance directive?"
(let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
......@@ -104,7 +57,16 @@ this function tries to locate the Windows FOLDER for one of
(defun validate-configuration-form (form tag directive-validator
&key location invalid-form-reporter)
"Validate a configuration FORM"
"Validate a configuration FORM. By default it will raise an error if the
FORM is not valid. Otherwise it will return the validated form.
Arguments control the behavior:
The configuration FORM should be of the form (TAG . <rest>)
Each element of <rest> will be checked by first seeing if it's a configuration inheritance
directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR
on it.
In the event of an invalid form, INVALID-FORM-REPORTER will be used to control
reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where
the configuration form appeared."
(unless (and (consp form) (eq (car form) tag))
(setf *ignored-configuration-form* t)
(report-invalid-form invalid-form-reporter :form form :location location)
......@@ -137,7 +99,9 @@ this function tries to locate the Windows FOLDER for one of
(return (nreverse x))))
(defun validate-configuration-file (file validator &key description)
"Validate a configuration file for conformance of its form with the validator function"
"Validate a configuration FILE. The configuration file should have only one s-expression
in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error
reporting."
(let ((forms (read-file-forms file)))
(unless (length=n-p forms 1)
(error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
......@@ -170,9 +134,10 @@ values of TAG include :source-registry and :output-translations."
:inherit-configuration)))
(defun resolve-relative-location (x &key ensure-directory wilden)
"Given a designator X for an relative location, resolve it to a pathname"
"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))
......@@ -208,23 +173,11 @@ directive.")
(defvar *user-cache* nil
"A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
(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)))))
(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 +220,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))
......@@ -282,6 +236,8 @@ directive.")
(defun location-designator-p (x)
"Is X a designator for a location?"
;; NIL means "skip this entry", or as an output translation, same as translation input.
;; T means "any input" for a translation, or as output, same as translation input.
(flet ((absolute-component-p (c)
(typep c '(or string pathname
(member :root :home :here :user-cache))))
......@@ -294,9 +250,8 @@ directive.")
(defun location-function-p (x)
"Is X the specification of a location function?"
(and
(length=n-p x 2)
(eq (car x) :function)))
;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support.
(and (length=n-p x 2) (eq (car x) :function)))
(defvar *clear-configuration-hook* '())
......@@ -314,6 +269,145 @@ directive.")
"If a previous version of ASDF failed to read some configuration, try again now."
(when *ignored-configuration-form*
(clear-configuration)
(setf *ignored-configuration-form* nil))))
(setf *ignored-configuration-form* nil)))
(defun get-folder-path (folder)
"Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
this function tries to locate the Windows FOLDER for one of
:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
Returns NIL when the folder is not defined (e.g., not on Windows)."
(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 (or (getenv-absolute-directory "LOCALAPPDATA")
(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 xdg-data-home (&rest more)
"Returns an absolute pathname for the directory containing user-specific data files.
MORE may contain specifications for a subpath relative to this directory: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
(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)
"Returns a pathname for the directory containing user-specific configuration files.
MORE may contain specifications for a subpath relative to this directory: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
(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 xdg-data-dirs (&rest more)
"The preference-ordered set of additional paths to search for data files.
Returns a list of absolute directory pathnames.
MORE may contain specifications for a subpath relative to these directories: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
(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 xdg-config-dirs (&rest more)
"The preference-ordered set of additional base paths to search for configuration files.
Returns a list of absolute directory pathnames.
MORE may contain specifications for a subpath relative to these directories: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
(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.
Returns an absolute directory pathname.
MORE may contain specifications for a subpath relative to this directory: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
(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 xdg-runtime-dir (&rest more)
"Pathname for user-specific non-essential runtime files and other file objects,
such as sockets, named pipes, etc.
Returns an absolute directory pathname.
MORE may contain specifications for a subpath relative to this directory: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
;; 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.
(resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more)))
;;; NOTE: modified the docstring because "system user configuration
;;; directories" seems self-contradictory. I'm not sure my wording is right.
(defun system-config-pathnames (&rest more)
"Return a list of directories where are stored the system's default user configuration information.
MORE may contain specifications for a subpath relative to these directories: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
(os-cond
((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more))))))
(defun filter-pathname-set (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 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.
MORE may contain specifications for a subpath relative to these directories: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
(filter-pathname-set
`(,(xdg-data-home more)
,@(xdg-data-dirs more))))
(defun xdg-config-pathnames (&rest more)
"Return a list of pathnames for application configuration.
MORE may contain specifications for a subpath relative to these directories: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
(filter-pathname-set
`(,(xdg-config-home more)
,@(xdg-config-dirs more))))
(defun find-preferred-file (files &key (direction :input))
"Find first file in the list of FILES that exists (for direction :input or :probe)
or just the first one (for direction :output or :io).
Note that when we say \"file\" here, the files in question may be directories."
(find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files))
(defun xdg-data-pathname (&optional more (direction :input))
(find-preferred-file (xdg-data-pathnames 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* (xdg-cache-home "common-lisp" :implementation)))
(register-image-restore-hook 'compute-user-cache))
......@@ -37,8 +37,9 @@
#+(or cmu scl) (ext:unix-namestring p nil)
#+sbcl (sb-ext:native-namestring p)
#-(or clozure cmu sbcl scl)
(if (os-unix-p) (unix-namestring p)
(namestring p)))))
(os-cond
((os-unix-p) (unix-namestring p))
(t (namestring p))))))
(defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
"From a native namestring suitable for use by the operating system, return
......@@ -50,9 +51,9 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
#+clozure (ccl:native-to-pathname string)
#+sbcl (sb-ext:parse-native-namestring string)
#-(or clozure sbcl)
(if (os-unix-p)
(parse-unix-namestring string :ensure-directory ensure-directory)
(parse-namestring string)))))
(os-cond
((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory))
(t (parse-namestring string))))))
(pathname
(if ensure-directory
(and pathname (ensure-directory-pathname pathname))
......@@ -501,7 +502,7 @@ Note that this operation is usually NOT thread-safe."
(with-upgradability ()
(defun inter-directory-separator ()
"What character does the current OS conventionally uses to separate directories?"
(if (os-unix-p) #\: #\;))
(os-cond ((os-unix-p) #\:) (t #\;)))
(defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
"Given a string of pathnames specified in native OS syntax, separate them in a list,
......
......@@ -656,9 +656,10 @@ given DEFAULTS-PATHNAME as a base pathname."
(defun directorize-pathname-host-device (pathname)
"Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components
added to its DIRECTORY component. This is useful for output translations."
#+(or unix abcl)
(when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
(return-from directorize-pathname-host-device pathname))
(os-cond
((os-unix-p)
(when (physical-pathname-p pathname)
(return-from directorize-pathname-host-device pathname))))
(let* ((root (pathname-root pathname))
(wild-root (wilden root))
(absolute-pathname (merge-pathnames* pathname root))
......
......@@ -739,7 +739,9 @@ It returns a process-info plist with possible keys:
(etypecase command
(string command)
(list (escape-shell-command
(if (os-unix-p) (cons "exec" command) command)))))
(os-cond
((os-unix-p) (cons "exec" command))
(t command))))))
(defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
(flet ((redirect (spec operator)
......@@ -756,14 +758,16 @@ It returns a process-info plist with possible keys:
(escape-shell-token (native-namestring pathname)))))))
(multiple-value-bind (before after)
(let ((normalized (%normalize-system-command command)))
(if (os-unix-p)
(values '("exec") (list " ; " normalized))
(values (list normalized) ())))
(os-cond
((os-unix-p) (values '("exec") (list " ; " normalized)))
(t (values (list normalized) ()))))
(reduce/strcat
(append
before (redirect in " <") (redirect out " >") (redirect err " 2>")
(when (and directory (os-unix-p)) ;; NB: unless on Unix, %system uses with-current-directory
`(" ; cd " ,(escape-shell-token (native-namestring directory))))
<