Commit 4888e70a authored by Gary King's avatar Gary King

* Faré's patch for better module-pathname handling

    * test for same

* Fix for my head-slap regex s&r madness.
parent d3a55cf2
...@@ -147,7 +147,7 @@ ...@@ -147,7 +147,7 @@
(defvar *asdf-revision* (defvar *asdf-revision*
;; the 1+ hair is to ensure that we don't do an inadvertant find and replace ;; 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 (defvar *resolve-symlinks* t
...@@ -315,6 +315,21 @@ and NIL NAME and TYPE components" ...@@ -315,6 +315,21 @@ and NIL NAME and TYPE components"
(declare (dynamic-extent format-args)) (declare (dynamic-extent format-args))
(apply #'format *verbose-out* format-string 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 ;; classes, condiitons
...@@ -440,9 +455,11 @@ and NIL NAME and TYPE components" ...@@ -440,9 +455,11 @@ and NIL NAME and TYPE components"
(defmethod component-relative-pathname ((component module)) (defmethod component-relative-pathname ((component module))
(or (slot-value component 'relative-pathname) (or (slot-value component 'relative-pathname)
(make-pathname (multiple-value-bind (relative path)
:directory `(:relative ,(component-name component)) (split-path-string (component-name component) t)
:host (pathname-host (component-parent-pathname component))))) (make-pathname
:directory `(,relative ,@path)
:host (pathname-host (component-parent-pathname component))))))
(defmethod component-pathname ((component component)) (defmethod component-pathname ((component component))
(let ((*default-pathname-defaults* (component-parent-pathname component))) (let ((*default-pathname-defaults* (component-parent-pathname component)))
...@@ -725,20 +742,18 @@ to `~a` which is not a directory.~@:>" ...@@ -725,20 +742,18 @@ to `~a` which is not a directory.~@:>"
(defmethod source-file-type ((c static-file) (s module)) nil) (defmethod source-file-type ((c static-file) (s module)) nil)
(defmethod component-relative-pathname ((component source-file)) (defmethod component-relative-pathname ((component source-file))
(let ((relative-pathname (slot-value component 'relative-pathname))) (multiple-value-bind (relative path name)
(if relative-pathname (split-path-string (component-name component))
(merge-pathnames (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 relative-pathname
(make-pathname (if type
:type (source-file-type component (component-system component)))) (make-pathname :name name :type type)
(let* ((*default-pathname-defaults* name))
(component-parent-pathname component)) (make-pathname :directory `(,relative ,@path) :name name :type type)))))
(name-type
(make-pathname
:name (component-name component)
:type (source-file-type component
(component-system component)))))
name-type))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; operations ;;; operations
......
...@@ -31,7 +31,7 @@ bumped=`expr $minor + 1` ...@@ -31,7 +31,7 @@ bumped=`expr $minor + 1`
new_version="$major.$bumped" new_version="$major.$bumped"
cp asdf.lisp asdf.bak 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" echo "Update reversion and commit"
git add asdf.lisp git add asdf.lisp
......
(defpackage :test-package (:use :cl))
(in-package :test-package)
(defvar *file-tmp* t)
(in-package :test-package)
(defvar *file-tmp2* t)
;;; -*- Lisp -*-
(asdf:defsystem test-module-pathnames
:components
((:module "sources/level1"
:serial t
:components
((:file "file1")
(:file "level2/file2")
(:static-file "test-tmp.cl")))))
;;; -*- 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"))
;; part of the test-module-pathnames test
(in-package #:test-package)
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