An ASDF patch

The following is a patch to asdf that does the following:

* Adds, exports and documents system-relative-pathname
* ensures that a name or type in *default-pathname-defaults* doesn't  
confuse the asdf preference file loading mechanism
* When not resolving symlinks, uses *load-pathname* rather than *load- 
truename* when running operations. The latter may have already  
resolved the links and that can leave one up a creek.

Comments welcome (and desired); if none are forthcoming, this will be  
checked in later this week.

thanks,



Index: asdf.lisp
===================================================================
RCS file: /cvsroot/cclan/asdf/asdf.lisp,v
retrieving revision 1.106
diff -u -w -r1.106 asdf.lisp
--- asdf.lisp	14 Feb 2007 15:16:24 -0000	1.106
+++ asdf.lisp	7 Mar 2007 15:40:34 -0000
@@ -13,7 +13,7 @@
;;; is the latest development version, whereas the revision tagged
;;; RELEASE may be slightly older but is considered `stable'
-;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
+;;; Copyright (c) 2001-2007 Daniel Barlow and contributors
;;;
;;; Permission is hereby granted, free of charge, to any person  
obtaining
;;; a copy of this software and associated documentation files (the
@@ -79,6 +79,8 @@
	   #:system-maintainer
	   #:system-license
	   #:system-licence
+	   #:system-source-file
+	   #:system-relative-pathname
	
	   #:operation-on-warnings
	   #:operation-on-failure
@@ -122,10 +124,13 @@
						    :junk-allowed t)))))
(defvar *compile-file-warnings-behaviour* :warn)
+
(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
(defvar *verbose-out* nil)
+(defvar *resolve-symlinks* t)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility stuff
@@ -876,11 +881,14 @@
    (preference-file-for-system/operation (find-system system t)  
operation))
(defmethod preference-file-for-system/operation ((s system)  
(operation t))
+  (let ((*default-pathname-defaults*
+	 (make-pathname :name nil :type nil
+			:defaults *default-pathname-defaults*)))
    (merge-pathnames
     (make-pathname :name (component-name s)
                    :type "lisp"
                    :directory '(:relative ".asdf"))
-   (truename (user-homedir-pathname))))
+     (truename (user-homedir-pathname)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations
@@ -957,9 +965,16 @@
				   :module (coerce-name ',name)
				   :pathname
				   (or ,pathname
-				       (when *load-truename*
+					;; If not resolving symlinks, then
+					;; use *load-pathname* instead of
+					;; *load-truename* since the latter,
+					;; in some implementations, has
+					;; already resolved a symlink.
+					(if *resolve-symlinks*
					 (pathname-sans-name+type
-					  (resolve-symlinks  *load-truename*)))
+					     (resolve-symlinks *load-pathname*))
+					    (pathname-sans-name+type
+					     *load-pathname*))
				       *default-pathname-defaults*)
				   ',component-options))))))

@@ -1190,6 +1205,27 @@
(defun hyperdoc (name doc-type)
    (hyperdocumentation (symbol-package name) name doc-type))
+(defun system-source-file (system-name)
+  (let ((system (asdf:find-system system-name)))
+    (make-pathname
+     :type "asd"
+     :name (asdf:component-name system)
+     :defaults (asdf:component-relative-pathname system))))
+
+(defun system-source-directory (system-name)
+  (make-pathname :name nil
+                 :type nil
+                 :defaults (system-source-file system-name)))
+
+(defun system-relative-pathname (system pathname &key name type)
+  (let ((directory (pathname-directory pathname)))
+    (when (eq (car directory) :absolute)
+      (setf (car directory) :relative))
+    (merge-pathnames
+     (make-pathname :name (or name (pathname-name pathname))
+                    :type (or type (pathname-type pathname))
+                    :directory directory)
+     (system-source-directory system))))
(pushnew :asdf *features*)
Index: asdf.texinfo
===================================================================
RCS file: /cvsroot/cclan/asdf/asdf.texinfo,v
retrieving revision 1.6
diff -u -w -r1.6 asdf.texinfo
--- asdf.texinfo	21 Jan 2007 14:09:52 -0000	1.6
+++ asdf.texinfo	7 Mar 2007 15:40:34 -0000
@@ -69,6 +69,7 @@
* The object model of asdf::
* Error handling::
* Compilation error and warning handling::
+* Miscellaneous additional functionality::
* Getting the latest version::
* TODO list::
* missing bits in implementation::
@@ -987,7 +988,7 @@
errors).  These are signalled using generalised instances of
@code{OPERATION-ERROR}.
-@node  Compilation error and warning handling, Getting the latest  
version, Error handling, Top
+@node  Compilation error and warning handling, Miscellaneous  
additional functionality, Error handling, Top
@comment  node-name,  next,  previous,  up
@chapter Compilation error and warning handling
@vindex *compile-file-warnings-behaviour*
@@ -999,7 +1000,39 @@
such events. The valid values for these variables are @code{:error},
@code{:warn}, and @code{:ignore}.
-@node Getting the latest version, TODO list, Compilation error and  
warning handling, Top
+@node  Miscellaneous additional functionality, Getting the latest  
version, Compilation error and warning handling, Top
+@comment  node-name,  next,  previous,  up
+@chapter Additional Functionality
+
+ASDF includes several additional features that are generally
+useful for system definition and development. These include:
+
+@enumerate
+@item
+system-relative-pathname
+
+It's often handy to locate a file relative to some system. The  
system-relative-pathname function meets this need. It takes two  
arguments: the name of a system and a relative pathname. It returns a  
pathname built from the
+location of the system's source file and the relative pathname. For  
example
+
+@lisp
+> (asdf:system-relative-pathname 'cl-ppcre "regex.data")
+#P"/repository/other/cl-ppcre/regex.data"
+@end lisp
+
+@item
+hyperdocumentation
+
+to be documented
+
+@item
+hyperdoc
+
+to be documented
+
+@end enumerate
+
+
+@node Getting the latest version, TODO list, Miscellaneous  
additional functionality, Top
@comment  node-name,  next,  previous,  up
@chapter Getting the latest version


--
Gary Warren King, metabang.com
Cell: (413) 885 9127
Fax: (206) 338-4052
gwkkwg on Skype * garethsan on AIM





-------------------------------------------------------------------------
Take Surveys. Earn Cash. Influence the Future of IT
Join SourceForge.net's Techsay panel and you'll get the chance to share your
opinions on IT & business topics through brief surveys-and earn cash
http://www.techsay.com/default.php?page=join.php&p=sourceforge&CID=DEVDEV