(name . guix-patches)(address . guix-patches@gnu.org)
87a7vnma48.fsf@gmail.com
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
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(-)
Toggle diff (109 lines)
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?)))
+
;;;
;;; 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))
(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