From 9d1d434cd07d8a0372b113c2c0efacd2eb6e258a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 13 Dec 2012 23:38:32 +0100 Subject: build-system/gnu: Avoid using /bin/sh. * guix/build/gnu-build-system.scm (configure): Add `inputs' keyword parameter. Take Bash from there, falling back to /bin/sh. Set `CONFIG_SHELL' and `SHELL' to that Bash. Run "bash ./configure" instead of just "./configure". * distro/packages/bootstrap.scm (%bootstrap-inputs): Add "bash". * distro/packages/base.scm (gcc-boot0-wrapped): Use "bash" from %BOOT1-INPUTS instead of /bin/sh. --- guix/build/gnu-build-system.scm | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 2b7d1c180e..efee570292 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -90,12 +90,17 @@ (append patch-flags (list "--input" p))))) patches)) -(define* (configure #:key outputs (configure-flags '()) out-of-source? +(define* (configure #:key inputs outputs (configure-flags '()) out-of-source? #:allow-other-keys) (let* ((prefix (assoc-ref outputs "out")) (libdir (assoc-ref outputs "lib")) (includedir (assoc-ref outputs "include")) - (flags `(,(string-append "--prefix=" prefix) + (bash (or (and=> (assoc-ref inputs "bash") + (cut string-append <> "/bin/bash")) + "/bin/sh")) + (flags `(,(string-append "CONFIG_SHELL=" bash) + ,(string-append "SHELL=" bash) + ,(string-append "--prefix=" prefix) "--enable-fast-install" ; when using Libtool ;; Produce multiple outputs when specific output names @@ -121,10 +126,15 @@ (format #t "build directory: ~s~%" (getcwd)) (format #t "configure flags: ~s~%" flags) + ;; Use BASH to reduce reliance on /bin/sh since it may not always be + ;; reliable (see + ;; + ;; for a summary of the situation.) + ;; ;; Call `configure' with a relative path. Otherwise, GCC's build system ;; (for instance) records absolute source file names, which typically ;; contain the hash part of the `.drv' file, leading to a reference leak. - (zero? (apply system* + (zero? (apply system* bash (string-append srcdir "/configure") flags)))) -- cgit v1.2.3 From 74baf333bf591cf3c91447d912d200783472d913 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 15 Dec 2012 15:54:29 +0100 Subject: utils: Make the buffer size of `dump-port' a parameter. * guix/build/utils.scm (dump-port): Make `buffer-size' a keyword parameter. --- guix/build/utils.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 8ae190f656..8f0eb66d39 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -364,9 +364,9 @@ all subject to the substitutions." ;;; Patching shebangs---e.g., /bin/sh -> /nix/store/xyz...-bash/bin/sh. ;;; -(define (dump-port in out) - "Read as much data as possible from IN and write it to OUT." - (define buffer-size 4096) +(define* (dump-port in out #:key (buffer-size 16384)) + "Read as much data as possible from IN and write it to OUT, using +chunks of BUFFER-SIZE bytes." (define buffer (make-bytevector buffer-size)) -- cgit v1.2.3 From c1c94acf3206a086358e2ea39aa011c8299d29e5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 15 Dec 2012 16:01:52 +0100 Subject: build-system/gnu: Make the error port line-buffered. * guix/build/gnu-build-system.scm (gnu-build): Make the error port line-buffered. --- guix/build/gnu-build-system.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index efee570292..3b139a99b8 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -242,6 +242,7 @@ "Build from SOURCE to OUTPUTS, using INPUTS, and by running all of PHASES in order. Return #t if all the PHASES succeeded, #f otherwise." (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) ;; The trick is to #:allow-other-keys everywhere, so that each procedure in ;; PHASES can pick the keyword arguments it's interested in. -- cgit v1.2.3 From d008415219df27f0b0ab000ceed12226183cd9b2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 15 Dec 2012 16:35:26 +0100 Subject: build-system/gnu: Patch shebangs in executable source files. This allows many packages to build in a chroot that lacks /bin and thus /bin/sh. * guix/build/gnu-build-system.scm (patch-source-shebangs): New procedure. (%standard-phases): Add it. * guix/build/utils.scm (executable-file?): New procedure. * distro/packages/perl.scm (perl): Don't use /bin/sh to run `Configure'. --- distro/packages/perl.scm | 2 +- guix/build/gnu-build-system.scm | 21 ++++++++++++++++++++- guix/build/utils.scm | 7 +++++++ 3 files changed, 28 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/distro/packages/perl.scm b/distro/packages/perl.scm index b17342f7ad..26b25b154d 100644 --- a/distro/packages/perl.scm +++ b/distro/packages/perl.scm @@ -55,7 +55,7 @@ (("/bin/pwd") pwd)) (zero? - (system* "/bin/sh" "./Configure" + (system* "./Configure" (string-append "-Dprefix=" out) (string-append "-Dman1dir=" out "/share/man/man1") (string-append "-Dman3dir=" out "/share/man/man3") diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 3b139a99b8..b67918552c 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -82,6 +82,24 @@ (and (zero? (system* "tar" "xvf" source)) (chdir (first-subdirectory ".")))) +(define* (patch-source-shebangs #:key source #:allow-other-keys) + ;; Patch shebangs in executable source files. Most scripts honor + ;; $SHELL and $CONFIG_SHELL, but some don't, such as `mkinstalldirs' + ;; or Automake's `missing' script. + (for-each patch-shebang + (filter (lambda (file) + (and (executable-file? file) + (not (file-is-directory? file)))) + (find-files "." ".*"))) + + ;; Gettext-generated po/Makefile.in.in does not honor $SHELL. + (let ((bash (search-path (search-path-as-string->list (getenv "PATH")) + "bash"))) + (when (file-exists? "po/Makefile.in.in") + (substitute* "po/Makefile.in.in" + (("^SHELL[[:blank:]]*=.*$") + (string-append "SHELL = " bash)))))) + (define* (patch #:key (patches '()) (patch-flags '("--batch" "-p1")) #:allow-other-keys) (every (lambda (p) @@ -231,7 +249,8 @@ ;; Standard build phases, as a list of symbol/procedure pairs. (let-syntax ((phases (syntax-rules () ((_ p ...) `((p . ,p) ...))))) - (phases set-paths unpack patch configure build check install + (phases set-paths unpack patch-source-shebangs patch configure + build check install patch-shebangs strip))) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 8f0eb66d39..99a43cfebd 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -26,6 +26,7 @@ #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:export (directory-exists? + executable-file? with-directory-excursion mkdir-p copy-recursively @@ -56,6 +57,12 @@ (and s (eq? 'directory (stat:type s))))) +(define (executable-file? file) + "Return #t if FILE exists and is executable." + (let ((s (stat file #f))) + (and s + (not (zero? (logand (stat:mode s) #o100)))))) + (define-syntax-rule (with-directory-excursion dir body ...) "Run BODY with DIR as the process's current directory." (let ((init (getcwd))) -- cgit v1.2.3 From c3ee7448c9c10d0fdcc52fd1d57031cf6677aafc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 18 Dec 2012 22:21:21 +0100 Subject: build-system/gnu: Change the order of `patch-source-shebangs' and `patch'. * guix/build/gnu-build-system.scm (patch-source-shebangs): Add a newline after the "SHELL =" line in po/Makefile.in.in. (%standard-phases): Move `patch-source-shebangs' after `patch'. --- guix/build/gnu-build-system.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index b67918552c..5e899403e8 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -98,7 +98,7 @@ (when (file-exists? "po/Makefile.in.in") (substitute* "po/Makefile.in.in" (("^SHELL[[:blank:]]*=.*$") - (string-append "SHELL = " bash)))))) + (string-append "SHELL = " bash "\n")))))) (define* (patch #:key (patches '()) (patch-flags '("--batch" "-p1")) #:allow-other-keys) @@ -249,7 +249,7 @@ ;; Standard build phases, as a list of symbol/procedure pairs. (let-syntax ((phases (syntax-rules () ((_ p ...) `((p . ,p) ...))))) - (phases set-paths unpack patch-source-shebangs patch configure + (phases set-paths unpack patch patch-source-shebangs configure build check install patch-shebangs strip))) -- cgit v1.2.3 From a18b4d085bf7d39cb089f9f67d6089516ebb345a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Dec 2012 01:34:42 +0100 Subject: utils: Add a `progress' parameter to `dump-port'. * guix/build/utils.scm (dump-port): Add a `progress' keyword parameter. Call it after each transfer. --- guix/build/utils.scm | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 99a43cfebd..0de7392620 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -371,17 +371,25 @@ all subject to the substitutions." ;;; Patching shebangs---e.g., /bin/sh -> /nix/store/xyz...-bash/bin/sh. ;;; -(define* (dump-port in out #:key (buffer-size 16384)) +(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." +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." (define buffer (make-bytevector buffer-size)) - (let loop ((bytes (get-bytevector-n! in buffer 0 buffer-size))) + (let loop ((total 0) + (bytes (get-bytevector-n! in buffer 0 buffer-size))) (or (eof-object? bytes) - (begin + (let ((total (+ total bytes))) (put-bytevector out buffer 0 bytes) - (loop (get-bytevector-n! in buffer 0 buffer-size)))))) + (progress total + (lambda () + (loop total + (get-bytevector-n! in buffer 0 buffer-size)))))))) (define patch-shebang (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)(.*)$"))) -- cgit v1.2.3 From 4c377e861b11ed5c5689fdb3ba2d1d864c77cef4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Dec 2012 22:31:08 +0100 Subject: build-system/gnu: Report the execution time of each phase. * guix/build/gnu-build-system.scm (gnu-build): Report the success or failure of each phase and its execution time. --- guix/build/gnu-build-system.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 5e899403e8..8692359bd8 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -20,6 +20,7 @@ #:use-module (guix build utils) #:use-module (ice-9 ftw) #:use-module (ice-9 match) + #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -267,6 +268,11 @@ in order. Return #t if all the PHASES succeeded, #f otherwise." ;; PHASES can pick the keyword arguments it's interested in. (every (match-lambda ((name . proc) - (format #t "starting phase `~a'~%" name) - (apply proc args))) + (let ((start (gettimeofday))) + (format #t "starting phase `~a'~%" name) + (let ((result (apply proc args)) + (end (gettimeofday))) + (format #t "phase `~a' ~:[failed~;succeeded~] after ~a seconds~%" + name result (- (car end) (car start))) + result)))) phases)) -- cgit v1.2.3 From eca63d3df8642587c35765af8446c1669e192789 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 20 Dec 2012 23:06:34 +0100 Subject: build-system/gnu: Patch shebangs after `configure'. * guix/build/gnu-build-system.scm (patch-generated-files): New procedure. (%standard-phases): Add it after `configure'. --- guix/build/gnu-build-system.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 8692359bd8..18c66e5256 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -101,6 +101,8 @@ (("^SHELL[[:blank:]]*=.*$") (string-append "SHELL = " bash "\n")))))) +(define patch-generated-files patch-source-shebangs) + (define* (patch #:key (patches '()) (patch-flags '("--batch" "-p1")) #:allow-other-keys) (every (lambda (p) @@ -250,7 +252,8 @@ ;; Standard build phases, as a list of symbol/procedure pairs. (let-syntax ((phases (syntax-rules () ((_ p ...) `((p . ,p) ...))))) - (phases set-paths unpack patch patch-source-shebangs configure + (phases set-paths unpack patch + patch-source-shebangs configure patch-generated-files build check install patch-shebangs strip))) -- cgit v1.2.3 From c089511288820cfb3efc5295e572be24aa83f068 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Dec 2012 22:31:25 +0100 Subject: build-system/gnu: Patch shebangs in all the source; patch SHELL in makefiles. * guix/build/utils.scm (call-with-ascii-input-file): New procedure. (patch-shebang): Use it. (patch-makefile-SHELL): New procedure. * guix/build/gnu-build-system.scm (patch-source-shebangs): Patch all the files, not just executables; remove `po/Makefile.in.in' patching. (patch-generated-files): Rename to... (patch-generated-file-shebangs): ... this. Patch executables and makefiles. (%standard-phases): Adjust accordingly. * distro/packages/autotools.scm (libtool): Remove call to `patch-shebang'. * distro/packages/base.scm (gcc-4.7): Likewise. (guile-final): Remove hack to skip `test-command-line-encoding2'. * distro/packages/bash.scm (bash): Remove `pre-configure-phase'. * distro/packages/readline.scm (readline): Likewise. * distro/packages/ncurses.scm (ncurses): Remove `pre-install-phase'. --- distro/packages/autotools.scm | 1 - distro/packages/base.scm | 31 +++----------- distro/packages/bash.scm | 16 ++------ distro/packages/ncurses.scm | 8 +--- distro/packages/readline.scm | 14 +------ guix/build/gnu-build-system.scm | 28 +++++++------ guix/build/utils.scm | 90 ++++++++++++++++++++++++++++++----------- 7 files changed, 92 insertions(+), 96 deletions(-) (limited to 'guix') diff --git a/distro/packages/autotools.scm b/distro/packages/autotools.scm index 1c01b3d3db..171855b937 100644 --- a/distro/packages/autotools.scm +++ b/distro/packages/autotools.scm @@ -118,7 +118,6 @@ Standards. Automake requires the use of Autoconf.") (string-append "-j" ncores))) ;; Path references to /bin/sh. - (patch-shebang "libtoolize") (let ((bash (assoc-ref inputs "bash"))) (substitute* "tests/testsuite" (("/bin/sh") diff --git a/distro/packages/base.scm b/distro/packages/base.scm index 0a937486a4..0289b6c688 100644 --- a/distro/packages/base.scm +++ b/distro/packages/base.scm @@ -428,9 +428,6 @@ BFD (Binary File Descriptor) library, `gprof', `nm', `strip', etc.") ~a~%" libc line)))) - ;; Adjust hard-coded #!/bin/sh. - (patch-shebang "gcc/exec-tool.in") - ;; Don't retain a dependency on the build-time sed. (substitute* "fixincludes/fixincl.x" (("static char const sed_cmd_z\\[\\] =.*;") @@ -967,29 +964,11 @@ store.") ;; FIXME: The Libtool used here, specifically its `bin/libtool' script, ;; holds a dependency on the bootstrap Binutils. Use multiple outputs for ;; Libtool, so that that dependency is isolated in the "bin" output. - (let ((guile (package (inherit guile-2.0/fixed) - (arguments - (substitute-keyword-arguments - (package-arguments guile-2.0/fixed) - ((#:phases phases) - `(alist-cons-before - 'patch-source-shebangs 'delete-encoded-test - (lambda* (#:key inputs #:allow-other-keys) - ;; %BOOTSTRAP-GUILE doesn't know about encodings other - ;; than UTF-8. That test declares an ISO-8859-1 - ;; encoding, which prevents `patch-shebang' from - ;; working, so skip it. - (call-with-output-file - "test-suite/standalone/test-command-line-encoding2" - (lambda (p) - (format p "#!~a/bin/bash\nexit 77" - (assoc-ref inputs "bash"))))) - ,phases))))))) - (package-with-bootstrap-guile - (package-with-explicit-inputs guile - %boot4-inputs - (current-source-location) - #:guile %bootstrap-guile)))) + (package-with-bootstrap-guile + (package-with-explicit-inputs guile-2.0/fixed + %boot4-inputs + (current-source-location) + #:guile %bootstrap-guile))) (define-public ld-wrapper ;; The final `ld' wrapper, which uses the final Guile. diff --git a/distro/packages/bash.scm b/distro/packages/bash.scm index c2022fcf95..f32293d82f 100644 --- a/distro/packages/bash.scm +++ b/distro/packages/bash.scm @@ -33,13 +33,6 @@ "-DNON_INTERACTIVE_LOGIN_SHELLS" "-DSSH_SOURCE_BASHRC") " ")) - (pre-configure-phase - '(lambda* (#:key inputs #:allow-other-keys) - ;; Use the right shell for makefiles. - (let ((bash (assoc-ref inputs "bash"))) - (substitute* "configure" - (("MAKE_SHELL=[^ ]+") - (format #f "MAKE_SHELL=~a/bin/bash" bash)))))) (post-install-phase '(lambda* (#:key outputs #:allow-other-keys) ;; Add a `bash' -> `sh' link. @@ -80,12 +73,9 @@ ;; for now. #:tests? #f - #:phases (alist-cons-before - 'configure 'pre-configure - ,pre-configure-phase - (alist-cons-after 'install 'post-install - ,post-install-phase - %standard-phases)))) + #:phases (alist-cons-after 'install 'post-install + ,post-install-phase + %standard-phases))) (synopsis "GNU Bourne-Again Shell") (description "Bash is the shell, or command language interpreter, that will appear in diff --git a/distro/packages/ncurses.scm b/distro/packages/ncurses.scm index 868222ef83..8bde3c1989 100644 --- a/distro/packages/ncurses.scm +++ b/distro/packages/ncurses.scm @@ -28,9 +28,6 @@ '(lambda _ (substitute* (find-files "." "Makefile.in") (("^SHELL[[:blank:]]*=.*$") "")))) - (pre-install-phase - '(lambda _ - (for-each patch-shebang (find-files "." "\\.sh$")))) (post-install-phase '(lambda* (#:key outputs #:allow-other-keys) (let ((out (assoc-ref outputs "out"))) @@ -93,10 +90,7 @@ (alist-cons-before 'configure 'patch-makefile-SHELL ,patch-makefile-phase - (alist-cons-before - 'install 'pre-install-phase - ,pre-install-phase - %standard-phases))) + %standard-phases)) ;; The `ncursesw5-config' has a #!/bin/sh that we don't want to ;; patch, to avoid retaining a reference to the build-time Bash. diff --git a/distro/packages/readline.scm b/distro/packages/readline.scm index bf542e90b5..8e2a4cbb5d 100644 --- a/distro/packages/readline.scm +++ b/distro/packages/readline.scm @@ -36,14 +36,7 @@ (for-each (lambda (f) (chmod f #o755)) (find-files lib "\\.so")) (for-each (lambda (f) (chmod f #o644)) - (find-files lib "\\.a"))))) - (pre-configure-phase - '(lambda* (#:key inputs #:allow-other-keys) - ;; Use the right shell for makefiles. - (let ((bash (assoc-ref inputs "bash"))) - (substitute* "configure" - (("^MAKE_SHELL=.*") - (format #f "MAKE_SHELL=~a/bin/bash" bash))))))) + (find-files lib "\\.a")))))) (package (name "readline") (version "6.2") @@ -69,10 +62,7 @@ #:phases (alist-cons-after 'install 'post-install ,post-install-phase - (alist-cons-before - 'configure 'pre-configure - ,pre-configure-phase - %standard-phases)))) + %standard-phases))) (synopsis "GNU Readline, a library for interactive line editing") (description "The GNU Readline library provides a set of functions for use by diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 18c66e5256..b5eaa26bf5 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -84,24 +84,26 @@ (chdir (first-subdirectory ".")))) (define* (patch-source-shebangs #:key source #:allow-other-keys) - ;; Patch shebangs in executable source files. Most scripts honor - ;; $SHELL and $CONFIG_SHELL, but some don't, such as `mkinstalldirs' - ;; or Automake's `missing' script. + "Patch shebangs in all source files; this includes non-executable +files such as `.in' templates. Most scripts honor $SHELL and +$CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's +`missing' script." + (for-each patch-shebang + (remove file-is-directory? (find-files "." ".*")))) + +(define (patch-generated-file-shebangs . rest) + "Patch shebangs in generated files, including `SHELL' variables in +makefiles." + ;; Patch executable files, some of which might have been generated by + ;; `configure'. (for-each patch-shebang (filter (lambda (file) (and (executable-file? file) (not (file-is-directory? file)))) (find-files "." ".*"))) - ;; Gettext-generated po/Makefile.in.in does not honor $SHELL. - (let ((bash (search-path (search-path-as-string->list (getenv "PATH")) - "bash"))) - (when (file-exists? "po/Makefile.in.in") - (substitute* "po/Makefile.in.in" - (("^SHELL[[:blank:]]*=.*$") - (string-append "SHELL = " bash "\n")))))) - -(define patch-generated-files patch-source-shebangs) + ;; Patch `SHELL' in generated makefiles. + (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$"))) (define* (patch #:key (patches '()) (patch-flags '("--batch" "-p1")) #:allow-other-keys) @@ -253,7 +255,7 @@ (let-syntax ((phases (syntax-rules () ((_ p ...) `((p . ,p) ...))))) (phases set-paths unpack patch - patch-source-shebangs configure patch-generated-files + patch-source-shebangs configure patch-generated-file-shebangs build check install patch-shebangs strip))) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 0de7392620..c54c83883b 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -27,6 +27,7 @@ #:use-module (rnrs io ports) #:export (directory-exists? executable-file? + call-with-ascii-input-file with-directory-excursion mkdir-p copy-recursively @@ -43,6 +44,7 @@ substitute* dump-port patch-shebang + patch-makefile-SHELL fold-port-matches remove-store-references)) @@ -63,6 +65,21 @@ (and s (not (zero? (logand (stat:mode s) #o100)))))) +(define (call-with-ascii-input-file file proc) + "Open FILE as an ASCII or binary file, and pass the resulting port to +PROC. FILE is closed when PROC's dynamic extent is left. Return the +return values of applying PROC to the port." + (let ((port (with-fluids ((%default-port-encoding #f)) + ;; Use "b" so that `open-file' ignores `coding:' cookies. + (open-file file "rb")))) + (dynamic-wind + (lambda () + #t) + (lambda () + (proc port)) + (lambda () + (close-input-port port))))) + (define-syntax-rule (with-directory-excursion dir body ...) "Run BODY with DIR as the process's current directory." (let ((init (getcwd))) @@ -418,30 +435,55 @@ patched, #f otherwise." (false-if-exception (delete-file template)) #f)))) - (with-fluids ((%default-port-encoding #f)) ; ASCII - (call-with-input-file file - (lambda (p) - (and (eq? #\# (read-char p)) - (eq? #\! (read-char p)) - (let ((line (false-if-exception (read-line p)))) - (and=> (and line (regexp-exec shebang-rx line)) - (lambda (m) - (let* ((cmd (match:substring m 1)) - (bin (search-path path - (basename cmd)))) - (if bin - (if (string=? bin cmd) - #f ; nothing to do - (begin - (format (current-error-port) - "patch-shebang: ~a: changing `~a' to `~a'~%" - file cmd bin) - (patch p bin (match:substring m 2)))) - (begin - (format (current-error-port) - "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%" - file (basename cmd)) - #f))))))))))))) + (call-with-ascii-input-file file + (lambda (p) + (and (eq? #\# (read-char p)) + (eq? #\! (read-char p)) + (let ((line (false-if-exception (read-line p)))) + (and=> (and line (regexp-exec shebang-rx line)) + (lambda (m) + (let* ((cmd (match:substring m 1)) + (bin (search-path path (basename cmd)))) + (if bin + (if (string=? bin cmd) + #f ; nothing to do + (begin + (format (current-error-port) + "patch-shebang: ~a: changing `~a' to `~a'~%" + file cmd bin) + (patch p bin (match:substring m 2)))) + (begin + (format (current-error-port) + "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%" + file (basename cmd)) + #f)))))))))))) + +(define (patch-makefile-SHELL file) + "Patch the `SHELL' variable in FILE, which is supposedly a makefile." + + ;; For instance, Gettext-generated po/Makefile.in.in do not honor $SHELL. + + ;; XXX: Unlike with `patch-shebang', FILE is always touched. + + (define (find-shell name) + (let ((shell + (search-path (search-path-as-string->list (getenv "PATH")) + name))) + (unless shell + (format (current-error-port) + "patch-makefile-SHELL: warning: no binary for shell `~a' found in $PATH~%" + name)) + shell)) + + (substitute* file + (("^ *SHELL[[:blank:]]*=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)[[:blank:]]*" _ dir shell) + (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 "\n"))))) (define* (fold-port-matches proc init pattern port #:optional (unmatched (lambda (_ r) r))) -- cgit v1.2.3 From 6253961de2628ed9e65987c823935d669c0e20fc Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Sat, 29 Dec 2012 21:03:23 +0100 Subject: build-system/gnu: enable test-target during the check phase * guix/build-system/gnu.scm: add variable test-target --- guix/build-system/gnu.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 9d94680d93..53fc4749f0 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -152,6 +152,7 @@ System: GCC, GNU Make, Bash, Coreutils, etc." (out-of-source? #f) (path-exclusions ''()) (tests? #t) + (test-target "check") (parallel-build? #t) (parallel-tests? #t) (patch-shebangs? #t) (strip-binaries? #t) @@ -193,6 +194,7 @@ which could lead to gratuitous input divergence." #:out-of-source? ,out-of-source? #:path-exclusions ,path-exclusions #:tests? ,tests? + #:test-target ,test-target #:parallel-build? ,parallel-build? #:parallel-tests? ,parallel-tests? #:patch-shebangs? ,patch-shebangs? -- cgit v1.2.3 From bc5bf85fa222cf06e5d8236d01872c1bb89a8d20 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 31 Dec 2012 01:17:43 +0100 Subject: utils: Restore the mtime/atime of patched files. * guix/build/utils.scm (set-file-time): New procedure. (patch-shebang): New `keep-mtime?' parameter; call `set-file-time' when it's true. (patch-makefile-SHELL): Likewise. --- guix/build/utils.scm | 48 ++++++++++++++++++++++++++++++++++-------------- 1 file changed, 34 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index c54c83883b..11bd4cc163 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -43,6 +43,7 @@ substitute substitute* dump-port + set-file-time patch-shebang patch-makefile-SHELL fold-port-matches @@ -408,17 +409,29 @@ bytes transferred and the continuation of the transfer as a thunk." (loop total (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." + (utime file + (stat:atime stat) + (stat:mtime stat) + (stat:atimensec stat) + (stat:mtimensec stat))) + (define patch-shebang (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]+)(.*)$"))) (lambda* (file - #:optional (path (search-path-as-string->list (getenv "PATH")))) + #:optional + (path (search-path-as-string->list (getenv "PATH"))) + #:key (keep-mtime? #t)) "Replace the #! interpreter file name in FILE by a valid one found in PATH, when FILE actually starts with a shebang. Return #t when FILE was -patched, #f otherwise." +patched, #f otherwise. When KEEP-MTIME? is true, the atime/mtime of +FILE are kept unchanged." (define (patch p interpreter rest-of-line) (let* ((template (string-append file ".XXXXXX")) (out (mkstemp! template)) - (mode (stat:mode (stat file)))) + (st (stat file)) + (mode (stat:mode st))) (with-throw-handler #t (lambda () (format out "#!~a~a~%" @@ -427,6 +440,8 @@ patched, #f otherwise." (close out) (chmod template mode) (rename-file template file) + (when keep-mtime? + (set-file-time file st)) #t) (lambda (key . args) (format (current-error-port) @@ -458,8 +473,9 @@ patched, #f otherwise." file (basename cmd)) #f)))))))))))) -(define (patch-makefile-SHELL file) - "Patch the `SHELL' variable in FILE, which is supposedly a makefile." +(define* (patch-makefile-SHELL file #:key (keep-mtime? #t)) + "Patch the `SHELL' variable in FILE, which is supposedly a makefile. +When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged." ;; For instance, Gettext-generated po/Makefile.in.in do not honor $SHELL. @@ -475,15 +491,19 @@ patched, #f otherwise." name)) shell)) - (substitute* file - (("^ *SHELL[[:blank:]]*=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)[[:blank:]]*" _ dir shell) - (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 "\n"))))) + (let ((st (stat file))) + (substitute* file + (("^ *SHELL[[:blank:]]*=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)[[:blank:]]*" _ dir shell) + (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 "\n")))) + + (when keep-mtime? + (set-file-time file st)))) (define* (fold-port-matches proc init pattern port #:optional (unmatched (lambda (_ r) r))) -- cgit v1.2.3 From b2adb3ae04ce2b0e383b6c4a0b78c7e885350d7a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 1 Jan 2013 16:52:27 +0100 Subject: build-system/gnu: Add support for the "bin" output. * guix/build/gnu-build-system.scm (configure): Add support for "bin" output. --- guix/build/gnu-build-system.scm | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index b5eaa26bf5..bd40289aac 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -116,6 +116,7 @@ makefiles." (define* (configure #:key inputs outputs (configure-flags '()) out-of-source? #:allow-other-keys) (let* ((prefix (assoc-ref outputs "out")) + (bindir (assoc-ref outputs "bin")) (libdir (assoc-ref outputs "lib")) (includedir (assoc-ref outputs "include")) (bash (or (and=> (assoc-ref inputs "bash") @@ -128,6 +129,9 @@ makefiles." ;; Produce multiple outputs when specific output names ;; are recognized. + ,@(if bindir + (list (string-append "--bindir=" bindir "/bin")) + '()) ,@(if libdir (list (string-append "--libdir=" libdir "/lib")) '()) -- cgit v1.2.3 From 4d058c67929aa9d464fcb1ff0217122424078cb8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 1 Jan 2013 16:55:34 +0100 Subject: build-system/gnu: Add `static-package'. * distro/packages/make-bootstrap.scm (static-package): Move to... * guix/build-system/gnu.scm (static-package): ... here. New procedure. --- distro/packages/make-bootstrap.scm | 25 +------------------------ guix/build-system/gnu.scm | 26 +++++++++++++++++++++++++- 2 files changed, 26 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/distro/packages/make-bootstrap.scm b/distro/packages/make-bootstrap.scm index 28be0b8c49..c0e5d8be5d 100644 --- a/distro/packages/make-bootstrap.scm +++ b/distro/packages/make-bootstrap.scm @@ -20,7 +20,7 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix build-system trivial) - #:use-module ((guix build-system gnu) #:select (package-with-explicit-inputs)) + #:use-module (guix build-system gnu) #:use-module ((distro) #:select (search-patch)) #:use-module (distro packages base) #:use-module (distro packages bash) @@ -45,29 +45,6 @@ ;;; ;;; Code: -(define* (static-package p #:optional (loc (current-source-location))) - "Return a statically-linked version of package P." - ;; TODO: Move to (guix build-system gnu). - (let ((args (package-arguments p))) - (package (inherit p) - (location (source-properties->location loc)) - (arguments - (let ((augment (lambda (args) - (let ((a (default-keyword-arguments args - '(#:configure-flags '() - #:strip-flags #f)))) - (substitute-keyword-arguments a - ((#:configure-flags flags) - `(cons* "--disable-shared" - "LDFLAGS=-static" - ,flags)) - ((#:strip-flags _) - ''("--strip-all"))))))) - (if (procedure? args) - (lambda x - (augment (apply args x))) - (augment args))))))) - (define %glibc-with-relocatable-system ;; A libc whose `system' and `popen' functions looks for `sh' in $PATH. (package (inherit glibc-final) diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 53fc4749f0..4d7ecd54de 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -21,6 +21,7 @@ #:use-module (guix utils) #:use-module (guix derivations) #:use-module (guix build-system) + #:use-module (guix build-system gnu) #:use-module (guix packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-39) @@ -29,7 +30,8 @@ gnu-build-system package-with-explicit-inputs package-with-extra-configure-variable - static-libgcc-package)) + static-libgcc-package + static-package)) ;; Commentary: ;; @@ -117,6 +119,28 @@ configure flags for VARIABLE, the associated value is augmented." "A version of P linked with `-static-gcc'." (package-with-extra-configure-variable p "LDFLAGS" "-static-libgcc")) +(define* (static-package p #:optional (loc (current-source-location))) + "Return a statically-linked version of package P." + (let ((args (package-arguments p))) + (package (inherit p) + (location (source-properties->location loc)) + (arguments + (let ((augment (lambda (args) + (let ((a (default-keyword-arguments args + '(#:configure-flags '() + #:strip-flags #f)))) + (substitute-keyword-arguments a + ((#:configure-flags flags) + `(cons* "--disable-shared" + "LDFLAGS=-static" + ,flags)) + ((#:strip-flags _) + ''("--strip-all"))))))) + (if (procedure? args) + (lambda x + (augment (apply args x))) + (augment args))))))) + (define %store ;; Store passed to STANDARD-INPUTS. -- cgit v1.2.3 From 93b035757554830d4f4e190aef7d5b90fa845bb0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 1 Jan 2013 23:12:34 +0100 Subject: utils: Use binary I/O primitives for `remove-store-references'. * guix/build/utils.scm (fold-port-matches)[get-char]: New procedure. (remove-store-references): Use `put-u8' and `put-bytevector'. --- guix/build/utils.scm | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 11bd4cc163..5729cdbf04 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,5 +1,5 @@ ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- -;;; Copyright (C) 2012 Ludovic Courtès +;;; Copyright (C) 2012, 2013 Ludovic Courtès ;;; ;;; This file is part of Guix. ;;; @@ -517,6 +517,14 @@ 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) @@ -576,16 +584,17 @@ known as `nuke-refs' in Nixpkgs." (setvbuf in _IOFBF 65536) (setvbuf out _IOFBF 65536) (fold-port-matches (lambda (match result) - (put-string out store) - (put-char out #\/) - (put-string out - "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-") + (put-bytevector out (string->utf8 store)) + (put-u8 out (char->integer #\/)) + (put-bytevector out + (string->utf8 + "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-")) #t) #f pattern in (lambda (char result) - (put-char out char) + (put-u8 out (char->integer char)) result)))))) ;;; Local Variables: -- cgit v1.2.3 From 7584f822bf076f4fc8aef9c1f4d48c179fe15fc3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Jan 2013 16:02:32 +0100 Subject: utils: Add `which'. * guix/build/utils.scm (which): New procedure. * distro/packages/lsh.scm (lsh): Use `which' instead of `search-path'. * distro/packages/perl.scm (perl): Likewise. * distro/packages/attr.scm (attr): Likewise. --- distro/packages/attr.scm | 9 +++------ distro/packages/lsh.scm | 5 ++--- distro/packages/perl.scm | 10 ++++------ guix/build/utils.scm | 8 ++++++++ 4 files changed, 17 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/distro/packages/attr.scm b/distro/packages/attr.scm index ad2cd3987a..c61f4d7031 100644 --- a/distro/packages/attr.scm +++ b/distro/packages/attr.scm @@ -56,12 +56,9 @@ 'check (lambda _ ;; Use the right shell. - (let ((bash (search-path (search-path-as-string->list - (getenv "PATH")) - "bash"))) - (substitute* "test/run" - (("/bin/sh") - (string-append bash "/bin/bash")))) + (substitute* "test/run" + (("/bin/sh") + (which "bash"))) (system* "make" "tests" "-C" "test") diff --git a/distro/packages/lsh.scm b/distro/packages/lsh.scm index aa74c77b60..8f44967726 100644 --- a/distro/packages/lsh.scm +++ b/distro/packages/lsh.scm @@ -1,5 +1,5 @@ ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- -;;; Copyright (C) 2012 Ludovic Courtès +;;; Copyright (C) 2012, 2013 Ludovic Courtès ;;; ;;; This file is part of Guix. ;;; @@ -114,8 +114,7 @@ (substitute* "src/testsuite/login-auth-test" (("/bin/cat") ;; Use the right path to `cat'. - (search-path (search-path-as-string->list (getenv "PATH")) - "cat")))) + (which "cat")))) %standard-phases))) (home-page "http://www.lysator.liu.se/~nisse/lsh/") (synopsis diff --git a/distro/packages/perl.scm b/distro/packages/perl.scm index 26b25b154d..c4bfb6b260 100644 --- a/distro/packages/perl.scm +++ b/distro/packages/perl.scm @@ -1,5 +1,5 @@ ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- -;;; Copyright (C) 2012 Ludovic Courtès +;;; Copyright (C) 2012, 2013 Ludovic Courtès ;;; ;;; This file is part of Guix. ;;; @@ -46,13 +46,11 @@ 'configure (lambda* (#:key inputs outputs #:allow-other-keys) (let ((out (assoc-ref outputs "out")) - (libc (assoc-ref inputs "libc")) - (pwd (search-path (search-path-as-string->list - (getenv "PATH")) - "pwd"))) + (libc (assoc-ref inputs "libc"))) ;; Use the right path for `pwd'. (substitute* "dist/Cwd/Cwd.pm" - (("/bin/pwd") pwd)) + (("/bin/pwd") + (which "pwd"))) (zero? (system* "./Configure" diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 5729cdbf04..f365b0db05 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -36,6 +36,8 @@ set-path-environment-variable search-path-as-string->list list->search-path-as-string + which + alist-cons-before alist-cons-after alist-replace @@ -214,6 +216,12 @@ SEPARATOR-separated path accordingly. Example: (format #t "environment variable `~a' set to `~a'~%" env-var value))) +(define (which program) + "Return the complete file name for PROGRAM as found in $PATH, or #f if +PROGRAM could not be found." + (search-path (search-path-as-string->list (getenv "PATH")) + program)) + ;;; ;;; Phases. -- cgit v1.2.3 From 4155e2a9093617e1d920e794aa848ac733064df0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Jan 2013 16:08:07 +0100 Subject: Update license headers of builder-side code. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Change license headers with this script: (use-modules (guix build utils)) (fluid-set! %default-port-encoding "UTF-8") (substitute* (cons "distro/packages/ld-wrapper.scm" (find-files "guix/build" "\\.scm$")) (("^([[:graph:]]+) This file is part of Guix." _ comment-start) (string-append comment-start " This file is part of GNU Guix.")) (("^([[:graph:]]+) Guix --- Nix package management.*" _ comment-start) (string-append comment-start " GNU Guix --- Functional package management for GNU\n")) (("^([[:graph:]]+) Guix is " _ comment-start) (string-append comment-start " GNU Guix is ")) (("^([[:graph:]]+) along with Guix." _ comment-start) (string-append comment-start " along with GNU Guix.")) (("^([[:graph:]]+) Copyright \\(C\\)" _ comment-start) (string-append comment-start " Copyright ©"))) * distro/packages/ld-wrapper.scm, guix/build/download.scm, guix/build/gnu-build-system.scm, guix/build/union.scm, guix/build/utils.scm: Update license headers. --- distro/packages/ld-wrapper.scm | 12 ++++++------ guix/build/download.scm | 12 ++++++------ guix/build/gnu-build-system.scm | 12 ++++++------ guix/build/union.scm | 12 ++++++------ guix/build/utils.scm | 12 ++++++------ 5 files changed, 30 insertions(+), 30 deletions(-) (limited to 'guix') diff --git a/distro/packages/ld-wrapper.scm b/distro/packages/ld-wrapper.scm index 5c98375814..fd5a4cbd0c 100644 --- a/distro/packages/ld-wrapper.scm +++ b/distro/packages/ld-wrapper.scm @@ -10,23 +10,23 @@ main="(@ (gnu build-support ld-wrapper) ld-wrapper)" exec @GUILE@ -c "(load-compiled \"$0.go\") (apply $main (cdr (command-line)))" "$@" !# -;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- -;;; Copyright (C) 2012 Ludovic Courtès +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012 Ludovic Courtès ;;; -;;; This file is part of Guix. +;;; This file is part of GNU Guix. ;;; -;;; Guix is free software; you can redistribute it and/or modify it +;;; 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. ;;; -;;; Guix is distributed in the hope that it will be useful, but +;;; 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 Guix. If not, see . +;;; along with GNU Guix. If not, see . (define-module (gnu build-support ld-wrapper) #:use-module (srfi srfi-1) diff --git a/guix/build/download.scm b/guix/build/download.scm index c09351cee4..5813ea81ea 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,20 +1,20 @@ -;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- -;;; Copyright (C) 2012 Ludovic Courtès +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012 Ludovic Courtès ;;; -;;; This file is part of Guix. +;;; This file is part of GNU Guix. ;;; -;;; Guix is free software; you can redistribute it and/or modify it +;;; 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. ;;; -;;; Guix is distributed in the hope that it will be useful, but +;;; 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 Guix. If not, see . +;;; along with GNU Guix. If not, see . (define-module (guix build download) #:use-module (web uri) diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index bd40289aac..e9421000bf 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -1,20 +1,20 @@ -;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- -;;; Copyright (C) 2012 Ludovic Courtès +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012 Ludovic Courtès ;;; -;;; This file is part of Guix. +;;; This file is part of GNU Guix. ;;; -;;; Guix is free software; you can redistribute it and/or modify it +;;; 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. ;;; -;;; Guix is distributed in the hope that it will be useful, but +;;; 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 Guix. If not, see . +;;; along with GNU Guix. If not, see . (define-module (guix build gnu-build-system) #:use-module (guix build utils) diff --git a/guix/build/union.scm b/guix/build/union.scm index ffd367917a..317c38a1d5 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -1,20 +1,20 @@ -;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- -;;; Copyright (C) 2012 Ludovic Courtès +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012 Ludovic Courtès ;;; -;;; This file is part of Guix. +;;; This file is part of GNU Guix. ;;; -;;; Guix is free software; you can redistribute it and/or modify it +;;; 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. ;;; -;;; Guix is distributed in the hope that it will be useful, but +;;; 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 Guix. If not, see . +;;; along with GNU Guix. If not, see . (define-module (guix build union) #:use-module (ice-9 ftw) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index f365b0db05..6921e31bdd 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,20 +1,20 @@ -;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- -;;; Copyright (C) 2012, 2013 Ludovic Courtès +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès ;;; -;;; This file is part of Guix. +;;; This file is part of GNU Guix. ;;; -;;; Guix is free software; you can redistribute it and/or modify it +;;; 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. ;;; -;;; Guix is distributed in the hope that it will be useful, but +;;; 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 Guix. If not, see . +;;; along with GNU Guix. If not, see . (define-module (guix build utils) #:use-module (srfi srfi-1) -- cgit v1.2.3 From fb83842efba5b4f08a151d2f8a0fd43de6c62778 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 6 Jan 2013 18:23:44 +0100 Subject: ftp-client: Add `ftp-size'. * guix/ftp-client.scm (ftp-size): New procedure. --- guix/ftp-client.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index 7e241f37b2..e3bacc3720 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012 Ludovic Courtès +;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,6 +33,7 @@ ftp-open ftp-close ftp-chdir + ftp-size ftp-list ftp-retr)) @@ -133,6 +134,12 @@ or a TCP port number), and return it." (%ftp-command (string-append "CWD " dir) 250 (ftp-connection-socket conn))) +(define (ftp-size conn file) + "Return the size in bytes of FILE." + (let ((message (%ftp-command (string-append "SIZE " file) 213 + (ftp-connection-socket conn)))) + (string->number (string-trim-both message)))) + (define (ftp-pasv conn) (define %pasv-rx (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)")) -- cgit v1.2.3 From e47bac790228d4f622bce9981fc4b6ed4767b973 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 6 Jan 2013 18:24:53 +0100 Subject: download: Report the progress of FTP downloads. * guix/build/download.scm (progress-proc): New procedure. (ftp-fetch): Call `ftp-size' on URI. Use `progress-proc', and pass the result to `dump-port', along with #:buffer-size. --- guix/build/download.scm | 29 ++++++++++++++++++++++++++--- 1 file changed, 26 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 27f5557692..8a715cf50b 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012 Ludovic Courtès +;;; Copyright © 2012, 2013 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +27,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (ice-9 match) + #:use-module (ice-9 format) #:export (url-fetch)) ;;; Commentary: @@ -35,17 +36,39 @@ ;;; ;;; Code: +(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)))) + (define (ftp-fetch uri file) "Fetch data from URI and write it to FILE. Return FILE on success." (let* ((conn (ftp-open (uri-host uri))) + (size (false-if-exception (ftp-size conn (uri-path uri)))) (in (ftp-retr conn (basename (uri-path uri)) (dirname (uri-path uri))))) (call-with-output-file file (lambda (out) - ;; TODO: Show a progress bar. - (dump-port in out))) + (dump-port in out + #:buffer-size 65536 ; don't flood the log + #:progress (progress-proc (uri->string uri) size)))) (ftp-close conn)) + (newline) file) (define (open-connection-for-uri uri) -- cgit v1.2.3 From e66ca1a5a898c4bfd0c2c3c2ec3284befde28ee6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 6 Jan 2013 18:36:50 +0100 Subject: download: Report the progress of HTTP downloads. * guix/build/download.scm (http-fetch): Rename `bv' to `bv-or-port'. Use `http-get*' followed by `dump-port' when the former is available, and pass a progress procedure to `dump-port'. --- guix/build/download.scm | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 8a715cf50b..7c48d7bff5 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -126,20 +126,34 @@ which is not available during bootstrap." (define (http-fetch uri file) "Fetch data from URI and write it to FILE. Return FILE on success." - ;; FIXME: Use a variant of `http-get' that returns a port instead of - ;; loading everything in memory. (let*-values (((connection) (open-connection-for-uri uri)) - ((resp bv) - (http-get uri #:port connection #:decode-body? #f)) + ((resp bv-or-port) + ;; XXX: `http-get*' was introduced in 2.0.7. We know + ;; we're using it within the chroot, but + ;; `guix-download' might be using a different version. + ;; So keep this compatibility hack for now. + (if (module-defined? (resolve-interface '(web client)) + 'http-get*) + (http-get* uri #:port connection #:decode-body? #f) + (http-get uri #:port connection #:decode-body? #f))) ((code) - (response-code resp))) + (response-code resp)) + ((size) + (response-content-length resp))) (case code ((200) ; OK (begin (call-with-output-file file (lambda (p) - (put-bytevector p bv))) + (if (port? bv-or-port) + (begin + (dump-port bv-or-port p + #:buffer-size 65536 ; don't flood the log + #:progress (progress-proc (uri->string uri) + size)) + (newline)) + (put-bytevector p bv-or-port)))) file)) ((302) ; found (redirection) (let ((uri (response-location resp))) -- cgit v1.2.3 From a06a99ff779c7419c2e47c475b5c0fa8a9fc24c1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Jan 2013 00:08:40 +0100 Subject: build-system/gnu: Improve support for "lib" outputs; support "doc" outputs. * guix/build/gnu-build-system.scm (configure)[package-name]: New procedure. When LIBDIR is true and INCLUDEDIR is false, add --includedir=LIBDIR/include. Add support for --docdir when a "doc" output exists. --- guix/build/gnu-build-system.scm | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index e9421000bf..b7b9fdac95 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012 Ludovic Courtès +;;; Copyright © 2012, 2013 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -115,10 +115,20 @@ makefiles." (define* (configure #:key inputs outputs (configure-flags '()) out-of-source? #:allow-other-keys) + (define (package-name) + (let* ((out (assoc-ref outputs "out")) + (base (basename out)) + (dash (string-rindex base #\-))) + ;; XXX: We'd rather use `package-name->name+version' or similar. + (if dash + (substring base 0 dash) + base))) + (let* ((prefix (assoc-ref outputs "out")) (bindir (assoc-ref outputs "bin")) (libdir (assoc-ref outputs "lib")) (includedir (assoc-ref outputs "include")) + (docdir (assoc-ref outputs "doc")) (bash (or (and=> (assoc-ref inputs "bash") (cut string-append <> "/bin/bash")) "/bin/sh")) @@ -133,12 +143,21 @@ makefiles." (list (string-append "--bindir=" bindir "/bin")) '()) ,@(if libdir - (list (string-append "--libdir=" libdir "/lib")) + (cons (string-append "--libdir=" libdir "/lib") + (if includedir + '() + (list + (string-append "--includedir=" + libdir "/include")))) '()) ,@(if includedir (list (string-append "--includedir=" includedir "/include")) '()) + ,@(if docdir + (list (string-append "--docdir=" docdir + "/doc/" (package-name))) + '()) ,@configure-flags)) (abs-srcdir (getcwd)) (srcdir (if out-of-source? -- cgit v1.2.3 From 28e55604212c01884a77a4f5eb66294c4957c48a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Jan 2013 15:41:58 +0100 Subject: download: Abbreviate URLs when displaying the progress report. * guix/build/download.scm (uri-abbreviation): New procedure. (ftp-fetch, http-fetch): Use it instead of `uri->string' when calling `progress-proc'. Reported by Andreas Enge. --- guix/build/download.scm | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 7c48d7bff5..09c62541de 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -55,6 +55,25 @@ argument to `dump-port'. The progress report is written to LOG-PORT." (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 +abbreviation of URI showing the scheme, host, and basename of the file." + (define uri-as-string + (uri->string uri)) + + (define (elide-path) + (let ((path (uri-path uri))) + (string-append (symbol->string (uri-scheme uri)) + "://" (uri-host uri) + (string-append "/.../" (basename path))))) + + (if (> (string-length uri-as-string) max-length) + (let ((short (elide-path))) + (if (< (string-length short) (string-length uri-as-string)) + short + uri-as-string)) + uri-as-string)) + (define (ftp-fetch uri file) "Fetch data from URI and write it to FILE. Return FILE on success." (let* ((conn (ftp-open (uri-host uri))) @@ -65,7 +84,7 @@ argument to `dump-port'. The progress report is written to LOG-PORT." (lambda (out) (dump-port in out #:buffer-size 65536 ; don't flood the log - #:progress (progress-proc (uri->string uri) size)))) + #:progress (progress-proc (uri-abbreviation uri) size)))) (ftp-close conn)) (newline) @@ -150,7 +169,7 @@ which is not available during bootstrap." (begin (dump-port bv-or-port p #:buffer-size 65536 ; don't flood the log - #:progress (progress-proc (uri->string uri) + #:progress (progress-proc (uri-abbreviation uri) size)) (newline)) (put-bytevector p bv-or-port)))) -- cgit v1.2.3