[bug#30708] [PATCH] utils: Add helper method to list subdirectories.

[Maxim Cournoyer <maxim.cournoyer@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 167 bytes --]

Hello Guix!

This adds a method useful to list subdirectories, which I am using to
list bundled copies of libraries (and delete them), for example.

Thank you,

Maxim

[-- Attachment #2: 0001-utils-Add-helper-method-to-list-subdirectories.patch --]
[-- Type: text/x-patch, Size: 4106 bytes --]

From b4b607800d770c4cf77f92c247276c368357e94f Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Sun, 25 Feb 2018 17:49:06 -0500
Subject: [PATCH] utils: Add helper method to list subdirectories.

* guix/build/utils.scm (find-subdirectories): New procedure.
* tests/build-utils.scm: Rename module so that it can be used with Geiser.
(%test-dir-hierarchy): New variable.
(make-test-dir-hierarchy): New test procedure.
("find-subdirectories"): New test.
---
 guix/build/utils.scm  | 16 ++++++++++++++++
 tests/build-utils.scm | 37 +++++++++++++++++++++++++++++++++++--
 2 files changed, 51 insertions(+), 2 deletions(-)

diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 7391307c8..9a321bf3e 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -60,6 +61,7 @@
             delete-file-recursively
             file-name-predicate
             find-files
+            find-subdirectories
 
             search-path-as-list
             set-path-environment-variable
@@ -395,6 +397,20 @@ also be included.  If FAIL-ON-ERROR? is true, raise an exception upon error."
                             stat)
           string<?)))
 
+(define* (find-subdirectories dir #:key fail-on-error?)
+  "Return the list of the immediate subdirectories of DIR."
+  ;; Strip the trailing '/' DIR is '/'.
+  (let ((dir (if (and (> 1 (string-length dir))
+                      (eq? (string-take-right dir 1) #\/))
+                 (string-drop-right dir 1)
+                 dir)))
+    (define (pred filename stat)
+      (and (eq? (stat:type stat) 'directory)
+           (string-match (string-append dir "/[^/]*$") filename)))
+    (find-files dir pred
+                #:directories? #t
+                #:fail-on-error? fail-on-error?)))
+
 \f
 ;;;
 ;;; Search paths.
diff --git a/tests/build-utils.scm b/tests/build-utils.scm
index 7d49446f6..6a3d43784 100644
--- a/tests/build-utils.scm
+++ b/tests/build-utils.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,7 +18,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 
-(define-module (test-build-utils)
+(define-module (tests build-utils)
   #:use-module (guix tests)
   #:use-module (guix build utils)
   #:use-module ((guix utils)
@@ -27,7 +28,8 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
-  #:use-module (ice-9 popen))
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 match))
 
 \f
 (test-begin "build-utils")
@@ -122,4 +124,35 @@
          (and (zero? (close-pipe pipe))
               str))))))
 
+(define %test-dir-hierarchy
+  ;; The first element of a list is a file if the only element, otherwise
+  ;; a directory.
+  '("top"
+    ("subdir1"
+     ("subsubdir1"
+      "a-file.txt"
+      "another-file.c"))
+    ("subdir2"
+     "yet-another-one.h")
+    ("file.txt")))
+
+(define* (make-test-dir-hierarchy hierarchy #:optional (top (getcwd)))
+  (mkdir-p top)
+  (match hierarchy
+    ((dir . rest)
+     (for-each
+      (lambda (item)
+        (make-test-dir-hierarchy item (string-append top "/" dir)))
+      rest))
+    (file
+     (system (string-append "echo  \"\" > " "\"" top "/" file "\"")))))
+
+(test-equal "find-subdirectories"
+  '("top/subdir1" "top/subdir2")
+  (call-with-temporary-directory
+   (lambda (directory)
+     (make-test-dir-hierarchy %test-dir-hierarchy directory)
+     (chdir directory)
+     (find-subdirectories "top"))))
+
 (test-end)
-- 
2.16.1