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

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

[Maxim Cournoyer]

[-- 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

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

[Ludovic Courtès]

Hi Maxim,

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

> 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.

[...]

> +(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?)))

‘find-files’ recurses in subdirectories, so the above implementation is
not as efficient as it could be.

I would instead suggest using ‘scandir’ (or ‘file-system-fold’) from
Guile’s (ice-9 ftw) module.

That said… is this a common enough operation?

Thanks,
Ludo’.

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

[Maxim Cournoyer]

Hi Ludovic,

ludo@gnu.org (Ludovic Courtès) writes:

> Hi Maxim,
>
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> 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.
>
> [...]
>
>> +(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?)))
>
> ‘find-files’ recurses in subdirectories, so the above implementation is
> not as efficient as it could be.
>
> I would instead suggest using ‘scandir’ (or ‘file-system-fold’) from
> Guile’s (ice-9 ftw) module.

Thanks! See the new patched attached. The test still passes.

> That said… is this a common enough operation?

I'm using it in a forthcoming new Guix package (SuperCollider) where it
allows me to explicitly list the bundled dependencies that are to be
*kept* rather than the ones to be removed, as is more commonly done. Without a
list of the subdirectories the contrib/vendor/whatever bundled
libraries directory I would not be able to do the following:

--8<---------------cut here---------------start------------->8---
+             ;; The build system doesn't allow us to unbundle the
+             ;; following libraries.
+             (let* ((all-dirs (find-subdirectories "./external_libraries"))
+                    (keep-dirs '("nova-simd" "nova-tt" "hidapi" "TLSF-2.4.6"
+                                 "oscpack_1_1_0"))
+                    (remove-dirs
+                     (remove (lambda (x)
+                               (member (basename x) keep-dirs))
+                             all-dirs)))
+               (format #t "Removing bundled libraries: ~s\n" remove-dirs)
+               (for-each delete-file-recursively remove-dirs)))))))
--8<---------------cut here---------------end--------------->8---

Although now that you've made me see the light (scandir), I could
rewrite the whole thing using:

--8<---------------cut here---------------start------------->8---
          (lambda _
             ;; The build system doesn't allow us to unbundle the following
             ;; libraries.
             (let ((keep-dirs '("nova-simd" "nova-tt" "hidapi" "TLSF-2.4.6"
                                "oscpack_1_1_0" "." "..")))
               (with-directory-excursion "./external_libraries"
                 (for-each
                  delete-file-recursively
                  (scandir "."
                           (lambda (x)
                             (and (eq? (stat:type (stat x)) 'directory)
                                  (not (member (basename x) keep-dirs))))))))
--8<---------------cut here---------------end--------------->8---

So, this patch can go to the recycle bin. Thanks! :)

Maxim

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

[Ludovic Courtès]

Hi Maxim,

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

> Although now that you've made me see the light (scandir), I could
> rewrite the whole thing using:
>
>           (lambda _
>              ;; The build system doesn't allow us to unbundle the following
>              ;; libraries.
>              (let ((keep-dirs '("nova-simd" "nova-tt" "hidapi" "TLSF-2.4.6"
>                                 "oscpack_1_1_0" "." "..")))
>                (with-directory-excursion "./external_libraries"
>                  (for-each
>                   delete-file-recursively
>                   (scandir "."
>                            (lambda (x)
>                              (and (eq? (stat:type (stat x)) 'directory)
>                                   (not (member (basename x) keep-dirs))))))))
>
> So, this patch can go to the recycle bin. Thanks! :)

Well, I’m glad that it works for you.  :-)

Thanks,
Ludo’.