From 4888e70a21f217488ca94641e41d37d317aae785 Mon Sep 17 00:00:00 2001
From: Gary King <gwking@franz.com>
Date: Sun, 13 Sep 2009 14:41:33 -0400
Subject: [PATCH] =?UTF-8?q?*=20Far=C3=A9's=20patch=20for=20better=20module?=
 =?UTF-8?q?-pathname=20handling?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

    * test for same

* Fix for my head-slap regex s&r madness.
---
 asdf.lisp                             | 49 +++++++++++++++++----------
 bin/bump-revision-and-tag.sh          |  2 +-
 test/sources/level1/file1.lisp        |  4 +++
 test/sources/level1/level2/file2.lisp |  3 ++
 test/test-module-pathnames.asd        | 11 ++++++
 test/test-module-pathnames.script     | 31 +++++++++++++++++
 test/test-tmp.cl                      |  3 ++
 7 files changed, 85 insertions(+), 18 deletions(-)
 create mode 100644 test/sources/level1/file1.lisp
 create mode 100644 test/sources/level1/level2/file2.lisp
 create mode 100644 test/test-module-pathnames.asd
 create mode 100644 test/test-module-pathnames.script
 create mode 100644 test/test-tmp.cl

diff --git a/asdf.lisp b/asdf.lisp
index b8713279..cf6399d5 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -147,7 +147,7 @@
 
 (defvar *asdf-revision* 
   ;; the 1+ hair is to ensure that we don't do an inadvertant find and replace
-  (subseq "REVISION:1.365" (1+ (length "REVISION"))))
+  (subseq "REVISION:1.366" (1+ (length "REVISION"))))
   
 
 (defvar *resolve-symlinks* t
@@ -315,6 +315,21 @@ and NIL NAME and TYPE components"
   (declare (dynamic-extent format-args))
   (apply #'format *verbose-out* format-string format-args))
 
+(defun split-path-string (s &optional force-directory)
+  (check-type s string)
+  (let* ((components (split s nil "/"))
+         (last-comp (car (last components))))
+    (multiple-value-bind (relative components)
+        (if (equal (first components) "")
+          (values :absolute (cdr components))
+          (values :relative components))
+      (cond
+        ((equal last-comp "")
+         (values relative (butlast components) nil))
+        (force-directory
+         (values relative components nil))
+        (t
+         (values relative (butlast components) last-comp))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; classes, condiitons
@@ -440,9 +455,11 @@ and NIL NAME and TYPE components"
 
 (defmethod component-relative-pathname ((component module))
   (or (slot-value component 'relative-pathname)
-      (make-pathname
-       :directory `(:relative ,(component-name component))
-       :host (pathname-host (component-parent-pathname component)))))
+      (multiple-value-bind (relative path)
+	  (split-path-string (component-name component) t)
+        (make-pathname
+         :directory `(,relative ,@path)
+         :host (pathname-host (component-parent-pathname component))))))
 
 (defmethod component-pathname ((component component))
   (let ((*default-pathname-defaults* (component-parent-pathname component)))
@@ -725,20 +742,18 @@ to `~a` which is not a directory.~@:>"
 (defmethod source-file-type ((c static-file) (s module)) nil)
 
 (defmethod component-relative-pathname ((component source-file))
-  (let ((relative-pathname (slot-value component 'relative-pathname)))
-    (if relative-pathname
-        (merge-pathnames
+  (multiple-value-bind (relative path name)
+      (split-path-string (component-name component))
+    (let ((type (source-file-type component (component-system component)))
+          (relative-pathname (slot-value component 'relative-pathname))
+          (*default-pathname-defaults* (component-parent-pathname component)))
+      (if relative-pathname
+	(merge-pathnames
          relative-pathname
-         (make-pathname
-          :type (source-file-type component (component-system component))))
-        (let* ((*default-pathname-defaults*
-                (component-parent-pathname component))
-               (name-type
-                (make-pathname
-                 :name (component-name component)
-                 :type (source-file-type component
-                                         (component-system component)))))
-          name-type))))
+         (if type
+           (make-pathname :name name :type type)
+           name))
+        (make-pathname :directory `(,relative ,@path) :name name :type type)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; operations
diff --git a/bin/bump-revision-and-tag.sh b/bin/bump-revision-and-tag.sh
index c619dfef..91be9b42 100755
--- a/bin/bump-revision-and-tag.sh
+++ b/bin/bump-revision-and-tag.sh
@@ -31,7 +31,7 @@ bumped=`expr $minor + 1`
 new_version="$major.$bumped"
 
 cp asdf.lisp asdf.bak
-perl -pi -e "s/REVISION:.*\"/REVISION:$new_version\"/" asdf.lisp
+perl -pi -e "s/REVISION:[^\"]*\"/REVISION:$new_version\"/" asdf.lisp
 
 echo "Update reversion and commit"
 git add asdf.lisp
diff --git a/test/sources/level1/file1.lisp b/test/sources/level1/file1.lisp
new file mode 100644
index 00000000..336ddb98
--- /dev/null
+++ b/test/sources/level1/file1.lisp
@@ -0,0 +1,4 @@
+(defpackage :test-package (:use :cl))
+(in-package :test-package)
+(defvar *file-tmp* t)
+
diff --git a/test/sources/level1/level2/file2.lisp b/test/sources/level1/level2/file2.lisp
new file mode 100644
index 00000000..09196900
--- /dev/null
+++ b/test/sources/level1/level2/file2.lisp
@@ -0,0 +1,3 @@
+(in-package :test-package)
+(defvar *file-tmp2* t)
+
diff --git a/test/test-module-pathnames.asd b/test/test-module-pathnames.asd
new file mode 100644
index 00000000..b7d3184f
--- /dev/null
+++ b/test/test-module-pathnames.asd
@@ -0,0 +1,11 @@
+;;; -*- Lisp -*-
+
+(asdf:defsystem test-module-pathnames
+  :components
+  ((:module "sources/level1"
+    :serial t
+	    :components
+	    ((:file "file1")
+	     (:file "level2/file2")
+	     (:static-file "test-tmp.cl")))))
+
diff --git a/test/test-module-pathnames.script b/test/test-module-pathnames.script
new file mode 100644
index 00000000..68549e36
--- /dev/null
+++ b/test/test-module-pathnames.script
@@ -0,0 +1,31 @@
+;;; -*- Lisp -*-
+(load "script-support")
+(load "../asdf")
+(quit-on-error 
+ (setf asdf:*central-registry* '(*default-pathname-defaults*))
+ (asdf:operate 'asdf:load-op 'test-module-pathnames))
+
+(quit-on-error 
+ (assert (find-package :test-package) nil
+	 "package test-package not found")
+ (assert (find-symbol (symbol-name '*file-tmp*) :test-package) nil
+	 "symbol `*file-tmp*` not found")
+ (assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package))
+	 nil "symbol `*file-tmp*` has wrong value")
+ (assert (probe-file (merge-pathnames 
+		      (make-pathname 
+		       :name "file1"
+		       :type (pathname-type (compile-file-pathname "x"))
+		       :directory '(:relative "sources" "level1"))))
+	 nil "compiled file not found")
+
+ (assert (find-symbol (symbol-name '*file-tmp2*) :test-package) nil
+	 "symbol `*file-tmp2*` not found")
+ (assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package))
+	 nil "symbol `*file-tmp2*` has wrong value")
+ (assert (probe-file (merge-pathnames 
+		      (make-pathname 
+		       :name "file2"
+		       :type (pathname-type (compile-file-pathname "x"))
+		       :directory '(:relative "sources" "level1" "level2"))))
+	 nil "compiled file not found"))
diff --git a/test/test-tmp.cl b/test/test-tmp.cl
new file mode 100644
index 00000000..0a21fc2e
--- /dev/null
+++ b/test/test-tmp.cl
@@ -0,0 +1,3 @@
+;; part of the test-module-pathnames test
+
+(in-package #:test-package)
-- 
GitLab