Commit 7efd8358 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau Committed by Robert Goldman

Fix XDG support and make Windows happier

Fixes lp#1437480.
Also includes backward compatibility with previous not-so-portable API.
parent 3a69c0a7
......@@ -155,13 +155,15 @@ 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))
(find-config-pathname "common-lisp" *output-translations-file* direction))
(defun system-output-translations-pathname (&key (direction :input))
(in-system-configuration-directory *output-translations-file* :direction direction))
(find-preferred-file (config-system-pathnames "common-lisp" *output-translations-file*)
:direction direction))
(defun user-output-translations-directory-pathname (&key (direction :input))
(in-user-configuration-directory *output-translations-directory* :direction direction))
(find-config-pathname "common-lisp" *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 (config-system-pathnames "common-lisp" *output-translations-directory*)
:direction direction))
(defun environment-output-translations ()
(getenv "ASDF_OUTPUT_TRANSLATIONS"))
......
......@@ -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 ,(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))
(find-config-pathname "common-lisp" *source-registry-file* direction))
(defun system-source-registry (&key (direction :input))
(in-system-configuration-directory *source-registry-file* :direction direction))
(find-preferred-file (config-system-pathnames "common-lisp" *source-registry-file*)
:direction direction))
(defun user-source-registry-directory (&key (direction :input))
(in-user-configuration-directory *source-registry-directory* :direction direction))
(find-config-pathname "common-lisp" *source-registry-directory* direction))
(defun system-source-registry-directory (&key (direction :input))
(in-system-configuration-directory *source-registry-directory* :direction direction))
(find-preferred-file (config-system-pathnames "common-lisp" *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,12 @@
(clear-system "test-system")))
(defun test-pathname-parsing ()
#-(or allegro clisp clozure ecl lispworks mkcl sbcl cmu)
#-(or allegro clisp clozure cmu ecl lispworks mkcl sbcl)
(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)
(let ((old-config (uiop:getenvp "XDG_CONFIG_DIRS"))
(old-home-config (uiop:getenvp "XDG_CONFIG_HOME")))
(unwind-protect
......@@ -432,13 +429,13 @@
(setf (uiop:getenv "XDG_CONFIG_DIRS") "/foo:prismatic")
(multiple-value-bind (ret err)
(ignore-errors
(uiop:user-configuration-directories))
(uiop: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: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,26 @@
(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 ()
"Determine user configuration directories.
DEPRECATED. Use uiop:config-pathnames instead."
(config-pathnames "common-lisp"))
(defun system-configuration-directories ()
"Determine system user configuration directories.
DEPRECATED. Use uiop:config-system-pathnames instead."
(config-system-pathnames "common-lisp"))
(defun in-first-directory (dirs x &key (direction :input))
"Find first file in the list of configuration DIRS with subpathname X that exists (for direction :input or :probe)
or just the first one (for direction :output or :io). 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 pathname under user configuration directory, subpathname X. DEPRECATED."
(find-config-pathname "common-lisp" x direction))
(defun in-system-configuration-directory (x &key (direction :input))
"return pathname under system configuration directory, subpathname X. DEPRECATED."
(find-preferred-file (config-system-pathnames "common-lisp" x) :direction direction)))
This diff is collapsed.
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