GNU bug report logs - #76492
[PATCH] build/utils: Add delete-all-but

Message received at submit <at> debbugs.gnu.org:

Received: (at submit) by debbugs.gnu.org; 23 Feb 2025 01:23:35 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Sat Feb 22 20:23:35 2025
Received: from localhost ([127.0.0.1]:58151 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1tm0iU-000864-Ra
	for submit <at> debbugs.gnu.org; Sat, 22 Feb 2025 20:23:35 -0500
Received: from lists.gnu.org ([2001:470:142::17]:39304)
 by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
 (Exim 4.84_2) (envelope-from <wongandj@HIDDEN>)
 id 1tm0iR-00085p-Of
 for submit <at> debbugs.gnu.org; Sat, 22 Feb 2025 20:23:33 -0500
Received: from eggs.gnu.org ([2001:470:142:3::10])
 by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
 (Exim 4.90_1) (envelope-from <wongandj@HIDDEN>)
 id 1tm0iM-000876-9b
 for guix-patches@HIDDEN; Sat, 22 Feb 2025 20:23:26 -0500
Received: from qs51p00im-qukt01080301.me.com ([17.57.155.20])
 by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
 (Exim 4.90_1) (envelope-from <wongandj@HIDDEN>)
 id 1tm0iK-0000ad-9Q
 for guix-patches@HIDDEN; Sat, 22 Feb 2025 20:23:25 -0500
DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=icloud.com;
 s=1a1hai; bh=poAOmTqI56tzS8O0yn364Gvtq1XSZbraNKAohoqtspE=;
 h=From:To:Subject:Date:Message-ID:MIME-Version:Content-Type:x-icloud-hme;
 b=A1dkf8cQifqW/JXAhI/uB+x0c3r3+F22is0gyMW0TQRh01WrezhiSxrPLq6SXs8wF
 50SbtLPKRlUimt8gmmuEjOKOuwSlsj+N5iQnOeVaArVze9SxzZBTv6Mi7cQHa2O8MJ
 E/c+trgPBhFN0wpIzjJthNaQpK6Mbp/9W6xTYxJE38XV9VZXlupgXtG+d+wH/IASH4
 8EyXJJhSNDjSQmao0TIjB+D9uNUg/SwQL9HArtDg8JyMP7rjcr73kzk7Y5Dwo9J13W
 4usTGS0YpBw1buU4jsRsASVbIMp3F//fv6aW72BcV8pM1OrTuYtfHnZKRazdufyEjM
 3RpavqJtP3hRQ==
Received: from wongworks.lan (qs51p00im-dlb-asmtp-mailmevip.me.com
 [17.57.155.28])
 by qs51p00im-qukt01080301.me.com (Postfix) with ESMTPSA id D86925F00173;
 Sun, 23 Feb 2025 01:23:18 +0000 (UTC)
From: Andrew Wong <wongandj@HIDDEN>
To: guix-patches@HIDDEN
Subject: [PATCH] build/utils: Add delete-all-but
Date: Sat, 22 Feb 2025 20:18:58 -0500
Message-ID: <0b8d4eb4212609048cf81f2e3e6e3da83c1caf46.1740273538.git.wongandj@HIDDEN>
X-Mailer: git-send-email 2.48.1
MIME-Version: 1.0
X-Debbugs-Cc: Andreas Enge <andreas@HIDDEN>, Janneke Nieuwenhuizen <janneke@HIDDEN>, Ludovic Courtès <ludo@HIDDEN>, Zheng Junjie <z572@HIDDEN>
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
X-Proofpoint-GUID: hoxzyO-ZrR8HdaAzRcC-78DA2kzndnw4
X-Proofpoint-ORIG-GUID: hoxzyO-ZrR8HdaAzRcC-78DA2kzndnw4
X-Proofpoint-Virus-Version: vendor=baseguard
 engine=ICAP:2.0.293,Aquarius:18.0.1057,Hydra:6.0.680,FMLib:17.12.68.34
 definitions=2025-02-22_11,2025-02-20_02,2024-11-22_01
X-Proofpoint-Spam-Details: rule=notspam policy=default score=0 bulkscore=0
 mlxscore=0 phishscore=0
 malwarescore=0 clxscore=1015 adultscore=0 suspectscore=0 spamscore=0
 mlxlogscore=671 classifier=spam adjust=0 reason=mlx scancount=1
 engine=8.19.0-2308100000 definitions=main-2502230008
X-Apple-Remote-Links: v=1;h=KCk=;charset=UTF-8
Received-SPF: pass client-ip=17.57.155.20; envelope-from=wongandj@HIDDEN;
 helo=qs51p00im-qukt01080301.me.com
X-Spam_score_int: -27
X-Spam_score: -2.8
X-Spam_bar: --
X-Spam_report: (-2.8 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1,
 DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001,
 RCVD_IN_DNSWL_LOW=-0.7, RCVD_IN_MSPIKE_H5=0.001, RCVD_IN_MSPIKE_WL=0.001,
 RCVD_IN_VALIDITY_CERTIFIED_BLOCKED=0.001, RCVD_IN_VALIDITY_RPBL_BLOCKED=0.001,
 SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no
X-Spam_action: no action
X-Spam-Score: 1.0 (+)
X-Debbugs-Envelope-To: submit
Cc: Andrew Wong <wongandj@HIDDEN>
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -0.0 (/)

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

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@HIDDEN>
 ;;; Copyright © 2021 Brendan Tildesley <mail@HIDDEN>
 ;;; Copyright © 2023 Carlo Zancanaro <carlo@HIDDEN>
+;;; Copyright © 2025 Andrew Wong <wongandj@HIDDEN>
 ;;;
 ;;; 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."

base-commit: cd20619cfcb32c2631fb602729512740bc510550
-- 
2.48.1