Raymond Toy pushed to branch issue-157-directory-returns-all-files at cmucl / cmucl

Commits:

2 changed files:

Changes:

  • src/code/pathname.lisp
    ... ... @@ -1222,25 +1222,29 @@ a host-structure or string."
    1222 1222 
     (defun %%pathname-match-p (pathname wildname)
    1223 1223 
       (macrolet ((frob (field &optional (op 'components-match ))
    1224 1224 
     	       `(,op (,field pathname) (,field wildname))))
    1225 
    +    (flet ((device-components-match (thing wild)
    1226 
    +	     (or (eq thing wild)
    1227 
    +		 (eq wild :wild)
    1228 
    +		 ;; A device component of :unspecific matches
    1229 
    +		 ;; nil.
    1230 
    +		 (or (and (null thing) (eq wild :unspecific))
    1231 
    +		     (and (eq thing :unspecific) (eq wild nil)))))
    1232 
    +	   (version-components-match (thing wild)
    1233 
    +	     (or (eq thing wild)
    1234 
    +		 (eq wild :wild)
    1235 
    +		 ;; A version component of :newest or :unspecific
    1236 
    +		 ;; is equivalent to nil.
    1237 
    +		 (and (null this) (or (eq that :newest)
    1238 
    +				      (eq that :unspecific)))
    1239 
    +		 (and (null that) (or (eq this :newest)
    1240 
    +				      (eq this :unspecific))))))
    1225 1241 
         (and (or (null (%pathname-host wildname))
    1226 1242 
     	     (eq (%pathname-host wildname) (%pathname-host pathname)))
    1227 
    -	 (flet ((device-components-match (thing wild)
    1228 
    -		  (or (eq thing wild)
    1229 
    -		      (eq wild :wild)
    1230 
    -		      ;; A device component of :unspecific matches
    1231 
    -		      ;; nil.
    1232 
    -		      (or (and (null thing) (eq wild :unspecific))
    1233 
    -			  (and (eq thing :unspecific) (eq wild nil))))))
    1234 
    -	   (frob %pathname-device device-components-match))
    1243 
    +	 (frob %pathname-device device-components-match)
    1235 1244 
     	 (frob %pathname-directory directory-components-match)
    1236 1245 
     	 (frob %pathname-name)
    1237 1246 
     	 (frob %pathname-type)
    1238 
    -	 (flet ((version-components-match (thing wild)
    1239 
    -		  (or (eq thing wild)
    1240 
    -		      (eq wild :wild)
    1241 
    -		      ;; A version component of :newest matches nil.
    1242 
    -		      (compare-version-component thing wild))))
    1243 
    -	   (frob %pathname-version version-components-match)))))
    1247 
    +	 (frob %pathname-version version-components-match)))))
    1244 1248
    1245 1249 
     ;; Like PATHNAME-MATCH-P but the pathnames should not be search-lists.
    1246 1250 
     ;; Primarily intended for TRANSLATE-LOGICAL-PATHNAME and friends,

  • tests/pathname.lisp
    ... ... @@ -43,7 +43,7 @@
    43 43 
       (assert-true (pathname-match-p "foo:zot/foo.lisp" "/usr/**/*.lisp"))
    44 44
    45 45 
       (assert-false (pathname-match-p "foo:foo" "/bin/*"))
    46 
    -
    46 
    +
    47 47 
       ;; Tests where both args are search-lists.
    48 48 
       (assert-true (pathname-match-p "foo:foo.lisp" "bar:*.*")))
    49 49
    ... ... @@ -68,7 +68,12 @@
    68 68 
     					      :name :wild :type :wild :version nil)))
    69 69 
     	    ("**;*"
    70 70 
     	     ,(merge-pathnames (make-pathname :directory '(:relative "asdf-src" :wild-inferiors)
    71 
    -					      :name :wild :type nil :version nil)))))))
    71 
    +					      :name :wild :type nil :version nil)))
    72 
    +	    ("tests;**;*.*"
    73 
    +	     "**/*.*")))
    74 
    +    (setf (logical-pathname-translations "test")
    75 
    +	  '(("**;*.*" "tests/**/*.*")
    76 
    +	    ("**;*.*.*" "tests/**/*.*.~*~")))))
    72 77 
     (setup-logical-host)
    73 78
    74 79 
     (define-test pathname-match-p.logical-pathname
    ... ... @@ -77,4 +82,77 @@
    77 82 
     			       :directory '(:absolute "system2" "module4")
    78 83 
     			       :name nil :type nil)
    79 84 
     		(parse-namestring "ASDFTEST:system2;module4;"))))
    80 
    -
    85 
    +
    86 
    +
    87 
    +
    88 
    +(define-test pathname-match-p.unspecific
    89 
    +  ;; Test that a field of :unspecific matches nil.
    90 
    +  (let ((wild-path #p"**/*.*"))
    91 
    +    (assert-true (pathname-match-p (make-pathname :device :unspecific)
    92 
    +				   wild-path))
    93 
    +    (assert-true (pathname-match-p (make-pathname :name :unspecific)
    94 
    +				   wild-path))
    95 
    +    (assert-true (pathname-match-p (make-pathname :type :unspecific)
    96 
    +				   wild-path))
    97 
    +    (assert-true (pathname-match-p (make-pathname :version :unspecific)
    98 
    +				   wild-path))
    99 
    +    ;; Slightly more complicated pathnames with :unspecific
    100 
    +    (assert-true (pathname-match-p (make-pathname :device :unspecific
    101 
    +						  :name "foo"
    102 
    +						  :type "bar")
    103 
    +				   wild-path))
    104 
    +    (assert-true (pathname-match-p (make-pathname :directory '(:relative "a")
    105 
    +						  :name :unspecific
    106 
    +						  :type "bar")
    107 
    +				   wild-path))
    108 
    +    (assert-true (pathname-match-p (make-pathname :directory '(:relative "a")
    109 
    +						  :name "foo"
    110 
    +						  :type :unspecific)
    111 
    +				   wild-path))
    112 
    +    (assert-true (pathname-match-p (make-pathname :directory '(:relative "a")
    113 
    +						  :name "foo"
    114 
    +						  :type "bar"
    115 
    +						  :version :unspecific)
    116 
    +				   wild-path))))
    117 
    +
    118 
    +(define-test directory-pathname-match-p
    119 
    +  ;; Test that directory and pathname-match-p are consistent
    120 
    +  (let* ((wild-path #P"**/*.*")
    121 
    +	 (dir (directory wild-path :truenamep nil)))
    122 
    +    (loop for p in dir
    123 
    +	  do
    124 
    +	     (assert-true (pathname-match-p p wild-path)))))
    125 
    +
    126 
    +(define-test directory-pathname-match-p.lpn
    127 
    +  ;; Like directory-pathname-match-p but for a logical pathname
    128 
    +  (let* ((wild-path #P"ASDFTEST:**;*.*.*")
    129 
    +	 (dir (directory wild-path :truenamep nil)))
    130 
    +    (loop for p in dir
    131 
    +	  do
    132 
    +	     (assert-true (pathname-match-p p wild-path)))))
    133 
    +
    134 
    +(define-test directory-consistent-pn-vs-lpn
    135 
    +  ;; Test the directory with a physical pathname and a logical
    136 
    +  ;; pathname return the same files.
    137 
    +  (let ((dir-pn (directory #P"tests/**/*.*" :truenamep nil))
    138 
    +	(dir-lpn (directory #P"test:**;*.*.*" :truenamep nil)))
    139 
    +    ;; The number of entries should be the same.
    140 
    +    (assert-equal (length dir-pn) (length dir-lpn)
    141 
    +		  dir-pn dir-lpn)
    142 
    +    (loop for pn in dir-pn
    143 
    +	  for lpn in dir-lpn
    144 
    +	  do
    145 
    +	     (assert-equal pn lpn))))
    146 
    +
    147 
    +(define-test directory-only
    148 
    +  ;; Test that we only get directories when requested
    149 
    +  (let ((dirs (directory #P"tests/**/" :truenamep nil)))
    150 
    +    (loop for p in dirs
    151 
    +	  do
    152 
    +	     (assert-false (pathname-name p) p)
    153 
    +	     (assert-false (pathname-type p) p)
    154 
    +	     (assert-true (let ((version (pathname-version p)))
    155 
    +			    (or (null version)
    156 
    +				(eq version :newest)))
    157 
    +			  p))))
    158 
    +

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help