[Git][cmucl/cmucl][issue-157-directory-returns-all-files] 3 commits: Add more tests
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Sat Mar 4 19:37:02 UTC 2023
Raymond Toy pushed to branch issue-157-directory-returns-all-files at cmucl / cmucl
Commits:
dd947ca0 by Raymond Toy at 2023-03-04T11:24:35-08:00
Add more tests
Add tests that the results of `directory` are consistent
with `pathname-match-p`.
Add a test where "**/" only returns directories.
Add some miscellaneous tests for `pathname-match-p` and logical
pathnames.
- - - - -
2bf9b39f by Raymond Toy at 2023-03-04T11:33:05-08:00
Treat :unspecific as equivalent to nil for pathname-version.
This equivalence is just for `pathname-match-p`.
- - - - -
6463e421 by Raymond Toy at 2023-03-04T11:36:07-08:00
Slighltly refactor %%pathname-match-p
Put all the flets into one at the beginning.
- - - - -
2 changed files:
- src/code/pathname.lisp
- tests/pathname.lisp
Changes:
=====================================
src/code/pathname.lisp
=====================================
@@ -1222,25 +1222,29 @@ a host-structure or string."
(defun %%pathname-match-p (pathname wildname)
(macrolet ((frob (field &optional (op 'components-match ))
`(,op (,field pathname) (,field wildname))))
+ (flet ((device-components-match (thing wild)
+ (or (eq thing wild)
+ (eq wild :wild)
+ ;; A device component of :unspecific matches
+ ;; nil.
+ (or (and (null thing) (eq wild :unspecific))
+ (and (eq thing :unspecific) (eq wild nil)))))
+ (version-components-match (thing wild)
+ (or (eq thing wild)
+ (eq wild :wild)
+ ;; A version component of :newest or :unspecific
+ ;; is equivalent to nil.
+ (and (null this) (or (eq that :newest)
+ (eq that :unspecific)))
+ (and (null that) (or (eq this :newest)
+ (eq this :unspecific))))))
(and (or (null (%pathname-host wildname))
(eq (%pathname-host wildname) (%pathname-host pathname)))
- (flet ((device-components-match (thing wild)
- (or (eq thing wild)
- (eq wild :wild)
- ;; A device component of :unspecific matches
- ;; nil.
- (or (and (null thing) (eq wild :unspecific))
- (and (eq thing :unspecific) (eq wild nil))))))
- (frob %pathname-device device-components-match))
+ (frob %pathname-device device-components-match)
(frob %pathname-directory directory-components-match)
(frob %pathname-name)
(frob %pathname-type)
- (flet ((version-components-match (thing wild)
- (or (eq thing wild)
- (eq wild :wild)
- ;; A version component of :newest matches nil.
- (compare-version-component thing wild))))
- (frob %pathname-version version-components-match)))))
+ (frob %pathname-version version-components-match)))))
;; Like PATHNAME-MATCH-P but the pathnames should not be search-lists.
;; Primarily intended for TRANSLATE-LOGICAL-PATHNAME and friends,
=====================================
tests/pathname.lisp
=====================================
@@ -43,7 +43,7 @@
(assert-true (pathname-match-p "foo:zot/foo.lisp" "/usr/**/*.lisp"))
(assert-false (pathname-match-p "foo:foo" "/bin/*"))
-
+
;; Tests where both args are search-lists.
(assert-true (pathname-match-p "foo:foo.lisp" "bar:*.*")))
@@ -68,7 +68,12 @@
:name :wild :type :wild :version nil)))
("**;*"
,(merge-pathnames (make-pathname :directory '(:relative "asdf-src" :wild-inferiors)
- :name :wild :type nil :version nil)))))))
+ :name :wild :type nil :version nil)))
+ ("tests;**;*.*"
+ "**/*.*")))
+ (setf (logical-pathname-translations "test")
+ '(("**;*.*" "tests/**/*.*")
+ ("**;*.*.*" "tests/**/*.*.~*~")))))
(setup-logical-host)
(define-test pathname-match-p.logical-pathname
@@ -77,4 +82,77 @@
:directory '(:absolute "system2" "module4")
:name nil :type nil)
(parse-namestring "ASDFTEST:system2;module4;"))))
-
+
+
+
+(define-test pathname-match-p.unspecific
+ ;; Test that a field of :unspecific matches nil.
+ (let ((wild-path #p"**/*.*"))
+ (assert-true (pathname-match-p (make-pathname :device :unspecific)
+ wild-path))
+ (assert-true (pathname-match-p (make-pathname :name :unspecific)
+ wild-path))
+ (assert-true (pathname-match-p (make-pathname :type :unspecific)
+ wild-path))
+ (assert-true (pathname-match-p (make-pathname :version :unspecific)
+ wild-path))
+ ;; Slightly more complicated pathnames with :unspecific
+ (assert-true (pathname-match-p (make-pathname :device :unspecific
+ :name "foo"
+ :type "bar")
+ wild-path))
+ (assert-true (pathname-match-p (make-pathname :directory '(:relative "a")
+ :name :unspecific
+ :type "bar")
+ wild-path))
+ (assert-true (pathname-match-p (make-pathname :directory '(:relative "a")
+ :name "foo"
+ :type :unspecific)
+ wild-path))
+ (assert-true (pathname-match-p (make-pathname :directory '(:relative "a")
+ :name "foo"
+ :type "bar"
+ :version :unspecific)
+ wild-path))))
+
+(define-test directory-pathname-match-p
+ ;; Test that directory and pathname-match-p are consistent
+ (let* ((wild-path #P"**/*.*")
+ (dir (directory wild-path :truenamep nil)))
+ (loop for p in dir
+ do
+ (assert-true (pathname-match-p p wild-path)))))
+
+(define-test directory-pathname-match-p.lpn
+ ;; Like directory-pathname-match-p but for a logical pathname
+ (let* ((wild-path #P"ASDFTEST:**;*.*.*")
+ (dir (directory wild-path :truenamep nil)))
+ (loop for p in dir
+ do
+ (assert-true (pathname-match-p p wild-path)))))
+
+(define-test directory-consistent-pn-vs-lpn
+ ;; Test the directory with a physical pathname and a logical
+ ;; pathname return the same files.
+ (let ((dir-pn (directory #P"tests/**/*.*" :truenamep nil))
+ (dir-lpn (directory #P"test:**;*.*.*" :truenamep nil)))
+ ;; The number of entries should be the same.
+ (assert-equal (length dir-pn) (length dir-lpn)
+ dir-pn dir-lpn)
+ (loop for pn in dir-pn
+ for lpn in dir-lpn
+ do
+ (assert-equal pn lpn))))
+
+(define-test directory-only
+ ;; Test that we only get directories when requested
+ (let ((dirs (directory #P"tests/**/" :truenamep nil)))
+ (loop for p in dirs
+ do
+ (assert-false (pathname-name p) p)
+ (assert-false (pathname-type p) p)
+ (assert-true (let ((version (pathname-version p)))
+ (or (null version)
+ (eq version :newest)))
+ p))))
+
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/30abe6ebd71ba3bcee4438fc8bb7fee757287e02...6463e42195f7c823357197a61272c2d98b94c213
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/30abe6ebd71ba3bcee4438fc8bb7fee757287e02...6463e42195f7c823357197a61272c2d98b94c213
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20230304/0c4dd700/attachment-0001.html>
More information about the cmucl-cvs
mailing list