From f43ffee90882c2d61b46d69728daa7432be297e4 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 1 Oct 2020 22:09:58 +0200
Subject: gexp: 'local-file' warns when passed a non-literal relative file
 name.

Fixes <https://bugs.gnu.org/43736>.
Reported by Vitaliy Shatrov <guix.vits@disroot.org>.

* guix/gexp.scm (%local-file): Add #:literal? and #:location.
Emit a warning when LITERAL? is false and FILE is not absolute.
(local-file): In the non-literal case, pass #:location and #:literal?.
* po/guix/POTFILES.in: Add guix/gexp.scm.
* tests/guix-system.sh: Add test for the warning.
---
 guix/gexp.scm | 19 +++++++++++++++----
 1 file changed, 15 insertions(+), 4 deletions(-)

(limited to 'guix')

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 9d3c52e783..40346b61e1 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -26,6 +26,8 @@
   #:use-module (guix derivations)
   #:use-module (guix grafts)
   #:use-module (guix utils)
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -401,9 +403,15 @@ Here TARGET is bound to the cross-compilation triplet or #f."
 (define (true file stat) #t)
 
 (define* (%local-file file promise #:optional (name (basename file))
-                      #:key recursive? (select? true))
+                      #:key
+                      (literal? #t) location
+                      recursive? (select? true))
   ;; This intermediate procedure is part of our ABI, but the underlying
   ;; %%LOCAL-FILE is not.
+  (when (and (not literal?) (not (string-prefix? "/" file)))
+    (warning (and=> location source-properties->location)
+             (G_ "resolving '~a' relative to current directory~%")
+             file))
   (%%local-file file promise name recursive? select?))
 
 (define (absolute-file-name file directory)
@@ -443,9 +451,12 @@ appears."
                       rest ...))
       ((_ file rest ...)
        ;; Resolve FILE relative to the current directory.
-       #'(%local-file file
-                      (delay (absolute-file-name file (getcwd)))
-                      rest ...))
+       (with-syntax ((location (datum->syntax s (syntax-source s))))
+        #`(%local-file file
+                       (delay (absolute-file-name file (getcwd)))
+                       #:location 'location
+                       #:literal? #f
+                       rest ...)))
       ((_)
        #'(syntax-error "missing file name"))
       (id
-- 
cgit v1.2.3