Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

2 changed files:

Changes:

  • src/code/pathname.lisp
    ... ... @@ -1219,6 +1219,32 @@ a host-structure or string."
    1219 1219 
     	(:version (frob (%pathname-version pathname)))))))
    1220 1220
    1221 1221
    1222 
     (defun %%pathname-match-p (pathname wildname)
    1223 
       (macrolet ((frob (field &optional (op 'components-match ))
    1224 
     		   `(or (null (,field wildname))
    1225 
     			(,op (,field pathname) (,field wildname)))))
    1226 
     	(and (or (null (%pathname-host wildname))
    1227 
     		 (eq (%pathname-host wildname) (%pathname-host pathname)))
    1228 
     	     (frob %pathname-device)
    1229 
     	     (frob %pathname-directory directory-components-match)
    1230 
     	     (frob %pathname-name)
    1231 
     	     (frob %pathname-type)
    1232 
     	     (frob %pathname-version))))
    1233
    1234 
     ;; Like PATHNAME-MATCH-P but the pathnames should not be search-lists.
    1235 
     ;; Primarily intended for TRANSLATE-LOGICAL-PATHNAME and friends,
    1236 
     ;; because PATHNAME-MATCH-P calls TRANSLATE-LOGICAL-PATHNAME, causing
    1237 
     ;; infinite recursion.
    1238 
     (defun %pathname-match-p (in-pathname in-wildname)
    1239 
       "Pathname matches the wildname template?"
    1240 
       (declare (type path-designator in-pathname)
    1241 
     	   ;; Not path-designator because a file-stream can't have a
    1242 
     	   ;; wild pathname.
    1243 
     	   (type (or string pathname) in-wildname))
    1244 
       (with-pathname (pathname in-pathname)
    1245 
         (with-pathname (wildname in-wildname)
    1246 
           (%%pathname-match-p pathname wildname))))
    1247
    1222 1248 
     ;;; PATHNAME-MATCH-P -- Interface
    1223 1249 
     ;;;
    1224 1250 
     (defun pathname-match-p (in-pathname in-wildname)
    ... ... @@ -1231,17 +1257,8 @@ a host-structure or string."
    1231 1257 
         (enumerate-search-list (pathname in-path)
    1232 1258 
           (with-pathname (in-wild in-wildname)
    1233 1259 
     	(enumerate-search-list (wildname in-wild)
    1234 
     	  (macrolet ((frob (field &optional (op 'components-match ))
    1235 
     		       `(or (null (,field wildname))
    1236 
     			    (,op (,field pathname) (,field wildname)))))
    1237 
     	    (when (and (or (null (%pathname-host wildname))
    1238 
     			   (eq (%pathname-host wildname) (%pathname-host pathname)))
    1239 
     		       (frob %pathname-device)
    1240 
     		       (frob %pathname-directory directory-components-match)
    1241 
     		       (frob %pathname-name)
    1242 
     		       (frob %pathname-type)
    1243 
     		       (frob %pathname-version))
    1244 
     	      (return-from pathname-match-p pathname))))))))
    1260 
     	  (when (%%pathname-match-p pathname wildname)
    1261 
     	    (return-from pathname-match-p pathname)))))))
    1245 1262
    1246 1263
    1247 1264 
     ;;; SUBSTITUTE-INTO -- Internal
    ... ... @@ -1476,7 +1493,7 @@ a host-structure or string."
    1476 1493 
       (with-pathname (source source)
    1477 1494 
         (with-pathname (from from-wildname)
    1478 1495 
           (with-pathname (to to-wildname)
    1479 
     	  (unless (pathname-match-p source from)
    1496 
     	  (unless (%pathname-match-p source from)
    1480 1497 
     	    (didnt-match-error source from))
    1481 1498 
     	  (let* ((source-host (%pathname-host source))
    1482 1499 
     		 (to-host (%pathname-host to))
    ... ... @@ -2171,7 +2188,7 @@ a host-structure or string."
    2171 2188 
     		       :format-control (intl:gettext "No translation for ~S")
    2172 2189 
     		       :format-arguments (list pathname)))
    2173 2190 
            (destructuring-bind (from to) x
    2174 
     	 (when (pathname-match-p pathname from)
    2191 
     	 (when (%pathname-match-p pathname from)
    2175 2192 
     	   (return (translate-logical-pathname
    2176 2193 
     		    (translate-pathname pathname from to)))))))
    2177 2194 
         (pathname pathname)

  • tests/pathname.lisp
    ... ... @@ -41,3 +41,35 @@
    41 41
    42 42 
       ;; Tests where both args are search-lists.
    43 43 
       (assert-true "foo:foo.lisp" "bar:*"))
    44
    45 
     ;; Verify PATHNAME-MATCH-P works with logical pathnames.  (Issue 27)
    46 
     ;; This test modeled after a test from asdf
    47 
     (defun setup-logical-host ()
    48 
       (let ((root *default-pathname-defaults*)
    49 
     	(bin-type (pathname-type (compile-file-pathname "foo.lisp"))))
    50 
         (setf (logical-pathname-translations "ASDFTEST")
    51 
     	  `((,(format nil "**;*.~a" bin-type)
    52 
     	      ,(merge-pathnames (make-pathname :directory '(:relative :wild-inferiors)
    53 
     					       :name :wild :type bin-type :version nil)))
    54 
     	    (,(format nil "**;*.~a.*" bin-type)
    55 
     	      ,(merge-pathnames (make-pathname :directory '(:relative "asdf-bin" :wild-inferiors)
    56 
     					       :name :wild :type bin-type
    57 
     					       :defaults root)))
    58 
     	    ("**;*.*.*"
    59 
     	     ,(merge-pathnames (make-pathname :directory '(:relative "asdf-src" :wild-inferiors)
    60 
     					      :name :wild :type :wild :version :wild)))
    61 
     	    ("**;*.*"
    62 
     	     ,(merge-pathnames (make-pathname :directory '(:relative "asdf-src" :wild-inferiors)
    63 
     					      :name :wild :type :wild :version nil)))
    64 
     	    ("**;*"
    65 
     	     ,(merge-pathnames (make-pathname :directory '(:relative "asdf-src" :wild-inferiors)
    66 
     					      :name :wild :type nil :version nil)))))))
    67 
     (setup-logical-host)
    68
    69 
     (define-test pathname-match-p.logical-pathname
    70 
       (assert-true (pathname-match-p
    71 
     		(make-pathname :host "ASDFTEST"
    72 
     			       :directory '(:absolute "system2" "module4")
    73 
     			       :name nil :type nil)
    74 
     		(parse-namestring "ASDFTEST:system2;module4;"))))
    75

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. If you'd like to receive fewer emails, you can adjust your notification settings.