abcl icon indicating copy to clipboard operation
abcl copied to clipboard

Directory "../<anything>" loses

Open alanruttenberg opened this issue 3 years ago • 2 comments

(directory "../lib/*.jar")
->NIL
(uiop::getcwd)
-> #P"/Users/alanr/repos/lsw2/bin/"

(directory "/Users/alanr/repos/lsw2/bin/../lib/*.jar")
-> (<bunch of stuff> #P"/Users/alanr/repos/lsw2/lib/abcl-aio.jar")

perhaps because...

(namestring "/Users/alanr/repos/lsw2/bin/../lib/*.jar")
-> "/Users/alanr/repos/lsw2/bin/lib/*.jar"

perhaps because...

(describe (pathname "/Users/alanr/repos/lsw2/bin/../lib/*.jar"))
->
#P"/Users/alanr/repos/lsw2/bin/lib/*.jar" is an object of type PATHNAME:
  HOST         NIL
  DEVICE       NIL
  DIRECTORY    (:ABSOLUTE "Users" "alanr" "repos" "lsw2" "bin" "lib")
  NAME         :WILD
  TYPE         "jar"
  VERSION      NIL

alanruttenberg avatar Jan 06 '22 00:01 alanruttenberg

It's because of pathname-match-p again. Directory calls it

(PATHNAME-MATCH-P #P"/Users/alanr/repos/lsw2/lib/abcl-aio.jar" #P"/Users/alanr/repos/lsw2/bin/../lib/*.jar")
->
NIL

A fix, perhaps not to your liking, though:

diff --git a/src/org/armedbear/lisp/directory.lisp b/src/org/armedbear/lisp/directory.lisp
index 80630437..a4cc3895 100644
--- a/src/org/armedbear/lisp/directory.lisp
+++ b/src/org/armedbear/lisp/directory.lisp
@@ -123,6 +123,8 @@ have truenames which do not exist, this routine will signal a file
 error to its caller."
 
   (let ((pathname (merge-pathnames pathspec)))
+    (when (equalp (pathname-host pathname) '(:scheme "file"))
+      (setq pathname (subseq (namestring pathname) #.(length "file://"))))
     (when (logical-pathname-p pathname)
       (setq pathname (translate-logical-pathname pathname)))
     (if (or (position #\* (namestring pathname))
@@ -143,26 +145,38 @@ error to its caller."
                              (concatenate 'string device ":" namestring))))))
                 (let ((entries (list-directories-with-wildcards 
                                 namestring nil resolve-symlinks))
-                      matching-entries)
-                  (dolist (entry entries)
-                    (when
-                        (or
-                         (and 
-                          (file-directory-p entry :wild-error-p nil)
-                          (pathname-match-p
-                           (directory-as-file entry) pathname))
-                         (pathname-match-p entry pathname))
-                      (push 
-                       (if resolve-symlinks
-                           (truename entry) 
-                           ;; Normalize nil DEVICE to :UNSPECIFIC under non-Windows
-                           ;; fixes ANSI DIRECTORY.[67]
-                           (if (and (not (find :windows *features*))
-                                    (not (pathname-device entry)))
-                               (make-pathname :defaults entry :device :unspecific)
-                               entry))
-                       matching-entries)))
-                  matching-entries))))
+                      (matching-entries nil))
+		  (flet ((no-dots (path)
+			   (merge-pathnames
+			    (make-pathname :directory 
+					   (let ((reversed nil))
+					     (dolist (el (pathname-directory path))
+					       (if (eq el :up) 
+						   (pop reversed)
+						   (unless (equal el ".")
+						     (push el reversed))))
+					     (reverse reversed)))
+			    path)))
+		    (let ((pathname (no-dots pathname)))
+		      (dolist (entry entries)
+			(when
+			    (or
+			     (and 
+			      (file-directory-p entry :wild-error-p nil)
+			      (pathname-match-p
+			       (directory-as-file entry) pathname))
+			     (pathname-match-p entry pathname))
+			  (push 
+			   (if resolve-symlinks
+			       (truename entry) 
+			       ;; Normalize nil DEVICE to :UNSPECIFIC under non-Windows
+			       ;; fixes ANSI DIRECTORY.[67]
+			       (if (and (not (find :windows *features*))
+					(not (pathname-device entry)))
+				   (make-pathname :defaults entry :device :unspecific)
+				   entry))
+			   matching-entries)))))
+		matching-entries))))
         ;; Not wild.
         (let ((truename (probe-file pathname)))
           (if truename

alanruttenberg avatar Jan 06 '22 04:01 alanruttenberg

@alanruttenberg It would be cool to have these in pull requests, but keep 'em coming!

When one changes the pathname code, one really needs to check the ABCL-TEST and ANSI-TEST suites as things break in unexpected ways. In general, though, I will take more correct behavior over no fixes anyday.

easye avatar Jun 20 '23 14:06 easye