Changeset 12644

Timestamp:

05/01/10 17:45:49 (13 years ago)

Author:

Mark Evenson

Message:

Fix for loading ASDF systems from jar files under win32.

Changed synthetic '/:jar:file:/' path into the hopefully never used
'/_jar_file_root_/' string which doesn't turn out to be a
relative pathname under Windows (thanks to Carlos Ungil).

Add Windows drive letter to output translation path to allow
identically named jars on different drives to be handled.

File:

• trunk/abcl/src/org/armedbear/lisp/asdf.lisp (modified) (2 diffs)

trunk/abcl/src/org/armedbear/lisp/asdf.lisp

@@ -2517 +2517 @@
     #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
     #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
-    #+abcl (#p"/:jar:file/**/*.*" (:user-cache #p"**/*.*"))
+    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
     ;; All-import, here is where we want user stuff to be:
     :inherit-configuration
@@ -2707 +2707 @@
 (defun translate-jar-pathname (source wildcard)
   (declare (ignore wildcard))
-  (let ((root (apply-output-translations
-               (concatenate 'string
-                            "/:jar:file/"
-                            (namestring (first (pathname-device
-                                                source))))))
-        (entry (make-pathname :directory (pathname-directory source)
-                              :name (pathname-name source)
-                              :type (pathname-type source))))
+  (let* ((p (first (pathname-device source)))
+   (r (concatenate 'string  
+       (if (and (find :windows *features*) 
+          (not (null (pathname-device p))))
+           (format nil "~A/" (pathname-device p))
+           "")
+       (namestring (make-pathname :directory (pathname-directory p)
+                :name (pathname-name p)
+                :type (pathname-type p)))))
+   (root (apply-output-translations
+    (format nil "/___jar___file___root___/~A" r)))
+   (entry (make-pathname :directory (pathname-directory source)
+             :name (pathname-name source)
+             :type (pathname-type source))))
     (concatenate 'string (namestring root) (namestring entry))))