Merge branch 'master' into HEAD

Change-Id: I3f5d121162d98ef2ae61a62c4da3b0fd19d864e8

15 files changed, 142 insertions, 47 deletions

diff --git a/guix/build-system/clojure.scm b/guix/build-system/clojure.scm
index fb897356bc..037fcaf21d 100644
--- a/guix/build-system/clojure.scm
+++ b/guix/build-system/clojure.scm
@@ -83,8 +83,8 @@
                             #:clojure #:jdk #:zip)))
 
     (if target
-        (error "No cross-compilation for clojure-build-system yet: LOWER"
-               target) ; FIXME
+        #f                              ; FIXME: No cross-compilation for
+                                        ; clojure-build-system yet
         (bag (name name)
              (system system)
              (host-inputs `(,@(if source
diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm
index 1bd292e267..bd3bb1c870 100644
--- a/guix/build-system/guile.scm
+++ b/guix/build-system/guile.scm
@@ -88,7 +88,8 @@
                       (compile-flags %compile-flags)
                       (imported-modules %guile-build-system-modules)
                       (modules '((guix build guile-build-system)
-                                 (guix build utils))))
+                                 (guix build utils)))
+                      (substitutable? #t))
   "Build SOURCE using Guile taken from the native inputs, and with INPUTS."
   (define builder
     (with-imported-modules imported-modules
@@ -114,6 +115,7 @@
                       #:system system
                       #:target #f
                       #:graft? #f
+                      #:substitutable? substitutable?
                       #:guile-for-build guile)))
 
 (define* (guile-cross-build name
@@ -133,7 +135,8 @@
                             (compile-flags %compile-flags)
                             (imported-modules %guile-build-system-modules)
                             (modules '((guix build guile-build-system)
-                                       (guix build utils))))
+                                       (guix build utils)))
+                            (substitutable? #t))
   (define builder
     (with-imported-modules imported-modules
       #~(begin
@@ -173,6 +176,7 @@
                       #:system system
                       #:target target
                       #:graft? #f
+                      #:substitutable? substitutable?
                       #:guile-for-build guile)))
 
 (define guile-build-system
diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm
index 7c617bffb0..2d14016b94 100644
--- a/guix/build-system/meson.scm
+++ b/guix/build-system/meson.scm
@@ -182,6 +182,7 @@ TRIPLET."
                       (imported-modules %meson-build-system-modules)
                       (modules '((guix build meson-build-system)
                                  (guix build utils)))
+                      (substitutable? #t)
                       allowed-references
                       disallowed-references)
   "Build SOURCE using MESON, and with INPUTS, assuming that SOURCE
@@ -266,6 +267,7 @@ has a 'meson.build' file."
                             (imported-modules %meson-build-system-modules)
                             (modules '((guix build meson-build-system)
                                        (guix build utils)))
+                            (substitutable? #t)
                             allowed-references
                             disallowed-references)
   "Cross-build SOURCE for TARGET using MESON, and with INPUTS, assuming that
diff --git a/guix/build-system/vim.scm b/guix/build-system/vim.scm
index fa874a1e3d..dddf7ea14b 100644
--- a/guix/build-system/vim.scm
+++ b/guix/build-system/vim.scm
@@ -106,6 +106,13 @@
                     (install-plan ''())
                     (phases '(@ (guix build vim-build-system) %standard-phases))
                     (outputs '("out"))
+                    (out-of-source? #t)
+                    (tests? #t)
+                    (validate-runpath? #t)
+                    (patch-shebangs? #t)
+                    (strip-binaries? #t)
+                    (strip-flags %strip-flags)
+                    (strip-directories %strip-directories)
                     (search-paths '())
                     (system (%current-system))
                     (substitutable? #t)
@@ -135,8 +142,14 @@
                            #:search-paths '#$(sexp->gexp
                                                (map search-path-specification->sexp
                                                     search-paths))
-                           #:inputs
-                           %build-inputs)))))
+                           #:inputs %build-inputs
+                           #:out-of-source? #$out-of-source?
+                           #:tests? #$tests?
+                           #:validate-runpath? #$validate-runpath?
+                           #:patch-shebangs? #$patch-shebangs?
+                           #:strip-binaries? #$strip-binaries?
+                           #:strip-flags #$strip-flags
+                           #:strip-directories #$strip-directories)))))
 
   (mlet %store-monad
         ((guile (package->derivation (or guile (default-guile))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index b29b6f78b6..4afe6d2f87 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -2338,18 +2338,24 @@ always a positive integer."
   (terminal-dimension window-size-rows port (const 25)))
 
 (define terminal-string-width
-  (let ((mbstowcs (syscall->procedure int "mbstowcs" (list '* '* size_t)))
-        (wcswidth (syscall->procedure int "wcswidth" (list '* size_t))))
-    (lambda (str)
-      "Return the width of a string as it would be printed on the terminal.
+  (let ((mbstowcs (and=> (false-if-exception
+                          (dynamic-func "mbstowcs" (dynamic-link)))
+                         (cute pointer->procedure int <> (list '* '* size_t))))
+        (wcswidth (and=> (false-if-exception
+                          (dynamic-func "wcswidth" (dynamic-link)))
+                         (cute pointer->procedure int <> (list '* size_t)))))
+    (if (and mbstowcs wcswidth)
+        (lambda (str)
+          "Return the width of a string as it would be printed on the terminal.
 This procedure accounts for characters that have a different width than 1, such
 as CJK double-width characters."
-      (let ((wchar (make-bytevector (* (+ (string-length str) 1) 4))))
-        (mbstowcs (bytevector->pointer wchar)
-                  (string->pointer str)
-                  (string-length str))
-        (wcswidth (bytevector->pointer wchar)
-                  (string-length str))))))
+          (let ((wchar (make-bytevector (* (+ (string-length str) 1) 4))))
+            (mbstowcs (bytevector->pointer wchar)
+                      (string->pointer str)
+                      (string-length str))
+            (wcswidth (bytevector->pointer wchar)
+                      (string-length str))))
+        string-length)))                      ;using a statically-linked Guile
 
 (define openpty
   (let ((proc (syscall->procedure int "openpty" '(* * * * *)
diff --git a/guix/git.scm b/guix/git.scm
index 4377b27e00..cbcdb1904b 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com>
 ;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
@@ -29,7 +29,7 @@
   #:use-module (guix cache)
   #:use-module (gcrypt hash)
   #:use-module ((guix build utils)
-                #:select (mkdir-p delete-file-recursively))
+                #:select (mkdir-p delete-file-recursively invoke/quiet))
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix records)
@@ -38,8 +38,9 @@
   #:use-module (guix gexp)
   #:autoload   (guix git-download)
   (git-reference-url git-reference-commit git-reference-recursive?)
+  #:autoload   (guix config) (%git)
   #:use-module (guix sets)
-  #:use-module ((guix diagnostics) #:select (leave warning))
+  #:use-module ((guix diagnostics) #:select (leave warning info))
   #:use-module (guix progress)
   #:autoload   (guix swh) (swh-download commit-id?)
   #:use-module (rnrs bytevectors)
@@ -430,6 +431,35 @@ could not be fetched from Software Heritage~%")
     (rename-file directory trashed)
     (delete-file-recursively trashed)))
 
+(define (packs-in-git-repository directory)
+  "Return the number of pack files under DIRECTORY, a Git checkout."
+  (catch 'system-error
+    (lambda ()
+      (let ((directory (opendir (in-vicinity directory ".git/objects/pack"))))
+        (let loop ((count 0))
+          (match (readdir directory)
+            ((? eof-object?)
+             (closedir directory)
+             count)
+            (str
+             (loop (if (string-suffix? ".pack" str)
+                       (+ 1 count)
+                       count)))))))
+    (const 0)))
+
+(define (maybe-run-git-gc directory)
+  "Run 'git gc' in DIRECTORY if needed."
+  ;; XXX: As of libgit2 1.3.x (used by Guile-Git), there's no support for GC.
+  ;; Each time a checkout is pulled, a new pack is created, which eventually
+  ;; takes up a lot of space (lots of small, poorly-compressed packs).  As a
+  ;; workaround, shell out to 'git gc' when the number of packs in a
+  ;; repository has become "too large", potentially wasting a lot of space.
+  ;; See <https://issues.guix.gnu.org/65720>.
+  (when (> (packs-in-git-repository directory) 25)
+    (info (G_ "compressing cached Git repository at '~a'...~%")
+          directory)
+    (invoke/quiet %git "-C" directory "gc")))
+
 (define* (update-cached-checkout url
                                  #:key
                                  (ref '())
@@ -517,6 +547,9 @@ it unchanged."
                    seconds seconds
                    nanoseconds nanoseconds))))
 
+       ;; Run 'git gc' if needed.
+       (maybe-run-git-gc cache-directory)
+
        ;; When CACHE-DIRECTORY is a sub-directory of the default cache
        ;; directory, remove expired checkouts that are next to it.
        (let ((parent (dirname cache-directory)))
diff --git a/guix/packages.scm b/guix/packages.scm
index e2e82692ad..b768dddb5f 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -866,7 +866,11 @@ identifiers.  The result is inferred from the file names of patches."
       ("lzip"  ,(ref '(gnu packages compression) 'lzip))
       ("unzip" ,(ref '(gnu packages compression) 'unzip))
       ("patch" ,(ref '(gnu packages base) 'patch))
-      ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
+      ("locales"
+       ,(parameterize ((%current-target-system #f))
+          (canonical
+           ((module-ref (resolve-interface '(gnu packages base))
+                        'libc-utf8-locales-for-target))))))))
 
 (define (default-guile)
   "Return the default Guile package used to run the build code of
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 031f1f59c6..ccc96478aa 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1000,8 +1000,9 @@ MANIFEST."
     (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo))
   (define gzip                                    ;lazy reference
     (module-ref (resolve-interface '(gnu packages compression)) 'gzip))
-  (define glibc-utf8-locales                      ;lazy reference
-    (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
+  (define libc-utf8-locales-for-target            ;lazy reference
+    (module-ref (resolve-interface '(gnu packages base))
+                'libc-utf8-locales-for-target))
 
   (define build
     (with-imported-modules '((guix build utils))
@@ -1043,7 +1044,8 @@ MANIFEST."
 
           (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
           (setenv "GUIX_LOCPATH"
-                  #+(file-append glibc-utf8-locales "/lib/locale"))
+                  #+(file-append (libc-utf8-locales-for-target system)
+                                 "/lib/locale"))
 
           (mkdir-p (string-append #$output "/share/info"))
           (exit (every install-info
@@ -1124,8 +1126,9 @@ MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
   ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html>
   ;; for a discussion.
 
-  (define glibc-utf8-locales                      ;lazy reference
-    (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
+  (define libc-utf8-locales-for-target  ;lazy reference
+    (module-ref (resolve-interface '(gnu packages base))
+                'libc-utf8-locales-for-target))
 
   (define build
     (with-imported-modules '((guix build utils))
@@ -1159,9 +1162,11 @@ MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
           ;; Some file names in the NSS certificates are UTF-8 encoded so
           ;; install a UTF-8 locale.
           (setenv "LOCPATH"
-                  (string-append #+glibc-utf8-locales "/lib/locale/"
+                  (string-append #+(libc-utf8-locales-for-target system)
+                                 "/lib/locale/"
                                  #+(version-major+minor
-                                    (package-version glibc-utf8-locales))))
+                                    (package-version
+                                     (libc-utf8-locales-for-target system)))))
           (setlocale LC_ALL "en_US.utf8")
 
           (match (append-map ca-files '#$(manifest-inputs manifest))
@@ -1999,19 +2004,21 @@ are cross-built for TARGET."
                     (and (derivation? drv) (gexp-input drv)))
                   extras))
 
-    (define glibc-utf8-locales                    ;lazy reference
+    (define libc-utf8-locales-for-target ;lazy reference
       (module-ref (resolve-interface '(gnu packages base))
-                  'glibc-utf8-locales))
+                  'libc-utf8-locales-for-target))
 
     (define set-utf8-locale
       ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so
       ;; install a UTF-8 locale.
-      #~(begin
-          (setenv "LOCPATH"
-                  #$(file-append glibc-utf8-locales "/lib/locale/"
-                                 (version-major+minor
-                                  (package-version glibc-utf8-locales))))
-          (setlocale LC_ALL "en_US.utf8")))
+      (let ((locales (libc-utf8-locales-for-target
+                      (or system (%current-system)))))
+        #~(begin
+            (setenv "LOCPATH"
+                    #$(file-append locales "/lib/locale/"
+                                   (version-major+minor
+                                    (package-version locales))))
+            (setlocale LC_ALL "en_US.utf8"))))
 
     (define builder
       (with-imported-modules '((guix build profiles)
diff --git a/guix/progress.scm b/guix/progress.scm
index 13d3ddc171..e1b35094e1 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -21,8 +21,7 @@
 
 (define-module (guix progress)
   #:use-module (guix records)
-  #:use-module ((guix build syscalls)
-                #:select (terminal-string-width))
+  #:autoload   (guix build syscalls) (terminal-string-width)
   #:use-module (srfi srfi-19)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
diff --git a/guix/read-print.scm b/guix/read-print.scm
index 7faad82c94..690f5dacdd 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -330,6 +330,7 @@ expressions and blanks that were read."
    ('add-after '(((modify-phases) . 3)))
    ('add-before '(((modify-phases) . 3)))
    ('replace '(((modify-phases) . 2)))         ;different from 'modify-inputs'
+   ('parameterize 2)
    ('substitute* 2)
    ('substitute-keyword-arguments 2)
    ('call-with-input-file 2)
diff --git a/guix/scripts/locate.scm b/guix/scripts/locate.scm
index 92af3509bf..963ff2bf57 100644
--- a/guix/scripts/locate.scm
+++ b/guix/scripts/locate.scm
@@ -114,14 +114,24 @@ alter table Packages
 add column output text;
 ")))
 
+;; XXX: missing in guile-sqlite3@0.1.3
+(define SQLITE_BUSY 5)
+
 (define (call-with-database file proc)
-  (let ((db (sqlite-open file)))
-    (dynamic-wind
-      (lambda () #t)
-      (lambda ()
-        (ensure-latest-database-schema db)
-        (proc db))
-      (lambda () (sqlite-close db)))))
+  (catch 'sqlite-error
+    (lambda ()
+      (let ((db (sqlite-open file)))
+        (dynamic-wind
+          (lambda () #t)
+          (lambda ()
+            (ensure-latest-database-schema db)
+            (proc db))
+          (lambda () (sqlite-close db)))))
+    (lambda (key who code errmsg)
+      (if (= code SQLITE_BUSY)
+          (leave (G_ "~a: database is locked by another process~%")
+                 file)
+          (throw key who code errmsg)))))
 
 (define (ensure-latest-database-schema db)
   "Ensure DB follows the latest known version of the schema."
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index bdbea49910..8071840de1 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -137,7 +137,8 @@ dependencies are registered."
 
             ;; Make sure non-ASCII file names are properly handled.
             (setenv "GUIX_LOCPATH"
-                    #+(file-append glibc-utf8-locales "/lib/locale"))
+                    #+(file-append (libc-utf8-locales-for-target (%current-system))
+                                   "/lib/locale"))
             (setlocale LC_ALL "en_US.utf8")
 
             (sql-schema #$schema)
@@ -209,7 +210,10 @@ GLIBC-UT8-LOCALES package."
           (profile-locales? profile))
       #~(begin
           (setenv "GUIX_LOCPATH"
-                  #+(file-append glibc-utf8-locales "/lib/locale"))
+                  #+(file-append (let-system (system target)
+                                   (libc-utf8-locales-for-target
+                                    (or target system)))
+                                 "/lib/locale"))
           (setlocale LC_ALL "en_US.utf8"))
       #~(setenv "GUIX_LOCPATH" "unset for tests")))
 
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index 10ea110fee..0584a7e018 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -399,9 +399,16 @@ return #f and #f."
       ((('nesting? . #t) . rest)
        (loop rest system file (append specs '("nested guix"))))
       ((('load . ('package candidate)) . rest)
+       ;; This is 'guix shell -D -f guix.scm'.
        (if (and (not file) (null? specs))
            (loop rest system candidate specs)
            (values #f #f)))
+      ((('load . ('ad-hoc-package candidate)) . rest)
+       ;; When running 'guix shell -f guix.scm', one typically expects
+       ;; 'guix.scm' to be evaluated every time because it may contain
+       ;; references like (local-file "." #:recursive? #t).  Thus, disable
+       ;; caching.
+       (values #f #f))
       ((('manifest . candidate) . rest)
        (if (and (not file) (null? specs))
            (loop rest system candidate specs)
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index 145cd09881..211980dc1c 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -625,6 +625,8 @@ Update package definitions to the latest style.\n"))
                                    opts)))
             (unless (eq? format-package-definition style)
               (warning (G_ "'--styling' option has no effect in whole-file mode~%")))
+            (when (null? files)
+              (warning (G_ "no files specified, nothing to do~%")))
             (for-each format-whole-file files))
           (let ((packages (filter-map (match-lambda
                                         (('argument . spec)
diff --git a/guix/self.scm b/guix/self.scm
index a1f235659d..f378548959 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -73,7 +73,10 @@
       ("po4a"               . ,(ref 'gettext 'po4a))
       ("gettext-minimal"    . ,(ref 'gettext 'gettext-minimal))
       ("gcc-toolchain"      . ,(ref 'commencement 'gcc-toolchain))
-      ("glibc-utf8-locales" . ,(ref 'base 'glibc-utf8-locales))
+      ("glibc-utf8-locales" . ,(delay
+                                 ((module-ref (resolve-interface
+                                               '(gnu packages base))
+                                              'libc-utf8-locales-for-target))))
       ("graphviz"           . ,(ref 'graphviz 'graphviz-minimal))
       ("font-ghostscript"   . ,(ref 'ghostscript 'font-ghostscript))
       ("texinfo"            . ,(ref 'texinfo 'texinfo)))))