projects/guix·blob master · refs

90 lines · 3.3 KiB

1#! /bin/sh
2# -*-scheme-*-
3build_aux=$(dirname $0)
4srcdir=$build_aux/..
5export LC_ALL=en_US.UTF-8
6export TZ=UTC0
7exec guile --no-auto-compile -L $srcdir -C $srcdir -e main -s "$0" "$@"
8!#
9
10;;; GNU Guix --- Functional package management for GNU
11;;; Copyright © 2024 Janneke Nieuwenhuizen <[email protected]>
12;;;
13;;; This file is part of GNU Guix.
14;;;
15;;; This program is free software; you can redistribute it and/or modify it
16;;; under the terms of the GNU General Public License as published by
17;;; the Free Software Foundation; either version 3 of the License, or (at
18;;; your option) any later version.
19;;;
20;;; This program is distributed in the hope that it will be useful, but
21;;; WITHOUT ANY WARRANTY; without even the implied warranty of
22;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23;;; GNU General Public License for more details.
24;;;
25;;; You should have received a copy of the GNU General Public License
26;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
27
28;;;; Commentary:
29;;;
30;;; This script provides an xgettext wrapper to (re)set POT-Creation-Date from
31;;; a Git timestamp. Test doing something like:
32;;;
33;;; build-aux/xgettext.scm --files-from=po/guix/POTFILES.in --default-domain=test
34;;;
35;;;; Code:
36
37(use-modules (srfi srfi-1)
38 (srfi srfi-26)
39 (ice-9 curried-definitions)
40 (ice-9 match)
41 (ice-9 popen)
42 (ice-9 rdelim)
43 (guix build utils))
44
45(define ((option? name) option)
46 (string-prefix? name option))
47
48(define (get-option args name)
49 (let ((option (find (option? name) args)))
50 (and option
51 (substring option (string-length name)))))
52
53(define (pipe-command command)
54 (let* ((port (apply open-pipe* OPEN_READ command))
55 (output (read-string port)))
56 (close-port port)
57 output))
58
59
60;;;
61;;; Entry point.
62;;;
63(define (main args)
64 (fluid-set! %default-port-encoding #f)
65 (let* ((files-from (get-option args "--files-from="))
66 (default-domain (get-option args "--default-domain="))
67 (directory (or (get-option args "--directory=") "."))
68 (xgettext (or (get-option args "--xgettext=") "xgettext"))
69 (xgettext-args (filter (negate (option? "--xgettext=")) args))
70 (command (match xgettext-args
71 ((xgettext.scm args ...)
72 `(,xgettext ,@args))))
73 (result (apply system* command))
74 (status (/ result 256)))
75 (if (or (not (zero? status))
76 (not files-from))
77 (exit status)
78 (let* ((text (with-input-from-file files-from read-string))
79 (lines (string-split text #\newline))
80 (files (filter (negate (cute string-prefix? "#" <>)) lines))
81 (files (map (cute string-append directory "/" <>) files))
82 (git-command `("git" "log" "--pretty=format:%ci" "-n1" ,@files))
83 (timestamp (pipe-command git-command))
84 (source-date-epoch (or (getenv "SOURCE_DATE_EPOCH") "1"))
85 (timestamp (if (string-null? timestamp) source-date-epoch
86 timestamp))
87 (po-file (string-append default-domain ".po")))
88 (substitute* po-file
89 (("(\"POT-Creation-Date: )[^\\]*" all header)
90 (string-append header timestamp)))))))