diff mbox series

[bug#76492] build/utils: Add delete-all-but

Message ID 0b8d4eb4212609048cf81f2e3e6e3da83c1caf46.1740273538.git.wongandj@icloud.com
State New
Headers
Series [bug#76492] build/utils: Add delete-all-but |

Commit Message

Andrew Wong Feb. 23, 2025, 1:18 a.m. UTC 
  * guix/build/utils.scm (delete-all-but): New procedure.

Change-Id: I82db4b63c45d88ef0529adb760182495c28dae9e
---
delete-all-but is defined and used within package definitions a total of 11 times according to a simple grep; it makes sense to move it to a common location. However, changing (guix build utils) is a heavy change, so perhaps there is a better branch to merge this to than master.

 guix/build/utils.scm | 25 +++++++++++++++++++++++++
 1 file changed, 25 insertions(+)


base-commit: cd20619cfcb32c2631fb602729512740bc510550
diff mbox series

Patch

diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 94714bf397..b74c1ad7d8 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -10,6 +10,7 @@ 
 ;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
 ;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot>
 ;;; Copyright © 2023 Carlo Zancanaro <carlo@zancanaro.id.au>
+;;; Copyright © 2025 Andrew Wong <wongandj@icloud.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -77,6 +78,7 @@  (define-module (guix build utils)
             make-file-writable
             copy-recursively
             delete-file-recursively
+            delete-all-but
             file-name-predicate
             find-files
             false-if-file-not-found
@@ -522,6 +524,29 @@  (define* (delete-file-recursively dir
                       ;; Don't follow symlinks.
                       lstat)))
 
+(define (delete-all-but paths-kept)
+  "Delete all paths in DIR except for those listed in PATHS-KEPT, without
+following symblinks. Report but don't ignore errors."
+  (let ((paths-kept (map (cut canonicalize-path <>)
+                         paths-kept)))
+    (file-system-fold
+     (lambda (current-path current-stat result) ;enter?
+       (not (member (canonicalize-path current-path) paths-kept string=?)))
+     (lambda (file file-stat result)    ;leaf
+       (if (not (any (cut string-prefix? (canonicalize-path file) <>)
+                     paths-kept))
+           (warn-on-error (delete-file file) file)))
+     (const #t)                         ;down
+     (lambda (dir dir-stat result)      ;up
+       (if (not (any (cut string-prefix? (canonicalize-path dir) <>)
+                     paths-kept))
+           (warn-on-error (rmdir dir) dir)))
+     (const #t)                         ;skip
+     (lambda (file stat errno result)   ;error
+       (format (current-error-port)
+               "warning: failed to delete ~a: ~a~%" file (strerror errno)))
+     #t (getcwd) lstat)))
+
 (define (file-name-predicate regexp)
   "Return a predicate that returns true when passed a file name whose base
 name matches REGEXP."