[bug#70169] [PATCH v2 07/12] maint: Use xgettext.scm wrapper to create .PO files reproducibly.

[Janneke Nieuwenhuizen <janneke@gnu.org>]

* build-aux/xgettext.scm: New script.
* po/guix/Makevars (XGETTEXT): Set it.
(XGETTEXT_OPTIONS): Add --xgettext option to `real' xgettext.
* po/packages/Makevars (XGETTEXT): Set it.
(XGETTEXT_OPTIONS): Add --xgettext option to `real' xgettext.

Change-Id: I71b6b843970090f765f46ac346b92a346560e3f0
---
 build-aux/xgettext.scm | 87 ++++++++++++++++++++++++++++++++++++++++++
 po/guix/Makevars       |  7 +++-
 po/packages/Makevars   | 10 ++++-
 3 files changed, 101 insertions(+), 3 deletions(-)
 create mode 100755 build-aux/xgettext.scm

diff --git a/build-aux/xgettext.scm b/build-aux/xgettext.scm
new file mode 100755
index 0000000000..e8a970f251
--- /dev/null
+++ b/build-aux/xgettext.scm
@@ -0,0 +1,87 @@
+#! /bin/sh
+# -*-scheme-*-
+build_aux=$(dirname $0)
+srcdir=$build_aux/..
+exec guile --no-auto-compile -L $srcdir -C $srcdir -e main -s "$0" "$@"
+!#
+
+;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This program is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;;; Commentary:
+;;;
+;;; This script provides an xgettext wrapper to (re)set POT-Creation-Date from
+;;; a Git timestamp.  Test doing something like:
+;;;
+;;; build-aux/xgettext.scm --files-from=po/guix/POTFILES.in --default-domain=test
+;;;
+;;;; Code:
+
+(use-modules (srfi srfi-1)
+             (srfi srfi-26)
+             (ice-9 curried-definitions)
+             (ice-9 match)
+             (ice-9 popen)
+             (ice-9 rdelim)
+             (guix build utils))
+
+(define ((option? name) option)
+  (string-prefix? name option))
+
+(define (get-option args name)
+  (let ((option (find (option? name) args)))
+    (and option
+         (substring option (string-length name)))))
+
+(define (pipe-command command)
+  (let* ((port (apply open-pipe* OPEN_READ command))
+         (output (read-string port)))
+    (close-port port)
+    output))
+
+\f
+;;;
+;;; Entry point.
+;;;
+(define (main args)
+  ;; Cater for being run in a container.
+  (setenv "LC_ALL" "en_US.UTF-8")
+  (setenv "TZ" "UTC0")
+  (fluid-set! %default-port-encoding #f)
+  (let* ((files-from (get-option args "--files-from="))
+         (default-domain (get-option args "--default-domain="))
+         (directory (or (get-option args "--directory=") "."))
+         (xgettext (or (get-option args "--xgettext=") "xgettext"))
+         (xgettext-args (filter (negate (option? "--xgettext=")) args))
+         (command (match xgettext-args
+                    ((xgettext.scm args ...)
+                     `(,xgettext ,@args))))
+         (result (apply system* command))
+         (status (/ result 256)))
+    (if (or (not (zero? status))
+            (not files-from))
+        (exit status)
+        (let* ((text (with-input-from-file files-from read-string))
+               (lines (string-split text #\newline))
+               (files (filter (negate (cute string-prefix? "#" <>)) lines))
+               (files (map (cute string-append directory "/" <>) files))
+               (git-command `("git" "log" "--pretty=format:%ci" "-n1" ,@files))
+               (timestamp (pipe-command git-command))
+               (po-file (string-append default-domain ".po")))
+          (when (string-null? timestamp)
+            (exit 1))
+          (substitute* po-file
+            (("(\"POT-Creation-Date: )[^\\]*" all header)
+             (string-append header timestamp)))))))
diff --git a/po/guix/Makevars b/po/guix/Makevars
index 88a4e8c7bc..4cfd0f431d 100644
--- a/po/guix/Makevars
+++ b/po/guix/Makevars
@@ -5,6 +5,10 @@ DOMAIN = guix
 subdir = po/guix
 top_builddir = ../..
 
+# We use our xgettext.scm wrapper to produce .PO files reproducibly using a
+# timestamp from Git.
+XGETTEXT:=$(top_srcdir)/build-aux/xgettext.scm
+
 # These options get passed to xgettext.  We want to catch standard
 # gettext uses, and SRFI-35 error condition messages.  In C++ code
 # we use 'n_' instead of the more usual 'N_' for no-ops.
@@ -14,7 +18,8 @@ XGETTEXT_OPTIONS =				\
   --keyword=message				\
   --keyword=description				\
   --keyword=synopsis				\
-  --keyword=n_
+  --keyword=n_					\
+  --xgettext=$(XGETTEXT_)
 
 COPYRIGHT_HOLDER = the authors of Guix (msgids)
 
diff --git a/po/packages/Makevars b/po/packages/Makevars
index 65912786d8..0ba4f1ba7e 100644
--- a/po/packages/Makevars
+++ b/po/packages/Makevars
@@ -6,12 +6,18 @@ DOMAIN = guix-packages
 subdir = po/packages
 top_builddir = ../..
 
+# We use our xgettext.scm wrapper to produce .PO files reproducibly using a
+# timestamp from Git.  The `real' xgettext is passed as an option to
+# xgettext.scm
+XGETTEXT:=$(top_srcdir)/build-aux/xgettext.scm
+
 # These options get passed to xgettext.  We want to catch exclusively package
 # synopses and descriptions.
 XGETTEXT_OPTIONS =				\
   --language=Scheme --from-code=UTF-8		\
-  --keyword=synopsis --keyword=description      \
-  --keyword=output-synopsis:2
+  --keyword=synopsis --keyword=description	\
+  --keyword=output-synopsis:2			\
+  --xgettext=$(XGETTEXT_)
 
 COPYRIGHT_HOLDER = the authors of Guix (msgids)
 
-- 
2.41.0