bartronx7/guix
1
0
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2026-01-25 03:55:08 -06:00
Code Issues Projects Releases Packages Wiki Activity Actions

gexp: Make 'local-file' follow symlinks.

Browse source 
Fix <https://lists.gnu.org/archive/html/guix-devel/2024-08/msg00047.html>
via making 'current-source-directory' always follow symlinks.

* guix/utils.scm (absolute-dirname, current-source-directory): Make
them follow symlinks.
* tests/gexp.scm ("local-file, load through symlink"): New test.

Fixes: guix/guix#3523
Change-Id: Ieb30101275deb56b7436df444f9bc21d240fba59
Signed-off-by: Florian Pelz <pelzflorian@pelzflorian.de>
This commit is contained in:
Nigko Yerden 2024-09-26 12:07:56 +05:00 • committed by Florian Pelz
parent 85a44ae636
commit 930ea819a5
No known key found for this signature in database
GPG key ID: 300888CB39C63817
2 changed files with 33 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
guix/utils.scm
View file

@ -1186,11 +1186,7 @@ failure."
(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)))))))
(dirname (canonicalize-path file))))))
(define-syntax current-source-directory
(lambda (s)
@ -1206,7 +1202,7 @@ be determined."
;; 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)
(dirname (canonicalize-path file-name))
#`(absolute-dirname #,file-name)))
((or ('filename . #f) #f)
;; raising an error would upset Geiser users

31
tests/gexp.scm
View file

@ -314,6 +314,37 @@
(string=? (local-file-absolute-file-name file)
(in-vicinity directory "the-unique-file.txt"))))))
(test-assert "local-file, load through symlink"
;; See <https://issues.guix.gnu.org/72867>.
(call-with-temporary-directory
(lambda (tmp-dir)
(with-directory-excursion tmp-dir
;; create content file
(call-with-output-file "content"
(lambda (port) (display "Hi!" port)))
;; Create a module that calls '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")
(symlink "../test-local-file.scm" "dir/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 file name. To test both of these branches we
;; execute 'test-local-file.scm' symlink first as a module (corresponds
;; to relative file name):
(dynamic-wind
(lambda () (set! %load-path (cons "dir" %load-path)))
(lambda () (resolve-module '(test-local-file) #:ensure #f))
(lambda () (set! %load-path (cdr %load-path))))
;; and then as a regular code (corresponds to absolute file name):
(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))))