summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2017-12-05 23:41:30 +0100
committerMarius Bakke <mbakke@fastmail.com>2017-12-05 23:41:30 +0100
commit77181815ae70cf573b6fa390a4400b718835aa8a (patch)
tree731ccaaccc7a69ddc90f04bb71a6a39aa5f3be5a /guix
parente3f9406b7c4b3b1afe3dd6affb7f7898434d607a (diff)
parent35377cfa908340e51fd22af7369aef15499d4a36 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/scons.scm134
-rw-r--r--guix/build/compile.scm6
-rw-r--r--guix/build/profiles.scm2
-rw-r--r--guix/build/scons-build-system.scm65
-rw-r--r--guix/build/union.scm11
-rw-r--r--guix/gexp.scm55
-rw-r--r--guix/git.scm12
-rw-r--r--guix/gnu-maintenance.scm10
-rw-r--r--guix/packages.scm1
-rw-r--r--guix/profiles.scm147
-rw-r--r--guix/progress.scm69
-rw-r--r--guix/records.scm2
-rw-r--r--guix/scripts/environment.scm2
-rw-r--r--guix/scripts/lint.scm31
-rw-r--r--guix/scripts/offload.scm2
-rw-r--r--guix/scripts/package.scm4
-rw-r--r--guix/scripts/pull.scm8
-rw-r--r--guix/scripts/system.scm85
-rw-r--r--guix/scripts/weather.scm106
-rw-r--r--guix/ssh.scm2
-rw-r--r--guix/ui.scm50
-rw-r--r--guix/utils.scm5
-rw-r--r--guix/zlib.scm46
23 files changed, 596 insertions, 259 deletions
diff --git a/guix/build-system/scons.scm b/guix/build-system/scons.scm
new file mode 100644
index 0000000000..da09cc7ded
--- /dev/null
+++ b/guix/build-system/scons.scm
@@ -0,0 +1,134 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build-system scons)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (guix derivations)
+ #:use-module (guix search-paths)
+ #:use-module (guix build-system)
+ #:use-module (guix build-system gnu)
+ #:use-module (ice-9 match)
+ #:export (%scons-build-system-modules
+ scons-build
+ scons-build-system))
+
+;; Commentary:
+;;
+;; Standard build procedure for applications using SCons. This is implemented
+;; as an extension of 'gnu-build-system'.
+;;
+;; Code:
+
+(define %scons-build-system-modules
+ ;; Build-side modules imported by default.
+ `((guix build scons-build-system)
+ ,@%gnu-build-system-modules))
+
+(define (default-scons)
+ "Return the default SCons package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((python (resolve-interface '(gnu packages python))))
+ (module-ref python 'scons)))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs system target
+ (scons (default-scons))
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME."
+ (define private-keywords
+ '(#:source #:target #:scons #:inputs #:native-inputs))
+
+ (and (not target) ;XXX: no cross-compilation
+ (bag
+ (name name)
+ (system system)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+
+ ;; Keep the standard inputs of 'gnu-build-system'.
+ ,@(standard-packages)))
+ (build-inputs `(("scons" ,scons)
+ ,@native-inputs))
+ (outputs outputs)
+ (build scons-build)
+ (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (scons-build store name inputs
+ #:key
+ (tests? #t)
+ (scons-flags ''())
+ (test-target "test")
+ (phases '(@ (guix build scons-build-system)
+ %standard-phases))
+ (outputs '("out"))
+ (search-paths '())
+ (system (%current-system))
+ (guile #f)
+ (imported-modules %scons-build-system-modules)
+ (modules '((guix build scons-build-system)
+ (guix build utils))))
+ "Build SOURCE using SCons, and with INPUTS. This assumes that SOURCE
+provides a 'SConstruct' file as its build system."
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (scons-build #:name ,name
+ #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:scons-flags ,scons-flags
+ #:system ,system
+ #:test-target ,test-target
+ #:tests? ,tests?
+ #:phases ,phases
+ #:outputs %outputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:inputs %build-inputs)))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f ; the default
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:inputs inputs
+ #:system system
+ #:modules imported-modules
+ #:outputs outputs
+ #:guile-for-build guile-for-build))
+
+(define scons-build-system
+ (build-system
+ (name 'scons)
+ (description "The standard SCons build system")
+ (lower lower)))
+
+;;; scons.scm ends here
diff --git a/guix/build/compile.scm b/guix/build/compile.scm
index 8b5a2faf84..1bd8c60fe5 100644
--- a/guix/build/compile.scm
+++ b/guix/build/compile.scm
@@ -163,7 +163,11 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
;; compile files in parallel.
(compile #f)
- (n-par-for-each workers build files)
+ ;; XXX: Don't use too many workers to work around the insane memory
+ ;; requirements of the compiler in Guile 2.2.2:
+ ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>.
+ (n-par-for-each (min workers 8) build files)
+
(unless (zero? total)
(report-compilation #f total total)))))
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index 5c96fe9067..b4160fba1b 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -82,7 +82,7 @@ definitions for all the SEARCH-PATHS."
# for this profile. You may want to define the 'GUIX_PROFILE' environment
# variable to point to the \"visible\" name of the profile, like this:
#
-# GUIX_PROFILE=/path/to/profile \\
+# GUIX_PROFILE=/path/to/profile ; \\
# source /path/to/profile/etc/profile
#
# When GUIX_PROFILE is undefined, the various environment variables refer
diff --git a/guix/build/scons-build-system.scm b/guix/build/scons-build-system.scm
new file mode 100644
index 0000000000..a8760968d8
--- /dev/null
+++ b/guix/build/scons-build-system.scm
@@ -0,0 +1,65 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build scons-build-system)
+ #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build utils)
+ #:export (%standard-phases
+ scons-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the SCons build system.
+;;
+;; Code:
+
+(define* (build #:key outputs (scons-flags '()) (parallel-build? #t) #:allow-other-keys)
+ (let ((out (assoc-ref outputs "out")))
+ (mkdir-p out)
+ (zero? (apply system* "scons"
+ (append (if parallel-build?
+ (list "-j" (number->string
+ (parallel-job-count)))
+ (list))
+ scons-flags)))))
+
+(define* (check #:key tests? test-target (scons-flags '()) #:allow-other-keys)
+ "Run the test suite of a given SCons application."
+ (cond (tests?
+ (zero? (apply system* "scons" test-target scons-flags)))
+ (else
+ (format #t "test suite not run~%")
+ #t)))
+
+(define* (install #:key outputs (scons-flags '()) #:allow-other-keys)
+ "Install a given SCons application."
+ (zero? (apply system* "scons" "install" scons-flags)))
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (delete 'configure)
+ (replace 'build build)
+ (replace 'check check)
+ (replace 'install install)))
+
+(define* (scons-build #:key inputs (phases %standard-phases)
+ #:allow-other-keys #:rest args)
+ "Build a given SCons application, applying all of PHASES in order."
+ (apply gnu:gnu-build #:inputs inputs #:phases phases args))
+
+;;; scons-build-system.scm ends here
diff --git a/guix/build/union.scm b/guix/build/union.scm
index 18167fa3e3..256123c566 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
;;;
@@ -78,11 +78,12 @@ identical, #f otherwise."
(define* (union-build output inputs
#:key (log-port (current-error-port))
- (create-all-directories? #f))
+ (create-all-directories? #f)
+ (symlink symlink))
"Build in the OUTPUT directory a symlink tree that is the union of all the
-INPUTS. As a special case, if CREATE-ALL-DIRECTORIES?, creates the
-subdirectories in the output directory to make sure the caller can modify them
-later."
+INPUTS, using SYMLINK to create symlinks. As a special case, if
+CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to
+make sure the caller can modify them later."
(define (symlink* input output)
(format log-port "`~a' ~~> `~a'~%" input output)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index b9525603ee..1929947d95 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -564,6 +564,7 @@ names and file names suitable for the #:allowed-references argument to
allowed-references disallowed-references
leaked-env-vars
local-build? (substitutable? #t)
+ deprecation-warnings
(script-name (string-append name "-builder")))
"Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
derivation) on SYSTEM; EXP is stored in a file called SCRIPT-NAME. When
@@ -599,6 +600,9 @@ refer to. Any reference to another store item will lead to a build error.
Similarly for DISALLOWED-REFERENCES, which can list items that must not be
referenced by the outputs.
+DEPRECATION-WARNINGS determines whether to show deprecation warnings while
+compiling modules. It can be #f, #t, or 'detailed.
+
The other arguments are as for 'derivation'."
(define %modules
(delete-duplicates
@@ -648,7 +652,9 @@ The other arguments are as for 'derivation'."
(compiled-modules %modules
#:system system
#:module-path module-path
- #:guile guile-for-build)
+ #:guile guile-for-build
+ #:deprecation-warnings
+ deprecation-warnings)
(return #f)))
(graphs (if references-graphs
(lower-reference-graphs references-graphs
@@ -1023,7 +1029,8 @@ last one is created from the given <scheme-file> object."
#:key (name "module-import-compiled")
(system (%current-system))
(guile (%guile-for-build))
- (module-path %load-path))
+ (module-path %load-path)
+ (deprecation-warnings #f))
"Return a derivation that builds a tree containing the `.go' files
corresponding to MODULES. All the MODULES are built in a context where
they can refer to each other."
@@ -1073,7 +1080,15 @@ they can refer to each other."
(gexp->derivation name build
#:system system
#:guile-for-build guile
- #:local-build? #t)))
+ #:local-build? #t
+ #:env-vars
+ (case deprecation-warnings
+ ((#f)
+ '(("GUILE_WARN_DEPRECATED" . "no")))
+ ((detailed)
+ '(("GUILE_WARN_DEPRECATED" . "detailed")))
+ (else
+ '())))))
;;;
@@ -1081,10 +1096,12 @@ they can refer to each other."
;;;
(define (default-guile)
- ;; Lazily resolve 'guile-final'. This module must not refer to (gnu …)
+ ;; Lazily resolve 'guile-2.2' (not 'guile-final' because this is for
+ ;; programs returned by 'program-file' and we don't want to keep references
+ ;; to several Guile packages). This module must not refer to (gnu …)
;; modules directly, to avoid circular dependencies, hence this hack.
- (module-ref (resolve-interface '(gnu packages commencement))
- 'guile-final))
+ (module-ref (resolve-interface '(gnu packages guile))
+ 'guile-2.2))
(define (load-path-expression modules)
"Return as a monadic value a gexp that sets '%load-path' and
@@ -1204,13 +1221,30 @@ This yields an 'etc' directory containing these two files."
(ungexp target))))))
files))))))
-(define (directory-union name things)
+(define* (directory-union name things
+ #:key (copy? #f) (quiet? #f))
"Return a directory that is the union of THINGS, where THINGS is a list of
file-like objects denoting directories. For example:
(directory-union \"guile+emacs\" (list guile emacs))
-yields a directory that is the union of the 'guile' and 'emacs' packages."
+yields a directory that is the union of the 'guile' and 'emacs' packages.
+
+When HARD-LINKS? is true, create hard links instead of symlinks. When QUIET?
+is true, the derivation will not print anything."
+ (define symlink
+ (if copy?
+ (gexp (lambda (old new)
+ (if (file-is-directory? old)
+ (symlink old new)
+ (copy-file old new))))
+ (gexp symlink)))
+
+ (define log-port
+ (if quiet?
+ (gexp (%make-void-port "w"))
+ (gexp (current-error-port))))
+
(match things
((one)
;; Only one thing; return it.
@@ -1221,7 +1255,10 @@ yields a directory that is the union of the 'guile' and 'emacs' packages."
(gexp (begin
(use-modules (guix build union))
(union-build (ungexp output)
- '(ungexp things)))))))))
+ '(ungexp things)
+
+ #:log-port (ungexp log-port)
+ #:symlink (ungexp symlink)))))))))
;;;
diff --git a/guix/git.scm b/guix/git.scm
index 7a83b56216..fc41e2ace3 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -80,11 +80,17 @@ of SHA1 string."
"-" (string-take sha1 7)))
(define* (copy-to-store store cache-directory #:key url repository)
- "Copy items in cache-directory to store. URL and REPOSITORY are used
-to forge store directory name."
+ "Copy CACHE-DIRECTORY recursively to STORE. URL and REPOSITORY are used to
+create the store directory name."
+ (define (dot-git? file stat)
+ (and (string=? (basename file) ".git")
+ (eq? 'directory (stat:type stat))))
+
(let* ((commit (repository->head-sha1 repository))
(name (url+commit->name url commit)))
- (values (add-to-store store name #t "sha256" cache-directory) commit)))
+ (values (add-to-store store name #t "sha256" cache-directory
+ #:select? (negate dot-git?))
+ commit)))
(define (switch-to-ref repository ref)
"Switch to REPOSITORY's branch, commit or tag specified by REF."
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 0de36f2f71..00e80bc79f 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -335,9 +335,6 @@ return the corresponding signature URL, or #f it signatures are unavailable."
(if (version>? (upstream-source-version a) (upstream-source-version b))
a b))
- (define contains-digit?
- (cut string-any char-set:digit <>))
-
(define patch-directory-name?
;; Return #t for patch directory names such as 'bash-4.2-patches'.
(cut string-suffix? "patches" <>))
@@ -361,8 +358,7 @@ return the corresponding signature URL, or #f it signatures are unavailable."
(result #f))
(let* ((entries (ftp-list conn directory))
- ;; Filter out sub-directories that do not contain digits---e.g.,
- ;; /gnuzilla/lang and /gnupg/patches. Filter out "w32"
+ ;; Filter out things like /gnupg/patches. Filter out "w32"
;; directories as found on ftp.gnutls.org.
(subdirs (filter-map (match-lambda
(((? patch-directory-name? dir)
@@ -370,8 +366,8 @@ return the corresponding signature URL, or #f it signatures are unavailable."
#f)
(("w32" 'directory . _)
#f)
- (((? contains-digit? dir) 'directory . _)
- (and (keep-file? dir) dir))
+ ((directory 'directory . _)
+ directory)
(_ #f))
entries))
diff --git a/guix/packages.scm b/guix/packages.scm
index 35f9b685a3..d3f3cf0fdd 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -609,6 +609,7 @@ specifies modules in scope when evaluating SNIPPET."
(gexp->derivation name build
#:graft? #f
#:system system
+ #:deprecation-warnings #t ;to avoid a rebuild
#:guile-for-build guile-for-build))))
(define (transitive-inputs inputs)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 51c330b323..07fe2faa3c 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1118,82 +1118,80 @@ the entries in MANIFEST."
(module-ref (resolve-interface '(gnu packages man)) 'man-db))
(define build
- #~(begin
- (use-modules (guix build utils)
- (srfi srfi-1)
- (srfi srfi-19)
- (srfi srfi-26))
-
- (define entries
- (filter-map (lambda (directory)
- (let ((man (string-append directory "/share/man")))
- (and (directory-exists? man)
- man)))
- '#$(manifest-inputs manifest)))
-
- (define manpages-collection-dir
- (string-append (getenv "PWD") "/manpages-collection"))
-
- (define man-directory
- (string-append #$output "/share/man"))
-
- (define (get-manpage-tail-path manpage-path)
- (let ((index (string-contains manpage-path "/share/man/")))
- (unless index
- (error "Manual path doesn't contain \"/share/man/\":"
- manpage-path))
- (string-drop manpage-path (+ index (string-length "/share/man/")))))
-
- (define (populate-manpages-collection-dir entries)
- (let ((manpages (append-map (cut find-files <> #:stat stat) entries)))
- (for-each (lambda (manpage)
- (let* ((dest-file (string-append
- manpages-collection-dir "/"
- (get-manpage-tail-path manpage))))
- (mkdir-p (dirname dest-file))
- (catch 'system-error
- (lambda ()
- (symlink manpage dest-file))
- (lambda args
- ;; Different packages may contain the same
- ;; manpage. Simply ignore the symlink error.
- #t))))
- manpages)))
-
- (mkdir-p manpages-collection-dir)
- (populate-manpages-collection-dir entries)
-
- ;; Create a mandb config file which contains a custom made
- ;; manpath. The associated catpath is the location where the database
- ;; gets generated.
- (copy-file #+(file-append man-db "/etc/man_db.conf")
- "man_db.conf")
- (substitute* "man_db.conf"
- (("MANDB_MAP /usr/man /var/cache/man/fsstnd")
- (string-append "MANDB_MAP " manpages-collection-dir " "
- man-directory)))
-
- (mkdir-p man-directory)
- (setenv "MANPATH" (string-join entries ":"))
-
- (format #t "Creating manual page database for ~a packages... "
- (length entries))
- (force-output)
- (let* ((start-time (current-time))
- (exit-status (system* #+(file-append man-db "/bin/mandb")
- "--quiet" "--create"
- "-C" "man_db.conf"))
- (duration (time-difference (current-time) start-time)))
- (format #t "done in ~,3f s~%"
- (+ (time-second duration)
- (* (time-nanosecond duration) (expt 10 -9))))
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (srfi srfi-1)
+ (srfi srfi-19)
+ (srfi srfi-26))
+
+ (define entries
+ (filter-map (lambda (directory)
+ (let ((man (string-append directory "/share/man")))
+ (and (directory-exists? man)
+ man)))
+ '#$(manifest-inputs manifest)))
+
+ (define manpages-collection-dir
+ (string-append (getenv "PWD") "/manpages-collection"))
+
+ (define man-directory
+ (string-append #$output "/share/man"))
+
+ (define (get-manpage-tail-path manpage-path)
+ (let ((index (string-contains manpage-path "/share/man/")))
+ (unless index
+ (error "Manual path doesn't contain \"/share/man/\":"
+ manpage-path))
+ (string-drop manpage-path (+ index (string-length "/share/man/")))))
+
+ (define (populate-manpages-collection-dir entries)
+ (let ((manpages (append-map (cut find-files <> #:stat stat) entries)))
+ (for-each (lambda (manpage)
+ (let* ((dest-file (string-append
+ manpages-collection-dir "/"
+ (get-manpage-tail-path manpage))))
+ (mkdir-p (dirname dest-file))
+ (catch 'system-error
+ (lambda ()
+ (symlink manpage dest-file))
+ (lambda args
+ ;; Different packages may contain the same
+ ;; manpage. Simply ignore the symlink error.
+ #t))))
+ manpages)))
+
+ (mkdir-p manpages-collection-dir)
+ (populate-manpages-collection-dir entries)
+
+ ;; Create a mandb config file which contains a custom made
+ ;; manpath. The associated catpath is the location where the database
+ ;; gets generated.
+ (copy-file #+(file-append man-db "/etc/man_db.conf")
+ "man_db.conf")
+ (substitute* "man_db.conf"
+ (("MANDB_MAP /usr/man /var/cache/man/fsstnd")
+ (string-append "MANDB_MAP " manpages-collection-dir " "
+ man-directory)))
+
+ (mkdir-p man-directory)
+ (setenv "MANPATH" (string-join entries ":"))
+
+ (format #t "Creating manual page database for ~a packages... "
+ (length entries))
(force-output)
- (zero? exit-status))))
+ (let* ((start-time (current-time))
+ (exit-status (system* #+(file-append man-db "/bin/mandb")
+ "--quiet" "--create"
+ "-C" "man_db.conf"))
+ (duration (time-difference (current-time) start-time)))
+ (format #t "done in ~,3f s~%"
+ (+ (time-second duration)
+ (* (time-nanosecond duration) (expt 10 -9))))
+ (force-output)
+ (zero? exit-status)))))
(gexp->derivation "manual-database" build
- #:modules '((guix build utils)
- (srfi srfi-19)
- (srfi srfi-26))
#:local-build? #t))
(define %default-profile-hooks
@@ -1294,6 +1292,9 @@ are cross-built for TARGET."
#:system system
#:target target
+ ;; Don't complain about _IO* on Guile 2.2.
+ #:env-vars '(("GUILE_WARN_DEPRECATED" . "no"))
+
;; Not worth offloading.
#:local-build? #t
diff --git a/guix/progress.scm b/guix/progress.scm
index beca2c22a6..0ca5c08782 100644
--- a/guix/progress.scm
+++ b/guix/progress.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -30,8 +31,13 @@
progress-reporter?
call-with-progress-reporter
+ start-progress-reporter!
+ stop-progress-reporter!
+ progress-reporter-report!
+
progress-reporter/silent
progress-reporter/file
+ progress-reporter/bar
byte-count->string
current-terminal-columns
@@ -58,6 +64,24 @@ stopped."
(($ <progress-reporter> start report stop)
(dynamic-wind start (lambda () (proc report)) stop))))
+(define (start-progress-reporter! reporter)
+ "Low-level procedure to start REPORTER."
+ (match reporter
+ (($ <progress-reporter> start report stop)
+ (start))))
+
+(define (progress-reporter-report! reporter)
+ "Low-level procedure to lead REPORTER to emit a report."
+ (match reporter
+ (($ <progress-reporter> start report stop)
+ (report))))
+
+(define (stop-progress-reporter! reporter)
+ "Low-level procedure to stop REPORTER."
+ (match reporter
+ (($ <progress-reporter> start report stop)
+ (stop))))
+
(define progress-reporter/silent
(make-progress-reporter noop noop noop))
@@ -146,13 +170,19 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f."
(define* (progress-bar % #:optional (bar-width 20))
"Return % as a string representing an ASCII-art progress bar. The total
width of the bar is BAR-WIDTH."
- (let* ((fraction (/ % 100))
+ (let* ((bar-width (max 3 (- bar-width 2)))
+ (fraction (/ % 100))
(filled (inexact->exact (floor (* fraction bar-width))))
(empty (- bar-width filled)))
(format #f "[~a~a]"
(make-string filled #\#)
(make-string empty #\space))))
+(define (erase-in-line port)
+ "Write an ANSI erase-in-line sequence to PORT to erase the whole line and
+move the cursor to the beginning of the line."
+ (display "\r\x1b[K" port))
+
(define* (progress-reporter/file file size
#:optional (log-port (current-output-port))
#:key (abbreviation basename))
@@ -176,7 +206,7 @@ ABBREVIATION used to shorten FILE for display."
(byte-count->string throughput)
(seconds->string elapsed)
(progress-bar %) %)))
- (display "\r\x1b[K" log-port)
+ (erase-in-line log-port)
(display (string-pad-middle left right
(current-terminal-columns))
log-port)
@@ -188,7 +218,7 @@ ABBREVIATION used to shorten FILE for display."
(byte-count->string throughput)
(seconds->string elapsed)
(byte-count->string transferred))))
- (display "\r\x1b[K" log-port)
+ (erase-in-line log-port)
(display (string-pad-middle left right
(current-terminal-columns))
log-port)
@@ -206,6 +236,39 @@ ABBREVIATION used to shorten FILE for display."
;; Don't miss the last report.
(stop render))))
+(define* (progress-reporter/bar total
+ #:optional
+ (prefix "")
+ (port (current-error-port)))
+ "Return a reporter that shows a progress bar every time one of the TOTAL
+tasks is performed. Write PREFIX at the beginning of the line."
+ (define done 0)
+
+ (define (report-progress)
+ (set! done (+ 1 done))
+ (unless (> done total)
+ (let* ((ratio (* 100. (/ done total))))
+ (erase-in-line port)
+ (if (string-null? prefix)
+ (display (progress-bar ratio (current-terminal-columns)) port)
+ (let ((width (- (current-terminal-columns)
+ (string-length prefix) 3)))
+ (display prefix port)
+ (display " " port)
+ (display (progress-bar ratio width) port)))
+ (force-output port))))
+
+ (progress-reporter
+ (start (lambda ()
+ (set! done 0)))
+ (report report-progress)
+ (stop (lambda ()
+ (erase-in-line port)
+ (unless (string-null? prefix)
+ (display prefix port)
+ (newline port))
+ (force-output port)))))
+
;; TODO: replace '(@ (guix build utils) dump-port))'.
(define* (dump-port* in out
#:key (buffer-size 16384)
diff --git a/guix/records.scm b/guix/records.scm
index 1f00e16603..c02395f2ae 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -81,7 +81,7 @@ fields, and DELAYED is the list of identifiers of delayed fields."
(record-error 'name s "extraneous field initializers ~a"
unexpected)))
- #`(make-struct type 0
+ #`(make-struct/no-tail type
#,@(map (lambda (field index)
(or (field-inherited-value field)
(if (innate-field? field)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 0d69218338..e1b7feecfa 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -586,7 +586,7 @@ message if any test fails."
store
(if bootstrap?
%bootstrap-guile
- (canonical-package guile-2.0)))))
+ (canonical-package guile-2.2)))))
(run-with-store store
;; Containers need a Bourne shell at /bin/sh.
(mlet* %store-monad ((bash (environment-bash container?
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 8840b1acb5..1b43b0a63c 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -587,24 +587,49 @@ from ~a")
(package-home-page package))
'home-page)))))
+(define %distro-directory
+ (dirname (search-path %load-path "gnu.scm")))
+
(define (check-patch-file-names package)
"Emit a warning if the patches requires by PACKAGE are badly named or if the
patch could not be found."
(guard (c ((message-condition? c) ;raised by 'search-patch'
(emit-warning package (condition-message c)
'patch-file-names)))
+ (define patches
+ (or (and=> (package-source package) origin-patches)
+ '()))
+
(unless (every (match-lambda ;patch starts with package name?
((? string? patch)
(and=> (string-contains (basename patch)
(package-name package))
zero?))
(_ #f)) ;must be an <origin> or something like that.
- (or (and=> (package-source package) origin-patches)
- '()))
+ patches)
(emit-warning
package
(G_ "file names of patches should start with the package name")
- 'patch-file-names))))
+ 'patch-file-names))
+
+ ;; Check whether we're reaching tar's maximum file name length.
+ (let ((prefix (string-length %distro-directory))
+ (margin (string-length "guix-0.13.0-10-123456789/"))
+ (max 99))
+ (for-each (match-lambda
+ ((? string? patch)
+ (when (> (+ margin (if (string-prefix? %distro-directory
+ patch)
+ (- (string-length patch) prefix)
+ (string-length patch)))
+ max)
+ (emit-warning
+ package
+ (format #f (G_ "~a: file name is too long")
+ (basename patch))
+ 'patch-file-names)))
+ (_ #f))
+ patches))))
(define (escape-quotes str)
"Replace any quote character in STR by an escaped quote character."
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 6a2485a007..ebd0bf783d 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -118,7 +118,7 @@ determined."
(catch #t
(lambda ()
;; Avoid ABI incompatibility with the <build-machine> record.
- (set! %fresh-auto-compile #t)
+ ;; (set! %fresh-auto-compile #t)
(save-module-excursion
(lambda ()
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index f972ca2ef7..0a4a07ae2a 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -49,7 +49,7 @@
#:use-module (srfi srfi-37)
#:use-module (gnu packages)
#:autoload (gnu packages base) (canonical-package)
- #:autoload (gnu packages guile) (guile-2.0)
+ #:autoload (gnu packages guile) (guile-2.2)
#:autoload (gnu packages bootstrap) (%bootstrap-guile)
#:export (build-and-use-profile
delete-generations
@@ -918,5 +918,5 @@ processed, #f otherwise."
(%store)
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
- (canonical-package guile-2.0)))))
+ (canonical-package guile-2.2)))))
(process-actions (%store) opts)))))))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 2400198000..be0c168444 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -25,7 +25,6 @@
#:use-module (guix config)
#:use-module (guix packages)
#:use-module (guix derivations)
- #:use-module (guix download)
#:use-module (guix gexp)
#:use-module (guix grafts)
#:use-module (guix monads)
@@ -39,14 +38,9 @@
#:use-module ((gnu packages bootstrap)
#:select (%bootstrap-guile))
#:use-module ((gnu packages certs) #:select (le-certs))
- #:use-module (gnu packages compression)
- #:use-module (gnu packages gnupg)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
- #:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:export (guix-pull))
@@ -281,7 +275,7 @@ certificates~%"))
store
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
- (canonical-package guile-2.0)))))
+ (canonical-package guile-2.2)))))
(run-with-store store
(build-and-install checkout (config-directory)
#:commit commit
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index e50f1d8ac7..e2ff42693f 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -36,6 +36,8 @@
#:use-module (guix graph)
#:use-module (guix scripts graph)
#:use-module (guix build utils)
+ #:use-module (guix progress)
+ #:use-module ((guix build syscalls) #:select (terminal-columns))
#:use-module (gnu build install)
#:autoload (gnu build file-systems)
(find-partition-by-label find-partition-by-uuid)
@@ -107,47 +109,54 @@ BODY..., and restore them."
(store-lift topologically-sorted))
-(define* (copy-item item target
+(define* (copy-item item references target
#:key (log-port (current-error-port)))
- "Copy ITEM to the store under root directory TARGET and register it."
- (mlet* %store-monad ((refs (references* item)))
- (let ((dest (string-append target item))
- (state (string-append target "/var/guix")))
- (format log-port "copying '~a'...~%" item)
-
- ;; Remove DEST if it exists to make sure that (1) we do not fail badly
- ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and
- ;; (2) we end up with the right contents.
- (when (file-exists? dest)
- (delete-file-recursively dest))
-
- (copy-recursively item dest
- #:log (%make-void-port "w"))
-
- ;; Register ITEM; as a side-effect, it resets timestamps, etc.
- ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
- ;; reproducing the user's current settings; see
- ;; <http://bugs.gnu.org/18049>.
- (unless (register-path item
- #:prefix target
- #:state-directory state
- #:references refs)
- (leave (G_ "failed to register '~a' under '~a'~%")
- item target))
-
- (return #t))))
+ "Copy ITEM to the store under root directory TARGET and register it with
+REFERENCES as its set of references."
+ (let ((dest (string-append target item))
+ (state (string-append target "/var/guix")))
+ (format log-port "copying '~a'...~%" item)
+
+ ;; Remove DEST if it exists to make sure that (1) we do not fail badly
+ ;; while trying to overwrite it (see <http://bugs.gnu.org/20722>), and
+ ;; (2) we end up with the right contents.
+ (when (file-exists? dest)
+ (delete-file-recursively dest))
+
+ (copy-recursively item dest
+ #:log (%make-void-port "w"))
+
+ ;; Register ITEM; as a side-effect, it resets timestamps, etc.
+ ;; Explicitly use "TARGET/var/guix" as the state directory, to avoid
+ ;; reproducing the user's current settings; see
+ ;; <http://bugs.gnu.org/18049>.
+ (unless (register-path item
+ #:prefix target
+ #:state-directory state
+ #:references references)
+ (leave (G_ "failed to register '~a' under '~a'~%")
+ item target))))
(define* (copy-closure item target
#:key (log-port (current-error-port)))
"Copy ITEM and all its dependencies to the store under root directory
TARGET, and register them."
- (mlet* %store-monad ((refs (references* item))
- (to-copy (topologically-sorted*
- (delete-duplicates (cons item refs)
- string=?))))
- (sequence %store-monad
- (map (cut copy-item <> target #:log-port log-port)
- to-copy))))
+ (mlet* %store-monad ((to-copy (topologically-sorted* (list item)))
+ (refs (mapm %store-monad references* to-copy)))
+ (define progress-bar
+ (progress-reporter/bar (length to-copy)
+ (format #f (G_ "copying to '~a'...")
+ target)))
+
+ (call-with-progress-reporter progress-bar
+ (lambda (report)
+ (let ((void (%make-void-port "w")))
+ (for-each (lambda (item refs)
+ (copy-item item refs target #:log-port void)
+ (report))
+ to-copy refs))))
+
+ (return *unspecified*)))
(define* (install-bootloader installer-drv
#:key
@@ -667,7 +676,8 @@ and TARGET arguments."
(gexp->file "bootloader-installer"
(with-imported-modules '((guix build utils))
#~(begin
- (use-modules (guix build utils))
+ (use-modules (guix build utils)
+ (ice-9 binary-ports))
(#$installer #$bootloader #$device #$target))))))
(define* (perform-action action os
@@ -1095,7 +1105,8 @@ argument list and OPTS is the option alist."
parse-sub-command))
(args (option-arguments opts))
(command (assoc-ref opts 'action)))
- (parameterize ((%graft? (assoc-ref opts 'graft?)))
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (current-terminal-columns (terminal-columns)))
(process-command command args opts)))))
;;; Local Variables:
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 0d4a7fa26b..2e782e36ce 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -23,10 +23,11 @@
#:use-module (guix packages)
#:use-module (guix profiles)
#:use-module (guix derivations)
+ #:use-module (guix progress)
#:use-module (guix monads)
#:use-module (guix store)
#:use-module (guix grafts)
- #:use-module (guix build syscalls)
+ #:use-module ((guix build syscalls) #:select (terminal-columns))
#:use-module (guix scripts substitute)
#:use-module (gnu packages)
#:use-module (web uri)
@@ -48,42 +49,38 @@
(cons package result))))
'()))
+(define (call-with-progress-reporter reporter proc)
+ "This is a variant of 'call-with-progress-reporter' that works with monadic
+scope."
+ ;; TODO: Move to a more appropriate place.
+ (with-monad %store-monad
+ (start-progress-reporter! reporter)
+ (mlet* %store-monad ((report -> (lambda ()
+ (progress-reporter-report! reporter)))
+ (result (proc report)))
+ (stop-progress-reporter! reporter)
+ (return result))))
+
(define* (package-outputs packages
#:optional (system (%current-system)))
"Return the list of outputs of all of PACKAGES for the given SYSTEM."
(let ((packages (filter (cut supported-package? <> system) packages)))
-
- (define update-progress!
- (let ((total (length packages))
- (done 0)
- (width (max 10 (- (terminal-columns) 10))))
- (lambda ()
- (set! done (+ 1 done))
- (let* ((ratio (/ done total 1.))
- (done (inexact->exact (round (* width ratio))))
- (left (- width done)))
- (format (current-error-port) "~5,1f% [~a~a]\r"
- (* ratio 100.)
- (make-string done #\#)
- (make-string left #\space))
- (when (>= done total)
- (newline (current-error-port)))
- (force-output (current-error-port))))))
-
(format (current-error-port)
(G_ "computing ~h package derivations for ~a...~%")
(length packages) system)
- (foldm %store-monad
- (lambda (package result)
- (mlet %store-monad ((drv (package->derivation package system
- #:graft? #f)))
- (update-progress!)
- (match (derivation->output-paths drv)
- (((names . items) ...)
- (return (append items result))))))
- '()
- packages)))
+ (call-with-progress-reporter (progress-reporter/bar (length packages))
+ (lambda (report)
+ (foldm %store-monad
+ (lambda (package result)
+ (mlet %store-monad ((drv (package->derivation package system
+ #:graft? #f)))
+ (report)
+ (match (derivation->output-paths drv)
+ (((names . items) ...)
+ (return (append items result))))))
+ '()
+ packages)))))
(cond-expand
(guile-2.2
@@ -204,31 +201,32 @@ Report the availability of substitutes.\n"))
(define (guix-weather . args)
(with-error-handling
- (let* ((opts (parse-command-line args %options
- (list %default-options)
- #:build-options? #f))
- (urls (assoc-ref opts 'substitute-urls))
- (systems (match (filter-map (match-lambda
- (('system . system) system)
- (_ #f))
- opts)
- (() (list (%current-system)))
- (systems systems)))
- (packages (let ((file (assoc-ref opts 'manifest)))
- (if file
- (load-manifest file)
- (all-packages))))
- (items (with-store store
- (parameterize ((%graft? #f))
- (concatenate
- (run-with-store store
- (mapm %store-monad
- (lambda (system)
- (package-outputs packages system))
- systems)))))))
- (for-each (lambda (server)
- (report-server-coverage server items))
- urls))))
+ (parameterize ((current-terminal-columns (terminal-columns)))
+ (let* ((opts (parse-command-line args %options
+ (list %default-options)
+ #:build-options? #f))
+ (urls (assoc-ref opts 'substitute-urls))
+ (systems (match (filter-map (match-lambda
+ (('system . system) system)
+ (_ #f))
+ opts)
+ (() (list (%current-system)))
+ (systems systems)))
+ (packages (let ((file (assoc-ref opts 'manifest)))
+ (if file
+ (load-manifest file)
+ (all-packages))))
+ (items (with-store store
+ (parameterize ((%graft? #f))
+ (concatenate
+ (run-with-store store
+ (mapm %store-monad
+ (lambda (system)
+ (package-outputs packages system))
+ systems)))))))
+ (for-each (lambda (server)
+ (report-server-coverage server items))
+ urls)))))
;;; Local Variables:
;;; eval: (put 'let/time 'scheme-indent-function 1)
diff --git a/guix/ssh.scm b/guix/ssh.scm
index 32cf6e464b..7b33ef5a3b 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -18,7 +18,7 @@
(define-module (guix ssh)
#:use-module (guix store)
- #:use-module ((guix ui) #:select (G_ N_))
+ #:use-module (guix i18n)
#:use-module (ssh session)
#:use-module (ssh auth)
#:use-module (ssh key)
diff --git a/guix/ui.scm b/guix/ui.scm
index 0fc5ab63ad..e40fe576ba 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -28,6 +28,7 @@
(define-module (guix ui)
#:use-module (guix i18n)
#:use-module (guix gexp)
+ #:use-module (guix sets)
#:use-module (guix utils)
#:use-module (guix store)
#:use-module (guix config)
@@ -194,7 +195,7 @@ messages."
(catch #t
(lambda ()
;; XXX: Force a recompilation to avoid ABI issues.
- (set! %fresh-auto-compile #t)
+ ;; (set! %fresh-auto-compile #t)
(set! %load-should-auto-compile #t)
(save-module-excursion
@@ -253,8 +254,9 @@ VARIABLE and return it, or #f if none was found."
(_ #t)))
(_ #f)))
- (let loop ((modules (list (resolve-module '() #f #f #:ensure #f)))
- (suggestions '()))
+ (let loop ((modules (list (resolve-module '() #f #f #:ensure #f)))
+ (suggestions '())
+ (visited (setq)))
(match modules
(()
;; Pick the "best" suggestion.
@@ -262,16 +264,19 @@ VARIABLE and return it, or #f if none was found."
(() #f)
((first _ ...) first)))
((head tail ...)
- (let ((next (append tail
- (hash-map->list (lambda (name module)
- module)
- (module-submodules head)))))
- (match (module-local-variable head variable)
- (#f (loop next suggestions))
- (_
- (match (module-name head)
- (('gnu _ ...) head) ;must be that one
- (_ (loop next (cons head suggestions)))))))))))
+ (if (set-contains? visited head)
+ (loop tail suggestions visited)
+ (let ((visited (set-insert head visited))
+ (next (append tail
+ (hash-map->list (lambda (name module)
+ module)
+ (module-submodules head)))))
+ (match (module-local-variable head variable)
+ (#f (loop next suggestions visited))
+ (_
+ (match (module-name head)
+ (('gnu _ ...) head) ;must be that one
+ (_ (loop next (cons head suggestions) visited)))))))))))
(define* (display-hint message #:optional (port (current-error-port)))
"Display MESSAGE, a l10n message possibly containing Texinfo markup, to
@@ -308,7 +313,7 @@ ARGS is the list of arguments received by the 'throw' handler."
(#f
(display-hint (G_ "Did you forget a @code{use-modules} form?")))
(module
- (display-hint (format #f (G_ "Try adding @code{(use-modules ~a)}.")
+ (display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?")
(module-name module))))))
(('srfi-34 obj)
(if (message-condition? obj)
@@ -545,19 +550,24 @@ interpreted."
(manifest-entry-version parent))
(report-parent-entries parent))))
- (report-error (G_ "profile contains conflicting entries for ~a:~a~%")
+ (define (manifest-entry-output* entry)
+ (match (manifest-entry-output entry)
+ ("out" "")
+ (output (string-append ":" output))))
+
+ (report-error (G_ "profile contains conflicting entries for ~a~a~%")
(manifest-entry-name entry)
- (manifest-entry-output entry))
- (report-error (G_ " first entry: ~a@~a:~a ~a~%")
+ (manifest-entry-output* entry))
+ (report-error (G_ " first entry: ~a@~a~a ~a~%")
(manifest-entry-name entry)
(manifest-entry-version entry)
- (manifest-entry-output entry)
+ (manifest-entry-output* entry)
(manifest-entry-item entry))
(report-parent-entries entry)
- (report-error (G_ " second entry: ~a@~a:~a ~a~%")
+ (report-error (G_ " second entry: ~a@~a~a ~a~%")
(manifest-entry-name conflict)
(manifest-entry-version conflict)
- (manifest-entry-output conflict)
+ (manifest-entry-output* conflict)
(manifest-entry-item conflict))
(report-parent-entries conflict)
(exit 1)))
diff --git a/guix/utils.scm b/guix/utils.scm
index c0ffed172a..fed31f4ca4 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -6,6 +6,7 @@
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -75,6 +76,7 @@
%current-target-system
package-name->name+version
target-mingw?
+ target-arm32?
version-compare
version>?
version>=?
@@ -467,6 +469,9 @@ a character other than '@'."
(and target
(string-suffix? "-mingw32" target)))
+(define (target-arm32?)
+ (string-prefix? "arm" (or (%current-target-system) (%current-system))))
+
(define version-compare
(let ((strverscmp
(let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
diff --git a/guix/zlib.scm b/guix/zlib.scm
index 955589ab48..3bd0ad86c9 100644
--- a/guix/zlib.scm
+++ b/guix/zlib.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -149,31 +149,6 @@ the number of uncompressed bytes written, a strictly positive integer."
;; Z_DEFAULT_COMPRESSION.
-1)
-(define (close-procedure gzfile port)
- "Return a procedure that closes GZFILE, ensuring its underlying PORT is
-closed even if closing GZFILE triggers an exception."
- (let-syntax ((ignore-EBADF
- (syntax-rules ()
- ((_ exp)
- (catch 'system-error
- (lambda ()
- exp)
- (lambda args
- (unless (= EBADF (system-error-errno args))
- (apply throw args))))))))
-
- (lambda ()
- (catch 'zlib-error
- (lambda ()
- ;; 'gzclose' closes the underlying file descriptor. 'close-port'
- ;; calls close(2) and gets EBADF, which we swallow.
- (gzclose gzfile)
- (ignore-EBADF (close-port port)))
- (lambda args
- ;; Make sure PORT is closed despite the zlib error.
- (ignore-EBADF (close-port port))
- (apply throw args))))))
-
(define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size))
"Return an input port that decompresses data read from PORT, a file port.
PORT is automatically closed when the resulting port is closed. BUFFER-SIZE
@@ -183,7 +158,14 @@ buffered input, which would be lost (and is lost anyway)."
(define gzfile
(match (drain-input port)
("" ;PORT's buffer is empty
- (gzdopen (fileno port) "r"))
+ ;; 'gzclose' will eventually close the file descriptor beneath PORT.
+ ;; 'close-port' on PORT would get EBADF if 'gzclose' already closed it,
+ ;; so that's no good; revealed ports are no good either because they
+ ;; leak (see <https://bugs.gnu.org/28784>); calling 'close-port' after
+ ;; 'gzclose' doesn't work either because it leads to a race condition
+ ;; (see <https://bugs.gnu.org/29335>). So we dup and close PORT right
+ ;; away.
+ (gzdopen (dup (fileno port)) "r"))
(_
;; This is unrecoverable but it's better than having the buffered input
;; be lost, leading to unclear end-of-file or corrupt-data errors down
@@ -197,8 +179,10 @@ buffered input, which would be lost (and is lost anyway)."
(unless (= buffer-size %default-buffer-size)
(gzbuffer! gzfile buffer-size))
+ (close-port port) ;we no longer need it
(make-custom-binary-input-port "gzip-input" read! #f #f
- (close-procedure gzfile port)))
+ (lambda ()
+ (gzclose gzfile))))
(define* (make-gzip-output-port port
#:key
@@ -210,7 +194,7 @@ port is closed."
(define gzfile
(begin
(force-output port) ;empty PORT's buffer
- (gzdopen (fileno port)
+ (gzdopen (dup (fileno port))
(string-append "w" (number->string level)))))
(define (write! bv start count)
@@ -219,8 +203,10 @@ port is closed."
(unless (= buffer-size %default-buffer-size)
(gzbuffer! gzfile buffer-size))
+ (close-port port)
(make-custom-binary-output-port "gzip-output" write! #f #f
- (close-procedure gzfile port)))
+ (lambda ()
+ (gzclose gzfile))))
(define* (call-with-gzip-input-port port proc
#:key (buffer-size %default-buffer-size))