[bug#72867] [PATCH] gexp: Make 'local-file' follow symlinks.

[Nigko Yerden <nigko.yerden@gmail.com>]

Fixes <https://lists.gnu.org/archive/html/guix-devel/2024-08/msg00047.html>

While the issue can be easily fixed (a one line change in 'absolute-dirname')
by changing 'current-source-directory' so that it always follows symlinks,
such a change may break someone else's code. Instead, this patch keeps the
original behavior of 'current-source-directory' macro and adds optional
'follow-symlinks?' argument to it.

This patch is the result of collective work of
Florian Pelz <pelzflorian@pelzflorian.de> and
Nigko Yerden <nigko.yerden@gmail.com>

* guix/utils.scm (absolute-dirname): Add 'follow-symlinks?' mandatory
argument.
(%guix-source-root-directory): Pass #f to 'absolute-dirname'
'follow-symlinks?' argument.
(current-source-directory): Add 'follow-symlinks?' optional argument.
* guix/gexp.scm (local-file): Pass #t to 'current-source-directory'
'follow-symlinks?' argument.

Change-Id: Ieb30101275deb56b7436df444f9bc21d240fba59
---
 guix/gexp.scm  |  2 +-
 guix/utils.scm | 52 ++++++++++++++++++++++++++++----------------------
 2 files changed, 30 insertions(+), 24 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 74b4c49f90..5911ca4815 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -508,7 +508,7 @@ (define-syntax local-file
        (string? (syntax->datum #'file))
        ;; FILE is a literal, so resolve it relative to the source directory.
        #'(%local-file file
-                      (delay (absolute-file-name file (current-source-directory)))
+                      (delay (absolute-file-name file (current-source-directory #t)))
                       rest ...))
       ((_ (assume-valid-file-name file) rest ...)
        ;; FILE is not a literal, so resolve it relative to the current
diff --git a/guix/utils.scm b/guix/utils.scm
index d8ce6ed886..b5fcf8cb28 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -1110,41 +1110,47 @@ (define (canonical-newline-port port)
 
 (define (%guix-source-root-directory)
   "Return the source root directory of the Guix found in %load-path."
-  (dirname (absolute-dirname "guix/packages.scm")))
+  (dirname (absolute-dirname "guix/packages.scm" #f)))
 
 (define absolute-dirname
   ;; Memoize to avoid repeated 'stat' storms from 'search-path'.
-  (mlambda (file)
+  (mlambda (file follow-symlinks?)
     "Return the absolute name of the directory containing FILE, or #f upon
-failure."
+failure. Follow symlinks if FOLLOW-SYMLINKS? is true."
     (match (search-path %load-path file)
       (#f #f)
       ((? string? file)
-       ;; If there are relative names in %LOAD-PATH, FILE can be relative and
-       ;; needs to be canonicalized.
-       (if (string-prefix? "/" file)
-           (dirname file)
-           (canonicalize-path (dirname file)))))))
+       (if follow-symlinks?
+	   (dirname (canonicalize-path file))
+	   ;; If there are relative names in %LOAD-PATH, FILE can be relative
+	   ;; and needs to be canonicalized.
+	   (if (string-prefix? "/" file)
+               (dirname file)
+               (canonicalize-path (dirname file))))))))
 
 (define-syntax current-source-directory
   (lambda (s)
     "Return the absolute name of the current directory, or #f if it could not
-be determined."
+be determined. Do not follow symlinks if FOLLOW-SYMLINKS? is false (the default)."
+    (define (source-directory follow-symlinks?)
+      (match (assq 'filename (or (syntax-source s) '()))
+	(('filename . (? string? file-name))
+	 ;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME
+	 ;; can be relative.  In that case, we try to find out at run time
+	 ;; the absolute file name by looking at %LOAD-PATH; doing this at
+	 ;; run time rather than expansion time is necessary to allow files
+	 ;; to be moved on the file system.
+	 (if (string-prefix? "/" file-name)
+	     (dirname (if follow-symlinks?
+			  (canonicalize-path file-name)
+			  file-name))
+	     #`(absolute-dirname #,file-name #,follow-symlinks?)))
+	((or ('filename . #f) #f)
+	 ;; raising an error would upset Geiser users
+	 #f)))
     (syntax-case s ()
-      ((_)
-       (match (assq 'filename (or (syntax-source s) '()))
-         (('filename . (? string? file-name))
-          ;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME
-          ;; can be relative.  In that case, we try to find out at run time
-          ;; the absolute file name by looking at %LOAD-PATH; doing this at
-          ;; run time rather than expansion time is necessary to allow files
-          ;; to be moved on the file system.
-          (if (string-prefix? "/" file-name)
-              (dirname file-name)
-              #`(absolute-dirname #,file-name)))
-         ((or ('filename . #f) #f)
-          ;; raising an error would upset Geiser users
-          #f))))))
+      ((_) (source-directory #f))
+      ((_ follow-symlinks?) (source-directory #'follow-symlinks?)))))
 
 \f
 ;;;

base-commit: 4c49cd171e2aa06af05cf52403050b18f100867a
-- 
2.45.2