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

find-system.lisp

+10 −8
Original line number Diff line number Diff line
@@ -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))

        (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)))))))

                (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))))



  (defun sysdef-central-registry-search (system)

    (let ((name (primary-system-name system))

output-translations.lisp

+10 −10
Original line number Diff line number Diff line
@@ -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)))))))))))

source-registry.lisp

+13 −22
Original line number Diff line number Diff line
@@ -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"))

test/asdf-pathname-test.script

+5 −11
Original line number Diff line number Diff line 
;;; -*- 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

uiop/backward-driver.lisp

+33 −3
Original line number Diff line number Diff line
@@ -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)))