Skip to content
Snippets Groups Projects
Commit 93998ef5 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Introduce *wild-file-for-directory*

When using DIRECTORY, the proper pattern to use to get all files
is #p"*" and not #p"*.*" on CLISP and GCL.
This is the opposite of other CL implementations, that
match everything with #p"*.*" and only files without extension with #p"*",
which seems more in line with the CLHS, though counter-intuitive wrt to POSIX.

Now the proper pattern to match all files with TRANSLATE-PATHNAME and
with logical pathnames is still #p"*.*" or #p"*.*.*".

Therefore, we introduce a new parameter *wild-file-for-directory*,
as distinguished from *wild-file*, for notable use with DIRECTORY-FILES.
parent d88e4273
No related branches found
No related tags found
No related merge requests found
...@@ -17,7 +17,7 @@ use a wild pathname instead." module))) ...@@ -17,7 +17,7 @@ use a wild pathname instead." module)))
(sysdef-error "Wild-module ~A specified with non-wild pathname ~A." (sysdef-error "Wild-module ~A specified with non-wild pathname ~A."
self pathname)) self pathname))
(setf (slot-value self 'components) (setf (slot-value self 'components)
(let* ((files (directory pathname)) (let* ((files (directory* pathname))
(class (wild-module-component-class self)) (class (wild-module-component-class self))
(options (wild-module-component-options self))) (options (wild-module-component-options self)))
(mapcar (lambda (file) (mapcar (lambda (file)
......
...@@ -48,12 +48,15 @@ ...@@ -48,12 +48,15 @@
,(subpathname root (make-pathname :directory '(:relative "asdf-bin" :wild-inferiors) ,(subpathname root (make-pathname :directory '(:relative "asdf-bin" :wild-inferiors)
:name :wild :type bin-type :name :wild :type bin-type
:defaults root))) :defaults root)))
("**;*.*.*"
,(subpathname root (make-pathname :directory '(:relative "asdf-src" :wild-inferiors)
:name :wild :type :wild :version :wild)))
("**;*.*" ("**;*.*"
,(subpathname root (make-pathname :directory '(:relative "asdf-src" :wild-inferiors) ,(subpathname root (make-pathname :directory '(:relative "asdf-src" :wild-inferiors)
:name :wild :type :wild :version nil))) :name :wild :type :wild :version nil)))
("**;*.*.*" ("**;*"
,(subpathname root (make-pathname :directory '(:relative "asdf-src" :wild-inferiors) ,(subpathname root (make-pathname :directory '(:relative "asdf-src" :wild-inferiors)
:name :wild :type :wild)))))) :name :wild :type nil :version nil))))))
(defclass test-status () (defclass test-status ()
((system-count :initform 0) ((system-count :initform 0)
...@@ -454,7 +457,7 @@ ...@@ -454,7 +457,7 @@
(assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory t) #p"/foo/bar/baz/") (assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory t) #p"/foo/bar/baz/")
(assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory t :wilden t) (wilden #p"/foo/bar/baz/")) (assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory t :wilden t) (wilden #p"/foo/bar/baz/"))
(assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory nil :wilden t) (wilden #p"/foo/bar/")) (assert-pathname-equal (resolve-location '("/foo" "bar" "baz") :ensure-directory nil :wilden t) (wilden #p"/foo/bar/"))
(assert-pathname-equal (resolve-location '("/foo" "bar" :**/ "baz" #p"*.*") :ensure-directory nil :wilden t) #p"/foo/bar/**/baz/*.*")) (assert-pathname-equal (resolve-location '("/foo" "bar" :**/ "baz" :*.*.*) :ensure-directory nil :wilden t) (merge-pathnames* *wild-file* #p"/foo/bar/**/baz/")))
(assert (directory-pathname-p (system-source-directory (find-system :test-asdf/test-source-directory-1)))) (assert (directory-pathname-p (system-source-directory (find-system :test-asdf/test-source-directory-1))))
(assert (directory-pathname-p (system-source-directory (find-system :test-asdf/test-source-directory-2)))) (assert (directory-pathname-p (system-source-directory (find-system :test-asdf/test-source-directory-2))))
......
...@@ -196,7 +196,7 @@ when using logical-pathnames." ...@@ -196,7 +196,7 @@ when using logical-pathnames."
:test 'pathname-equal) :test 'pathname-equal)
entries)) entries))
(defun directory-files (directory &optional (pattern *wild-file*)) (defun directory-files (directory &optional (pattern *wild-file-for-directory*))
"Return a list of the files in a directory according to the PATTERN. "Return a list of the files in a directory according to the PATTERN.
Subdirectories should NOT be returned. Subdirectories should NOT be returned.
PATTERN defaults to a pattern carefully chosen based on the implementation; PATTERN defaults to a pattern carefully chosen based on the implementation;
...@@ -214,20 +214,7 @@ but the behavior in presence of symlinks is not portable. Use IOlib to handle su ...@@ -214,20 +214,7 @@ but the behavior in presence of symlinks is not portable. Use IOlib to handle su
(error "Invalid file pattern ~S for logical directory ~S" pattern directory)) (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
(setf pattern (make-pathname-logical pattern (pathname-host dir)))) (setf pattern (make-pathname-logical pattern (pathname-host dir))))
(let* ((pat (merge-pathnames* pattern dir)) (let* ((pat (merge-pathnames* pattern dir))
;; the following complex block is (entries (ignore-errors (directory* pat))))
;; needed because clisp handles "*" pathnames differently from
;; "*.*" -- the former is more more general than the latter.
;; GCL does something odd, too, but I don't know what this is.
;; Looks like it treats "*" and "*.*" as disjoint.
;; [2016/06/23:rpg]
(entries (append #-clisp (ignore-errors (directory* pat))
#+clisp
(if (equal :wild (pathname-type pattern))
(ignore-errors (directory* (make-pathname :type nil :defaults pat)))
(ignore-errors (directory* pat)))
#+gcl
(when (equal :wild (pathname-type pattern))
(ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
(remove-if 'directory-pathname-p (remove-if 'directory-pathname-p
(filter-logical-directory-results (filter-logical-directory-results
directory entries directory entries
......
...@@ -31,7 +31,8 @@ ...@@ -31,7 +31,8 @@
;; Checking constraints ;; Checking constraints
#:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints
;; Wildcard pathnames ;; Wildcard pathnames
#:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden #:*wild* #:*wild-file* #:*wild-file-for-directory* #:*wild-directory*
#:*wild-inferiors* #:*wild-path* #:wilden
;; Translate a pathname ;; Translate a pathname
#:relativize-directory-component #:relativize-pathname-directory #:relativize-directory-component #:relativize-pathname-directory
#:directory-separator-for-host #:directorize-pathname-host-device #:directory-separator-for-host #:directorize-pathname-host-device
...@@ -608,7 +609,11 @@ given DEFAULTS-PATHNAME as a base pathname." ...@@ -608,7 +609,11 @@ given DEFAULTS-PATHNAME as a base pathname."
(defparameter *wild-file* (defparameter *wild-file*
(make-pathname :directory nil :name *wild* :type *wild* (make-pathname :directory nil :name *wild* :type *wild*
:version (or #-(or allegro abcl xcl) *wild*)) :version (or #-(or allegro abcl xcl) *wild*))
"A pathname object with wildcards for matching any file in a given directory") "A pathname object with wildcards for matching any file with TRANSLATE-PATHNAME")
(defparameter *wild-file-for-directory*
(make-pathname :directory nil :name *wild* :type (or #-(or clisp gcl) *wild*)
:version (or #-(or allegro abcl clisp gcl xcl) *wild*))
"A pathname object with wildcards for matching any file with DIRECTORY")
(defparameter *wild-directory* (defparameter *wild-directory*
(make-pathname :directory `(:relative ,*wild-directory-component*) (make-pathname :directory `(:relative ,*wild-directory-component*)
:name nil :type nil :version nil) :name nil :type nil :version nil)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment