Skip to content
Snippets Groups Projects
Commit c07cad4b authored by Raymond Toy's avatar Raymond Toy
Browse files

Fix #27: PATHNAME-MATCH-P loops for logical pathnames

When support for search-lists was added to PATHNAME-MATCH-P, support
for logical pathnames was broken because PATHNAME-MATCH-P eventually
calls TRANSLATE-LOGICAL-PATHNAME which calls PATHNAME-MATCH-P with
logical pathnames.  This caused infinite recursion.

So add back the original PATHNAME-MATCH-P, but rename to
%PATHNAME-MATCH-P and use that in TRANSLATE-LOGICAL-PATHNAME and
friends.

Add test for this case too.
parent a8934d15
No related branches found
No related tags found
No related merge requests found
...@@ -1219,6 +1219,26 @@ a host-structure or string." ...@@ -1219,6 +1219,26 @@ a host-structure or string."
(:version (frob (%pathname-version pathname))))))) (:version (frob (%pathname-version pathname)))))))
;; Like PATHNAME-MATCH-P but the pathnames should not be search-lists.
(defun %pathname-match-p (in-pathname in-wildname)
"Pathname matches the wildname template?"
(declare (type path-designator in-pathname)
;; Not path-designator because a file-stream can't have a
;; wild pathname.
(type (or string pathname) in-wildname))
(with-pathname (pathname in-pathname)
(with-pathname (wildname in-wildname)
(macrolet ((frob (field &optional (op 'components-match ))
`(or (null (,field wildname))
(,op (,field pathname) (,field wildname)))))
(and (or (null (%pathname-host wildname))
(eq (%pathname-host wildname) (%pathname-host pathname)))
(frob %pathname-device)
(frob %pathname-directory directory-components-match)
(frob %pathname-name)
(frob %pathname-type)
(frob %pathname-version))))))
;;; PATHNAME-MATCH-P -- Interface ;;; PATHNAME-MATCH-P -- Interface
;;; ;;;
(defun pathname-match-p (in-pathname in-wildname) (defun pathname-match-p (in-pathname in-wildname)
...@@ -1476,7 +1496,7 @@ a host-structure or string." ...@@ -1476,7 +1496,7 @@ a host-structure or string."
(with-pathname (source source) (with-pathname (source source)
(with-pathname (from from-wildname) (with-pathname (from from-wildname)
(with-pathname (to to-wildname) (with-pathname (to to-wildname)
(unless (pathname-match-p source from) (unless (%pathname-match-p source from)
(didnt-match-error source from)) (didnt-match-error source from))
(let* ((source-host (%pathname-host source)) (let* ((source-host (%pathname-host source))
(to-host (%pathname-host to)) (to-host (%pathname-host to))
...@@ -2171,7 +2191,7 @@ a host-structure or string." ...@@ -2171,7 +2191,7 @@ a host-structure or string."
:format-control (intl:gettext "No translation for ~S") :format-control (intl:gettext "No translation for ~S")
:format-arguments (list pathname))) :format-arguments (list pathname)))
(destructuring-bind (from to) x (destructuring-bind (from to) x
(when (pathname-match-p pathname from) (when (%pathname-match-p pathname from)
(return (translate-logical-pathname (return (translate-logical-pathname
(translate-pathname pathname from to))))))) (translate-pathname pathname from to)))))))
(pathname pathname) (pathname pathname)
......
...@@ -41,3 +41,35 @@ ...@@ -41,3 +41,35 @@
;; Tests where both args are search-lists. ;; Tests where both args are search-lists.
(assert-true "foo:foo.lisp" "bar:*")) (assert-true "foo:foo.lisp" "bar:*"))
;; Verify PATHNAME-MATCH-P works with logical pathnames. (Issue 27)
;; This test modeled after a test from asdf
(defun setup-logical-host ()
(let ((root *default-pathname-defaults*)
(bin-type (pathname-type (compile-file-pathname "foo.lisp"))))
(setf (logical-pathname-translations "ASDFTEST")
`((,(format nil "**;*.~a" bin-type)
,(merge-pathnames (make-pathname :directory '(:relative :wild-inferiors)
:name :wild :type bin-type :version nil)))
(,(format nil "**;*.~a.*" bin-type)
,(merge-pathnames (make-pathname :directory '(:relative "asdf-bin" :wild-inferiors)
:name :wild :type bin-type
:defaults root)))
("**;*.*.*"
,(merge-pathnames (make-pathname :directory '(:relative "asdf-src" :wild-inferiors)
:name :wild :type :wild :version :wild)))
("**;*.*"
,(merge-pathnames (make-pathname :directory '(:relative "asdf-src" :wild-inferiors)
:name :wild :type :wild :version nil)))
("**;*"
,(merge-pathnames (make-pathname :directory '(:relative "asdf-src" :wild-inferiors)
:name :wild :type nil :version nil)))))))
(setup-logical-host)
(define-test pathname-match-p.logical-pathname
(assert-true (pathname-match-p
(make-pathname :host "ASDFTEST"
:directory '(:absolute "system2" "module4")
:name nil :type nil)
(parse-namestring "ASDFTEST:system2;module4;"))))
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