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?))))) ;;;