Subject: [bug#76143] [PATCH v3 1/1] gnu: Find patches directory through symlinks.

From: Noé Lopez <[email-masked]>
Date: Sun, 16 Feb 2025 15:44:00 +0100

From: Noé Lopez <[email-masked]>

This fixes a bug where patches would not be found in %patch-path when the
Guile load path would contain a different path (via symlink or trailing slash)
to the %distro-root-directory than what was previously found.  We use stat to
make sure that two different paths to the same directory are still matched.

For example: if the Guile path was /guix/ and %distro-root-directory was
/guix, patches would not be found even though the two directories are the
same.

* gnu/packages.scm (%patch-path): Compare directories with directory=?.
* guix/utils.scm (directory=?): New procedure.
* tests/utils.scm: Add tests for directory=?.

Change-Id: I73f65b6c050cdeff85637e13ffd0319dcc1d4958
---
 gnu/packages.scm |  2 +-
 guix/utils.scm   | 16 ++++++++++++++++
 tests/utils.scm  | 13 +++++++++++++
 3 files changed, 30 insertions(+), 1 deletion(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index bdd5d21940..5cad0d50ff 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -168,7 +168,7 @@ (define %patch-path
   ;; directories, allowing patches in $GUIX_PACKAGE_PATH to be found.
   (make-parameter
    (map (lambda (directory)
-          (if (string=? directory %distro-root-directory)
+          (if (directory=? directory %distro-root-directory)
               (string-append directory "/gnu/packages/patches")
               directory))
         %load-path)))
diff --git a/guix/utils.scm b/guix/utils.scm
index b6cf5aea4f..7979eba040 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -21,6 +21,7 @@
 ;;; Copyright © 2023 Zheng Junjie <[email-masked]>
 ;;; Copyright © 2023 Foundation Devices, Inc. <[email-masked]>
 ;;; Copyright © 2024 Herman Rimm <[email-masked]>
+;;; Copyright © 2025 Noé Lopez <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -41,6 +42,7 @@ (define-module (guix utils)
   #:use-module (guix config)
   #:autoload   (guix read-print) (object->string*)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-71)
@@ -162,6 +164,7 @@ (define-module (guix utils)
             compressed-output-port
             call-with-compressed-output-port
             canonical-newline-port
+            directory=?
 
             string-distance
             string-closest
@@ -1150,6 +1153,19 @@ (define (canonical-newline-port port)
                                  get-position
                                  set-position!
                                  close))
+
+(define* (directory=? directory #:rest directories)
+  (define (dev+ino directory)
+    (and-let* ((stats (stat directory #f))
+               (dev (stat:dev stats))
+               (ino (stat:ino stats)))
+      (cons dev ino)))
+  (define check (dev+ino directory))
+  (and check
+       (fold (lambda (element acc)
+               (and acc (equal? (dev+ino element) check)))
+             #t
+             directories)))
 
 ;;;
 ;;; Source location.
diff --git a/tests/utils.scm b/tests/utils.scm
index 462e43e2b1..88a88eba1d 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2021 Maxime Devos <[email-masked]>
 ;;; Copyright © 2023 Foundation Devices, Inc. <[email-masked]>
 ;;; Copyright © 2024 Herman Rimm <[email-masked]>
+;;; Copyright © 2025 Noé Lopez <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -370,6 +371,18 @@ (define-public package-2\n  'package)\n"
          ;; way.
          "avr32" "avr32-unknown-none")))
 
+;; Try to not depend on the user’s filesystem.
+(test-equal "directory=?"
+  '(#t #t #t #t #t #f #f)
+  (list
+   (directory=? "/" "/")
+   (directory=? "/../" "//")
+   (directory=? "//../" "/")
+   (directory=? "/")
+   (directory=? "/" "/../" "//" "//..//../")
+   (directory=? "/proc/99999999" "/proc/99999999") ;nonexistent directories
+   (directory=? "/proc/99999999/../../" "/")))
+
 (test-end)
 
 (false-if-exception (delete-file temp-file))
-- 
2.48.1