01/12: grafts: Run with a UTF-8 locale.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 19206eee69e8c22d63104af1b7f1f815969bff7f
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Nov 10 18:20:23 2022 +0100

    grafts: Run with a UTF-8 locale.
    
    Fixes <https://issues.guix.gnu.org/55968>.
    Reported by Maxime Devos <maximedevos@telenet.be>.
    
    * guix/grafts.scm (%graft-with-utf8-locale?): New parameter.
    (graft-derivation/shallow)[glibc-locales, set-utf8-locale]: New
    variables.
    [build]: Use 'set-utf8-locale'.
    * tests/gexp.scm, tests/grafts.scm, tests/packages.scm: Set
    '%graft-with-utf8-locale?' to #f.
---
 guix/grafts.scm    | 24 +++++++++++++++++++++++-
 tests/gexp.scm     |  4 ++++
 tests/grafts.scm   |  5 ++++-
 tests/packages.scm |  3 +++
 4 files changed, 34 insertions(+), 2 deletions(-)

diff --git a/guix/grafts.scm b/guix/grafts.scm
index 1686aa1413..f93da32981 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -40,7 +40,9 @@
             graft-replacement-output
 
             graft-derivation
-            graft-derivation/shallow)
+            graft-derivation/shallow
+
+            %graft-with-utf8-locale?)
   #:re-export (%graft?                            ;for backward compatibility
                without-grafting
                set-grafting
@@ -79,6 +81,12 @@
     (($ <graft> (? string? item))
      item)))
 
+(define %graft-with-utf8-locale?
+  ;; Whether to install a UTF-8 locale for grafting.  This parameter exists
+  ;; for the sole purpose of being able to run tests without having to build
+  ;; 'glibc-utf8-locales'.
+  (make-parameter #t))
+
 (define* (graft-derivation/shallow drv grafts
                                    #:key
                                    (name (derivation-name drv))
@@ -88,6 +96,10 @@
   "Return a derivation called NAME, which applies GRAFTS to the specified
 OUTPUTS of DRV.  This procedure performs \"shallow\" grafting in that GRAFTS
 are not recursively applied to dependencies of DRV."
+  (define glibc-locales
+    (module-ref (resolve-interface '(gnu packages commencement))
+                'glibc-utf8-locales-final))
+
   (define mapping
     ;; List of store item pairs.
     (map (lambda (graft)
@@ -98,6 +110,15 @@ are not recursively applied to dependencies of DRV."
                        (graft-replacement-output graft)))))
          grafts))
 
+  (define set-utf8-locale
+    (and (%graft-with-utf8-locale?)
+         #~(begin
+             ;; Let Guile interpret file names as UTF-8.
+             (setenv "GUIX_LOCPATH"
+                     #+(file-append glibc-locales "/lib/locale"))
+             (setlocale LC_ALL "en_US.utf8"))))
+
+
   (define build
     (with-imported-modules '((guix build graft)
                              (guix build utils)
@@ -111,6 +132,7 @@ are not recursively applied to dependencies of DRV."
           (define %outputs
             (ungexp (outputs->gexp outputs)))
 
+          #+set-utf8-locale
           (let* ((old-outputs '(ungexp
                                 (map (lambda (output)
                                        (gexp ((ungexp output)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 6d57ac5d7a..7a90f8dcbf 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -21,6 +21,7 @@
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix gexp)
+  #:use-module ((guix grafts) #:select (%graft-with-utf8-locale?))
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix build-system trivial)
@@ -49,6 +50,9 @@
 ;; Globally disable grafts because they can trigger early builds.
 (%graft? #f)
 
+;; When grafting, do not add dependency on 'glibc-utf8-locales'.
+(%graft-with-utf8-locale? #f)
+
 ;; For white-box testing.
 (define (gexp-inputs x)
   ((@@ (guix gexp) gexp-inputs) x))
diff --git a/tests/grafts.scm b/tests/grafts.scm
index 7e1959e4a7..63dbb13830 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès 
<ludo@gnu.org>
+;;; Copyright © 2014-2019, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2021 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -35,6 +35,9 @@
 (define %store
   (open-connection-for-tests))
 
+;; When grafting, do not add dependency on 'glibc-utf8-locales'.
+(%graft-with-utf8-locale? #f)
+
 (define (bootstrap-binary name)
   (let ((bin (search-bootstrap-binary name (%current-system))))
     (and %store
diff --git a/tests/packages.scm b/tests/packages.scm
index a71eb1125d..a5819d8de3 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -75,6 +75,9 @@
 ;; can trigger builds early.)
 (%graft? #f)
 
+;; When grafting, do not add dependency on 'glibc-utf8-locales'.
+(%graft-with-utf8-locale? #f)
+
 
 (test-begin "packages")