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