03/03: discovery: Recurse into directories pointed to by a symlink.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 960c6ce96d746cf19829ad26e092ec5dad2a5c62
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jul 3 23:35:56 2017 +0200

    discovery: Recurse into directories pointed to by a symlink.
    
    Reported by Christopher Baines <address@hidden>
    and Alex Kost <address@hidden>
    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.
---
 guix/discovery.scm  | 14 ++++++++++++--
 tests/discovery.scm | 14 ++++++++++++++
 2 files changed, 26 insertions(+), 2 deletions(-)

diff --git a/guix/discovery.scm b/guix/discovery.scm
index 292df2b..2741725 100644
--- a/guix/discovery.scm
+++ b/guix/discovery.scm
@@ -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))))))
               '()
diff --git a/tests/discovery.scm b/tests/discovery.scm
index 04de83f..753e6a8 100644
--- a/tests/discovery.scm
+++ b/tests/discovery.scm
@@ -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"))