02/02: packages: 'package-field-location' preserves the original file name.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit f2b24f01f42c1bad3ddffd140194de1aec38a5f8
Author: Ludovic Courtès <address@hidden>
AuthorDate: Fri Mar 20 23:34:03 2020 +0100

    packages: 'package-field-location' preserves the original file name.
    
    Fixes <https://bugs.gnu.org/39425>.
    Reported by Alex ter Weele <address@hidden>.
    
    * guix/packages.scm (package-field-location): Remove 'with-fluids' for
    '%file-port-name-canonicalization'.  Change the 'file' field of the
    resulting location to FILE.
---
 guix/packages.scm | 37 ++++++++++++++++++-------------------
 1 file changed, 18 insertions(+), 19 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 5ecb97f..4ab8650 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -355,25 +355,24 @@ object."
      (catch 'system-error
        (lambda ()
          ;; In general we want to keep relative file names for modules.
-         (with-fluids ((%file-port-name-canonicalization 'relative))
-           (call-with-input-file (search-path %load-path file)
-             (lambda (port)
-               (goto port line column)
-               (match (read port)
-                 (('package inits ...)
-                  (let ((field (assoc field inits)))
-                    (match field
-                      ((_ value)
-                       ;; Put the `or' here, and not in the first argument of
-                       ;; `and=>', to work around a compiler bug in 2.0.5.
-                       (or (and=> (source-properties value)
-                                  source-properties->location)
-                           (and=> (source-properties field)
-                                  source-properties->location)))
-                      (_
-                       #f))))
-                 (_
-                  #f))))))
+         (call-with-input-file (search-path %load-path file)
+           (lambda (port)
+             (goto port line column)
+             (match (read port)
+               (('package inits ...)
+                (let ((field (assoc field inits)))
+                  (match field
+                    ((_ value)
+                     (let ((props (source-properties value)))
+                       (and props
+                            ;; Preserve the original file name, which may be a
+                            ;; relative file name.
+                            (let ((loc (source-properties->location props)))
+                              (set-field loc (location-file) file)))))
+                    (_
+                     #f))))
+               (_
+                #f)))))
        (lambda _
          #f)))
     (_ #f)))