armedbear / abcl

Armed Bear Common Lisp <git+https://github.com/armedbear/abcl/> <--> <svn+https://abcl.org/svn> Bridge
https://abcl.org#rdfs:seeAlso<https://gitlab.common-lisp.net/abcl/abcl>
Other
291 stars 30 forks source link

Directory "../<anything>" loses #428

Open alanruttenberg opened 2 years ago

alanruttenberg commented 2 years ago
(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 commented 2 years ago

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
easye commented 1 year ago

@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.