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

Merge branch 'rtoy-fix-27-pathname-match-p' into 'master'

Fix #27: pathname-match-p infinite recursion

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.

See merge request !10
parents a8934d15 37c549c6
No related branches found
No related tags found
No related merge requests found
...@@ -1219,6 +1219,32 @@ a host-structure or string." ...@@ -1219,6 +1219,32 @@ a host-structure or string."
(:version (frob (%pathname-version pathname))))))) (:version (frob (%pathname-version pathname)))))))
(defun %%pathname-match-p (pathname 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))))
;; Like PATHNAME-MATCH-P but the pathnames should not be search-lists.
;; Primarily intended for TRANSLATE-LOGICAL-PATHNAME and friends,
;; because PATHNAME-MATCH-P calls TRANSLATE-LOGICAL-PATHNAME, causing
;; infinite recursion.
(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)
(%%pathname-match-p pathname wildname))))
;;; PATHNAME-MATCH-P -- Interface ;;; PATHNAME-MATCH-P -- Interface
;;; ;;;
(defun pathname-match-p (in-pathname in-wildname) (defun pathname-match-p (in-pathname in-wildname)
...@@ -1231,17 +1257,8 @@ a host-structure or string." ...@@ -1231,17 +1257,8 @@ a host-structure or string."
(enumerate-search-list (pathname in-path) (enumerate-search-list (pathname in-path)
(with-pathname (in-wild in-wildname) (with-pathname (in-wild in-wildname)
(enumerate-search-list (wildname in-wild) (enumerate-search-list (wildname in-wild)
(macrolet ((frob (field &optional (op 'components-match )) (when (%%pathname-match-p pathname wildname)
`(or (null (,field wildname)) (return-from pathname-match-p pathname)))))))
(,op (,field pathname) (,field wildname)))))
(when (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))
(return-from pathname-match-p pathname))))))))
;;; SUBSTITUTE-INTO -- Internal ;;; SUBSTITUTE-INTO -- Internal
...@@ -1476,7 +1493,7 @@ a host-structure or string." ...@@ -1476,7 +1493,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 +2188,7 @@ a host-structure or string." ...@@ -2171,7 +2188,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