01/05: packages: 'package-field-location' handles 'search-path' returning #f.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 9a38bed2cf32e9462badfa43e74cdd4580e804fc
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Feb 22 10:52:21 2021 +0100

    packages: 'package-field-location' handles 'search-path' returning #f.
    
    Fixes <https://bugs.gnu.org/46390>.
    Reported by zimoun <zimon.toutoune@gmail.com>.
    
    This is similar to the fix in d10474c38d58bdc676e64336769dc2e00cdfa8ed.
    
    * guix/packages.scm (package-field-location): Handle FILE not in %LOAD-PATH.
    * tests/guix-lint.sh: Add test.
---
 guix/packages.scm  | 51 ++++++++++++++++++++++++++++-----------------------
 tests/guix-lint.sh |  5 +++++
 2 files changed, 33 insertions(+), 23 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 9305dab..57bc148 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -475,29 +475,34 @@ object."
 
   (match (package-location package)
     (($ <location> file line column)
-     (catch 'system-error
-       (lambda ()
-         ;; In general we want to keep relative file names for modules.
-         (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 ((loc (and=> (source-properties value)
-                                       source-properties->location)))
-                       (and loc
-                            ;; Preserve the original file name, which may be a
-                            ;; relative file name.
-                            (set-field loc (location-file) file))))
-                    (_
-                     #f))))
-               (_
-                #f)))))
-       (lambda _
-         #f)))
+     (match (search-path %load-path file)
+       ((? string? file)
+        (catch 'system-error
+          (lambda ()
+            ;; In general we want to keep relative file names for modules.
+            (call-with-input-file file
+              (lambda (port)
+                (goto port line column)
+                (match (read port)
+                  (('package inits ...)
+                   (let ((field (assoc field inits)))
+                     (match field
+                       ((_ value)
+                        (let ((loc (and=> (source-properties value)
+                                          source-properties->location)))
+                          (and loc
+                               ;; Preserve the original file name, which may 
be a
+                               ;; relative file name.
+                               (set-field loc (location-file) file))))
+                       (_
+                        #f))))
+                  (_
+                   #f)))))
+          (lambda _
+            #f)))
+       (#f
+        ;; FILE could not be found in %LOAD-PATH.
+        #f)))
     (_ #f)))
 
 
diff --git a/tests/guix-lint.sh b/tests/guix-lint.sh
index fdf548f..97c2ea8 100644
--- a/tests/guix-lint.sh
+++ b/tests/guix-lint.sh
@@ -90,3 +90,8 @@ guix lint -L $module_dir -c inputs-should-be-native dummy 
dummy@42 dummy
 # that it does find it anyway.  See <https://bugs.gnu.org/42543>.
 (cd "$module_dir"/.. ; guix lint -c formatting -L "$(basename "$module_dir")" 
dummy@42) 2>&1 > "$module_dir/out"
 test -z "$(cat "$module_dir/out")"
+
+# Likewise, when there's a warning, 'package-field-location' used to crash
+# because it can't find "t-xyz/foo.scm".  See <https://bugs.gnu.org/46390>.
+(cd "$module_dir"/.. ; guix lint -c synopsis -L "$(basename "$module_dir")" 
dummy@42) 2>&1 > "$module_dir/out"
+grep_warning "`cat "$module_dir/out"`"