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/30abe6ebd71ba3bcee4438f... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/30abe6ebd71ba3bcee4438f... You're receiving this email because of your account on gitlab.common-lisp.net.