[asdf-install-devel] Relative symlinks to sysfiles

[Chaitanya Gupta]

Hi,

One minor problem I have with asdf-install is that symlinks (usually in
the systems/ directory) to .asd files are absolute, and not relative.
This becomes a pain if you want to shift your Lisp libraries to a
different directory from the one they were installed in - all the
symlinks have to be created again.

So I have attached a small patch which allows one to create relative
symlinks to .asd files (usually in the systems/ directory) -- if
*relative-symlinks* is non-NIL, the symlinks created are relative. The
code is not all that great, but this is the "best, hopefully portable"
solution that I could come up with (will be great if anyone can suggest
improvements). It works on ACL8 and SBCL 1.0.5 on OS X (I cannot test it
on other environments right now, but it should work fine on Linux for
these two implementations, I think).

The patch is in unified diff format (created using darcs diff -u). If
its good enough, I'll create a patch file and send it. Otherwise
suggestions are always welcome.

Thanks,

Chaitanya
-------------- next part --------------
Tue Dec 25 02:04:26 IST 2007  mail at chaitanyagupta.com
  * Minor bugfix to relative symlinks to make it work with SBCL.
Tue Dec 25 01:50:33 IST 2007  mail at chaitanyagupta.com
  * Added *relative-symlinks* which allows one to create relative symlinks.
diff -rN -u old-asdf-install/asdf-install/port.lisp new-asdf-install/asdf-install/port.lisp
--- old-asdf-install/asdf-install/port.lisp	2007-12-25 02:16:47.000000000 +0530
+++ new-asdf-install/asdf-install/port.lisp	2007-12-25 02:16:47.000000000 +0530
@@ -261,6 +261,10 @@
     (format t "~S~%" command)
     (shell-command command)))
 
+(defvar *relative-symlinks* nil
+  "If non-NIL, symlinks to the sysfile from System are relative
+  to System. Otherwise the symlink contains an absolute path.")
+
 (defun maybe-symlink-sysfile (system sysfile)
   (declare (ignorable system sysfile))
   #-(or :win32 :mswindows)
@@ -270,7 +274,50 @@
                  system)))
     (when (probe-file target)
       (unlink-file target))
-    (symlink-files sysfile target)))
+    (symlink-files (if *relative-symlinks*
+                       (compute-relative-path sysfile target)
+                       sysfile)
+                   target)))
+
+(defun compute-base-path (path1 path2)
+  "Computes the common parent directories between PATH1 and PATH2
+and returns it as a pathname. The common path is calculated only
+if PATH1 and PATH2 are absolute paths and their HOST and DEVICE
+components are equal. If this is not safisfied, then a NULL value
+is returned. The HOST and DEVICE components of the returned
+pathname are the same as that of PATH1 (and PATH2)."
+  (when (and (equal (first (pathname-directory path1)) :absolute)
+             (equal (first (pathname-directory path2)) :absolute)
+             (equal (pathname-host path1) (pathname-host path2))
+             (equal (pathname-device path1) (pathname-device path2)))
+    (make-pathname :host (pathname-host path1)
+                   :device (pathname-device path1)
+                   :directory (loop
+                                 for dir1-element in (pathname-directory path1)
+                                 for dir2-element in (pathname-directory path2)
+                                 while (equal dir1-element dir2-element)
+                                 collect dir1-element))))
+
+(defun compute-relative-path (path1 path2)
+  "Tries to compute a relative path to PATH1 from PATH2 if these
+are absolute paths and have the same HOST and DEVICE
+components. If a relative path cannot be calculated, then PATH1
+is returned."
+  (let* ((base-path (or (compute-base-path path1 path2)
+                        (return-from compute-relative-path path1)))
+         (enough-path1 (pathname (enough-namestring path1 base-path)))
+         (enough-path2 (pathname (enough-namestring path2 base-path)))
+         (enough-path2-dir (pathname-directory enough-path2))
+         (path2-back-dir (make-pathname
+                          :directory (cond
+                                       ((null enough-path2-dir)
+                                        nil)
+                                       ((equal (first enough-path2-dir) :relative)
+                                        (cons :relative
+                                              (mapcar (constantly :up) (rest enough-path2-dir))))
+                                       (t
+                                        (return-from compute-relative-path path1))))))
+    (merge-pathnames enough-path1 path2-back-dir)))
 
 ;;; ---------------------------------------------------------------------------
 ;;; read-header-line