Package: guix-patches;
Reported by: Nigko Yerden <nigko.yerden <at> gmail.com>
Date: Thu, 29 Aug 2024 06:10:01 UTC
Severity: normal
Tags: patch
Message #38 received at 72867 <at> debbugs.gnu.org (full text, mbox):
From: Nigko Yerden <nigko.yerden <at> gmail.com> To: 72867 <at> debbugs.gnu.org Cc: Florian Pelz <pelzflorian <at> pelzflorian.de>, Nigko Yerden <nigko.yerden <at> gmail.com> Subject: [PATCH v4] gexp: Make 'local-file' follow symlinks. Date: Thu, 5 Sep 2024 09:16:51 +0500
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.
;;; Copyright © 2024 Nigko Yerden <nigko.yerden <at> 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.
* tests/gexp.scm ("local-file, load through symlink"): New test.
Change-Id: Ieb30101275deb56b7436df444f9bc21d240fba59
---
Hello Florian,
pelzflorian (Florian Pelz) wrote:
>> * tests/gexp.scm ("local-file, load through symlink"): New test.
>
>This one is a good test; but it tests only half, namely the
>rare-in-practice case of `local-file' when loading a Scheme file. Here,
>`current-source-directory' evaluate file-name to
>"/tmp/guix-directory.VxrxZT/dir/link-to-code.scm", which has a slash as
>prefix, so absolute-dirname is not called.
Thanks for noticing this. Indeed 'absolute-dirname' was not called.
I have fixed this by turning 'code.scm' into a module 'test-local-file.scm'
and loading it twice: first using 'use-module' and then via 'load'
(for some unclear reason 'primitive-load' causes an error here, so
I replaced it with 'load').
>Thanks for the credit, but it would be unusual to mention me in the
>commit message, where discussion does not count.
>Please do not put me in the commit message; I made no code contribution.
OK, I removed your name from the commit message.
Regards,
Nigko
guix/gexp.scm | 2 +-
guix/utils.scm | 53 ++++++++++++++++++++++++++++----------------------
tests/gexp.scm | 33 +++++++++++++++++++++++++++++++
3 files changed, 64 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..ea3d80707e 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -1110,41 +1110,48 @@ (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 (syntax->datum #'follow-symlinks?))))))
;;;
diff --git a/tests/gexp.scm b/tests/gexp.scm
index b35bfc920f..8f267214cd 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -292,6 +292,39 @@ (define %extension-package
(equal? (scandir (string-append dir "/tests"))
'("." ".." "gexp.scm"))))))
+(test-assert "local-file, load through symlink"
+ ;; See <https://issues.guix.gnu.org/72867>.
+ (call-with-temporary-directory
+ (lambda (tmp-dir)
+ (chdir tmp-dir)
+ ;; create content file
+ (call-with-output-file "content"
+ (lambda (port) (display "Hi!" port)))
+ ;; Create module that call 'local-file'
+ ;; with the content file and returns its
+ ;; absolute file-name. An error is raised
+ ;; if the content file can't be found.
+ (call-with-output-file "test-local-file.scm"
+ (lambda (port) (display "\
+(define-module (test-local-file)
+ #:use-module (guix gexp))
+(define file (local-file \"content\" \"test-file\"))
+(local-file-absolute-file-name file)" port)))
+ (mkdir "dir")
+ (chdir "dir")
+ (symlink "../test-local-file.scm" "test-local-file.scm")
+ ;; 'local-file' in turn calls 'current-source-directory'
+ ;; which has an 'if' branching condition depending on whether
+ ;; 'file-name' is absolute or relative path. To test both
+ ;; of these branches we execute 'test-local-file.scm' symlink
+ ;; first as a module (corresponds to relative path):
+ (eval (begin
+ (add-to-load-path ".")
+ (use-modules (test-local-file)))
+ (current-module))
+ ;; and then as a regular code (corresponds to absolute path):
+ (load (string-append tmp-dir "/dir/test-local-file.scm")))))
+
(test-assert "one plain file"
(let* ((file (plain-file "hi" "Hello, world!"))
(exp (gexp (display (ungexp file))))
base-commit: 4c49cd171e2aa06af05cf52403050b18f100867a
--
2.45.2
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.