From c417fd282faa6c70e507651420100670ae98960a Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Mon, 12 Apr 2010 14:27:44 -0400
Subject: [PATCH] 1.674: Fix long-form of source-registry parsing. Add tests
 for configuration files. Also export
 enable-asdf-binary-locations-compatibility.

---
 asdf.lisp                      |  5 ++-
 doc/asdf.texinfo               |  4 +-
 doc/index.html                 |  8 ++--
 test/script-support.lisp       | 19 ++++----
 test/test-configuration.script | 78 ++++++++++++++++++++++++++++++++
 test/test-module-depend.script |  2 +-
 test/test-source-registry.s    | 82 ----------------------------------
 test/test-utilities.script     | 15 -------
 8 files changed, 99 insertions(+), 114 deletions(-)
 create mode 100644 test/test-configuration.script
 delete mode 100644 test/test-source-registry.s

diff --git a/asdf.lisp b/asdf.lisp
index d3d96c419..3b295df32 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -60,7 +60,7 @@
 (eval-when (:load-toplevel :compile-toplevel :execute)
   (let* ((asdf-version
           ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
-          (subseq "VERSION:1.673" (1+ (length "VERSION"))))
+          (subseq "VERSION:1.674" (1+ (length "VERSION"))))
          #+allegro (excl::*autoload-package-name-alist* nil)
          (existing-asdf (find-package :asdf))
          (versym '#:*asdf-version*)
@@ -257,6 +257,7 @@
            #:ensure-output-translations
            #:apply-output-translations
            #:compile-file-pathname*
+           #:enable-asdf-binary-locations-compatibility
 
            #:*default-source-registries*
            #:initialize-source-registry
@@ -2883,7 +2884,7 @@ with a different configuration, so the configuration would be re-read then."
      '(:source-registry :inherit-configuration))
     ((not (stringp string))
      (error "environment string isn't: ~S" string))
-    ((eql (char string 0) "\"(")
+    ((find (char string 0) "\"(")
      (validate-source-registry-form (read-from-string string)))
     (t
      (loop
diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo
index aafb56274..c6e9061cd 100644
--- a/doc/asdf.texinfo
+++ b/doc/asdf.texinfo
@@ -2904,7 +2904,7 @@ Here is an old list of things to do,
 in addition to the bugs that are now tracked on launchpad:
 @url{https://launchpad.net/asdf}.
 
-* Outstanding spec questions, things to add
+@section Outstanding spec questions, things to add
 
 ** packaging systems
 
@@ -2956,7 +2956,7 @@ A ``dry run'' of an operation can be made with the following form:
 This uses unexported symbols.
 What would be a nice interface for this functionality?
 
-* Missing bits in implementation
+@section Missing bits in implementation
 
 ** all of the above
 
diff --git a/doc/index.html b/doc/index.html
index 6a14b0441..1e0098aeb 100644
--- a/doc/index.html
+++ b/doc/index.html
@@ -95,14 +95,14 @@
           <dd>Fran&ccedil;ois-Ren&eacute; Rideau is de facto maintainer,
             with notable contributions from Robert P. Goldman.
             Push towards an ASDF 2 release
-            which many clean-ups, simplified configuration
+            with many clean-ups, better configurability
             and updated documentation.
           </dd>
           <dt>May 2006 to November 2009</dt>
           <dd>Gary King is de facto maintainer,
             with notable contributions from
             Robert P. Goldman, Nikodemus Siivola, Christophe Rhodes, D Herring.
-            Many small features and fixing bugs,
+            Many small features and bug fixes,
             trying to make the project more usable,
             moving to using git and common-lisp.net.
           </dd>
@@ -110,9 +110,9 @@
           <dd>Christophe Rhodes is de facto maintainer,
             with notable contributions from
             Nikodemus Siivola, Peter Van Eynde, Edi Weitz, Kevin Rosenberg.
-            Make the system more robust, a few more features.
+            The system made more robust, a few more features.
           <dt>August 2001 to May 2004</dt>
-          <dd>Maintained by Daniel Barlow, with notable contributions from
+          <dd>Developed by Daniel Barlow, with notable contributions from
             Christophe Rhodes, Kevin Rosenberg, Edi Weitz, Rahul Jain.
           <dt>August 2001</dt>
           <dd>Created by Daniel Barlow</dd>
diff --git a/test/script-support.lisp b/test/script-support.lisp
index 8358e5aa9..edecd3be3 100644
--- a/test/script-support.lisp
+++ b/test/script-support.lisp
@@ -2,13 +2,16 @@
 
 ;; We can't use asdf:merge-pathnames* because ASDF isn't loaded yet.
 ;; We still want to work despite and host/device funkiness.
-(defvar *asdf-lisp*
-  (truename
-   (merge-pathnames
-    (make-pathname :directory '(:relative :up) :name "asdf" :type "lisp"
-                   :defaults *load-truename*)
-    *load-truename*)))
-(defvar *asdf-fasl*
+(defparameter *test-directory*
+  (make-pathname :name nil :type nil :version nil
+                 :defaults (or *load-truename* *compile-file-truename*)))
+(defparameter *asdf-directory*
+  (merge-pathnames
+   (make-pathname :directory '(:relative :back) :defaults *test-directory*)
+   *test-directory*))
+(defparameter *asdf-lisp*
+  (make-pathname :name "asdf" :type "lisp" :defaults *asdf-directory*))
+(defparameter *asdf-fasl*
   (compile-file-pathname
    (let ((impl (string-downcase
                 (or #+allegro
@@ -28,7 +31,7 @@
                     #+scl scl))))
      (merge-pathnames
       (make-pathname :directory `(:relative "tmp" "fasls" ,impl)
-                     :defaults *asdf-lisp*)
+                     :defaults *asdf-directory*)
       *asdf-lisp*))))
 
 (defun load-asdf ()
diff --git a/test/test-configuration.script b/test/test-configuration.script
new file mode 100644
index 000000000..9b6406cf3
--- /dev/null
+++ b/test/test-configuration.script
@@ -0,0 +1,78 @@
+;;; -*- Lisp -*-
+(load "script-support")
+(load-asdf)
+(in-package :asdf)
+
+(defparameter *test-directory*
+  (merge-pathnames*
+    (make-pathname :directory '(:relative "tmp"))
+    cl-user::*asdf-directory*))
+
+(defun under-test-directory (designator &optional (defaults *test-directory*))
+  (namestring (merge-pathnames* (merge-component-name-type designator) defaults)))
+
+(defun create-conf-files (&optional (path *test-directory*))
+  (let ((v `(("conf.d/conf1.conf"
+              ((:directory ,(under-test-directory "dir1/"))))
+             ("conf.d/conf2.conf"
+              ((:tree ,(under-test-directory "dir2/")))))))
+    (loop
+      :for (file contents) :in v
+      :for name = (under-test-directory file path)
+      :do
+      (ensure-directories-exist name)
+      (with-open-file (out name
+                           :direction :output
+                           :if-exists :supersede)
+        (with-standard-io-syntax
+          (format out "~{~S~}" contents))))))
+
+(defparameter *test-asd-directories*
+  (loop
+    :for dir
+    :in '("dir1/" "dir2/dir3/" "dir2/dir4/" "dir2/")
+    :collect (under-test-directory dir)))
+
+(defun create-asd-files ()
+  (loop
+    :for d :in *test-asd-directories*
+    :for i :from 0 :do
+    (ensure-directories-exist d)
+    (with-open-file (s (merge-pathnames* (format nil "foo~D.asd" i) d)
+                       :direction :output
+                       :if-exists :rename-and-delete
+                       :if-does-not-exist :create)
+      (format s "(asdf:defsystem :foo~D)~%" i))))
+
+(cl-user::quit-on-error
+
+(assert
+ (equal (parse-output-translations-string "/foo:/bar::/baz:/quux")
+        '(:output-translations
+          ("/foo" "/bar")
+          :inherit-configuration
+          ("/baz" "/quux"))))
+(assert
+ (equal (parse-output-translations-string "/:")
+        '(:output-translations ("/" nil) :ignore-inherited-configuration)))
+(assert
+ (equal (parse-output-translations-string "/::")
+        '(:output-translations ("/" nil) :inherit-configuration)))
+(assert
+ (equal (parse-output-translations-string "/:/")
+        '(:output-translations ("/" "/") :ignore-inherited-configuration)))
+
+(assert
+ (equal (parse-output-translations-string
+         "(:output-translations (\"/\" \"/\") :ignore-inherited-configuration)")
+        '(:output-translations ("/" "/") :ignore-inherited-configuration)))
+
+(create-asd-files)
+(create-conf-files)
+(initialize-source-registry
+ `(:source-registry (:include ,(under-test-directory "conf.d/"))
+                    :ignore-inherited-configuration))
+(assert
+ (equal (namestring (system-relative-pathname :foo3 "bar/baz.lisp"))
+        (under-test-directory "dir2/bar/baz.lisp")))
+)
diff --git a/test/test-module-depend.script b/test/test-module-depend.script
index 5bd7efa2b..ff6296a6b 100644
--- a/test/test-module-depend.script
+++ b/test/test-module-depend.script
@@ -19,8 +19,8 @@
    ;; dependency bug is fixed.
 
    (let ((before (file-write-date (asdf:compile-file-pathname* "file2"))))
-     (asdf::run-shell-command "touch file1.lisp")
      (sleep 1)
+     (asdf::run-shell-command "touch file1.lisp")
      (asdf:operate 'asdf:load-op 'test-module-depend)
      (assert (> (file-write-date (asdf:compile-file-pathname* "file2")) before))
      ;; does this properly go to the second level?
diff --git a/test/test-source-registry.s b/test/test-source-registry.s
deleted file mode 100644
index 51b348217..000000000
--- a/test/test-source-registry.s
+++ /dev/null
@@ -1,82 +0,0 @@
-(load "script-support")
-(load "../asdf")
-
-(defvar *test-directory*
-  (ensure-directory-pathname
-   (getenv "PWD")))
-
-(defvar *test-conf-directory*
-  (merge-pathnames "conf.d/" (getenv "PWD")))
-
-(defun under-test-directory (path &optional (defaults *test-directory*))
-  (merge-pathnames path defaults))
-
-(defun ensure-recursive-directory (path)
-  (concatenate
-   'string
-   (namestring
-    (ensure-directory-pathname path))
-   "/"))
-
-(defun create-conf-files (&optional (path *test-conf-directory*))
-  (let ((v `(("conf1.conf"
-              ((:directory ,(namestring (under-test-directory "dir1/")))))
-             ("conf2.conf"
-              ((:tree ,(namestring (under-test-directory "dir2/"))))))))
-    (loop
-     :for (file contents) :in v :do
-     (with-open-file (out (merge-pathnames file path)
-                          :direction :output
-                          :if-exists :supersede)
-       (with-standard-io-syntax
-         (format out "~{~S~}" contents))))))
-
-(defvar *test-config-1*
-  `(:source-registry
-    (:tree ,(getenv "PWD"))
-    (:ignore-inherited-configuration)))
-
-(defvar *test-expect-1*
-  (append
-   (loop
-    :for dir
-    :in '("dir1/" "dir2/dir3/" "dir2/dir4/" "dir2/")
-    :collect (merge-pathnames dir *test-directory*))
-   (list *test-directory*)))
-
-(defvar *test-source-registries*
-  '(test-environment-source-registry
-    test-environment-source-registry-recursive
-    test-something-3))
-
-(defun test-environment-source-registry ()
-  (process-source-registry (getenv "CL_SOURCE_REGISTRY")
-                           :inherit *test-source-registries*))
-
-(defun test-environment-source-registry-recursive ()
-  (process-source-registry
-   (ensure-recursive-directory
-    (getenv "CL_SOURCE_REGISTRY"))
-   :inherit *test-source-registries*))
-
-(defun test-directory-source-registry
-    (&optional (directory *test-conf-directory*))
-  (process-source-registry
-   (validate-source-registry-directory directory)))
-
-(defun test-something-3 () nil)
-
-(cl-user::quit-on-error
- (create-conf-files)
- (assert (every #'pathname (test-environment-source-registry)))
- (assert (every #'pathname (test-environment-source-registry-recursive)))
- (assert (equal (test-directory-source-registry) *test-expect-1*))
-
- ;; FIXME:
- ;; (assert (equal (process-source-registry
- ;;                 *test-config-1*)
- ;;                *test-expect-1*))
-
- ;; FIXME: add more tests
- ;; (assert (equal ...))
- )
\ No newline at end of file
diff --git a/test/test-utilities.script b/test/test-utilities.script
index e252a313d..5be682f6f 100644
--- a/test/test-utilities.script
+++ b/test/test-utilities.script
@@ -43,19 +43,4 @@
 (assert
  (not (asdf::version-satisfies (asdf:asdf-version) "666")))
 
-(assert
- (equal (asdf::parse-output-translations-string "/foo:/bar::/baz:/quux")
-        '(:output-translations
-          ("/foo" "/bar")
-          :inherit-configuration
-          ("/baz" "/quux"))))
-(assert
- (equal (asdf::parse-output-translations-string "/:")
-        '(:output-translations ("/" nil) :ignore-inherited-configuration)))
-(assert
- (equal (asdf::parse-output-translations-string "/::")
-        '(:output-translations ("/" nil) :inherit-configuration)))
-(assert
- (equal (asdf::parse-output-translations-string "/:/")
-        '(:output-translations ("/" "/") :ignore-inherited-configuration)))
 )
-- 
GitLab