discovery: Recurse into directories pointed to by a symlink.
Reported by Christopher Baines <mail@cbaines.net> and Alex Kost <alezost@gmail.com> at <https://lists.gnu.org/archive/html/guix-devel/2017-06/msg00290.html>. * guix/discovery.scm (scheme-files): When ENTRY is a symlink that doesn't end in '.scm', call 'stat' and recurse if it points to a directory. * tests/discovery.scm ("scheme-modules recurses in symlinks to directories"): New test.
This commit is contained in:
parent
cc1dfc202f
commit
960c6ce96d
|
@ -60,11 +60,21 @@ DIRECTORY is not accessible."
|
|||
(case (entry-type absolute properties)
|
||||
((directory)
|
||||
(append (scheme-files absolute) result))
|
||||
((regular symlink)
|
||||
;; XXX: We don't recurse if we find a symlink.
|
||||
((regular)
|
||||
(if (string-suffix? ".scm" name)
|
||||
(cons absolute result)
|
||||
result))
|
||||
((symlink)
|
||||
(cond ((string-suffix? ".scm" name)
|
||||
(cons absolute result))
|
||||
((stat absolute #f)
|
||||
=>
|
||||
(match-lambda
|
||||
(#f result)
|
||||
((= stat:type 'directory)
|
||||
(append (scheme-files absolute)
|
||||
result))
|
||||
(_ result)))))
|
||||
(else
|
||||
result))))))
|
||||
'()
|
||||
|
|
|
@ -19,6 +19,7 @@
|
|||
(define-module (test-discovery)
|
||||
#:use-module (guix discovery)
|
||||
#:use-module (guix build-system)
|
||||
#:use-module (guix utils)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (ice-9 match))
|
||||
|
||||
|
@ -32,6 +33,19 @@
|
|||
((('guix 'import _ ...) ..1)
|
||||
#t)))
|
||||
|
||||
(test-assert "scheme-modules recurses in symlinks to directories"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(mkdir (string-append directory "/guix"))
|
||||
(symlink (string-append %top-srcdir "/guix/import")
|
||||
(string-append directory "/guix/import"))
|
||||
|
||||
;; DIRECTORY/guix/import is a symlink but we want to make sure
|
||||
;; 'scheme-modules' recurses into it.
|
||||
(match (map module-name (scheme-modules directory))
|
||||
((('guix 'import _ ...) ..1)
|
||||
#t)))))
|
||||
|
||||
(test-equal "scheme-modules, non-existent directory"
|
||||
'()
|
||||
(scheme-modules "/does/not/exist"))
|
||||
|
|
Loading…
Reference in New Issue