Commit a237921f authored by Robert Goldman's avatar Robert Goldman

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)))
This diff is collapsed.
......@@ -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))))
(os-cond
((os-unix-p)
(when directory ;; NB: unless on Unix, %system uses with-current-directory
`(" ; cd " ,(escape-shell-token (native-namestring directory))))))
after)))))
(defun %system (command &rest keys
......@@ -782,7 +786,7 @@ It returns a process-info plist with possible keys:
(apply '%run-program %command :wait t
:input :interactive :output :interactive :error-output :interactive keys))
#-(or clisp (and lispworks os-windows))
(with-current-directory ((unless (os-unix-p) directory))
(with-current-directory ((os-cond ((not (os-unix-p)) directory)))
#+abcl (ext:run-shell-command %command)
#+cormanlisp (win32:system %command)
#+(or clasp ecl) (let ((*standard-input* *stdin*)
......
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