summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/gnu.scm6
-rw-r--r--guix/build/cmake-build-system.scm10
-rw-r--r--guix/build/download.scm83
-rw-r--r--guix/build/glib-or-gtk-build-system.scm11
-rw-r--r--guix/build/gnu-build-system.scm36
-rw-r--r--guix/build/gnu-dist.scm17
-rw-r--r--guix/build/perl-build-system.scm16
-rw-r--r--guix/build/python-build-system.scm22
-rw-r--r--guix/build/ruby-build-system.scm16
-rw-r--r--guix/build/utils.scm142
-rw-r--r--guix/build/waf-build-system.scm13
-rw-r--r--guix/gexp.scm7
-rw-r--r--guix/packages.scm15
13 files changed, 264 insertions, 130 deletions
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index c675155a6a..c91ad2ee0c 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -278,6 +278,7 @@ standard packages used as implicit inputs of the GNU build system."
(strip-directories ''("lib" "lib64" "libexec"
"bin" "sbin"))
(phases '%standard-phases)
+ (locale "en_US.UTF-8")
(system (%current-system))
(imported-modules %default-modules)
(modules %default-modules)
@@ -328,6 +329,7 @@ are allowed to refer to."
#:search-paths ',(map search-path-specification->sexp
search-paths)
#:phases ,phases
+ #:locale ,locale
#:configure-flags ,configure-flags
#:make-flags ,make-flags
#:out-of-source? ,out-of-source?
@@ -410,6 +412,7 @@ is one of `host' or `target'."
(strip-directories ''("lib" "lib64" "libexec"
"bin" "sbin"))
(phases '%standard-phases)
+ (locale "en_US.UTF-8")
(system (%current-system))
(imported-modules '((guix build gnu-build-system)
(guix build utils)))
@@ -473,6 +476,7 @@ platform."
search-path-specification->sexp
native-search-paths)
#:phases ,phases
+ #:locale ,locale
#:configure-flags ,configure-flags
#:make-flags ,make-flags
#:out-of-source? ,out-of-source?
diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm
index 74b4f01425..08ae73ef8d 100644
--- a/guix/build/cmake-build-system.scm
+++ b/guix/build/cmake-build-system.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014 Andreas Enge <andreas@enge.fr>
;;;
@@ -57,6 +57,8 @@
"-DCMAKE_INSTALL_RPATH_USE_LINK_PATH=TRUE"
;; add (other) libraries of the project itself to rpath
,(string-append "-DCMAKE_INSTALL_RPATH=" out "/lib")
+ ;; enable verbose output from builds
+ "-DCMAKE_VERBOSE_MAKEFILE=ON"
,@configure-flags)))
(setenv "CMAKE_LIBRARY_PATH" (getenv "LIBRARY_PATH"))
(setenv "CMAKE_INCLUDE_PATH" (getenv "CPATH"))
@@ -72,9 +74,9 @@
(define %standard-phases
;; Everything is as with the GNU Build System except for the `configure'
;; and 'check' phases.
- (alist-replace 'configure configure
- (alist-replace 'check check
- gnu:%standard-phases)))
+ (modify-phases gnu:%standard-phases
+ (replace check check)
+ (replace configure configure)))
(define* (cmake-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index e8d61e0d92..a3105ad41d 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -26,6 +26,7 @@
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
@@ -42,24 +43,66 @@
;;;
;;; Code:
+(define %http-receive-buffer-size
+ ;; Size of the HTTP receive buffer.
+ 65536)
+
+(define (duration->seconds duration)
+ "Return the number of seconds represented by DURATION, a 'time-duration'
+object, as an inexact number."
+ (+ (time-second duration)
+ (/ (time-nanosecond duration) 1e9)))
+
+(define (throughput->string throughput)
+ "Given THROUGHPUT, measured in bytes per second, return a string
+representing it in a human-readable way."
+ (if (> throughput 3e6)
+ (format #f "~,2f MiB/s" (/ throughput (expt 2. 20)))
+ (format #f "~,0f KiB/s" (/ throughput 1024.0))))
+
(define* (progress-proc file size #:optional (log-port (current-output-port)))
"Return a procedure to show the progress of FILE's download, which is
SIZE byte long. The returned procedure is suitable for use as an
argument to `dump-port'. The progress report is written to LOG-PORT."
- (if (number? size)
- (lambda (transferred cont)
- (let ((% (* 100.0 (/ transferred size))))
- (display #\cr log-port)
- (format log-port "~a\t~5,1f% of ~,1f KiB"
- file % (/ size 1024.0))
- (flush-output-port log-port)
- (cont)))
- (lambda (transferred cont)
- (display #\cr log-port)
- (format log-port "~a\t~6,1f KiB transferred"
- file (/ transferred 1024.0))
- (flush-output-port log-port)
- (cont))))
+ ;; XXX: Because of <http://bugs.gnu.org/19939> this procedure is often not
+ ;; called as frequently as we'd like too; this is especially bad with Nginx
+ ;; on hydra.gnu.org, which returns whole nars as a single chunk.
+ (let ((start-time #f))
+ (let-syntax ((with-elapsed-time
+ (syntax-rules ()
+ ((_ elapsed body ...)
+ (let* ((now (current-time time-monotonic))
+ (elapsed (and start-time
+ (duration->seconds
+ (time-difference now
+ start-time)))))
+ (unless start-time
+ (set! start-time now))
+ body ...)))))
+ (if (number? size)
+ (lambda (transferred cont)
+ (with-elapsed-time elapsed
+ (let ((% (* 100.0 (/ transferred size)))
+ (throughput (if elapsed
+ (/ transferred elapsed)
+ 0)))
+ (display #\cr log-port)
+ (format log-port "~a\t~5,1f% of ~,1f KiB (~a)"
+ file % (/ size 1024.0)
+ (throughput->string throughput))
+ (flush-output-port log-port)
+ (cont))))
+ (lambda (transferred cont)
+ (with-elapsed-time elapsed
+ (let ((throughput (if elapsed
+ (/ transferred elapsed)
+ 0)))
+ (display #\cr log-port)
+ (format log-port "~a\t~6,1f KiB transferred (~a)"
+ file (/ transferred 1024.0)
+ (throughput->string throughput))
+ (flush-output-port log-port)
+ (cont))))))))
(define* (uri-abbreviation uri #:optional (max-length 42))
"If URI's string representation is larger than MAX-LENGTH, return an
@@ -92,7 +135,7 @@ abbreviation of URI showing the scheme, host, and basename of the file."
(call-with-output-file file
(lambda (out)
(dump-port in out
- #:buffer-size 65536 ; don't flood the log
+ #:buffer-size %http-receive-buffer-size
#:progress (progress-proc (uri-abbreviation uri) size))))
(ftp-close conn))
@@ -182,7 +225,7 @@ which is not available during bootstrap."
(connect s (addrinfo:addr ai))
;; Buffer input and output on this port.
- (setvbuf s _IOFBF)
+ (setvbuf s _IOFBF %http-receive-buffer-size)
(if (eq? 'https (uri-scheme uri))
(tls-wrap s (uri-host uri))
@@ -334,7 +377,7 @@ Return the resulting target URI."
(if (port? bv-or-port)
(begin
(dump-port bv-or-port p
- #:buffer-size 65536 ; don't flood the log
+ #:buffer-size %http-receive-buffer-size
#:progress (progress-proc (uri-abbreviation uri)
size))
(newline))
@@ -423,4 +466,8 @@ on success."
file url)
#f))))
+;;; Local Variables:
+;;; eval: (put 'with-elapsed-time 'scheme-indent-function 1)
+;;; End:
+
;;; download.scm ends here
diff --git a/guix/build/glib-or-gtk-build-system.scm b/guix/build/glib-or-gtk-build-system.scm
index 92e91bf7a5..c57bc3e731 100644
--- a/guix/build/glib-or-gtk-build-system.scm
+++ b/guix/build/glib-or-gtk-build-system.scm
@@ -239,13 +239,10 @@ needed."
outputs))
(define %standard-phases
- (alist-cons-after
- 'install 'glib-or-gtk-wrap wrap-all-programs
- (alist-cons-after
- 'install 'glib-or-gtk-icon-cache generate-icon-cache
- (alist-cons-after
- 'install 'glib-or-gtk-compile-schemas compile-glib-schemas
- gnu:%standard-phases))))
+ (modify-phases gnu:%standard-phases
+ (add-after install glib-or-gtk-compile-schemas compile-glib-schemas)
+ (add-after install glib-or-gtk-icon-cache generate-icon-cache)
+ (add-after install glib-or-gtk-wrap wrap-all-programs)))
(define* (glib-or-gtk-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 2880168273..5ae537150f 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -94,6 +94,33 @@
#t)
+(define* (install-locale #:key
+ (locale "en_US.UTF-8")
+ (locale-category LC_ALL)
+ #:allow-other-keys)
+ "Try to install LOCALE; emit a warning if that fails. The main goal is to
+use a UTF-8 locale so that Guile correctly interprets UTF-8 file names.
+
+This phase must typically happen after 'set-paths' so that $LOCPATH has a
+chance to be set."
+ (catch 'system-error
+ (lambda ()
+ (setlocale locale-category locale)
+
+ ;; While we're at it, pass it to sub-processes.
+ (setenv (locale-category->string locale-category) locale)
+
+ (format (current-error-port) "using '~a' locale for category ~s~%"
+ locale (locale-category->string locale-category))
+ #t)
+ (lambda args
+ ;; This is known to fail for instance in early bootstrap where locales
+ ;; are not available.
+ (format (current-error-port)
+ "warning: failed to install '~a' locale: ~a~%"
+ locale (strerror (system-error-errno args)))
+ #t)))
+
(define* (unpack #:key source #:allow-other-keys)
"Unpack SOURCE in the working directory, and change directory within the
source. When SOURCE is a directory, copy it in a sub-directory of the current
@@ -108,7 +135,9 @@ working directory."
(copy-recursively source "."
#:keep-mtime? #t)
#t)
- (and (zero? (system* "tar" "xvf" source))
+ (and (if (string-suffix? ".zip" source)
+ (zero? (system* "unzip" source))
+ (zero? (system* "tar" "xvf" source)))
(chdir (first-subdirectory ".")))))
;; See <http://bugs.gnu.org/17840>.
@@ -452,7 +481,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
;; Standard build phases, as a list of symbol/procedure pairs.
(let-syntax ((phases (syntax-rules ()
((_ p ...) `((p . ,p) ...)))))
- (phases set-paths unpack
+ (phases set-paths install-locale unpack
patch-usr-bin-file
patch-source-shebangs configure patch-generated-file-shebangs
build check install
@@ -470,6 +499,9 @@ in order. Return #t if all the PHASES succeeded, #f otherwise."
(setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF)
+ ;; Encoding/decoding errors shouldn't be silent.
+ (fluid-set! %default-port-conversion-strategy 'error)
+
;; The trick is to #:allow-other-keys everywhere, so that each procedure in
;; PHASES can pick the keyword arguments it's interested in.
(every (match-lambda
diff --git a/guix/build/gnu-dist.scm b/guix/build/gnu-dist.scm
index 562056b5f6..887b5e94e9 100644
--- a/guix/build/gnu-dist.scm
+++ b/guix/build/gnu-dist.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -82,14 +82,11 @@
(define %dist-phases
;; Phases for building a source tarball.
- (alist-replace
- 'unpack copy-source
- (alist-cons-before
- 'configure 'autoreconf autoreconf
- (alist-replace
- 'build build
- (alist-replace
- 'install install-dist
- (alist-delete 'strip %standard-phases))))))
+ (modify-phases %standard-phases
+ (delete strip)
+ (replace install install-dist)
+ (replace build build)
+ (add-before configure autoreconf autoreconf)
+ (replace unpack copy-source)))
;;; gnu-dist.scm ends here
diff --git a/guix/build/perl-build-system.scm b/guix/build/perl-build-system.scm
index 7eb944ccd1..9ca5353bb9 100644
--- a/guix/build/perl-build-system.scm
+++ b/guix/build/perl-build-system.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -71,15 +71,11 @@
(define %standard-phases
;; Everything is as with the GNU Build System except for the `configure',
;; `build', `check', and `install' phases.
- (alist-replace
- 'configure configure
- (alist-replace
- 'build build
- (alist-replace
- 'check check
- (alist-replace
- 'install install
- gnu:%standard-phases)))))
+ (modify-phases gnu:%standard-phases
+ (replace install install)
+ (replace check check)
+ (replace build build)
+ (replace configure configure)))
(define* (perl-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)
diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm
index 74ba0c765d..9f853134bd 100644
--- a/guix/build/python-build-system.scm
+++ b/guix/build/python-build-system.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
@@ -122,19 +122,13 @@ installed with setuptools."
(define %standard-phases
;; 'configure' and 'build' phases are not needed. Everything is done during
;; 'install'.
- (alist-cons-before
- 'strip 'rename-pth-file
- rename-pth-file
- (alist-cons-after
- 'install 'wrap
- wrap
- (alist-replace
- 'build build
- (alist-replace
- 'check check
- (alist-replace 'install install
- (alist-delete 'configure
- gnu:%standard-phases)))))))
+ (modify-phases gnu:%standard-phases
+ (delete configure)
+ (replace install install)
+ (replace check check)
+ (replace build build)
+ (add-after install wrap wrap)
+ (add-before strip rename-pth-file rename-pth-file)))
(define* (python-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm
index 4221295d88..1310c4a0b3 100644
--- a/guix/build/ruby-build-system.scm
+++ b/guix/build/ruby-build-system.scm
@@ -71,16 +71,12 @@ directory."
"--bindir" (string-append out "/bin")))))
(define %standard-phases
- (alist-cons-after
- 'unpack 'gitify gitify
- (alist-replace
- 'build build
- (alist-replace
- 'install install
- (alist-replace
- 'check check
- (alist-delete
- 'configure gnu:%standard-phases))))))
+ (modify-phases gnu:%standard-phases
+ (delete configure)
+ (add-after unpack gitify gitify)
+ (replace build build)
+ (replace install install)
+ (replace check check)))
(define* (ruby-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 4407f9af23..a5a6167a8c 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -21,6 +21,7 @@
(define-module (guix build utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-60)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
@@ -54,6 +55,7 @@
alist-cons-before
alist-cons-after
alist-replace
+ modify-phases
with-atomic-file-replacement
substitute
substitute*
@@ -64,7 +66,9 @@
patch-/usr/bin/file
fold-port-matches
remove-store-references
- wrap-program))
+ wrap-program
+
+ locale-category->string))
;;;
@@ -323,7 +327,7 @@ for under the directories designated by FILES. For example:
(list file)
'())))))
files))
- input-dirs))
+ (delete-duplicates input-dirs)))
(define (list->search-path-as-string lst separator)
(string-join lst separator))
@@ -423,6 +427,33 @@ An error is raised when no such pair exists."
((_ after ...)
(append before (alist-cons key value after))))))
+(define-syntax-rule (modify-phases phases mod-spec ...)
+ "Modify PHASES sequentially as per each MOD-SPEC, which may have one of the
+following forms:
+
+ (delete <old-phase-name>)
+ (replace <old-phase-name> <new-phase>)
+ (add-before <old-phase-name> <new-phase-name> <new-phase>)
+ (add-after <old-phase-name> <new-phase-name> <new-phase>)
+
+Where every <*-phase-name> is an automatically quoted symbol, and <new-phase>
+an expression evaluating to a procedure."
+ (let* ((phases* phases)
+ (phases* (%modify-phases phases* mod-spec))
+ ...)
+ phases*))
+
+(define-syntax %modify-phases
+ (syntax-rules (delete replace add-before add-after)
+ ((_ phases (delete old-phase-name))
+ (alist-delete 'old-phase-name phases))
+ ((_ phases (replace old-phase-name new-phase))
+ (alist-replace 'old-phase-name new-phase phases))
+ ((_ phases (add-before old-phase-name new-phase-name new-phase))
+ (alist-cons-before 'old-phase-name 'new-phase-name new-phase phases))
+ ((_ phases (add-after old-phase-name new-phase-name new-phase))
+ (alist-cons-after 'old-phase-name 'new-phase-name new-phase phases))))
+
;;;
;;; Text substitution (aka. sed).
@@ -557,22 +588,27 @@ match the terminating newline of a line."
(define* (dump-port in out
#:key (buffer-size 16384)
(progress (lambda (t k) (k))))
- "Read as much data as possible from IN and write it to OUT, using
-chunks of BUFFER-SIZE bytes. Call PROGRESS after each successful
-transfer of BUFFER-SIZE bytes or less, passing it the total number of
-bytes transferred and the continuation of the transfer as a thunk."
+ "Read as much data as possible from IN and write it to OUT, using chunks of
+BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful
+transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
+transferred and the continuation of the transfer as a thunk."
(define buffer
(make-bytevector buffer-size))
- (let loop ((total 0)
- (bytes (get-bytevector-n! in buffer 0 buffer-size)))
+ (define (loop total bytes)
(or (eof-object? bytes)
(let ((total (+ total bytes)))
(put-bytevector out buffer 0 bytes)
(progress total
(lambda ()
(loop total
- (get-bytevector-n! in buffer 0 buffer-size))))))))
+ (get-bytevector-n! in buffer 0 buffer-size)))))))
+
+ ;; Make sure PROGRESS is called when we start so that it can measure
+ ;; throughput.
+ (progress 0
+ (lambda ()
+ (loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))
(define (set-file-time file stat)
"Set the atime/mtime of FILE to that specified by STAT."
@@ -582,6 +618,14 @@ bytes transferred and the continuation of the transfer as a thunk."
(stat:atimensec stat)
(stat:mtimensec stat)))
+(define (get-char* p)
+ ;; We call it `get-char', but that's really a binary version
+ ;; thereof. (The real `get-char' cannot be used here because our
+ ;; bootstrap Guile is hacked to always use UTF-8.)
+ (match (get-u8 p)
+ ((? integer? x) (integer->char x))
+ (x x)))
+
(define patch-shebang
(let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
(lambda* (file
@@ -617,8 +661,8 @@ FILE are kept unchanged."
(call-with-ascii-input-file file
(lambda (p)
- (and (eq? #\# (read-char p))
- (eq? #\! (read-char p))
+ (and (eq? #\# (get-char* p))
+ (eq? #\! (get-char* p))
(let ((line (false-if-exception (read-line p))))
(and=> (and line (regexp-exec shebang-rx line))
(lambda (m)
@@ -668,16 +712,18 @@ When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged."
shell))
(let ((st (stat file)))
- (substitute* file
- (("^ *SHELL[[:blank:]]*:?=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)(.*)$"
- _ dir shell args)
- (let* ((old (string-append dir shell))
- (new (or (find-shell shell) old)))
- (unless (string=? new old)
- (format (current-error-port)
- "patch-makefile-SHELL: ~a: changing `SHELL' from `~a' to `~a'~%"
- file old new))
- (string-append "SHELL = " new args))))
+ ;; Consider FILE is using an 8-bit encoding to avoid errors.
+ (with-fluids ((%default-port-encoding #f))
+ (substitute* file
+ (("^ *SHELL[[:blank:]]*:?=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)(.*)$"
+ _ dir shell args)
+ (let* ((old (string-append dir shell))
+ (new (or (find-shell shell) old)))
+ (unless (string=? new old)
+ (format (current-error-port)
+ "patch-makefile-SHELL: ~a: changing `SHELL' from `~a' to `~a'~%"
+ file old new))
+ (string-append "SHELL = " new args)))))
(when keep-mtime?
(set-file-time file st))))
@@ -694,13 +740,15 @@ unchanged."
"patch-/usr/bin/file: warning: \
no replacement 'file' command, doing nothing~%")
(let ((st (stat file)))
- (substitute* file
- (("/usr/bin/file")
- (begin
- (format (current-error-port)
- "patch-/usr/bin/file: ~a: changing `~a' to `~a'~%"
- file "/usr/bin/file" file-command)
- file-command)))
+ ;; Consider FILE is using an 8-bit encoding to avoid errors.
+ (with-fluids ((%default-port-encoding #f))
+ (substitute* file
+ (("/usr/bin/file")
+ (begin
+ (format (current-error-port)
+ "patch-/usr/bin/file: ~a: changing `~a' to `~a'~%"
+ file "/usr/bin/file" file-command)
+ file-command))))
(when keep-mtime?
(set-file-time file st)))))
@@ -717,21 +765,13 @@ for each unmatched character."
(map char-set (string->list pattern))
pattern))
- (define (get-char p)
- ;; We call it `get-char', but that's really a binary version
- ;; thereof. (The real `get-char' cannot be used here because our
- ;; bootstrap Guile is hacked to always use UTF-8.)
- (match (get-u8 p)
- ((? integer? x) (integer->char x))
- (x x)))
-
;; Note: we're not really striving for performance here...
(let loop ((chars '())
(pattern initial-pattern)
(matched '())
(result init))
(cond ((null? chars)
- (loop (list (get-char port))
+ (loop (list (get-char* port))
pattern
matched
result))
@@ -816,7 +856,7 @@ contents:
#!location/of/bin/bash
export PATH=\"/gnu/.../bar/bin\"
export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/gnu/.../baz/certs:/qux/certs\"
- exec -a location/of/foo location/of/.foo-real \"$@\"
+ exec -a $0 location/of/.foo-real \"$@\"
This is useful for scripts that expect particular programs to be in $PATH, for
programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or
@@ -837,7 +877,7 @@ the previous wrapper."
(if (zero? number)
(let ((prog-real (string-append (dirname prog) "/."
(basename prog) "-real")))
- (copy-file prog prog-real)
+ (rename-file prog prog-real)
prog-real)
(wrapper-file-name number)))
@@ -870,11 +910,10 @@ the previous wrapper."
(with-output-to-file prog-tmp
(lambda ()
(format #t
- "#!~a~%~a~%exec -a \"~a\" \"~a\" \"$@\"~%"
+ "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%"
(which "bash")
(string-join (map export-variable vars)
"\n")
- (canonicalize-path prog)
(canonicalize-path target))))
(chmod prog-tmp #o755)
@@ -882,6 +921,27 @@ the previous wrapper."
(symlink wrapper prog-tmp)
(rename-file prog-tmp prog)))
+
+;;;
+;;; Locales.
+;;;
+
+(define (locale-category->string category)
+ "Return the name of locale category CATEGORY, one of the 'LC_' constants.
+If CATEGORY is a bitwise or of several 'LC_' constants, an approximation is
+returned."
+ (letrec-syntax ((convert (syntax-rules ()
+ ((_)
+ (number->string category))
+ ((_ first rest ...)
+ (if (= first category)
+ (symbol->string 'first)
+ (convert rest ...))))))
+ (convert LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE
+ LC_IDENTIFICATION LC_MEASUREMENT LC_MESSAGES LC_MONETARY
+ LC_NAME LC_NUMERIC LC_PAPER LC_TELEPHONE
+ LC_TIME)))
+
;;; Local Variables:
;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
;;; eval: (put 'call-with-ascii-input-file 'scheme-indent-function 1)
diff --git a/guix/build/waf-build-system.scm b/guix/build/waf-build-system.scm
index e64b51abc0..d172c5a836 100644
--- a/guix/build/waf-build-system.scm
+++ b/guix/build/waf-build-system.scm
@@ -69,14 +69,11 @@
(call-waf "install" params)))
(define %standard-phases
- (alist-replace
- 'configure configure
- (alist-replace
- 'build build
- (alist-replace
- 'check check
- (alist-replace 'install install
- gnu:%standard-phases)))))
+ (modify-phases gnu:%standard-phases
+ (replace configure configure)
+ (replace build build)
+ (replace check check)
+ (replace install install)))
(define* (waf-build #:key inputs (phases %standard-phases)
#:allow-other-keys #:rest args)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index a8349c7d6e..1e26342101 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -314,12 +314,13 @@ references."
(cons name result))
((? gexp? exp)
(append (gexp-outputs exp) result))
+ ((lst ...)
+ (fold-right add-reference-output result lst))
(_
result)))
- (fold-right add-reference-output
- '()
- (gexp-references exp)))
+ (delete-duplicates
+ (add-reference-output (gexp-references exp) '())))
(define* (gexp->sexp exp #:key
(system (%current-system))
diff --git a/guix/packages.scm b/guix/packages.scm
index 5b686a122f..fc5264673d 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -335,7 +335,8 @@ corresponds to the arguments expected by `set-path-environment-variable'."
("bzip2" ,(ref '(gnu packages compression) 'bzip2))
("gzip" ,(ref '(gnu packages compression) 'gzip))
("lzip" ,(ref '(gnu packages compression) 'lzip))
- ("patch" ,(ref '(gnu packages base) 'patch)))))
+ ("patch" ,(ref '(gnu packages base) 'patch))
+ ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
(define (default-guile)
"Return the default Guile package used to run the build code of
@@ -411,7 +412,11 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
(srfi srfi-1)
(guix build utils))
- (let ((out (assoc-ref %outputs "out"))
+ ;; Encoding/decoding errors shouldn't be silent.
+ (fluid-set! %default-port-conversion-strategy 'error)
+
+ (let ((locales (assoc-ref %build-inputs "locales"))
+ (out (assoc-ref %outputs "out"))
(xz (assoc-ref %build-inputs "xz"))
(decomp (assoc-ref %build-inputs ,decompression-type))
(source (assoc-ref %build-inputs "source"))
@@ -433,6 +438,12 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
(lambda (name)
(not (member name '("." "..")))))))
+ (when locales
+ ;; First of all, install a UTF-8 locale so that UTF-8 file names
+ ;; are correctly interpreted. During bootstrap, LOCALES is #f.
+ (setenv "LOCPATH" (string-append locales "/lib/locale"))
+ (setlocale LC_ALL "en_US.UTF-8"))
+
(setenv "PATH" (string-append xz "/bin" ":"
decomp "/bin"))
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-10 21:47:32 +0000