* [PATCH] Improve shell script headers and pre-inst-env handling
@ 2013-02-12 1:45 Mark H Weaver
2013-02-12 2:24 ` Mark H Weaver
2013-02-12 15:56 ` Ludovic Courtès
0 siblings, 2 replies; 17+ messages in thread
From: Mark H Weaver @ 2013-02-12 1:45 UTC (permalink / raw)
To: bug-guix
Hello all,
I've attached two patches. The first arranges to make sure that
'pre-inst-env' will be rebuilt when 'pre-inst-env.in' is modified.
The second patch is the main subject of this email. It reworks the
shell script headers at the top of 'guix-package' and the other scripts
to avoid modifying environment variables (which could propagate to
unrelated subprocesses that use libguile), and to avoid prepending
installed directories to the guile load paths in the case where
'pre-inst-env' is being used.
My approach here might be controversial, given that the resulting code
is a bit longer, so if you don't like it, no worries :)
However, I do find it nice to write more scheme and less shell code, and
as a bonus the scheme code at the top is properly handled by emacs and
paredit as if it were in the main body of the file.
What do you think?
Mark
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH] Improve shell script headers and pre-inst-env handling
2013-02-12 1:45 [PATCH] Improve shell script headers and pre-inst-env handling Mark H Weaver
@ 2013-02-12 2:24 ` Mark H Weaver
2013-02-12 4:36 ` Mark H Weaver
2013-02-12 15:53 ` Ludovic Courtès
2013-02-12 15:56 ` Ludovic Courtès
1 sibling, 2 replies; 17+ messages in thread
From: Mark H Weaver @ 2013-02-12 2:24 UTC (permalink / raw)
To: bug-guix
[-- Attachment #1: Type: text/plain, Size: 944 bytes --]
I wrote:
> I've attached two patches. The first arranges to make sure that
> 'pre-inst-env' will be rebuilt when 'pre-inst-env.in' is modified.
>
> The second patch is the main subject of this email. It reworks the
> shell script headers at the top of 'guix-package' and the other scripts
> to avoid modifying environment variables (which could propagate to
> unrelated subprocesses that use libguile), and to avoid prepending
> installed directories to the guile load paths in the case where
> 'pre-inst-env' is being used.
>
> My approach here might be controversial, given that the resulting code
> is a bit longer, so if you don't like it, no worries :)
>
> However, I do find it nice to write more scheme and less shell code, and
> as a bonus the scheme code at the top is properly handled by emacs and
> paredit as if it were in the main body of the file.
>
> What do you think?
And here are the actual patches (oops :)
Mark
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: [PATCH 1/2] Add noinst_SCRIPTS = pre-inst-env to Makefile.am --]
[-- Type: text/x-diff, Size: 655 bytes --]
From 172011c586a96cd15e6401cf813fd6d6ea59b355 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Mon, 11 Feb 2013 19:23:20 -0500
Subject: [PATCH 1/2] Add noinst_SCRIPTS = pre-inst-env to Makefile.am.
* Makefile.am: Add noinst_SCRIPTS = pre-inst-env.
---
Makefile.am | 3 +++
1 file changed, 3 insertions(+)
diff --git a/Makefile.am b/Makefile.am
index b90f7e0..9ec7f55 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -24,6 +24,9 @@ bin_SCRIPTS = \
guix-package \
guix-gc
+noinst_SCRIPTS = \
+ pre-inst-env
+
MODULES = \
guix/base32.scm \
guix/utils.scm \
--
1.7.10.4
[-- Attachment #3: [PATCH 2/2] Improve shell script headers and pre-inst-env handling --]
[-- Type: text/x-diff, Size: 8505 bytes --]
From 4df3f71782256c7a90f9a7445f093a545fcaa1b1 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Mon, 11 Feb 2013 19:13:32 -0500
Subject: [PATCH 2/2] Improve shell script headers and pre-inst-env handling.
* pre-inst-env.in: Define $GUIX_UNINSTALLED.
* guix-build.in, guix-download.in, guix-gc.in, guix-import.in,
guix-package.in: Rewrite shell script headers to adjust '%load-path' and
'%load-compiled-path' within Guile itself instead of setting environment
variables. Inhibit this behavior if $GUIX_UNINSTALLED is set to a non-empty
string.
---
guix-build.in | 22 ++++++++++++++++------
guix-download.in | 22 ++++++++++++++++------
guix-gc.in | 24 +++++++++++++++++-------
guix-import.in | 22 ++++++++++++++++------
guix-package.in | 24 +++++++++++++++++-------
pre-inst-env.in | 7 ++++++-
6 files changed, 88 insertions(+), 33 deletions(-)
diff --git a/guix-build.in b/guix-build.in
index f8c7115..6b79962 100644
--- a/guix-build.in
+++ b/guix-build.in
@@ -1,15 +1,25 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
+script=guix-build
+
prefix="@prefix@"
datarootdir="@datarootdir@"
+moduledir="@guilemoduledir@"
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-build)) '\'guix-build')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
+start="
+(let ()
+ (define (main interp guix-uninstalled-str module-dir script-file . args)
+ (let* ((guix-uninstalled? (not (string-null? guix-uninstalled-str)))
+ (path-to-prepend (if guix-uninstalled? '() (list module-dir))))
+ (set! %load-path (append path-to-prepend %load-path))
+ (set! %load-compiled-path (append path-to-prepend %load-compiled-path))
+ (load script-file)
+ (let (($script (module-ref (resolve-interface '($script)) '$script)))
+ (apply $script args))))
+ (apply main (command-line)))
+"
+exec "${GUILE-@GUILE@}" -c "$start" "$GUIX_UNINSTALLED" "$moduledir" "$0" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
diff --git a/guix-download.in b/guix-download.in
index ea62b09..f6f226e 100644
--- a/guix-download.in
+++ b/guix-download.in
@@ -1,15 +1,25 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
+script=guix-download
+
prefix="@prefix@"
datarootdir="@datarootdir@"
+moduledir="@guilemoduledir@"
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-download)) '\'guix-download')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
+start="
+(let ()
+ (define (main interp guix-uninstalled-str module-dir script-file . args)
+ (let* ((guix-uninstalled? (not (string-null? guix-uninstalled-str)))
+ (path-to-prepend (if guix-uninstalled? '() (list module-dir))))
+ (set! %load-path (append path-to-prepend %load-path))
+ (set! %load-compiled-path (append path-to-prepend %load-compiled-path))
+ (load script-file)
+ (let (($script (module-ref (resolve-interface '($script)) '$script)))
+ (apply $script args))))
+ (apply main (command-line)))
+"
+exec "${GUILE-@GUILE@}" -c "$start" "$GUIX_UNINSTALLED" "$moduledir" "$0" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
diff --git a/guix-gc.in b/guix-gc.in
index 1a4a541..aa30a5f 100644
--- a/guix-gc.in
+++ b/guix-gc.in
@@ -1,15 +1,25 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
+script=guix-gc
+
prefix="@prefix@"
datarootdir="@datarootdir@"
-
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-gc)) '\'guix-gc')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
+moduledir="@guilemoduledir@"
+
+start="
+(let ()
+ (define (main interp guix-uninstalled-str module-dir script-file . args)
+ (let* ((guix-uninstalled? (not (string-null? guix-uninstalled-str)))
+ (path-to-prepend (if guix-uninstalled? '() (list module-dir))))
+ (set! %load-path (append path-to-prepend %load-path))
+ (set! %load-compiled-path (append path-to-prepend %load-compiled-path))
+ (load script-file)
+ (let (($script (module-ref (resolve-interface '($script)) '$script)))
+ (apply $script args))))
+ (apply main (command-line)))
+"
+exec "${GUILE-@GUILE@}" -c "$start" "$GUIX_UNINSTALLED" "$moduledir" "$0" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
diff --git a/guix-import.in b/guix-import.in
index 97619a9..525fa30 100644
--- a/guix-import.in
+++ b/guix-import.in
@@ -1,15 +1,25 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
+script=guix-import
+
prefix="@prefix@"
datarootdir="@datarootdir@"
+moduledir="@guilemoduledir@"
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-import)) '\'guix-import')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
+start="
+(let ()
+ (define (main interp guix-uninstalled-str module-dir script-file . args)
+ (let* ((guix-uninstalled? (not (string-null? guix-uninstalled-str)))
+ (path-to-prepend (if guix-uninstalled? '() (list module-dir))))
+ (set! %load-path (append path-to-prepend %load-path))
+ (set! %load-compiled-path (append path-to-prepend %load-compiled-path))
+ (load script-file)
+ (let (($script (module-ref (resolve-interface '($script)) '$script)))
+ (apply $script args))))
+ (apply main (command-line)))
+"
+exec "${GUILE-@GUILE@}" -c "$start" "$GUIX_UNINSTALLED" "$moduledir" "$0" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
diff --git a/guix-package.in b/guix-package.in
index ae3d2cd..2082a93 100644
--- a/guix-package.in
+++ b/guix-package.in
@@ -1,15 +1,25 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
+script=guix-package
+
prefix="@prefix@"
datarootdir="@datarootdir@"
-
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
+moduledir="@guilemoduledir@"
+
+start="
+(let ()
+ (define (main interp guix-uninstalled-str module-dir script-file . args)
+ (let* ((guix-uninstalled? (not (string-null? guix-uninstalled-str)))
+ (path-to-prepend (if guix-uninstalled? '() (list module-dir))))
+ (set! %load-path (append path-to-prepend %load-path))
+ (set! %load-compiled-path (append path-to-prepend %load-compiled-path))
+ (load script-file)
+ (let (($script (module-ref (resolve-interface '($script)) '$script)))
+ (apply $script args))))
+ (apply main (command-line)))
+"
+exec "${GUILE-@GUILE@}" -c "$start" "$GUIX_UNINSTALLED" "$moduledir" "$0" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
diff --git a/pre-inst-env.in b/pre-inst-env.in
index 1dc63cd..5349c4c 100644
--- a/pre-inst-env.in
+++ b/pre-inst-env.in
@@ -43,7 +43,12 @@ export NIX_ROOT_FINDER NIX_SETUID_HELPER
# auto-compilation.
NIX_HASH="@NIX_HASH@"
-
export NIX_HASH
+# Define $GUIX_UNINSTALLED to prevent `guix-package' and other scripts from
+# prepending @guilemoduledir@ to the Guile load paths.
+
+GUIX_UNINSTALLED=1
+export GUIX_UNINSTALLED
+
exec "$@"
--
1.7.10.4
^ permalink raw reply related [flat|nested] 17+ messages in thread
* Re: [PATCH] Improve shell script headers and pre-inst-env handling
2013-02-12 2:24 ` Mark H Weaver
@ 2013-02-12 4:36 ` Mark H Weaver
2013-02-12 15:53 ` Ludovic Courtès
1 sibling, 0 replies; 17+ messages in thread
From: Mark H Weaver @ 2013-02-12 4:36 UTC (permalink / raw)
To: bug-guix
[-- Attachment #1: Type: text/plain, Size: 132 bytes --]
Here's an improved version of the second patch. There's no functional
difference, but the code is easier to read IMO.
Mark
[-- Attachment #2: [PATCH 2/2] Improve shell script headers and pre-inst-env handling --]
[-- Type: text/x-diff, Size: 7711 bytes --]
From b1ea7f6ab01fb5c1ae1638315dad3fc8903682dc Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Mon, 11 Feb 2013 19:13:32 -0500
Subject: [PATCH 2/2] Improve shell script headers and pre-inst-env handling.
* pre-inst-env.in: Define $GUIX_UNINSTALLED.
* guix-build.in, guix-download.in, guix-gc.in, guix-import.in,
guix-package.in: Rewrite shell script headers to augment '%load-path' and
'%load-compiled-path' within Guile itself instead of setting environment
variables. Inhibit this behavior if $GUIX_UNINSTALLED is set.
---
guix-build.in | 22 ++++++++++++++++------
guix-download.in | 22 ++++++++++++++++------
guix-gc.in | 22 ++++++++++++++++------
guix-import.in | 22 ++++++++++++++++------
guix-package.in | 22 ++++++++++++++++------
pre-inst-env.in | 7 ++++++-
6 files changed, 86 insertions(+), 31 deletions(-)
diff --git a/guix-build.in b/guix-build.in
index f8c7115..29241c7 100644
--- a/guix-build.in
+++ b/guix-build.in
@@ -1,15 +1,25 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
+script=guix-build
+
prefix="@prefix@"
datarootdir="@datarootdir@"
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-build)) '\'guix-build')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
+startup="
+(let ()
+ (define-syntax-rule (push! elt v) (set! v (cons elt v)))
+ (define (main interpreter module-dir script-file . args)
+ (unless (getenv \"GUIX_UNINSTALLED\")
+ (push! module-dir %load-path)
+ (push! module-dir %load-compiled-path))
+ (load script-file)
+ (let ((proc (module-ref (resolve-interface '($script))
+ '$script)))
+ (apply proc args)))
+ (apply main (command-line)))
+"
+exec "${GUILE-@GUILE@}" -c "$startup" "@guilemoduledir@" "$0" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
diff --git a/guix-download.in b/guix-download.in
index ea62b09..ccffbde 100644
--- a/guix-download.in
+++ b/guix-download.in
@@ -1,15 +1,25 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
+script=guix-download
+
prefix="@prefix@"
datarootdir="@datarootdir@"
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-download)) '\'guix-download')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
+startup="
+(let ()
+ (define-syntax-rule (push! elt v) (set! v (cons elt v)))
+ (define (main interpreter module-dir script-file . args)
+ (unless (getenv \"GUIX_UNINSTALLED\")
+ (push! module-dir %load-path)
+ (push! module-dir %load-compiled-path))
+ (load script-file)
+ (let ((proc (module-ref (resolve-interface '($script))
+ '$script)))
+ (apply proc args)))
+ (apply main (command-line)))
+"
+exec "${GUILE-@GUILE@}" -c "$startup" "@guilemoduledir@" "$0" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
diff --git a/guix-gc.in b/guix-gc.in
index 1a4a541..84f18dd 100644
--- a/guix-gc.in
+++ b/guix-gc.in
@@ -1,15 +1,25 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
+script=guix-gc
+
prefix="@prefix@"
datarootdir="@datarootdir@"
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-gc)) '\'guix-gc')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
+startup="
+(let ()
+ (define-syntax-rule (push! elt v) (set! v (cons elt v)))
+ (define (main interpreter module-dir script-file . args)
+ (unless (getenv \"GUIX_UNINSTALLED\")
+ (push! module-dir %load-path)
+ (push! module-dir %load-compiled-path))
+ (load script-file)
+ (let ((proc (module-ref (resolve-interface '($script))
+ '$script)))
+ (apply proc args)))
+ (apply main (command-line)))
+"
+exec "${GUILE-@GUILE@}" -c "$startup" "@guilemoduledir@" "$0" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
diff --git a/guix-import.in b/guix-import.in
index 97619a9..2666d78 100644
--- a/guix-import.in
+++ b/guix-import.in
@@ -1,15 +1,25 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
+script=guix-import
+
prefix="@prefix@"
datarootdir="@datarootdir@"
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-import)) '\'guix-import')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
+startup="
+(let ()
+ (define-syntax-rule (push! elt v) (set! v (cons elt v)))
+ (define (main interpreter module-dir script-file . args)
+ (unless (getenv \"GUIX_UNINSTALLED\")
+ (push! module-dir %load-path)
+ (push! module-dir %load-compiled-path))
+ (load script-file)
+ (let ((proc (module-ref (resolve-interface '($script))
+ '$script)))
+ (apply proc args)))
+ (apply main (command-line)))
+"
+exec "${GUILE-@GUILE@}" -c "$startup" "@guilemoduledir@" "$0" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
diff --git a/guix-package.in b/guix-package.in
index ae3d2cd..32d9afd 100644
--- a/guix-package.in
+++ b/guix-package.in
@@ -1,15 +1,25 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
+script=guix-package
+
prefix="@prefix@"
datarootdir="@datarootdir@"
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
+startup="
+(let ()
+ (define-syntax-rule (push! elt v) (set! v (cons elt v)))
+ (define (main interpreter module-dir script-file . args)
+ (unless (getenv \"GUIX_UNINSTALLED\")
+ (push! module-dir %load-path)
+ (push! module-dir %load-compiled-path))
+ (load script-file)
+ (let ((proc (module-ref (resolve-interface '($script))
+ '$script)))
+ (apply proc args)))
+ (apply main (command-line)))
+"
+exec "${GUILE-@GUILE@}" -c "$startup" "@guilemoduledir@" "$0" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
diff --git a/pre-inst-env.in b/pre-inst-env.in
index 1dc63cd..5349c4c 100644
--- a/pre-inst-env.in
+++ b/pre-inst-env.in
@@ -43,7 +43,12 @@ export NIX_ROOT_FINDER NIX_SETUID_HELPER
# auto-compilation.
NIX_HASH="@NIX_HASH@"
-
export NIX_HASH
+# Define $GUIX_UNINSTALLED to prevent `guix-package' and other scripts from
+# prepending @guilemoduledir@ to the Guile load paths.
+
+GUIX_UNINSTALLED=1
+export GUIX_UNINSTALLED
+
exec "$@"
--
1.7.10.4
^ permalink raw reply related [flat|nested] 17+ messages in thread
* Re: [PATCH] Improve shell script headers and pre-inst-env handling
2013-02-12 2:24 ` Mark H Weaver
2013-02-12 4:36 ` Mark H Weaver
@ 2013-02-12 15:53 ` Ludovic Courtès
1 sibling, 0 replies; 17+ messages in thread
From: Ludovic Courtès @ 2013-02-12 15:53 UTC (permalink / raw)
To: Mark H Weaver; +Cc: bug-guix
Mark H Weaver <mhw@netris.org> skribis:
> From 172011c586a96cd15e6401cf813fd6d6ea59b355 Mon Sep 17 00:00:00 2001
> From: Mark H Weaver <mhw@netris.org>
> Date: Mon, 11 Feb 2013 19:23:20 -0500
> Subject: [PATCH 1/2] Add noinst_SCRIPTS = pre-inst-env to Makefile.am.
>
> * Makefile.am: Add noinst_SCRIPTS = pre-inst-env.
> ---
> Makefile.am | 3 +++
> 1 file changed, 3 insertions(+)
>
> diff --git a/Makefile.am b/Makefile.am
> index b90f7e0..9ec7f55 100644
> --- a/Makefile.am
> +++ b/Makefile.am
> @@ -24,6 +24,9 @@ bin_SCRIPTS = \
> guix-package \
> guix-gc
>
> +noinst_SCRIPTS = \
> + pre-inst-env
I think you need ‘nodist_’ too. Can you also add ‘test-env’ there?
Feel free to push then.
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH] Improve shell script headers and pre-inst-env handling
2013-02-12 1:45 [PATCH] Improve shell script headers and pre-inst-env handling Mark H Weaver
2013-02-12 2:24 ` Mark H Weaver
@ 2013-02-12 15:56 ` Ludovic Courtès
2013-02-12 18:44 ` Mark H Weaver
1 sibling, 1 reply; 17+ messages in thread
From: Ludovic Courtès @ 2013-02-12 15:56 UTC (permalink / raw)
To: Mark H Weaver; +Cc: bug-guix
Mark H Weaver <mhw@netris.org> skribis:
> The second patch is the main subject of this email. It reworks the
> shell script headers at the top of 'guix-package' and the other scripts
> to avoid modifying environment variables (which could propagate to
> unrelated subprocesses that use libguile), and to avoid prepending
> installed directories to the guile load paths in the case where
> 'pre-inst-env' is being used.
>
> My approach here might be controversial, given that the resulting code
> is a bit longer, so if you don't like it, no worries :)
[...]
> +script=guix-build
> +
> prefix="@prefix@"
> datarootdir="@datarootdir@"
>
> -GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
> -export GUILE_LOAD_COMPILED_PATH
> -
> -main='(module-ref (resolve-interface '\''(guix-build)) '\'guix-build')'
> -exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
> - -c "(apply $main (cdr (command-line)))" "$@"
> +startup="
> +(let ()
> + (define-syntax-rule (push! elt v) (set! v (cons elt v)))
> + (define (main interpreter module-dir script-file . args)
> + (unless (getenv \"GUIX_UNINSTALLED\")
> + (push! module-dir %load-path)
> + (push! module-dir %load-compiled-path))
> + (load script-file)
> + (let ((proc (module-ref (resolve-interface '($script))
> + '$script)))
> + (apply proc args)))
> + (apply main (command-line)))
> +"
> +exec "${GUILE-@GUILE@}" -c "$startup" "@guilemoduledir@" "$0" "$@"
Well, it’s a bit longer. :-)
Honestly, I wouldn’t worry about the propagation of $GUILE_LOAD_PATH &
co. to subprocesses, because we know there’s none anyway.
What about a simple:
if test "x$GUIX_UNINSTALLED" = x; then
...
?
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH] Improve shell script headers and pre-inst-env handling
2013-02-12 15:56 ` Ludovic Courtès
@ 2013-02-12 18:44 ` Mark H Weaver
2013-02-12 21:48 ` Ludovic Courtès
0 siblings, 1 reply; 17+ messages in thread
From: Mark H Weaver @ 2013-02-12 18:44 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: bug-guix
ludo@gnu.org (Ludovic Courtès) writes:
> Honestly, I wouldn’t worry about the propagation of $GUILE_LOAD_PATH &
> co. to subprocesses, because we know there’s none anyway.
That policy will lead to future where libguile-using programs break in
random ways when they happen to be subprocesses of each other.
Shouldn't we be setting a better example than that?
If we assume that Guile will never be widely used, and encourage usage
patterns that will cause things to break if it ever becomes more
successful, then we are pretty much guaranteeing a bleak future for
Guile.
Isn't correctness more important than brevity?
What do you think?
Mark
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH] Improve shell script headers and pre-inst-env handling
2013-02-12 18:44 ` Mark H Weaver
@ 2013-02-12 21:48 ` Ludovic Courtès
2013-02-12 22:44 ` Mark H Weaver
2013-02-13 9:55 ` Mark H Weaver
0 siblings, 2 replies; 17+ messages in thread
From: Ludovic Courtès @ 2013-02-12 21:48 UTC (permalink / raw)
To: Mark H Weaver; +Cc: bug-guix
Mark H Weaver <mhw@netris.org> skribis:
> ludo@gnu.org (Ludovic Courtès) writes:
>> Honestly, I wouldn’t worry about the propagation of $GUILE_LOAD_PATH &
>> co. to subprocesses, because we know there’s none anyway.
>
> That policy will lead to future where libguile-using programs break in
> random ways when they happen to be subprocesses of each other.
I agree in general with your feeling.
However, in that case, we know that these command-line tools are just
wrappers around our Scheme APIs, and that they won’t ever launch any
program (programs are a thing of the past; procedures are the future).
So it just seemed safe to me to do that in this particular case.
What do you think?
(BTW, rather than $GUIX_UNINSTALLED, it just occurred to me that
$GUIX_LOAD_PATH would do just as well while being more generic and
easier to implement/use.)
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH] Improve shell script headers and pre-inst-env handling
2013-02-12 21:48 ` Ludovic Courtès
@ 2013-02-12 22:44 ` Mark H Weaver
2013-02-13 14:42 ` Ludovic Courtès
2013-02-13 9:55 ` Mark H Weaver
1 sibling, 1 reply; 17+ messages in thread
From: Mark H Weaver @ 2013-02-12 22:44 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: bug-guix
ludo@gnu.org (Ludovic Courtès) writes:
> Mark H Weaver <mhw@netris.org> skribis:
>
>> ludo@gnu.org (Ludovic Courtès) writes:
>>> Honestly, I wouldn’t worry about the propagation of $GUILE_LOAD_PATH &
>>> co. to subprocesses, because we know there’s none anyway.
>>
>> That policy will lead to future where libguile-using programs break in
>> random ways when they happen to be subprocesses of each other.
>
> I agree in general with your feeling.
>
> However, in that case, we know that these command-line tools are just
> wrappers around our Scheme APIs, and that they won’t ever launch any
> program (programs are a thing of the past; procedures are the future).
> So it just seemed safe to me to do that in this particular case.
>
> What do you think?
Ah, okay, I didn't realize that. When you said "we know there's none
anyway", I thought you meant "no subprocesses that use Guile", but I
guess you meant "no subprocesses at all".
I guess guix-daemon is the only one with subprocesses, and by the time
that's written in Guile hopefully Guile will have a command-line option
to augment %load-compiled-path.
In that case, I withdraw my proposal. I'll make a new patch.
> (BTW, rather than $GUIX_UNINSTALLED, it just occurred to me that
> $GUIX_LOAD_PATH would do just as well while being more generic and
> easier to implement/use.)
Sounds good.
Mark
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH] Improve shell script headers and pre-inst-env handling
2013-02-12 21:48 ` Ludovic Courtès
2013-02-12 22:44 ` Mark H Weaver
@ 2013-02-13 9:55 ` Mark H Weaver
2013-02-13 20:57 ` Ludovic Courtès
1 sibling, 1 reply; 17+ messages in thread
From: Mark H Weaver @ 2013-02-13 9:55 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: bug-guix
Hi Ludovic,
ludo@gnu.org (Ludovic Courtès) writes:
> Mark H Weaver <mhw@netris.org> skribis:
>
>> ludo@gnu.org (Ludovic Courtès) writes:
>>> Honestly, I wouldn’t worry about the propagation of $GUILE_LOAD_PATH &
>>> co. to subprocesses, because we know there’s none anyway.
>>
>> That policy will lead to future where libguile-using programs break in
>> random ways when they happen to be subprocesses of each other.
>
> I agree in general with your feeling.
>
> However, in that case, we know that these command-line tools are just
> wrappers around our Scheme APIs, and that they won’t ever launch any
> program (programs are a thing of the past; procedures are the future).
> So it just seemed safe to me to do that in this particular case.
>
> What do you think?
So I've been working on a patch to fix the ./pre-inst-env problem using
portable shell code instead of Guile code, as you suggested, and this is
the kind of code I'm coming up with:
--8<---------------cut here---------------start------------->8---
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
prefix="@prefix@"
datarootdir="@datarootdir@"
main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')'
if test "x$GUIX_UNINSTALLED" = x; then
GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
export GUILE_LOAD_COMPILED_PATH
exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
-c "(apply $main (cdr (command-line)))" "$@"
else
exec ${GUILE-@GUILE@} -l "$0" \
-c "(apply $main (cdr (command-line)))" "$@"
fi
!#
--8<---------------cut here---------------end--------------->8---
or perhaps you'd prefer something more like this:
--8<---------------cut here---------------start------------->8---
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
prefix="@prefix@"
datarootdir="@datarootdir@"
if test "x$GUIX_UNINSTALLED" = x; then
GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
export GUILE_LOAD_COMPILED_PATH
load_path_args="-L @guilemoduledir@"
else
load_path_args=""
fi
main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')'
exec ${GUILE-@GUILE@} $load_path_args -l "$0" \
-c "(apply $main (cdr (command-line)))" "$@"
!#
--8<---------------cut here---------------end--------------->8---
but the more I look at this ugly, buggy code; and the more I fret
about the inherent bugs having to do with poor handling of shell
meta-characters and colons in file names; and the more I read of the
"Portable Shell Programming" chapter of the autoconf manual, the less
I understand why you feel so strongly about using this awful language
instead of the Guile code I wrote. To save a few lines?
Please take a look at my proposed code one more time with fresh eyes:
--8<---------------cut here---------------start------------->8---
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
script=guix-build
prefix="@prefix@"
datarootdir="@datarootdir@"
startup="
(let ()
(define-syntax-rule (push! elt v) (set! v (cons elt v)))
(define (main interpreter module-dir script-file . args)
(unless (getenv \"GUIX_UNINSTALLED\")
(push! module-dir %load-path)
(push! module-dir %load-compiled-path))
(load script-file)
(let ((proc (module-ref (resolve-interface '($script))
'$script)))
(apply proc args)))
(apply main (command-line)))
"
exec "${GUILE-@GUILE@}" -c "$startup" "@guilemoduledir@" "$0" "$@"
--8<---------------cut here---------------end--------------->8---
Allow me to list the advantages:
* Schemers will have a much easier time understanding precisely what
this code does, without having to grok the finer details of shell
programming and Guile's command-line handling.
* It sets a good example for how to write a Guile program that will be
robust in the case where subprocesses might also use Guile.
* The boilerplate code is identical in all scripts except on line 4
(script=guix-build).
* It is completely robust in its handling of unusual characters, with
the sole exception of "${GUILE-@GUILE@}" which could fail if @GUILE@
contains meta-characters. I could fix that too with a few more lines
of code. (And yes, I know that autoconf is already unable to handle
filenames with meta-characters, but that's no excuse to create similar
bugs in our own code if we can easily avoid it. Besides, maybe some
day autoconf can be made more robust).
and the only disadvantage I'm aware of:
* It's four lines longer (two of which could be trivially eliminated by
removing the "script=guix-build" line and instead replacing the two
occurrences of "$script" with "guix-build").
I would urge you to please reconsider your position.
If you still prefer the shell-based approach, then could you please take
care of fixing the ./pre-inst-env bug as you think is best? I don't
want my name associated with it.
> (BTW, rather than $GUIX_UNINSTALLED, it just occurred to me that
> $GUIX_LOAD_PATH would do just as well while being more generic and
> easier to implement/use.)
I thought about this too, but it seems to me that it wouldn't work
properly for "./pre-inst-env guile". Or am I missing something?
Regards,
Mark
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH] Improve shell script headers and pre-inst-env handling
2013-02-12 22:44 ` Mark H Weaver
@ 2013-02-13 14:42 ` Ludovic Courtès
0 siblings, 0 replies; 17+ messages in thread
From: Ludovic Courtès @ 2013-02-13 14:42 UTC (permalink / raw)
To: Mark H Weaver; +Cc: bug-guix
Mark H Weaver <mhw@netris.org> skribis:
> ludo@gnu.org (Ludovic Courtès) writes:
>
>> Mark H Weaver <mhw@netris.org> skribis:
>>
>>> ludo@gnu.org (Ludovic Courtès) writes:
>>>> Honestly, I wouldn’t worry about the propagation of $GUILE_LOAD_PATH &
>>>> co. to subprocesses, because we know there’s none anyway.
>>>
>>> That policy will lead to future where libguile-using programs break in
>>> random ways when they happen to be subprocesses of each other.
>>
>> I agree in general with your feeling.
>>
>> However, in that case, we know that these command-line tools are just
>> wrappers around our Scheme APIs, and that they won’t ever launch any
>> program (programs are a thing of the past; procedures are the future).
>> So it just seemed safe to me to do that in this particular case.
>>
>> What do you think?
>
> Ah, okay, I didn't realize that. When you said "we know there's none
> anyway", I thought you meant "no subprocesses that use Guile", but I
> guess you meant "no subprocesses at all".
Exactly.
> I guess guix-daemon is the only one with subprocesses, and by the time
> that's written in Guile hopefully Guile will have a command-line option
> to augment %load-compiled-path.
Actually, guix-daemon spawns processes written in Guile, such as
list-runtime-roots and hopefully soon a “binary substituter”, but these
should be simple stand-alone programs.
> In that case, I withdraw my proposal. I'll make a new patch.
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH] Improve shell script headers and pre-inst-env handling
2013-02-13 9:55 ` Mark H Weaver
@ 2013-02-13 20:57 ` Ludovic Courtès
2013-02-14 8:28 ` Mark H Weaver
0 siblings, 1 reply; 17+ messages in thread
From: Ludovic Courtès @ 2013-02-13 20:57 UTC (permalink / raw)
To: Mark H Weaver; +Cc: bug-guix
Mark H Weaver <mhw@netris.org> skribis:
> So I've been working on a patch to fix the ./pre-inst-env problem using
> portable shell code instead of Guile code, as you suggested, and this is
> the kind of code I'm coming up with:
The first snippet looks good to me.
> but the more I look at this ugly, buggy code; and the more I fret
> about the inherent bugs having to do with poor handling of shell
> meta-characters and colons in file names; and the more I read of the
> "Portable Shell Programming" chapter of the autoconf manual, the less
> I understand why you feel so strongly about using this awful language
> instead of the Guile code I wrote. To save a few lines?
I think either we mix shell and Scheme (which we more or less have to do
because Guile is largely unusable as a shebang for several reasons), in
which case the shell snippet should be as small as possible, or we do
Scheme-only (which I thought was impossible, but I could be wrong.)
So:
> Please take a look at my proposed code one more time with fresh eyes:
[...]
> startup="
> (let ()
> (define-syntax-rule (push! elt v) (set! v (cons elt v)))
> (define (main interpreter module-dir script-file . args)
> (unless (getenv \"GUIX_UNINSTALLED\")
> (push! module-dir %load-path)
> (push! module-dir %load-compiled-path))
> (load script-file)
> (let ((proc (module-ref (resolve-interface '($script))
> '$script)))
> (apply proc args)))
> (apply main (command-line)))
Would this work if we used “#!@GUILE@ -ds” and do that from there?
> * The boilerplate code is identical in all scripts except on line 4
> (script=guix-build).
Note that I think we’ll most likely have a single ‘guix’ script in the
near future, so that ‘guix-pull’ can actually update everything: Guix,
commands, and distro.
>> (BTW, rather than $GUIX_UNINSTALLED, it just occurred to me that
>> $GUIX_LOAD_PATH would do just as well while being more generic and
>> easier to implement/use.)
>
> I thought about this too, but it seems to me that it wouldn't work
> properly for "./pre-inst-env guile". Or am I missing something?
Something like:
--8<---------------cut here---------------start------------->8---
GUILE_LOAD_COMPILED_PATH="${GUIX_LOAD_PATH}${GUIX_LOAD_PATH:+:}@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
export GUILE_LOAD_COMPILED_PATH
GUILE_LOAD_PATH="${GUIX_LOAD_PATH}${GUIX_LOAD_PATH:+:}@guilemoduledir@:$GUILE_LOAD_PATH"
export GUILE_LOAD_PATH
main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')'
exec ${GUILE-@GUILE@} -l "$0" ...
--8<---------------cut here---------------end--------------->8---
Thoughts? :-)
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH] Improve shell script headers and pre-inst-env handling
2013-02-13 20:57 ` Ludovic Courtès
@ 2013-02-14 8:28 ` Mark H Weaver
2013-02-14 9:44 ` [PATCH] Replace individual scripts with master 'guix' script Mark H Weaver
0 siblings, 1 reply; 17+ messages in thread
From: Mark H Weaver @ 2013-02-14 8:28 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: bug-guix
[-- Attachment #1: Type: text/plain, Size: 813 bytes --]
Hi Ludovic,
ludo@gnu.org (Ludovic Courtès) writes:
> Note that I think we’ll most likely have a single ‘guix’ script in the
> near future, so that ‘guix-pull’ can actually update everything: Guix,
> commands, and distro.
Okay, I have another proposal. I've written a proposed 'guix' script
that's pure Guile code. The idea is that "guix FOO ARGS ..." augments
the load paths as needed, loads the module (guix scripts guix-FOO) and
then applies the procedure 'guix-FOO' to (ARGS ...)
It also supports "guix-FOO ARGS ..." simply by making 'guix-FOO' a
symlink to 'guix'.
Then we can move all the scripts into guix/scripts/, and remove the
boilerplate shell code from the top of all them. They become pure guile
modules. No more shell at all.
What do you think?
Mark
[-- Attachment #2: guix.in --]
[-- Type: text/plain, Size: 2625 bytes --]
#!@GUILE@ -s
-*- scheme -*-
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;;
;;; 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/>.
(use-modules (ice-9 regex))
(let ()
(define-syntax-rule (push! elt v) (set! v (cons elt v)))
(define config-lookup
(let ((config '(("prefix" . "@prefix@")
("datarootdir" . "@datarootdir@")
("guilemoduledir" . "@guilemoduledir@")))
(var-ref-regexp (make-regexp "\\$\\{([a-z]+)\\}")))
(define (expand-var-ref match)
(lookup (match:substring match 1)))
(define (expand str)
(regexp-substitute/global #f var-ref-regexp str
'pre expand-var-ref 'post))
(define (lookup name)
(expand (assoc-ref config name)))
lookup))
(define (maybe-augment-load-paths!)
(unless (getenv "GUIX_UNINSTALLED")
(let ((module-dir (config-lookup "guilemoduledir")))
(push! module-dir %load-path)
(push! module-dir %load-compiled-path))))
(define (run-script name args)
(let* ((symbol (string->symbol name))
(module (resolve-interface `(guix scripts ,symbol)))
(script (module-ref module symbol)))
(apply script args)))
(define (main arg0 . args)
(setlocale LC_ALL "") ; XXX Is there a reason not to do this?
(maybe-augment-load-paths!)
(let ((cmd (basename arg0)))
(cond ((string-prefix? "guix-" cmd)
(run-script cmd args))
((not (null? args))
(run-script (string-append "guix-" (car args))
(cdr args)))
(else
;; TODO: Dynamically generate a summary of available commands.
(format (current-error-port)
"Usage: guix <command> [<args>]~%")
(exit 1)))))
(apply main (command-line)))
^ permalink raw reply [flat|nested] 17+ messages in thread
* [PATCH] Replace individual scripts with master 'guix' script
2013-02-14 8:28 ` Mark H Weaver
@ 2013-02-14 9:44 ` Mark H Weaver
2013-02-14 13:41 ` Ludovic Courtès
0 siblings, 1 reply; 17+ messages in thread
From: Mark H Weaver @ 2013-02-14 9:44 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: bug-guix
[-- Attachment #1: Type: text/plain, Size: 935 bytes --]
I wrote:
> ludo@gnu.org (Ludovic Courtès) writes:
>> Note that I think we’ll most likely have a single ‘guix’ script in the
>> near future, so that ‘guix-pull’ can actually update everything: Guix,
>> commands, and distro.
>
> Okay, I have another proposal. I've written a proposed 'guix' script
> that's pure Guile code. The idea is that "guix FOO ARGS ..." augments
> the load paths as needed, loads the module (guix scripts guix-FOO) and
> then applies the procedure 'guix-FOO' to (ARGS ...)
>
> It also supports "guix-FOO ARGS ..." simply by making 'guix-FOO' a
> symlink to 'guix'.
>
> Then we can move all the scripts into guix/scripts/, and remove the
> boilerplate shell code from the top of all them. They become pure guile
> modules. No more shell at all.
>
> What do you think?
I went ahead and made a preliminary patch to do this.
Comments and suggestions welcome.
Mark
[-- Attachment #2: [PATCH 1/2] PRELIMINARY: Replace individual scripts with master 'guix' script --]
[-- Type: text/x-diff, Size: 132228 bytes --]
From 726ef0a61f943522ecb5a8d8b609c6810727b9d3 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 14 Feb 2013 04:15:25 -0500
Subject: [PATCH 1/2] PRELIMINARY: Replace individual scripts with master
'guix' script.
TODO: Update documentation.
TODO: Install links for 'guix-package' and friends.
* scripts/guix.in: New script.
* Makefile.am (bin_SCRIPTS): Add 'scripts/guix'. Remove 'guix-build',
'guix-download', 'guix-import', 'guix-package', and 'guix-gc'.
(MODULES): Add 'guix/scripts/guix-build.scm',
'guix/scripts/guix-download.scm', 'guix/scripts/guix-import.scm',
'guix/scripts/guix-package.scm', and 'guix/scripts/guix-gc.scm'.
* configure.ac (AC_CONFIG_FILES): Add 'scripts/guix'. Remove 'guix-build',
'guix-download', 'guix-import', 'guix-package', and 'guix-gc'.
* guix-build.in, guix-download.in, guix-gc.in, guix-import.in,
guix-package.in: Remove shell script boilerplate. Move to guix/scripts and
change suffix from ".in" to ".scm". Change module name from (NAME) to
(guix scripts NAME).
* pre-inst-env.in: Add "@abs_top_builddir@/scripts" to the front of $PATH.
Export $GUIX_UNINSTALLED.
* .gitignore: Add '/scripts/guix'. Remove '/guix-build', '/guix-download',
'/guix-package', '/guix-import', and '/guix-gc'.
---
.gitignore | 6 +-
Makefile.am | 11 +-
configure.ac | 9 +-
guix-build.in | 317 ------------------
guix-download.in | 164 ----------
guix-gc.in | 183 -----------
guix-import.in | 137 --------
guix-package.in | 706 ----------------------------------------
guix/scripts/guix-build.scm | 304 +++++++++++++++++
guix/scripts/guix-download.scm | 151 +++++++++
guix/scripts/guix-gc.scm | 170 ++++++++++
guix/scripts/guix-import.scm | 124 +++++++
guix/scripts/guix-package.scm | 693 +++++++++++++++++++++++++++++++++++++++
pre-inst-env.in | 11 +-
scripts/guix.in | 68 ++++
15 files changed, 1527 insertions(+), 1527 deletions(-)
delete mode 100644 guix-build.in
delete mode 100644 guix-download.in
delete mode 100644 guix-gc.in
delete mode 100644 guix-import.in
delete mode 100644 guix-package.in
create mode 100644 guix/scripts/guix-build.scm
create mode 100644 guix/scripts/guix-download.scm
create mode 100644 guix/scripts/guix-gc.scm
create mode 100644 guix/scripts/guix-import.scm
create mode 100644 guix/scripts/guix-package.scm
create mode 100644 scripts/guix.in
diff --git a/.gitignore b/.gitignore
index ecdaed2..302e473 100644
--- a/.gitignore
+++ b/.gitignore
@@ -34,7 +34,6 @@ config.cache
/po/remove-potcdate.sin
/po/stamp-po
/po/guix.pot
-/guix-build
/tests/*.trs
/INSTALL
/m4/*
@@ -44,12 +43,9 @@ config.cache
/doc/guix.pdf
/doc/stamp-vti
/doc/version.texi
-/guix-download
/gnu/packages/bootstrap/x86_64-linux/guile-2.0.7.tar.xz
/gnu/packages/bootstrap/i686-linux/guile-2.0.7.tar.xz
-/guix-package
/guix/config.scm
-/guix-import
/nix/nix-daemon/nix-daemon.cc
/nix/config.h
/nix/config.h.in
@@ -64,7 +60,7 @@ stamp-h[0-9]
/nix/scripts/list-runtime-roots
/test-env
/nix/nix-setuid-helper/nix-setuid-helper.cc
-/guix-gc
+/scripts/guix
/doc/guix.aux
/doc/guix.cp
/doc/guix.cps
diff --git a/Makefile.am b/Makefile.am
index 7b0613d..f19eae7 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -18,17 +18,18 @@
# along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
bin_SCRIPTS = \
- guix-build \
- guix-download \
- guix-import \
- guix-package \
- guix-gc
+ scripts/guix
nodist_noinst_SCRIPTS = \
pre-inst-env \
test-env
MODULES = \
+ guix/scripts/guix-build.scm \
+ guix/scripts/guix-download.scm \
+ guix/scripts/guix-import.scm \
+ guix/scripts/guix-package.scm \
+ guix/scripts/guix-gc.scm \
guix/base32.scm \
guix/utils.scm \
guix/derivations.scm \
diff --git a/configure.ac b/configure.ac
index a9cf17a..dd1f843 100644
--- a/configure.ac
+++ b/configure.ac
@@ -117,14 +117,9 @@ AC_CONFIG_FILES([Makefile
po/Makefile.in
guix/config.scm])
-AC_CONFIG_FILES([guix-build
- guix-download
- guix-import
- guix-package
- guix-gc
+AC_CONFIG_FILES([scripts/guix
pre-inst-env
test-env],
- [chmod +x guix-build guix-download guix-import guix-package guix-gc \
- pre-inst-env test-env])
+ [chmod +x scripts/guix pre-inst-env test-env])
AC_OUTPUT
diff --git a/guix-build.in b/guix-build.in
deleted file mode 100644
index 35ddb00..0000000
--- a/guix-build.in
+++ /dev/null
@@ -1,317 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-
-prefix="@prefix@"
-datarootdir="@datarootdir@"
-
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-build)) '\'guix-build')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
-;;;
-;;; 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)
- #:use-module (guix ui)
- #:use-module (guix store)
- #:use-module (guix derivations)
- #:use-module (guix packages)
- #:use-module (guix utils)
- #:use-module (ice-9 format)
- #:use-module (ice-9 match)
- #:use-module (ice-9 vlist)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-37)
- #:autoload (gnu packages) (find-packages-by-name
- find-newest-available-packages)
- #:export (guix-build))
-
-(define %store
- (make-parameter #f))
-
-(define (derivations-from-package-expressions exp system source?)
- "Eval EXP and return the corresponding derivation path for SYSTEM.
-When SOURCE? is true, return the derivations of the package sources."
- (let ((p (eval exp (current-module))))
- (if (package? p)
- (if source?
- (let ((source (package-source p))
- (loc (package-location p)))
- (if source
- (package-source-derivation (%store) source)
- (leave (_ "~a: error: package `~a' has no source~%")
- (location->string loc) (package-name p))))
- (package-derivation (%store) p system))
- (leave (_ "expression `~s' does not evaluate to a package~%")
- exp))))
-
-\f
-;;;
-;;; Command-line options.
-;;;
-
-(define %default-options
- ;; Alist of default option values.
- `((system . ,(%current-system))
- (substitutes? . #t)
- (verbosity . 0)))
-
-(define (show-help)
- (display (_ "Usage: guix-build [OPTION]... PACKAGE-OR-DERIVATION...
-Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
- (display (_ "
- -e, --expression=EXPR build the package EXPR evaluates to"))
- (display (_ "
- -S, --source build the packages' source derivations"))
- (display (_ "
- -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
- (display (_ "
- -d, --derivations return the derivation paths of the given packages"))
- (display (_ "
- -K, --keep-failed keep build tree of failed builds"))
- (display (_ "
- -n, --dry-run do not build the derivations"))
- (display (_ "
- --no-substitutes build instead of resorting to pre-built substitutes"))
- (display (_ "
- -c, --cores=N allow the use of up to N CPU cores for the build"))
- (display (_ "
- -r, --root=FILE make FILE a symlink to the result, and register it
- as a garbage collector root"))
- (display (_ "
- --verbosity=LEVEL use the given verbosity LEVEL"))
- (newline)
- (display (_ "
- -h, --help display this help and exit"))
- (display (_ "
- -V, --version display version information and exit"))
- (newline)
- (show-bug-report-information))
-
-(define %options
- ;; Specifications of the command-line options.
- (list (option '(#\h "help") #f #f
- (lambda args
- (show-help)
- (exit 0)))
- (option '(#\V "version") #f #f
- (lambda args
- (show-version-and-exit "guix-build")))
-
- (option '(#\S "source") #f #f
- (lambda (opt name arg result)
- (alist-cons 'source? #t result)))
- (option '(#\s "system") #t #f
- (lambda (opt name arg result)
- (alist-cons 'system arg
- (alist-delete 'system result eq?))))
- (option '(#\d "derivations") #f #f
- (lambda (opt name arg result)
- (alist-cons 'derivations-only? #t result)))
- (option '(#\e "expression") #t #f
- (lambda (opt name arg result)
- (alist-cons 'expression
- (call-with-input-string arg read)
- result)))
- (option '(#\K "keep-failed") #f #f
- (lambda (opt name arg result)
- (alist-cons 'keep-failed? #t result)))
- (option '(#\c "cores") #t #f
- (lambda (opt name arg result)
- (let ((c (false-if-exception (string->number arg))))
- (if c
- (alist-cons 'cores c result)
- (leave (_ "~a: not a number~%") arg)))))
- (option '(#\n "dry-run") #f #f
- (lambda (opt name arg result)
- (alist-cons 'dry-run? #t result)))
- (option '("no-substitutes") #f #f
- (lambda (opt name arg result)
- (alist-cons 'substitutes? #f
- (alist-delete 'substitutes? result))))
- (option '(#\r "root") #t #f
- (lambda (opt name arg result)
- (alist-cons 'gc-root arg result)))
- (option '("verbosity") #t #f
- (lambda (opt name arg result)
- (let ((level (string->number arg)))
- (alist-cons 'verbosity level
- (alist-delete 'verbosity result)))))))
-
-\f
-;;;
-;;; Entry point.
-;;;
-
-(define (guix-build . args)
- (define (parse-options)
- ;; Return the alist of option values.
- (args-fold args %options
- (lambda (opt name arg result)
- (leave (_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (alist-cons 'argument arg result))
- %default-options))
-
- (define (register-root paths root)
- ;; Register ROOT as an indirect GC root for all of PATHS.
- (let* ((root (string-append (canonicalize-path (dirname root))
- "/" root)))
- (catch 'system-error
- (lambda ()
- (match paths
- ((path)
- (symlink path root)
- (add-indirect-root (%store) root))
- ((paths ...)
- (fold (lambda (path count)
- (let ((root (string-append root "-" (number->string count))))
- (symlink path root)
- (add-indirect-root (%store) root))
- (+ 1 count))
- 0
- paths))))
- (lambda args
- (format (current-error-port)
- (_ "failed to create GC root `~a': ~a~%")
- root (strerror (system-error-errno args)))
- (exit 1)))))
-
- (define newest-available-packages
- (memoize find-newest-available-packages))
-
- (define (find-best-packages-by-name name version)
- (if version
- (find-packages-by-name name version)
- (match (vhash-assoc name (newest-available-packages))
- ((_ version pkgs ...) pkgs)
- (#f '()))))
-
- (define (find-package request)
- ;; Return a package matching REQUEST. REQUEST may be a package
- ;; name, or a package name followed by a hyphen and a version
- ;; number. If the version number is not present, return the
- ;; preferred newest version.
- (let-values (((name version)
- (package-name->name+version request)))
- (match (find-best-packages-by-name name version)
- ((p) ; one match
- p)
- ((p x ...) ; several matches
- (format (current-error-port)
- (_ "warning: ambiguous package specification `~a'~%")
- request)
- (format (current-error-port)
- (_ "warning: choosing ~a from ~a~%")
- (package-full-name p)
- (location->string (package-location p)))
- p)
- (_ ; no matches
- (if version
- (leave (_ "~A: package not found for version ~a~%")
- name version)
- (leave (_ "~A: unknown package~%") name))))))
-
- (install-locale)
- (textdomain "guix")
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
-
- (with-error-handling
- (let ((opts (parse-options)))
- (parameterize ((%store (open-connection)))
- (let* ((src? (assoc-ref opts 'source?))
- (sys (assoc-ref opts 'system))
- (drv (filter-map (match-lambda
- (('expression . exp)
- (derivations-from-package-expressions exp sys
- src?))
- (('argument . (? derivation-path? drv))
- drv)
- (('argument . (? string? x))
- (let ((p (find-package x)))
- (if src?
- (let ((s (package-source p)))
- (package-source-derivation
- (%store) s))
- (package-derivation (%store) p sys))))
- (_ #f))
- opts))
- (req (append-map (lambda (drv-path)
- (let ((d (call-with-input-file drv-path
- read-derivation)))
- (derivation-prerequisites-to-build (%store) d)))
- drv))
- (req* (delete-duplicates
- (append (remove (compose (cut valid-path? (%store) <>)
- derivation-path->output-path)
- drv)
- (map derivation-input-path req))))
- (roots (filter-map (match-lambda
- (('gc-root . root) root)
- (_ #f))
- opts)))
- (if (assoc-ref opts 'dry-run?)
- (format (current-error-port)
- (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
- "~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
- (length req*))
- (null? req*) req*)
- (format (current-error-port)
- (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
- "~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
- (length req*))
- (null? req*) req*))
-
- ;; TODO: Add more options.
- (set-build-options (%store)
- #:keep-failed? (assoc-ref opts 'keep-failed?)
- #:build-cores (or (assoc-ref opts 'cores) 0)
- #:use-substitutes? (assoc-ref opts 'substitutes?)
- #:verbosity (assoc-ref opts 'verbosity))
-
- (if (assoc-ref opts 'derivations-only?)
- (begin
- (format #t "~{~a~%~}" drv)
- (for-each (cut register-root <> <>)
- (map list drv) roots))
- (or (assoc-ref opts 'dry-run?)
- (and (build-derivations (%store) drv)
- (for-each (lambda (d)
- (let ((drv (call-with-input-file d
- read-derivation)))
- (format #t "~{~a~%~}"
- (map (match-lambda
- ((out-name . out)
- (derivation-path->output-path
- d out-name)))
- (derivation-outputs drv)))))
- drv)
- (for-each (cut register-root <> <>)
- (map (lambda (drv)
- (map cdr
- (derivation-path->output-paths drv)))
- drv)
- roots)))))))))
diff --git a/guix-download.in b/guix-download.in
deleted file mode 100644
index ea62b09..0000000
--- a/guix-download.in
+++ /dev/null
@@ -1,164 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-
-prefix="@prefix@"
-datarootdir="@datarootdir@"
-
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-download)) '\'guix-download')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; 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-download)
- #:use-module (guix ui)
- #:use-module (guix store)
- #:use-module (guix utils)
- #:use-module (guix base32)
- #:use-module ((guix download) #:select (%mirrors))
- #:use-module (guix build download)
- #:use-module (web uri)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-37)
- #:use-module (rnrs bytevectors)
- #:use-module (rnrs io ports)
- #:export (guix-download))
-
-(define (call-with-temporary-output-file proc)
- (let* ((template (string-copy "guix-download.XXXXXX"))
- (out (mkstemp! template)))
- (dynamic-wind
- (lambda ()
- #t)
- (lambda ()
- (proc template out))
- (lambda ()
- (false-if-exception (delete-file template))))))
-
-(define (fetch-and-store store fetch name)
- "Call FETCH for URI, and pass it the name of a file to write to; eventually,
-copy data from that port to STORE, under NAME. Return the resulting
-store path."
- (call-with-temporary-output-file
- (lambda (temp port)
- (let ((result
- (parameterize ((current-output-port (current-error-port)))
- (fetch temp))))
- (close port)
- (and result
- (add-to-store store name #f "sha256" temp))))))
-\f
-;;;
-;;; Command-line options.
-;;;
-
-(define %default-options
- ;; Alist of default option values.
- `((format . ,bytevector->nix-base32-string)))
-
-(define (show-help)
- (display (_ "Usage: guix-download [OPTION]... URL
-Download the file at URL, add it to the store, and print its store path
-and the hash of its contents.\n"))
- (format #t (_ "
- -f, --format=FMT write the hash in the given format (default: `nix-base32')"))
- (newline)
- (display (_ "
- -h, --help display this help and exit"))
- (display (_ "
- -V, --version display version information and exit"))
- (newline)
- (show-bug-report-information))
-
-(define %options
- ;; Specifications of the command-line options.
- (list (option '(#\f "format") #t #f
- (lambda (opt name arg result)
- (define fmt-proc
- (match arg
- ("nix-base32"
- bytevector->nix-base32-string)
- ("base32"
- bytevector->base32-string)
- ((or "base16" "hex" "hexadecimal")
- bytevector->base16-string)
- (x
- (format (current-error-port)
- "unsupported hash format: ~a~%" arg))))
-
- (alist-cons 'format fmt-proc
- (alist-delete 'format result))))
-
- (option '(#\h "help") #f #f
- (lambda args
- (show-help)
- (exit 0)))
- (option '(#\V "version") #f #f
- (lambda args
- (show-version-and-exit "guix-download")))))
-
-\f
-;;;
-;;; Entry point.
-;;;
-
-(define (guix-download . args)
- (define (parse-options)
- ;; Return the alist of option values.
- (args-fold args %options
- (lambda (opt name arg result)
- (leave (_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (alist-cons 'argument arg result))
- %default-options))
-
- (install-locale)
- (textdomain "guix")
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
-
- (let* ((opts (parse-options))
- (store (open-connection))
- (arg (assq-ref opts 'argument))
- (uri (or (string->uri arg)
- (leave (_ "guix-download: ~a: failed to parse URI~%")
- arg)))
- (path (case (uri-scheme uri)
- ((file)
- (add-to-store store (basename (uri-path uri))
- #f "sha256" (uri-path uri)))
- (else
- (fetch-and-store store
- (cut url-fetch arg <>
- #:mirrors %mirrors)
- (basename (uri-path uri))))))
- (hash (call-with-input-file
- (or path
- (leave (_ "guix-download: ~a: download failed~%")
- arg))
- (compose sha256 get-bytevector-all)))
- (fmt (assq-ref opts 'format)))
- (format #t "~a~%~a~%" path (fmt hash))
- #t))
diff --git a/guix-gc.in b/guix-gc.in
deleted file mode 100644
index 1a4a541..0000000
--- a/guix-gc.in
+++ /dev/null
@@ -1,183 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-
-prefix="@prefix@"
-datarootdir="@datarootdir@"
-
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-gc)) '\'guix-gc')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; 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-gc)
- #:use-module (guix ui)
- #:use-module (guix store)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-37)
- #:export (guix-gc))
-
-\f
-;;;
-;;; Command-line options.
-;;;
-
-(define %default-options
- ;; Alist of default option values.
- `((action . collect-garbage)))
-
-(define (show-help)
- (display (_ "Usage: guix-gc [OPTION]... PATHS...
-Invoke the garbage collector.\n"))
- (display (_ "
- -C, --collect-garbage[=MIN]
- collect at least MIN bytes of garbage"))
- (display (_ "
- -d, --delete attempt to delete PATHS"))
- (display (_ "
- --list-dead list dead paths"))
- (display (_ "
- --list-live list live paths"))
- (newline)
- (display (_ "
- -h, --help display this help and exit"))
- (display (_ "
- -V, --version display version information and exit"))
- (newline)
- (show-bug-report-information))
-
-(define (size->number str)
- "Convert STR, a storage measurement representation such as \"1024\" or
-\"1MiB\", to a number of bytes. Raise an error if STR could not be
-interpreted."
- (define unit-pos
- (string-rindex str char-set:digit))
-
- (define unit
- (and unit-pos (substring str (+ 1 unit-pos))))
-
- (let* ((numstr (if unit-pos
- (substring str 0 (+ 1 unit-pos))
- str))
- (num (string->number numstr)))
- (if num
- (* num
- (match unit
- ("KiB" (expt 2 10))
- ("MiB" (expt 2 20))
- ("GiB" (expt 2 30))
- ("TiB" (expt 2 40))
- ("KB" (expt 10 3))
- ("MB" (expt 10 6))
- ("GB" (expt 10 9))
- ("TB" (expt 10 12))
- ("" 1)
- (_
- (format (current-error-port) (_ "error: unknown unit: ~a~%")
- unit)
- (exit 1))))
- (begin
- (format (current-error-port)
- (_ "error: invalid number: ~a") numstr)
- (exit 1)))))
-
-(define %options
- ;; Specification of the command-line options.
- (list (option '(#\h "help") #f #f
- (lambda args
- (show-help)
- (exit 0)))
- (option '(#\V "version") #f #f
- (lambda args
- (show-version-and-exit "guix-gc")))
-
- (option '(#\C "collect-garbage") #f #t
- (lambda (opt name arg result)
- (let ((result (alist-cons 'action 'collect-garbage
- (alist-delete 'action result))))
- (match arg
- ((? string?)
- (let ((amount (size->number arg)))
- (if arg
- (alist-cons 'min-freed amount result)
- (begin
- (format (current-error-port)
- (_ "error: invalid amount of storage: ~a~%")
- arg)
- (exit 1)))))
- (#f result)))))
- (option '(#\d "delete") #f #f
- (lambda (opt name arg result)
- (alist-cons 'action 'delete
- (alist-delete 'action result))))
- (option '("list-dead") #f #f
- (lambda (opt name arg result)
- (alist-cons 'action 'list-dead
- (alist-delete 'action result))))
- (option '("list-live") #f #f
- (lambda (opt name arg result)
- (alist-cons 'action 'list-live
- (alist-delete 'action result))))))
-
-\f
-;;;
-;;; Entry point.
-;;;
-
-(define (guix-gc . args)
- (define (parse-options)
- ;; Return the alist of option values.
- (args-fold args %options
- (lambda (opt name arg result)
- (leave (_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (alist-cons 'argument arg result))
- %default-options))
-
- (install-locale)
- (textdomain "guix")
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
-
- (with-error-handling
- (let ((opts (parse-options))
- (store (open-connection)))
- (case (assoc-ref opts 'action)
- ((collect-garbage)
- (let ((min-freed (assoc-ref opts 'min-freed)))
- (if min-freed
- (collect-garbage store min-freed)
- (collect-garbage store))))
- ((delete)
- (let ((paths (filter-map (match-lambda
- (('argument . arg) arg)
- (_ #f))
- opts)))
- (delete-paths store paths)))
- ((list-dead)
- (for-each (cut simple-format #t "~a~%" <>)
- (dead-paths store)))
- ((list-live)
- (for-each (cut simple-format #t "~a~%" <>)
- (live-paths store)))))))
diff --git a/guix-import.in b/guix-import.in
deleted file mode 100644
index 97619a9..0000000
--- a/guix-import.in
+++ /dev/null
@@ -1,137 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-
-prefix="@prefix@"
-datarootdir="@datarootdir@"
-
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-import)) '\'guix-import')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
-;;;
-;;; 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-import)
- #:use-module (guix ui)
- #:use-module (guix snix)
- #:use-module (guix utils)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-37)
- #:use-module (ice-9 match)
- #:use-module (ice-9 pretty-print)
- #:export (guix-import))
-
-\f
-;;;
-;;; Helper.
-;;;
-
-(define (newline-rewriting-port output)
- "Return an output port that rewrites strings containing the \\n escape
-to an actual newline. This works around the behavior of `pretty-print'
-and `write', which output these as \\n instead of actual newlines,
-whereas we want the `description' field to contain actual newlines
-rather than \\n."
- (define (write-string str)
- (let loop ((chars (string->list str)))
- (match chars
- (()
- #t)
- ((#\\ #\n rest ...)
- (newline output)
- (loop rest))
- ((chr rest ...)
- (write-char chr output)
- (loop rest)))))
-
- (make-soft-port (vector (cut write-char <>)
- write-string
- (lambda _ #t) ; flush
- #f
- (lambda _ #t) ; close
- #f)
- "w"))
-
-\f
-;;;
-;;; Command-line options.
-;;;
-
-(define %default-options
- '())
-
-(define (show-help)
- (display (_ "Usage: guix-import NIXPKGS ATTRIBUTE
-Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n"))
- (display (_ "
- -h, --help display this help and exit"))
- (display (_ "
- -V, --version display version information and exit"))
- (newline)
- (show-bug-report-information))
-
-(define %options
- ;; Specification of the command-line options.
- (list (option '(#\h "help") #f #f
- (lambda args
- (show-help)
- (exit 0)))
- (option '(#\V "version") #f #f
- (lambda args
- (show-version-and-exit "guix-import")))))
-
-\f
-;;;
-;;; Entry point.
-;;;
-
-(define (guix-import . args)
- (define (parse-options)
- ;; Return the alist of option values.
- (args-fold args %options
- (lambda (opt name arg result)
- (leave (_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (alist-cons 'argument arg result))
- %default-options))
-
- (install-locale)
- (textdomain "guix")
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
-
- (let* ((opts (parse-options))
- (args (filter-map (match-lambda
- (('argument . value)
- value)
- (_ #f))
- (reverse opts))))
- (match args
- ((nixpkgs attribute)
- (let-values (((expr loc)
- (nixpkgs->guix-package nixpkgs attribute)))
- (format #t ";; converted from ~a:~a~%~%"
- (location-file loc) (location-line loc))
- (pretty-print expr (newline-rewriting-port (current-output-port)))))
- (_
- (leave (_ "wrong number of arguments~%"))))))
diff --git a/guix-package.in b/guix-package.in
deleted file mode 100644
index 584481a..0000000
--- a/guix-package.in
+++ /dev/null
@@ -1,706 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-
-prefix="@prefix@"
-datarootdir="@datarootdir@"
-
-GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
-export GUILE_LOAD_COMPILED_PATH
-
-main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')'
-exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
-;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
-;;;
-;;; 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-package)
- #:use-module (guix ui)
- #:use-module (guix store)
- #:use-module (guix derivations)
- #:use-module (guix packages)
- #:use-module (guix utils)
- #:use-module (guix config)
- #:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
- #:use-module (ice-9 ftw)
- #:use-module (ice-9 format)
- #:use-module (ice-9 match)
- #:use-module (ice-9 regex)
- #:use-module (ice-9 vlist)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-37)
- #:use-module (gnu packages)
- #:use-module ((gnu packages base) #:select (guile-final))
- #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
- #:export (guix-package))
-
-(define %store
- (make-parameter #f))
-
-\f
-;;;
-;;; User environment.
-;;;
-
-(define %user-environment-directory
- (and=> (getenv "HOME")
- (cut string-append <> "/.guix-profile")))
-
-(define %profile-directory
- (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/"
- (or (and=> (getenv "USER")
- (cut string-append "per-user/" <>))
- "default")))
-
-(define %current-profile
- ;; Call it `guix-profile', not `profile', to allow Guix profiles to
- ;; coexist with Nix profiles.
- (string-append %profile-directory "/guix-profile"))
-
-(define (profile-manifest profile)
- "Return the PROFILE's manifest."
- (let ((manifest (string-append profile "/manifest")))
- (if (file-exists? manifest)
- (call-with-input-file manifest read)
- '(manifest (version 1) (packages ())))))
-
-(define (manifest-packages manifest)
- "Return the packages listed in MANIFEST."
- (match manifest
- (('manifest ('version 0)
- ('packages ((name version output path) ...)))
- (zip name version output path
- (make-list (length name) '())))
-
- ;; Version 1 adds a list of propagated inputs to the
- ;; name/version/output/path tuples.
- (('manifest ('version 1)
- ('packages (packages ...)))
- packages)
-
- (_
- (error "unsupported manifest format" manifest))))
-
-(define (profile-regexp profile)
- "Return a regular expression that matches PROFILE's name and number."
- (make-regexp (string-append "^" (regexp-quote (basename profile))
- "-([0-9]+)")))
-
-(define (profile-numbers profile)
- "Return the list of generation numbers of PROFILE, or '(0) if no
-former profiles were found."
- (define* (scandir name #:optional (select? (const #t))
- (entry<? (@ (ice-9 i18n) string-locale<?)))
- ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
- (define (enter? dir stat result)
- (and stat (string=? dir name)))
-
- (define (visit basename result)
- (if (select? basename)
- (cons basename result)
- result))
-
- (define (leaf name stat result)
- (and result
- (visit (basename name) result)))
-
- (define (down name stat result)
- (visit "." '()))
-
- (define (up name stat result)
- (visit ".." result))
-
- (define (skip name stat result)
- ;; All the sub-directories are skipped.
- (visit (basename name) result))
-
- (define (error name* stat errno result)
- (if (string=? name name*) ; top-level NAME is unreadable
- result
- (visit (basename name*) result)))
-
- (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
- (lambda (files)
- (sort files entry<?))))
-
- (match (scandir (dirname profile)
- (cute regexp-exec (profile-regexp profile) <>))
- (#f ; no profile directory
- '(0))
- (() ; no profiles
- '(0))
- ((profiles ...) ; former profiles around
- (map (compose string->number
- (cut match:substring <> 1)
- (cute regexp-exec (profile-regexp profile) <>))
- profiles))))
-
-(define (previous-profile-number profile number)
- "Return the number of the generation before generation NUMBER of
-PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
-case when generations have been deleted (there are \"holes\")."
- (fold (lambda (candidate highest)
- (if (and (< candidate number) (> candidate highest))
- candidate
- highest))
- 0
- (profile-numbers profile)))
-
-(define (profile-derivation store packages)
- "Return a derivation that builds a profile (a user environment) with
-all of PACKAGES, a list of name/version/output/path/deps tuples."
- (define builder
- `(begin
- (use-modules (ice-9 pretty-print)
- (guix build union))
-
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
-
- (let ((output (assoc-ref %outputs "out"))
- (inputs (map cdr %build-inputs)))
- (format #t "building user environment `~a' with ~a packages...~%"
- output (length inputs))
- (union-build output inputs)
- (call-with-output-file (string-append output "/manifest")
- (lambda (p)
- (pretty-print '(manifest (version 1)
- (packages ,packages))
- p))))))
-
- (build-expression->derivation store "user-environment"
- (%current-system)
- builder
- (append-map (match-lambda
- ((name version output path deps)
- `((,name ,path)
- ,@deps)))
- packages)
- #:modules '((guix build union))))
-
-(define (profile-number profile)
- "Return PROFILE's number or 0. An absolute file name must be used."
- (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
- (basename (readlink profile))))
- (compose string->number (cut match:substring <> 1)))
- 0))
-
-(define (switch-symlinks link target)
- "Atomically switch LINK, a symbolic link, to point to TARGET. Works
-both when LINK already exists and when it does not."
- (let ((pivot (string-append link ".new")))
- (symlink target pivot)
- (rename-file pivot link)))
-
-(define (roll-back profile)
- "Roll back to the previous generation of PROFILE."
- (let* ((number (profile-number profile))
- (previous-number (previous-profile-number profile number))
- (previous-profile (format #f "~a-~a-link"
- profile previous-number))
- (manifest (string-append previous-profile "/manifest")))
-
- (define (switch-link)
- ;; Atomically switch PROFILE to the previous profile.
- (format #t (_ "switching from generation ~a to ~a~%")
- number previous-number)
- (switch-symlinks profile previous-profile))
-
- (cond ((not (file-exists? profile)) ; invalid profile
- (format (current-error-port)
- (_ "error: profile `~a' does not exist~%")
- profile))
- ((zero? number) ; empty profile
- (format (current-error-port)
- (_ "nothing to do: already at the empty profile~%")))
- ((or (zero? previous-number) ; going to emptiness
- (not (file-exists? previous-profile)))
- (let*-values (((drv-path drv)
- (profile-derivation (%store) '()))
- ((prof)
- (derivation-output-path
- (assoc-ref (derivation-outputs drv) "out"))))
- (when (not (build-derivations (%store) (list drv-path)))
- (leave (_ "failed to build the empty profile~%")))
-
- (switch-symlinks previous-profile prof)
- (switch-link)))
- (else (switch-link))))) ; anything else
-
-(define (find-packages-by-description rx)
- "Search in SYNOPSIS and DESCRIPTION using RX. Return a list of
-matching packages."
- (define (same-location? p1 p2)
- ;; Compare locations of two packages.
- (equal? (package-location p1) (package-location p2)))
-
- (delete-duplicates
- (sort
- (fold-packages (lambda (package result)
- (define matches?
- (cut regexp-exec rx <>))
-
- (if (or (and=> (package-synopsis package)
- (compose matches? gettext))
- (and=> (package-description package)
- (compose matches? gettext)))
- (cons package result)
- result))
- '())
- (lambda (p1 p2)
- (string<? (package-name p1)
- (package-name p2))))
- same-location?))
-
-(define (input->name+path input)
- "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
- (let loop ((input input))
- (match input
- ((name package)
- (loop `(,name ,package "out")))
- ((name package sub-drv)
- (let*-values (((_ drv)
- (package-derivation (%store) package))
- ((out)
- (derivation-output-path
- (assoc-ref (derivation-outputs drv) sub-drv))))
- `(,name ,out))))))
-
-\f
-;;;
-;;; Command-line options.
-;;;
-
-(define %default-options
- ;; Alist of default option values.
- `((profile . ,%current-profile)))
-
-(define (show-help)
- (display (_ "Usage: guix-package [OPTION]... PACKAGES...
-Install, remove, or upgrade PACKAGES in a single transaction.\n"))
- (display (_ "
- -i, --install=PACKAGE install PACKAGE"))
- (display (_ "
- -r, --remove=PACKAGE remove PACKAGE"))
- (display (_ "
- -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP"))
- (display (_ "
- --roll-back roll back to the previous generation"))
- (newline)
- (display (_ "
- -p, --profile=PROFILE use PROFILE instead of the user's default profile"))
- (display (_ "
- -n, --dry-run show what would be done without actually doing it"))
- (display (_ "
- --bootstrap use the bootstrap Guile to build the profile"))
- (display (_ "
- --verbose produce verbose output"))
- (newline)
- (display (_ "
- -s, --search=REGEXP search in synopsis and description using REGEXP"))
- (display (_ "
- -I, --list-installed[=REGEXP]
- list installed packages matching REGEXP"))
- (display (_ "
- -A, --list-available[=REGEXP]
- list available packages matching REGEXP"))
- (newline)
- (display (_ "
- -h, --help display this help and exit"))
- (display (_ "
- -V, --version display version information and exit"))
- (newline)
- (show-bug-report-information))
-
-(define %options
- ;; Specification of the command-line options.
- (list (option '(#\h "help") #f #f
- (lambda args
- (show-help)
- (exit 0)))
- (option '(#\V "version") #f #f
- (lambda args
- (show-version-and-exit "guix-package")))
-
- (option '(#\i "install") #t #f
- (lambda (opt name arg result)
- (alist-cons 'install arg result)))
- (option '(#\r "remove") #t #f
- (lambda (opt name arg result)
- (alist-cons 'remove arg result)))
- (option '(#\u "upgrade") #t #f
- (lambda (opt name arg result)
- (alist-cons 'upgrade arg result)))
- (option '("roll-back") #f #f
- (lambda (opt name arg result)
- (alist-cons 'roll-back? #t result)))
- (option '(#\p "profile") #t #f
- (lambda (opt name arg result)
- (alist-cons 'profile arg
- (alist-delete 'profile result))))
- (option '(#\n "dry-run") #f #f
- (lambda (opt name arg result)
- (alist-cons 'dry-run? #t result)))
- (option '("bootstrap") #f #f
- (lambda (opt name arg result)
- (alist-cons 'bootstrap? #t result)))
- (option '("verbose") #f #f
- (lambda (opt name arg result)
- (alist-cons 'verbose? #t result)))
- (option '(#\s "search") #t #f
- (lambda (opt name arg result)
- (cons `(query search ,(or arg ""))
- result)))
- (option '(#\I "list-installed") #f #t
- (lambda (opt name arg result)
- (cons `(query list-installed ,(or arg ""))
- result)))
- (option '(#\A "list-available") #f #t
- (lambda (opt name arg result)
- (cons `(query list-available ,(or arg ""))
- result)))))
-
-\f
-;;;
-;;; Entry point.
-;;;
-
-(define (guix-package . args)
- (define (parse-options)
- ;; Return the alist of option values.
- (args-fold args %options
- (lambda (opt name arg result)
- (leave (_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (leave (_ "~A: extraneous argument~%") arg))
- %default-options))
-
- (define (guile-missing?)
- ;; Return #t if %GUILE-FOR-BUILD is not available yet.
- (let ((out (derivation-path->output-path (%guile-for-build))))
- (not (valid-path? (%store) out))))
-
- (define (show-what-to-build drv dry-run?)
- ;; Show what will/would be built in realizing the derivations listed
- ;; in DRV.
- (let* ((req (append-map (lambda (drv-path)
- (let ((d (call-with-input-file drv-path
- read-derivation)))
- (derivation-prerequisites-to-build
- (%store) d)))
- drv))
- (req* (delete-duplicates
- (append (remove (compose (cute valid-path? (%store) <>)
- derivation-path->output-path)
- drv)
- (map derivation-input-path req)))))
- (if dry-run?
- (format (current-error-port)
- (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
- "~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
- (length req*))
- (null? req*) req*)
- (format (current-error-port)
- (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
- "~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
- (length req*))
- (null? req*) req*))))
-
- (define newest-available-packages
- (memoize find-newest-available-packages))
-
- (define (find-best-packages-by-name name version)
- (if version
- (find-packages-by-name name version)
- (match (vhash-assoc name (newest-available-packages))
- ((_ version pkgs ...) pkgs)
- (#f '()))))
-
- (define (find-package name)
- ;; Find the package NAME; NAME may contain a version number and a
- ;; sub-derivation name. If the version number is not present,
- ;; return the preferred newest version.
- (define request name)
-
- (define (ensure-output p sub-drv)
- (if (member sub-drv (package-outputs p))
- p
- (leave (_ "~a: error: package `~a' lacks output `~a'~%")
- (location->string (package-location p))
- (package-full-name p)
- sub-drv)))
-
- (let*-values (((name sub-drv)
- (match (string-rindex name #\:)
- (#f (values name "out"))
- (colon (values (substring name 0 colon)
- (substring name (+ 1 colon))))))
- ((name version)
- (package-name->name+version name)))
- (match (find-best-packages-by-name name version)
- ((p)
- (list name (package-version p) sub-drv (ensure-output p sub-drv)
- (package-transitive-propagated-inputs p)))
- ((p p* ...)
- (format (current-error-port)
- (_ "warning: ambiguous package specification `~a'~%")
- request)
- (format (current-error-port)
- (_ "warning: choosing ~a from ~a~%")
- (package-full-name p)
- (location->string (package-location p)))
- (list name (package-version p) sub-drv (ensure-output p sub-drv)
- (package-transitive-propagated-inputs p)))
- (()
- (leave (_ "~a: package not found~%") request)))))
-
- (define (upgradeable? name current-version current-path)
- ;; Return #t if there's a version of package NAME newer than
- ;; CURRENT-VERSION, or if the newest available version is equal to
- ;; CURRENT-VERSION but would have an output path different than
- ;; CURRENT-PATH.
- (match (vhash-assoc name (newest-available-packages))
- ((_ candidate-version pkg . rest)
- (case (version-compare candidate-version current-version)
- ((>) #t)
- ((<) #f)
- ((=) (let ((candidate-path (derivation-path->output-path
- (package-derivation (%store) pkg))))
- (not (string=? current-path candidate-path))))))
- (#f #f)))
-
- (define (ensure-default-profile)
- ;; Ensure the default profile symlink and directory exist.
-
- ;; Create ~/.guix-profile if it doesn't exist yet.
- (when (and %user-environment-directory
- %current-profile
- (not (false-if-exception
- (lstat %user-environment-directory))))
- (symlink %current-profile %user-environment-directory))
-
- ;; Attempt to create /…/profiles/per-user/$USER if needed.
- (unless (directory-exists? %profile-directory)
- (catch 'system-error
- (lambda ()
- (mkdir-p %profile-directory))
- (lambda args
- ;; Often, we cannot create %PROFILE-DIRECTORY because its
- ;; parent directory is root-owned and we're running
- ;; unprivileged.
- (format (current-error-port)
- (_ "error: while creating directory `~a': ~a~%")
- %profile-directory
- (strerror (system-error-errno args)))
- (format (current-error-port)
- (_ "Please create the `~a' directory, with you as the owner.~%")
- %profile-directory)
- (exit 1)))))
-
- (define (process-actions opts)
- ;; Process any install/remove/upgrade action from OPTS.
-
- (define dry-run? (assoc-ref opts 'dry-run?))
- (define verbose? (assoc-ref opts 'verbose?))
- (define profile (assoc-ref opts 'profile))
-
- (define (canonicalize-deps deps)
- ;; Remove duplicate entries from DEPS, a list of propagated inputs,
- ;; where each input is a name/path tuple.
- (define (same? d1 d2)
- (match d1
- ((_ path1)
- (match d2
- ((_ path2)
- (string=? path1 path2))))))
-
- (delete-duplicates (map input->name+path deps) same?))
-
- ;; First roll back if asked to.
- (if (and (assoc-ref opts 'roll-back?) (not dry-run?))
- (begin
- (roll-back profile)
- (process-actions (alist-delete 'roll-back? opts)))
- (let* ((installed (manifest-packages (profile-manifest profile)))
- (upgrade-regexps (filter-map (match-lambda
- (('upgrade . regexp)
- (make-regexp regexp))
- (_ #f))
- opts))
- (upgrade (if (null? upgrade-regexps)
- '()
- (let ((newest (find-newest-available-packages)))
- (filter-map (match-lambda
- ((name version output path _)
- (and (any (cut regexp-exec <> name)
- upgrade-regexps)
- (upgradeable? name version path)
- (find-package name)))
- (_ #f))
- installed))))
- (install (append
- upgrade
- (filter-map (match-lambda
- (('install . (? store-path?))
- #f)
- (('install . package)
- (find-package package))
- (_ #f))
- opts)))
- (drv (filter-map (match-lambda
- ((name version sub-drv
- (? package? package)
- (deps ...))
- (package-derivation (%store) package))
- (_ #f))
- install))
- (install* (append
- (filter-map (match-lambda
- (('install . (? store-path? path))
- (let-values (((name version)
- (package-name->name+version
- (store-path-package-name
- path))))
- `(,name ,version #f ,path ())))
- (_ #f))
- opts)
- (map (lambda (tuple drv)
- (match tuple
- ((name version sub-drv _ (deps ...))
- (let ((output-path
- (derivation-path->output-path
- drv sub-drv)))
- `(,name ,version ,sub-drv ,output-path
- ,(canonicalize-deps deps))))))
- install drv)))
- (remove (filter-map (match-lambda
- (('remove . package)
- package)
- (_ #f))
- opts))
- (packages (append install*
- (fold (lambda (package result)
- (match package
- ((name _ ...)
- (alist-delete name result))))
- (fold alist-delete installed remove)
- install*))))
-
- (when (equal? profile %current-profile)
- (ensure-default-profile))
-
- (show-what-to-build drv dry-run?)
-
- (or dry-run?
- (and (build-derivations (%store) drv)
- (let* ((prof-drv (profile-derivation (%store) packages))
- (prof (derivation-path->output-path prof-drv))
- (old-drv (profile-derivation
- (%store) (manifest-packages
- (profile-manifest profile))))
- (old-prof (derivation-path->output-path old-drv))
- (number (profile-number profile))
-
- ;; Always use NUMBER + 1 for the new profile,
- ;; possibly overwriting a "previous future
- ;; generation".
- (name (format #f "~a-~a-link"
- profile (+ 1 number))))
- (if (string=? old-prof prof)
- (when (or (pair? install) (pair? remove))
- (format (current-error-port)
- (_ "nothing to be done~%")))
- (and (parameterize ((current-build-output-port
- ;; Output something when Guile
- ;; needs to be built.
- (if (or verbose? (guile-missing?))
- (current-error-port)
- (%make-void-port "w"))))
- (build-derivations (%store) (list prof-drv)))
- (begin
- (switch-symlinks name prof)
- (switch-symlinks profile name))))))))))
-
- (define (process-query opts)
- ;; Process any query specified by OPTS. Return #t when a query was
- ;; actually processed, #f otherwise.
- (let ((profile (assoc-ref opts 'profile)))
- (match (assoc-ref opts 'query)
- (('list-installed regexp)
- (let* ((regexp (and regexp (make-regexp regexp)))
- (manifest (profile-manifest profile))
- (installed (manifest-packages manifest)))
- (for-each (match-lambda
- ((name version output path _)
- (when (or (not regexp)
- (regexp-exec regexp name))
- (format #t "~a\t~a\t~a\t~a~%"
- name (or version "?") output path))))
- installed)
- #t))
-
- (('list-available regexp)
- (let* ((regexp (and regexp (make-regexp regexp)))
- (available (fold-packages
- (lambda (p r)
- (let ((n (package-name p)))
- (if regexp
- (if (regexp-exec regexp n)
- (cons p r)
- r)
- (cons p r))))
- '())))
- (for-each (lambda (p)
- (format #t "~a\t~a\t~a\t~a~%"
- (package-name p)
- (package-version p)
- (string-join (package-outputs p) ",")
- (location->string (package-location p))))
- (sort available
- (lambda (p1 p2)
- (string<? (package-name p1)
- (package-name p2)))))
- #t))
-
- (('search regexp)
- (let ((regexp (make-regexp regexp regexp/icase)))
- (for-each (cute package->recutils <> (current-output-port))
- (find-packages-by-description regexp))
- #t))
- (_ #f))))
-
- (install-locale)
- (textdomain "guix")
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
-
- (let ((opts (parse-options)))
- (or (process-query opts)
- (parameterize ((%store (open-connection)))
- (with-error-handling
- (parameterize ((%guile-for-build
- (package-derivation (%store)
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- guile-final))))
- (process-actions opts)))))))
diff --git a/guix/scripts/guix-build.scm b/guix/scripts/guix-build.scm
new file mode 100644
index 0000000..3d1accc
--- /dev/null
+++ b/guix/scripts/guix-build.scm
@@ -0,0 +1,304 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
+;;;
+;;; 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 scripts guix-build)
+ #:use-module (guix ui)
+ #:use-module (guix store)
+ #:use-module (guix derivations)
+ #:use-module (guix packages)
+ #:use-module (guix utils)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-37)
+ #:autoload (gnu packages) (find-packages-by-name
+ find-newest-available-packages)
+ #:export (guix-build))
+
+(define %store
+ (make-parameter #f))
+
+(define (derivations-from-package-expressions exp system source?)
+ "Eval EXP and return the corresponding derivation path for SYSTEM.
+When SOURCE? is true, return the derivations of the package sources."
+ (let ((p (eval exp (current-module))))
+ (if (package? p)
+ (if source?
+ (let ((source (package-source p))
+ (loc (package-location p)))
+ (if source
+ (package-source-derivation (%store) source)
+ (leave (_ "~a: error: package `~a' has no source~%")
+ (location->string loc) (package-name p))))
+ (package-derivation (%store) p system))
+ (leave (_ "expression `~s' does not evaluate to a package~%")
+ exp))))
+
+\f
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ ;; Alist of default option values.
+ `((system . ,(%current-system))
+ (substitutes? . #t)
+ (verbosity . 0)))
+
+(define (show-help)
+ (display (_ "Usage: guix-build [OPTION]... PACKAGE-OR-DERIVATION...
+Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
+ (display (_ "
+ -e, --expression=EXPR build the package EXPR evaluates to"))
+ (display (_ "
+ -S, --source build the packages' source derivations"))
+ (display (_ "
+ -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
+ (display (_ "
+ -d, --derivations return the derivation paths of the given packages"))
+ (display (_ "
+ -K, --keep-failed keep build tree of failed builds"))
+ (display (_ "
+ -n, --dry-run do not build the derivations"))
+ (display (_ "
+ --no-substitutes build instead of resorting to pre-built substitutes"))
+ (display (_ "
+ -c, --cores=N allow the use of up to N CPU cores for the build"))
+ (display (_ "
+ -r, --root=FILE make FILE a symlink to the result, and register it
+ as a garbage collector root"))
+ (display (_ "
+ --verbosity=LEVEL use the given verbosity LEVEL"))
+ (newline)
+ (display (_ "
+ -h, --help display this help and exit"))
+ (display (_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ ;; Specifications of the command-line options.
+ (list (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix-build")))
+
+ (option '(#\S "source") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'source? #t result)))
+ (option '(#\s "system") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'system arg
+ (alist-delete 'system result eq?))))
+ (option '(#\d "derivations") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'derivations-only? #t result)))
+ (option '(#\e "expression") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'expression
+ (call-with-input-string arg read)
+ result)))
+ (option '(#\K "keep-failed") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'keep-failed? #t result)))
+ (option '(#\c "cores") #t #f
+ (lambda (opt name arg result)
+ (let ((c (false-if-exception (string->number arg))))
+ (if c
+ (alist-cons 'cores c result)
+ (leave (_ "~a: not a number~%") arg)))))
+ (option '(#\n "dry-run") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'dry-run? #t result)))
+ (option '("no-substitutes") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'substitutes? #f
+ (alist-delete 'substitutes? result))))
+ (option '(#\r "root") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'gc-root arg result)))
+ (option '("verbosity") #t #f
+ (lambda (opt name arg result)
+ (let ((level (string->number arg)))
+ (alist-cons 'verbosity level
+ (alist-delete 'verbosity result)))))))
+
+\f
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-build . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (args-fold args %options
+ (lambda (opt name arg result)
+ (leave (_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (alist-cons 'argument arg result))
+ %default-options))
+
+ (define (register-root paths root)
+ ;; Register ROOT as an indirect GC root for all of PATHS.
+ (let* ((root (string-append (canonicalize-path (dirname root))
+ "/" root)))
+ (catch 'system-error
+ (lambda ()
+ (match paths
+ ((path)
+ (symlink path root)
+ (add-indirect-root (%store) root))
+ ((paths ...)
+ (fold (lambda (path count)
+ (let ((root (string-append root "-" (number->string count))))
+ (symlink path root)
+ (add-indirect-root (%store) root))
+ (+ 1 count))
+ 0
+ paths))))
+ (lambda args
+ (format (current-error-port)
+ (_ "failed to create GC root `~a': ~a~%")
+ root (strerror (system-error-errno args)))
+ (exit 1)))))
+
+ (define newest-available-packages
+ (memoize find-newest-available-packages))
+
+ (define (find-best-packages-by-name name version)
+ (if version
+ (find-packages-by-name name version)
+ (match (vhash-assoc name (newest-available-packages))
+ ((_ version pkgs ...) pkgs)
+ (#f '()))))
+
+ (define (find-package request)
+ ;; Return a package matching REQUEST. REQUEST may be a package
+ ;; name, or a package name followed by a hyphen and a version
+ ;; number. If the version number is not present, return the
+ ;; preferred newest version.
+ (let-values (((name version)
+ (package-name->name+version request)))
+ (match (find-best-packages-by-name name version)
+ ((p) ; one match
+ p)
+ ((p x ...) ; several matches
+ (format (current-error-port)
+ (_ "warning: ambiguous package specification `~a'~%")
+ request)
+ (format (current-error-port)
+ (_ "warning: choosing ~a from ~a~%")
+ (package-full-name p)
+ (location->string (package-location p)))
+ p)
+ (_ ; no matches
+ (if version
+ (leave (_ "~A: package not found for version ~a~%")
+ name version)
+ (leave (_ "~A: unknown package~%") name))))))
+
+ (install-locale)
+ (textdomain "guix")
+ (setvbuf (current-output-port) _IOLBF)
+ (setvbuf (current-error-port) _IOLBF)
+
+ (with-error-handling
+ (let ((opts (parse-options)))
+ (parameterize ((%store (open-connection)))
+ (let* ((src? (assoc-ref opts 'source?))
+ (sys (assoc-ref opts 'system))
+ (drv (filter-map (match-lambda
+ (('expression . exp)
+ (derivations-from-package-expressions exp sys
+ src?))
+ (('argument . (? derivation-path? drv))
+ drv)
+ (('argument . (? string? x))
+ (let ((p (find-package x)))
+ (if src?
+ (let ((s (package-source p)))
+ (package-source-derivation
+ (%store) s))
+ (package-derivation (%store) p sys))))
+ (_ #f))
+ opts))
+ (req (append-map (lambda (drv-path)
+ (let ((d (call-with-input-file drv-path
+ read-derivation)))
+ (derivation-prerequisites-to-build (%store) d)))
+ drv))
+ (req* (delete-duplicates
+ (append (remove (compose (cut valid-path? (%store) <>)
+ derivation-path->output-path)
+ drv)
+ (map derivation-input-path req))))
+ (roots (filter-map (match-lambda
+ (('gc-root . root) root)
+ (_ #f))
+ opts)))
+ (if (assoc-ref opts 'dry-run?)
+ (format (current-error-port)
+ (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
+ "~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
+ (length req*))
+ (null? req*) req*)
+ (format (current-error-port)
+ (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
+ "~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
+ (length req*))
+ (null? req*) req*))
+
+ ;; TODO: Add more options.
+ (set-build-options (%store)
+ #:keep-failed? (assoc-ref opts 'keep-failed?)
+ #:build-cores (or (assoc-ref opts 'cores) 0)
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:verbosity (assoc-ref opts 'verbosity))
+
+ (if (assoc-ref opts 'derivations-only?)
+ (begin
+ (format #t "~{~a~%~}" drv)
+ (for-each (cut register-root <> <>)
+ (map list drv) roots))
+ (or (assoc-ref opts 'dry-run?)
+ (and (build-derivations (%store) drv)
+ (for-each (lambda (d)
+ (let ((drv (call-with-input-file d
+ read-derivation)))
+ (format #t "~{~a~%~}"
+ (map (match-lambda
+ ((out-name . out)
+ (derivation-path->output-path
+ d out-name)))
+ (derivation-outputs drv)))))
+ drv)
+ (for-each (cut register-root <> <>)
+ (map (lambda (drv)
+ (map cdr
+ (derivation-path->output-paths drv)))
+ drv)
+ roots)))))))))
diff --git a/guix/scripts/guix-download.scm b/guix/scripts/guix-download.scm
new file mode 100644
index 0000000..0d049d0
--- /dev/null
+++ b/guix/scripts/guix-download.scm
@@ -0,0 +1,151 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 scripts guix-download)
+ #:use-module (guix ui)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix base32)
+ #:use-module ((guix download) #:select (%mirrors))
+ #:use-module (guix build download)
+ #:use-module (web uri)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-37)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:export (guix-download))
+
+(define (call-with-temporary-output-file proc)
+ (let* ((template (string-copy "guix-download.XXXXXX"))
+ (out (mkstemp! template)))
+ (dynamic-wind
+ (lambda ()
+ #t)
+ (lambda ()
+ (proc template out))
+ (lambda ()
+ (false-if-exception (delete-file template))))))
+
+(define (fetch-and-store store fetch name)
+ "Call FETCH for URI, and pass it the name of a file to write to; eventually,
+copy data from that port to STORE, under NAME. Return the resulting
+store path."
+ (call-with-temporary-output-file
+ (lambda (temp port)
+ (let ((result
+ (parameterize ((current-output-port (current-error-port)))
+ (fetch temp))))
+ (close port)
+ (and result
+ (add-to-store store name #f "sha256" temp))))))
+\f
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ ;; Alist of default option values.
+ `((format . ,bytevector->nix-base32-string)))
+
+(define (show-help)
+ (display (_ "Usage: guix-download [OPTION]... URL
+Download the file at URL, add it to the store, and print its store path
+and the hash of its contents.\n"))
+ (format #t (_ "
+ -f, --format=FMT write the hash in the given format (default: `nix-base32')"))
+ (newline)
+ (display (_ "
+ -h, --help display this help and exit"))
+ (display (_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ ;; Specifications of the command-line options.
+ (list (option '(#\f "format") #t #f
+ (lambda (opt name arg result)
+ (define fmt-proc
+ (match arg
+ ("nix-base32"
+ bytevector->nix-base32-string)
+ ("base32"
+ bytevector->base32-string)
+ ((or "base16" "hex" "hexadecimal")
+ bytevector->base16-string)
+ (x
+ (format (current-error-port)
+ "unsupported hash format: ~a~%" arg))))
+
+ (alist-cons 'format fmt-proc
+ (alist-delete 'format result))))
+
+ (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix-download")))))
+
+\f
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-download . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (args-fold args %options
+ (lambda (opt name arg result)
+ (leave (_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (alist-cons 'argument arg result))
+ %default-options))
+
+ (install-locale)
+ (textdomain "guix")
+ (setvbuf (current-output-port) _IOLBF)
+ (setvbuf (current-error-port) _IOLBF)
+
+ (let* ((opts (parse-options))
+ (store (open-connection))
+ (arg (assq-ref opts 'argument))
+ (uri (or (string->uri arg)
+ (leave (_ "guix-download: ~a: failed to parse URI~%")
+ arg)))
+ (path (case (uri-scheme uri)
+ ((file)
+ (add-to-store store (basename (uri-path uri))
+ #f "sha256" (uri-path uri)))
+ (else
+ (fetch-and-store store
+ (cut url-fetch arg <>
+ #:mirrors %mirrors)
+ (basename (uri-path uri))))))
+ (hash (call-with-input-file
+ (or path
+ (leave (_ "guix-download: ~a: download failed~%")
+ arg))
+ (compose sha256 get-bytevector-all)))
+ (fmt (assq-ref opts 'format)))
+ (format #t "~a~%~a~%" path (fmt hash))
+ #t))
diff --git a/guix/scripts/guix-gc.scm b/guix/scripts/guix-gc.scm
new file mode 100644
index 0000000..5b1ed1c
--- /dev/null
+++ b/guix/scripts/guix-gc.scm
@@ -0,0 +1,170 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 scripts guix-gc)
+ #:use-module (guix ui)
+ #:use-module (guix store)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-37)
+ #:export (guix-gc))
+
+\f
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ ;; Alist of default option values.
+ `((action . collect-garbage)))
+
+(define (show-help)
+ (display (_ "Usage: guix-gc [OPTION]... PATHS...
+Invoke the garbage collector.\n"))
+ (display (_ "
+ -C, --collect-garbage[=MIN]
+ collect at least MIN bytes of garbage"))
+ (display (_ "
+ -d, --delete attempt to delete PATHS"))
+ (display (_ "
+ --list-dead list dead paths"))
+ (display (_ "
+ --list-live list live paths"))
+ (newline)
+ (display (_ "
+ -h, --help display this help and exit"))
+ (display (_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define (size->number str)
+ "Convert STR, a storage measurement representation such as \"1024\" or
+\"1MiB\", to a number of bytes. Raise an error if STR could not be
+interpreted."
+ (define unit-pos
+ (string-rindex str char-set:digit))
+
+ (define unit
+ (and unit-pos (substring str (+ 1 unit-pos))))
+
+ (let* ((numstr (if unit-pos
+ (substring str 0 (+ 1 unit-pos))
+ str))
+ (num (string->number numstr)))
+ (if num
+ (* num
+ (match unit
+ ("KiB" (expt 2 10))
+ ("MiB" (expt 2 20))
+ ("GiB" (expt 2 30))
+ ("TiB" (expt 2 40))
+ ("KB" (expt 10 3))
+ ("MB" (expt 10 6))
+ ("GB" (expt 10 9))
+ ("TB" (expt 10 12))
+ ("" 1)
+ (_
+ (format (current-error-port) (_ "error: unknown unit: ~a~%")
+ unit)
+ (exit 1))))
+ (begin
+ (format (current-error-port)
+ (_ "error: invalid number: ~a") numstr)
+ (exit 1)))))
+
+(define %options
+ ;; Specification of the command-line options.
+ (list (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix-gc")))
+
+ (option '(#\C "collect-garbage") #f #t
+ (lambda (opt name arg result)
+ (let ((result (alist-cons 'action 'collect-garbage
+ (alist-delete 'action result))))
+ (match arg
+ ((? string?)
+ (let ((amount (size->number arg)))
+ (if arg
+ (alist-cons 'min-freed amount result)
+ (begin
+ (format (current-error-port)
+ (_ "error: invalid amount of storage: ~a~%")
+ arg)
+ (exit 1)))))
+ (#f result)))))
+ (option '(#\d "delete") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'action 'delete
+ (alist-delete 'action result))))
+ (option '("list-dead") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'action 'list-dead
+ (alist-delete 'action result))))
+ (option '("list-live") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'action 'list-live
+ (alist-delete 'action result))))))
+
+\f
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-gc . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (args-fold args %options
+ (lambda (opt name arg result)
+ (leave (_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (alist-cons 'argument arg result))
+ %default-options))
+
+ (install-locale)
+ (textdomain "guix")
+ (setvbuf (current-output-port) _IOLBF)
+ (setvbuf (current-error-port) _IOLBF)
+
+ (with-error-handling
+ (let ((opts (parse-options))
+ (store (open-connection)))
+ (case (assoc-ref opts 'action)
+ ((collect-garbage)
+ (let ((min-freed (assoc-ref opts 'min-freed)))
+ (if min-freed
+ (collect-garbage store min-freed)
+ (collect-garbage store))))
+ ((delete)
+ (let ((paths (filter-map (match-lambda
+ (('argument . arg) arg)
+ (_ #f))
+ opts)))
+ (delete-paths store paths)))
+ ((list-dead)
+ (for-each (cut simple-format #t "~a~%" <>)
+ (dead-paths store)))
+ ((list-live)
+ (for-each (cut simple-format #t "~a~%" <>)
+ (live-paths store)))))))
diff --git a/guix/scripts/guix-import.scm b/guix/scripts/guix-import.scm
new file mode 100644
index 0000000..53572d8
--- /dev/null
+++ b/guix/scripts/guix-import.scm
@@ -0,0 +1,124 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 scripts guix-import)
+ #:use-module (guix ui)
+ #:use-module (guix snix)
+ #:use-module (guix utils)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
+ #:export (guix-import))
+
+\f
+;;;
+;;; Helper.
+;;;
+
+(define (newline-rewriting-port output)
+ "Return an output port that rewrites strings containing the \\n escape
+to an actual newline. This works around the behavior of `pretty-print'
+and `write', which output these as \\n instead of actual newlines,
+whereas we want the `description' field to contain actual newlines
+rather than \\n."
+ (define (write-string str)
+ (let loop ((chars (string->list str)))
+ (match chars
+ (()
+ #t)
+ ((#\\ #\n rest ...)
+ (newline output)
+ (loop rest))
+ ((chr rest ...)
+ (write-char chr output)
+ (loop rest)))))
+
+ (make-soft-port (vector (cut write-char <>)
+ write-string
+ (lambda _ #t) ; flush
+ #f
+ (lambda _ #t) ; close
+ #f)
+ "w"))
+
+\f
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ '())
+
+(define (show-help)
+ (display (_ "Usage: guix-import NIXPKGS ATTRIBUTE
+Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n"))
+ (display (_ "
+ -h, --help display this help and exit"))
+ (display (_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ ;; Specification of the command-line options.
+ (list (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix-import")))))
+
+\f
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (args-fold args %options
+ (lambda (opt name arg result)
+ (leave (_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (alist-cons 'argument arg result))
+ %default-options))
+
+ (install-locale)
+ (textdomain "guix")
+ (setvbuf (current-output-port) _IOLBF)
+ (setvbuf (current-error-port) _IOLBF)
+
+ (let* ((opts (parse-options))
+ (args (filter-map (match-lambda
+ (('argument . value)
+ value)
+ (_ #f))
+ (reverse opts))))
+ (match args
+ ((nixpkgs attribute)
+ (let-values (((expr loc)
+ (nixpkgs->guix-package nixpkgs attribute)))
+ (format #t ";; converted from ~a:~a~%~%"
+ (location-file loc) (location-line loc))
+ (pretty-print expr (newline-rewriting-port (current-output-port)))))
+ (_
+ (leave (_ "wrong number of arguments~%"))))))
diff --git a/guix/scripts/guix-package.scm b/guix/scripts/guix-package.scm
new file mode 100644
index 0000000..2dc548e
--- /dev/null
+++ b/guix/scripts/guix-package.scm
@@ -0,0 +1,693 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
+;;;
+;;; 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 scripts guix-package)
+ #:use-module (guix ui)
+ #:use-module (guix store)
+ #:use-module (guix derivations)
+ #:use-module (guix packages)
+ #:use-module (guix utils)
+ #:use-module (guix config)
+ #:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 vlist)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-37)
+ #:use-module (gnu packages)
+ #:use-module ((gnu packages base) #:select (guile-final))
+ #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
+ #:export (guix-package))
+
+(define %store
+ (make-parameter #f))
+
+\f
+;;;
+;;; User environment.
+;;;
+
+(define %user-environment-directory
+ (and=> (getenv "HOME")
+ (cut string-append <> "/.guix-profile")))
+
+(define %profile-directory
+ (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/"
+ (or (and=> (getenv "USER")
+ (cut string-append "per-user/" <>))
+ "default")))
+
+(define %current-profile
+ ;; Call it `guix-profile', not `profile', to allow Guix profiles to
+ ;; coexist with Nix profiles.
+ (string-append %profile-directory "/guix-profile"))
+
+(define (profile-manifest profile)
+ "Return the PROFILE's manifest."
+ (let ((manifest (string-append profile "/manifest")))
+ (if (file-exists? manifest)
+ (call-with-input-file manifest read)
+ '(manifest (version 1) (packages ())))))
+
+(define (manifest-packages manifest)
+ "Return the packages listed in MANIFEST."
+ (match manifest
+ (('manifest ('version 0)
+ ('packages ((name version output path) ...)))
+ (zip name version output path
+ (make-list (length name) '())))
+
+ ;; Version 1 adds a list of propagated inputs to the
+ ;; name/version/output/path tuples.
+ (('manifest ('version 1)
+ ('packages (packages ...)))
+ packages)
+
+ (_
+ (error "unsupported manifest format" manifest))))
+
+(define (profile-regexp profile)
+ "Return a regular expression that matches PROFILE's name and number."
+ (make-regexp (string-append "^" (regexp-quote (basename profile))
+ "-([0-9]+)")))
+
+(define (profile-numbers profile)
+ "Return the list of generation numbers of PROFILE, or '(0) if no
+former profiles were found."
+ (define* (scandir name #:optional (select? (const #t))
+ (entry<? (@ (ice-9 i18n) string-locale<?)))
+ ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
+ (define (enter? dir stat result)
+ (and stat (string=? dir name)))
+
+ (define (visit basename result)
+ (if (select? basename)
+ (cons basename result)
+ result))
+
+ (define (leaf name stat result)
+ (and result
+ (visit (basename name) result)))
+
+ (define (down name stat result)
+ (visit "." '()))
+
+ (define (up name stat result)
+ (visit ".." result))
+
+ (define (skip name stat result)
+ ;; All the sub-directories are skipped.
+ (visit (basename name) result))
+
+ (define (error name* stat errno result)
+ (if (string=? name name*) ; top-level NAME is unreadable
+ result
+ (visit (basename name*) result)))
+
+ (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
+ (lambda (files)
+ (sort files entry<?))))
+
+ (match (scandir (dirname profile)
+ (cute regexp-exec (profile-regexp profile) <>))
+ (#f ; no profile directory
+ '(0))
+ (() ; no profiles
+ '(0))
+ ((profiles ...) ; former profiles around
+ (map (compose string->number
+ (cut match:substring <> 1)
+ (cute regexp-exec (profile-regexp profile) <>))
+ profiles))))
+
+(define (previous-profile-number profile number)
+ "Return the number of the generation before generation NUMBER of
+PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
+case when generations have been deleted (there are \"holes\")."
+ (fold (lambda (candidate highest)
+ (if (and (< candidate number) (> candidate highest))
+ candidate
+ highest))
+ 0
+ (profile-numbers profile)))
+
+(define (profile-derivation store packages)
+ "Return a derivation that builds a profile (a user environment) with
+all of PACKAGES, a list of name/version/output/path/deps tuples."
+ (define builder
+ `(begin
+ (use-modules (ice-9 pretty-print)
+ (guix build union))
+
+ (setvbuf (current-output-port) _IOLBF)
+ (setvbuf (current-error-port) _IOLBF)
+
+ (let ((output (assoc-ref %outputs "out"))
+ (inputs (map cdr %build-inputs)))
+ (format #t "building user environment `~a' with ~a packages...~%"
+ output (length inputs))
+ (union-build output inputs)
+ (call-with-output-file (string-append output "/manifest")
+ (lambda (p)
+ (pretty-print '(manifest (version 1)
+ (packages ,packages))
+ p))))))
+
+ (build-expression->derivation store "user-environment"
+ (%current-system)
+ builder
+ (append-map (match-lambda
+ ((name version output path deps)
+ `((,name ,path)
+ ,@deps)))
+ packages)
+ #:modules '((guix build union))))
+
+(define (profile-number profile)
+ "Return PROFILE's number or 0. An absolute file name must be used."
+ (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
+ (basename (readlink profile))))
+ (compose string->number (cut match:substring <> 1)))
+ 0))
+
+(define (switch-symlinks link target)
+ "Atomically switch LINK, a symbolic link, to point to TARGET. Works
+both when LINK already exists and when it does not."
+ (let ((pivot (string-append link ".new")))
+ (symlink target pivot)
+ (rename-file pivot link)))
+
+(define (roll-back profile)
+ "Roll back to the previous generation of PROFILE."
+ (let* ((number (profile-number profile))
+ (previous-number (previous-profile-number profile number))
+ (previous-profile (format #f "~a-~a-link"
+ profile previous-number))
+ (manifest (string-append previous-profile "/manifest")))
+
+ (define (switch-link)
+ ;; Atomically switch PROFILE to the previous profile.
+ (format #t (_ "switching from generation ~a to ~a~%")
+ number previous-number)
+ (switch-symlinks profile previous-profile))
+
+ (cond ((not (file-exists? profile)) ; invalid profile
+ (format (current-error-port)
+ (_ "error: profile `~a' does not exist~%")
+ profile))
+ ((zero? number) ; empty profile
+ (format (current-error-port)
+ (_ "nothing to do: already at the empty profile~%")))
+ ((or (zero? previous-number) ; going to emptiness
+ (not (file-exists? previous-profile)))
+ (let*-values (((drv-path drv)
+ (profile-derivation (%store) '()))
+ ((prof)
+ (derivation-output-path
+ (assoc-ref (derivation-outputs drv) "out"))))
+ (when (not (build-derivations (%store) (list drv-path)))
+ (leave (_ "failed to build the empty profile~%")))
+
+ (switch-symlinks previous-profile prof)
+ (switch-link)))
+ (else (switch-link))))) ; anything else
+
+(define (find-packages-by-description rx)
+ "Search in SYNOPSIS and DESCRIPTION using RX. Return a list of
+matching packages."
+ (define (same-location? p1 p2)
+ ;; Compare locations of two packages.
+ (equal? (package-location p1) (package-location p2)))
+
+ (delete-duplicates
+ (sort
+ (fold-packages (lambda (package result)
+ (define matches?
+ (cut regexp-exec rx <>))
+
+ (if (or (and=> (package-synopsis package)
+ (compose matches? gettext))
+ (and=> (package-description package)
+ (compose matches? gettext)))
+ (cons package result)
+ result))
+ '())
+ (lambda (p1 p2)
+ (string<? (package-name p1)
+ (package-name p2))))
+ same-location?))
+
+(define (input->name+path input)
+ "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
+ (let loop ((input input))
+ (match input
+ ((name package)
+ (loop `(,name ,package "out")))
+ ((name package sub-drv)
+ (let*-values (((_ drv)
+ (package-derivation (%store) package))
+ ((out)
+ (derivation-output-path
+ (assoc-ref (derivation-outputs drv) sub-drv))))
+ `(,name ,out))))))
+
+\f
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ ;; Alist of default option values.
+ `((profile . ,%current-profile)))
+
+(define (show-help)
+ (display (_ "Usage: guix-package [OPTION]... PACKAGES...
+Install, remove, or upgrade PACKAGES in a single transaction.\n"))
+ (display (_ "
+ -i, --install=PACKAGE install PACKAGE"))
+ (display (_ "
+ -r, --remove=PACKAGE remove PACKAGE"))
+ (display (_ "
+ -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP"))
+ (display (_ "
+ --roll-back roll back to the previous generation"))
+ (newline)
+ (display (_ "
+ -p, --profile=PROFILE use PROFILE instead of the user's default profile"))
+ (display (_ "
+ -n, --dry-run show what would be done without actually doing it"))
+ (display (_ "
+ --bootstrap use the bootstrap Guile to build the profile"))
+ (display (_ "
+ --verbose produce verbose output"))
+ (newline)
+ (display (_ "
+ -s, --search=REGEXP search in synopsis and description using REGEXP"))
+ (display (_ "
+ -I, --list-installed[=REGEXP]
+ list installed packages matching REGEXP"))
+ (display (_ "
+ -A, --list-available[=REGEXP]
+ list available packages matching REGEXP"))
+ (newline)
+ (display (_ "
+ -h, --help display this help and exit"))
+ (display (_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ ;; Specification of the command-line options.
+ (list (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix-package")))
+
+ (option '(#\i "install") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'install arg result)))
+ (option '(#\r "remove") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'remove arg result)))
+ (option '(#\u "upgrade") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'upgrade arg result)))
+ (option '("roll-back") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'roll-back? #t result)))
+ (option '(#\p "profile") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'profile arg
+ (alist-delete 'profile result))))
+ (option '(#\n "dry-run") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'dry-run? #t result)))
+ (option '("bootstrap") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'bootstrap? #t result)))
+ (option '("verbose") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'verbose? #t result)))
+ (option '(#\s "search") #t #f
+ (lambda (opt name arg result)
+ (cons `(query search ,(or arg ""))
+ result)))
+ (option '(#\I "list-installed") #f #t
+ (lambda (opt name arg result)
+ (cons `(query list-installed ,(or arg ""))
+ result)))
+ (option '(#\A "list-available") #f #t
+ (lambda (opt name arg result)
+ (cons `(query list-available ,(or arg ""))
+ result)))))
+
+\f
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-package . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (args-fold args %options
+ (lambda (opt name arg result)
+ (leave (_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (leave (_ "~A: extraneous argument~%") arg))
+ %default-options))
+
+ (define (guile-missing?)
+ ;; Return #t if %GUILE-FOR-BUILD is not available yet.
+ (let ((out (derivation-path->output-path (%guile-for-build))))
+ (not (valid-path? (%store) out))))
+
+ (define (show-what-to-build drv dry-run?)
+ ;; Show what will/would be built in realizing the derivations listed
+ ;; in DRV.
+ (let* ((req (append-map (lambda (drv-path)
+ (let ((d (call-with-input-file drv-path
+ read-derivation)))
+ (derivation-prerequisites-to-build
+ (%store) d)))
+ drv))
+ (req* (delete-duplicates
+ (append (remove (compose (cute valid-path? (%store) <>)
+ derivation-path->output-path)
+ drv)
+ (map derivation-input-path req)))))
+ (if dry-run?
+ (format (current-error-port)
+ (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
+ "~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
+ (length req*))
+ (null? req*) req*)
+ (format (current-error-port)
+ (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
+ "~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
+ (length req*))
+ (null? req*) req*))))
+
+ (define newest-available-packages
+ (memoize find-newest-available-packages))
+
+ (define (find-best-packages-by-name name version)
+ (if version
+ (find-packages-by-name name version)
+ (match (vhash-assoc name (newest-available-packages))
+ ((_ version pkgs ...) pkgs)
+ (#f '()))))
+
+ (define (find-package name)
+ ;; Find the package NAME; NAME may contain a version number and a
+ ;; sub-derivation name. If the version number is not present,
+ ;; return the preferred newest version.
+ (define request name)
+
+ (define (ensure-output p sub-drv)
+ (if (member sub-drv (package-outputs p))
+ p
+ (leave (_ "~a: error: package `~a' lacks output `~a'~%")
+ (location->string (package-location p))
+ (package-full-name p)
+ sub-drv)))
+
+ (let*-values (((name sub-drv)
+ (match (string-rindex name #\:)
+ (#f (values name "out"))
+ (colon (values (substring name 0 colon)
+ (substring name (+ 1 colon))))))
+ ((name version)
+ (package-name->name+version name)))
+ (match (find-best-packages-by-name name version)
+ ((p)
+ (list name (package-version p) sub-drv (ensure-output p sub-drv)
+ (package-transitive-propagated-inputs p)))
+ ((p p* ...)
+ (format (current-error-port)
+ (_ "warning: ambiguous package specification `~a'~%")
+ request)
+ (format (current-error-port)
+ (_ "warning: choosing ~a from ~a~%")
+ (package-full-name p)
+ (location->string (package-location p)))
+ (list name (package-version p) sub-drv (ensure-output p sub-drv)
+ (package-transitive-propagated-inputs p)))
+ (()
+ (leave (_ "~a: package not found~%") request)))))
+
+ (define (upgradeable? name current-version current-path)
+ ;; Return #t if there's a version of package NAME newer than
+ ;; CURRENT-VERSION, or if the newest available version is equal to
+ ;; CURRENT-VERSION but would have an output path different than
+ ;; CURRENT-PATH.
+ (match (vhash-assoc name (newest-available-packages))
+ ((_ candidate-version pkg . rest)
+ (case (version-compare candidate-version current-version)
+ ((>) #t)
+ ((<) #f)
+ ((=) (let ((candidate-path (derivation-path->output-path
+ (package-derivation (%store) pkg))))
+ (not (string=? current-path candidate-path))))))
+ (#f #f)))
+
+ (define (ensure-default-profile)
+ ;; Ensure the default profile symlink and directory exist.
+
+ ;; Create ~/.guix-profile if it doesn't exist yet.
+ (when (and %user-environment-directory
+ %current-profile
+ (not (false-if-exception
+ (lstat %user-environment-directory))))
+ (symlink %current-profile %user-environment-directory))
+
+ ;; Attempt to create /…/profiles/per-user/$USER if needed.
+ (unless (directory-exists? %profile-directory)
+ (catch 'system-error
+ (lambda ()
+ (mkdir-p %profile-directory))
+ (lambda args
+ ;; Often, we cannot create %PROFILE-DIRECTORY because its
+ ;; parent directory is root-owned and we're running
+ ;; unprivileged.
+ (format (current-error-port)
+ (_ "error: while creating directory `~a': ~a~%")
+ %profile-directory
+ (strerror (system-error-errno args)))
+ (format (current-error-port)
+ (_ "Please create the `~a' directory, with you as the owner.~%")
+ %profile-directory)
+ (exit 1)))))
+
+ (define (process-actions opts)
+ ;; Process any install/remove/upgrade action from OPTS.
+
+ (define dry-run? (assoc-ref opts 'dry-run?))
+ (define verbose? (assoc-ref opts 'verbose?))
+ (define profile (assoc-ref opts 'profile))
+
+ (define (canonicalize-deps deps)
+ ;; Remove duplicate entries from DEPS, a list of propagated inputs,
+ ;; where each input is a name/path tuple.
+ (define (same? d1 d2)
+ (match d1
+ ((_ path1)
+ (match d2
+ ((_ path2)
+ (string=? path1 path2))))))
+
+ (delete-duplicates (map input->name+path deps) same?))
+
+ ;; First roll back if asked to.
+ (if (and (assoc-ref opts 'roll-back?) (not dry-run?))
+ (begin
+ (roll-back profile)
+ (process-actions (alist-delete 'roll-back? opts)))
+ (let* ((installed (manifest-packages (profile-manifest profile)))
+ (upgrade-regexps (filter-map (match-lambda
+ (('upgrade . regexp)
+ (make-regexp regexp))
+ (_ #f))
+ opts))
+ (upgrade (if (null? upgrade-regexps)
+ '()
+ (let ((newest (find-newest-available-packages)))
+ (filter-map (match-lambda
+ ((name version output path _)
+ (and (any (cut regexp-exec <> name)
+ upgrade-regexps)
+ (upgradeable? name version path)
+ (find-package name)))
+ (_ #f))
+ installed))))
+ (install (append
+ upgrade
+ (filter-map (match-lambda
+ (('install . (? store-path?))
+ #f)
+ (('install . package)
+ (find-package package))
+ (_ #f))
+ opts)))
+ (drv (filter-map (match-lambda
+ ((name version sub-drv
+ (? package? package)
+ (deps ...))
+ (package-derivation (%store) package))
+ (_ #f))
+ install))
+ (install* (append
+ (filter-map (match-lambda
+ (('install . (? store-path? path))
+ (let-values (((name version)
+ (package-name->name+version
+ (store-path-package-name
+ path))))
+ `(,name ,version #f ,path ())))
+ (_ #f))
+ opts)
+ (map (lambda (tuple drv)
+ (match tuple
+ ((name version sub-drv _ (deps ...))
+ (let ((output-path
+ (derivation-path->output-path
+ drv sub-drv)))
+ `(,name ,version ,sub-drv ,output-path
+ ,(canonicalize-deps deps))))))
+ install drv)))
+ (remove (filter-map (match-lambda
+ (('remove . package)
+ package)
+ (_ #f))
+ opts))
+ (packages (append install*
+ (fold (lambda (package result)
+ (match package
+ ((name _ ...)
+ (alist-delete name result))))
+ (fold alist-delete installed remove)
+ install*))))
+
+ (when (equal? profile %current-profile)
+ (ensure-default-profile))
+
+ (show-what-to-build drv dry-run?)
+
+ (or dry-run?
+ (and (build-derivations (%store) drv)
+ (let* ((prof-drv (profile-derivation (%store) packages))
+ (prof (derivation-path->output-path prof-drv))
+ (old-drv (profile-derivation
+ (%store) (manifest-packages
+ (profile-manifest profile))))
+ (old-prof (derivation-path->output-path old-drv))
+ (number (profile-number profile))
+
+ ;; Always use NUMBER + 1 for the new profile,
+ ;; possibly overwriting a "previous future
+ ;; generation".
+ (name (format #f "~a-~a-link"
+ profile (+ 1 number))))
+ (if (string=? old-prof prof)
+ (when (or (pair? install) (pair? remove))
+ (format (current-error-port)
+ (_ "nothing to be done~%")))
+ (and (parameterize ((current-build-output-port
+ ;; Output something when Guile
+ ;; needs to be built.
+ (if (or verbose? (guile-missing?))
+ (current-error-port)
+ (%make-void-port "w"))))
+ (build-derivations (%store) (list prof-drv)))
+ (begin
+ (switch-symlinks name prof)
+ (switch-symlinks profile name))))))))))
+
+ (define (process-query opts)
+ ;; Process any query specified by OPTS. Return #t when a query was
+ ;; actually processed, #f otherwise.
+ (let ((profile (assoc-ref opts 'profile)))
+ (match (assoc-ref opts 'query)
+ (('list-installed regexp)
+ (let* ((regexp (and regexp (make-regexp regexp)))
+ (manifest (profile-manifest profile))
+ (installed (manifest-packages manifest)))
+ (for-each (match-lambda
+ ((name version output path _)
+ (when (or (not regexp)
+ (regexp-exec regexp name))
+ (format #t "~a\t~a\t~a\t~a~%"
+ name (or version "?") output path))))
+ installed)
+ #t))
+
+ (('list-available regexp)
+ (let* ((regexp (and regexp (make-regexp regexp)))
+ (available (fold-packages
+ (lambda (p r)
+ (let ((n (package-name p)))
+ (if regexp
+ (if (regexp-exec regexp n)
+ (cons p r)
+ r)
+ (cons p r))))
+ '())))
+ (for-each (lambda (p)
+ (format #t "~a\t~a\t~a\t~a~%"
+ (package-name p)
+ (package-version p)
+ (string-join (package-outputs p) ",")
+ (location->string (package-location p))))
+ (sort available
+ (lambda (p1 p2)
+ (string<? (package-name p1)
+ (package-name p2)))))
+ #t))
+
+ (('search regexp)
+ (let ((regexp (make-regexp regexp regexp/icase)))
+ (for-each (cute package->recutils <> (current-output-port))
+ (find-packages-by-description regexp))
+ #t))
+ (_ #f))))
+
+ (install-locale)
+ (textdomain "guix")
+ (setvbuf (current-output-port) _IOLBF)
+ (setvbuf (current-error-port) _IOLBF)
+
+ (let ((opts (parse-options)))
+ (or (process-query opts)
+ (parameterize ((%store (open-connection)))
+ (with-error-handling
+ (parameterize ((%guile-for-build
+ (package-derivation (%store)
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ guile-final))))
+ (process-actions opts)))))))
diff --git a/pre-inst-env.in b/pre-inst-env.in
index 1dc63cd..4e079c8 100644
--- a/pre-inst-env.in
+++ b/pre-inst-env.in
@@ -27,9 +27,9 @@ GUILE_LOAD_COMPILED_PATH="@abs_top_builddir@${GUILE_LOAD_COMPILED_PATH:+:}$GUILE
GUILE_LOAD_PATH="@abs_top_builddir@:@abs_top_srcdir@${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH"
export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH
-# Define $PATH so that `guix-build' and friends are easily found.
+# Define $PATH so that `guix' and friends are easily found.
-PATH="@abs_top_builddir@:$PATH"
+PATH="@abs_top_builddir@/scripts:@abs_top_builddir@:$PATH"
export PATH
# Daemon helpers.
@@ -43,7 +43,12 @@ export NIX_ROOT_FINDER NIX_SETUID_HELPER
# auto-compilation.
NIX_HASH="@NIX_HASH@"
-
export NIX_HASH
+# Define $GUIX_UNINSTALLED to prevent `guix' from
+# prepending @guilemoduledir@ to the Guile load paths.
+
+GUIX_UNINSTALLED=1
+export GUIX_UNINSTALLED
+
exec "$@"
diff --git a/scripts/guix.in b/scripts/guix.in
new file mode 100644
index 0000000..6c77298
--- /dev/null
+++ b/scripts/guix.in
@@ -0,0 +1,68 @@
+#!@GUILE@ -s
+-*- scheme -*-
+!#
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
+;;;
+;;; 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/>.
+
+(use-modules (ice-9 regex))
+
+(let ()
+ (define-syntax-rule (push! elt v) (set! v (cons elt v)))
+
+ (define config-lookup
+ (let ((config '(("prefix" . "@prefix@")
+ ("datarootdir" . "@datarootdir@")
+ ("guilemoduledir" . "@guilemoduledir@")))
+ (var-ref-regexp (make-regexp "\\$\\{([a-z]+)\\}")))
+ (define (expand-var-ref match)
+ (lookup (match:substring match 1)))
+ (define (expand str)
+ (regexp-substitute/global #f var-ref-regexp str
+ 'pre expand-var-ref 'post))
+ (define (lookup name)
+ (expand (assoc-ref config name)))
+ lookup))
+
+ (define (maybe-augment-load-paths!)
+ (unless (getenv "GUIX_UNINSTALLED")
+ (let ((module-dir (config-lookup "guilemoduledir")))
+ (push! module-dir %load-path)
+ (push! module-dir %load-compiled-path))))
+
+ (define (run-script name args)
+ (let* ((symbol (string->symbol name))
+ (module (resolve-interface `(guix scripts ,symbol)))
+ (script (module-ref module symbol)))
+ (apply script args)))
+
+ (define (main arg0 . args)
+ (setlocale LC_ALL "") ; XXX Is there a reason not to do this?
+ (maybe-augment-load-paths!)
+ (let ((cmd (basename arg0)))
+ (cond ((string-prefix? "guix-" cmd)
+ (run-script cmd args))
+ ((not (null? args))
+ (run-script (string-append "guix-" (car args))
+ (cdr args)))
+ (else
+ ;; TODO: Dynamically generate a summary of available commands.
+ (format (current-error-port)
+ "Usage: guix <command> [<args>]~%")
+ (exit 1)))))
+
+ (apply main (command-line)))
--
1.7.10.4
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: [PATCH 2/2] PRELIMINARY Adjust tests to use main 'guix' script --]
[-- Type: text/x-diff, Size: 12084 bytes --]
From 7a71391a2b24dcfaf4a94e9ecb657f3edfb565ad Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 14 Feb 2013 04:16:30 -0500
Subject: [PATCH 2/2] PRELIMINARY Adjust tests to use main 'guix' script.
This will not be necessary if we install links for 'guix-package'
and friends.
---
tests/guix-build.sh | 26 +++++++++++-----------
tests/guix-daemon.sh | 6 +++---
tests/guix-download.sh | 12 +++++------
tests/guix-gc.sh | 24 ++++++++++-----------
tests/guix-package.sh | 56 ++++++++++++++++++++++++------------------------
5 files changed, 62 insertions(+), 62 deletions(-)
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index 5718b07..721a7c6 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -17,44 +17,44 @@
# along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
#
-# Test the `guix-build' command-line utility.
+# Test the `guix build' command-line utility.
#
-guix-build --version
+guix build --version
# Should fail.
-if guix-build -e +;
+if guix build -e +;
then false; else true; fi
# Should fail because this is a source-less package.
-if guix-build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S
+if guix build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S
then false; else true; fi
# Should pass.
-guix-build -e '(@@ (gnu packages base) %bootstrap-guile)' | \
+guix build -e '(@@ (gnu packages base) %bootstrap-guile)' | \
grep -e '-guile-'
-guix-build hello -d | \
+guix build hello -d | \
grep -e '-hello-[0-9\.]\+\.drv$'
# Should fail because the name/version combination could not be found.
-if guix-build hello-0.0.1 -n; then false; else true; fi
+if guix build hello-0.0.1 -n; then false; else true; fi
# Keep a symlink to the result, registered as a root.
result="t-result-$$"
-guix-build -r "$result" \
+guix build -r "$result" \
-e '(@@ (gnu packages base) %bootstrap-guile)'
test -x "$result/bin/guile"
# Should fail, because $result already exists.
-if guix-build -r "$result" -e '(@@ (gnu packages base) %bootstrap-guile)'
+if guix build -r "$result" -e '(@@ (gnu packages base) %bootstrap-guile)'
then false; else true; fi
rm -f "$result"
# Parsing package names and versions.
-guix-build -n time # PASS
-guix-build -n time-1.7 # PASS, version found
-if guix-build -n time-3.2; # FAIL, version not found
+guix build -n time # PASS
+guix build -n time-1.7 # PASS, version found
+if guix build -n time-3.2; # FAIL, version not found
then false; else true; fi
-if guix-build -n something-that-will-never-exist; # FAIL
+if guix build -n something-that-will-never-exist; # FAIL
then false; else true; fi
diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh
index 0d39ff4..6985164 100644
--- a/tests/guix-daemon.sh
+++ b/tests/guix-daemon.sh
@@ -23,7 +23,7 @@
set -e
guix-daemon --version
-guix-build --version
+guix build --version
-guix-build -e '(@ (gnu packages bootstrap) %bootstrap-guile)'
-guix-build coreutils -n
+guix build -e '(@ (gnu packages bootstrap) %bootstrap-guile)'
+guix build coreutils -n
diff --git a/tests/guix-download.sh b/tests/guix-download.sh
index f0ea731..7af6f18 100644
--- a/tests/guix-download.sh
+++ b/tests/guix-download.sh
@@ -17,20 +17,20 @@
# along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
#
-# Test the `guix-download' command-line utility.
+# Test the `guix download' command-line utility.
#
-guix-download --version
+guix download --version
# Make sure it fails here.
-if guix-download http://does.not/exist
+if guix download http://does.not/exist
then false; else true; fi
-if guix-download unknown://some/where;
+if guix download unknown://some/where;
then false; else true; fi
-if guix-download not/a/uri;
+if guix download not/a/uri;
then false; else true; fi
# This one should succeed.
-guix-download "file://$abs_top_srcdir/README"
+guix download "file://$abs_top_srcdir/README"
diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh
index 805300e..a90d085 100644
--- a/tests/guix-gc.sh
+++ b/tests/guix-gc.sh
@@ -17,38 +17,38 @@
# along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
#
-# Test the `guix-gc' command-line utility.
+# Test the `guix gc' command-line utility.
#
-guix-gc --version
+guix gc --version
trap "rm -f guix-gc-root" EXIT
rm -f guix-gc-root
# Add then reclaim a .drv file.
-drv="`guix-build idutils -d`"
+drv="`guix build idutils -d`"
test -f "$drv"
-guix-gc --list-dead | grep "$drv"
-guix-gc --delete "$drv"
+guix gc --list-dead | grep "$drv"
+guix gc --delete "$drv"
! test -f "$drv"
# Add a .drv, register it as a root.
-drv="`guix-build --root=guix-gc-root lsh -d`"
+drv="`guix build --root=guix-gc-root lsh -d`"
test -f "$drv" && test -L guix-gc-root
-guix-gc --list-live | grep "$drv"
-if guix-gc --delete "$drv";
+guix gc --list-live | grep "$drv"
+if guix gc --delete "$drv";
then false; else true; fi
rm guix-gc-root
-guix-gc --list-dead | grep "$drv"
-guix-gc --delete "$drv"
+guix gc --list-dead | grep "$drv"
+guix gc --delete "$drv"
! test -f "$drv"
# Try a random collection.
-guix-gc -C 1KiB
+guix gc -C 1KiB
# Check trivial error cases.
-if guix-gc --delete /dev/null;
+if guix gc --delete /dev/null;
then false; else true; fi
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 617318b..cf8bc5c 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -18,10 +18,10 @@
# along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
#
-# Test the `guix-package' command-line utility.
+# Test the `guix package' command-line utility.
#
-guix-package --version
+guix package --version
readlink_base ()
{
@@ -33,12 +33,12 @@ rm -f "$profile"
trap 'rm "$profile" "$profile-"[0-9]* ; rm -rf t-home-'"$$" EXIT
-guix-package --bootstrap -p "$profile" -i guile-bootstrap
+guix package --bootstrap -p "$profile" -i guile-bootstrap
test -L "$profile" && test -L "$profile-1-link"
test -f "$profile/bin/guile"
# Installing the same package a second time does nothing.
-guix-package --bootstrap -p "$profile" -i guile-bootstrap
+guix package --bootstrap -p "$profile" -i guile-bootstrap
test -L "$profile" && test -L "$profile-1-link"
! test -f "$profile-2-link"
test -f "$profile/bin/guile"
@@ -46,8 +46,8 @@ test -f "$profile/bin/guile"
# Check whether we have network access.
if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null
then
- boot_make="`guix-build -e '(@@ (gnu packages base) gnu-make-boot0)'`"
- guix-package --bootstrap -p "$profile" -i "$boot_make"
+ boot_make="`guix build -e '(@@ (gnu packages base) gnu-make-boot0)'`"
+ guix package --bootstrap -p "$profile" -i "$boot_make"
test -L "$profile-2-link"
test -f "$profile/bin/make" && test -f "$profile/bin/guile"
@@ -55,7 +55,7 @@ then
# Check whether `--list-installed' works.
# XXX: Change the tests when `--install' properly extracts the package
# name and version string.
- installed="`guix-package -p "$profile" --list-installed | cut -f1 | xargs echo | sort`"
+ installed="`guix package -p "$profile" --list-installed | cut -f1 | xargs echo | sort`"
case "x$installed" in
"guile-bootstrap make-boot0")
true;;
@@ -65,68 +65,68 @@ then
false;;
esac
- test "`guix-package -p "$profile" -I 'g.*e' | cut -f1`" = "guile-bootstrap"
+ test "`guix package -p "$profile" -I 'g.*e' | cut -f1`" = "guile-bootstrap"
# Search.
- test "`guix-package -s "GNU Hello" | grep ^name:`" = "name: hello"
- test "`guix-package -s "n0t4r341p4ck4g3"`" = ""
+ test "`guix package -s "GNU Hello" | grep ^name:`" = "name: hello"
+ test "`guix package -s "n0t4r341p4ck4g3"`" = ""
# Remove a package.
- guix-package --bootstrap -p "$profile" -r "guile-bootstrap"
+ guix package --bootstrap -p "$profile" -r "guile-bootstrap"
test -L "$profile-3-link"
test -f "$profile/bin/make" && ! test -f "$profile/bin/guile"
# Roll back.
- guix-package --roll-back -p "$profile"
+ guix package --roll-back -p "$profile"
test "`readlink_base "$profile"`" = "$profile-2-link"
test -x "$profile/bin/guile" && test -x "$profile/bin/make"
- guix-package --roll-back -p "$profile"
+ guix package --roll-back -p "$profile"
test "`readlink_base "$profile"`" = "$profile-1-link"
test -x "$profile/bin/guile" && ! test -x "$profile/bin/make"
# Move to the empty profile.
for i in `seq 1 3`
do
- guix-package --bootstrap --roll-back -p "$profile"
+ guix package --bootstrap --roll-back -p "$profile"
! test -f "$profile/bin"
! test -f "$profile/lib"
test "`readlink_base "$profile"`" = "$profile-0-link"
done
# Reinstall after roll-back to the empty profile.
- guix-package --bootstrap -p "$profile" -i "$boot_make"
+ guix package --bootstrap -p "$profile" -i "$boot_make"
test "`readlink_base "$profile"`" = "$profile-1-link"
test -x "$profile/bin/guile" && ! test -x "$profile/bin/make"
# Roll-back to generation 0, and install---all at once.
- guix-package --bootstrap -p "$profile" --roll-back -i guile-bootstrap
+ guix package --bootstrap -p "$profile" --roll-back -i guile-bootstrap
test "`readlink_base "$profile"`" = "$profile-1-link"
test -x "$profile/bin/guile" && ! test -x "$profile/bin/make"
# Install Make.
- guix-package --bootstrap -p "$profile" -i "$boot_make"
+ guix package --bootstrap -p "$profile" -i "$boot_make"
test "`readlink_base "$profile"`" = "$profile-2-link"
test -x "$profile/bin/guile" && test -x "$profile/bin/make"
# Make a "hole" in the list of generations, and make sure we can
# roll back "over" it.
rm "$profile-1-link"
- guix-package --bootstrap -p "$profile" --roll-back
+ guix package --bootstrap -p "$profile" --roll-back
test "`readlink_base "$profile"`" = "$profile-0-link"
fi
# Make sure the `:' syntax works.
-guix-package --bootstrap -i "binutils:lib" -p "$profile" -n
+guix package --bootstrap -i "binutils:lib" -p "$profile" -n
# Make sure nonexistent outputs are reported.
-guix-package --bootstrap -i "guile-bootstrap:out" -p "$profile" -n
-if guix-package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile" -n;
+guix package --bootstrap -i "guile-bootstrap:out" -p "$profile" -n
+if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile" -n;
then false; else true; fi
-if guix-package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile";
+if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile";
then false; else true; fi
# Check whether `--list-available' returns something sensible.
-guix-package -A 'gui.*e' | grep guile
+guix package -A 'gui.*e' | grep guile
#
# Try with the default profile.
@@ -139,17 +139,17 @@ export HOME
mkdir -p "$HOME"
-guix-package --bootstrap -i guile-bootstrap
+guix package --bootstrap -i guile-bootstrap
test -L "$HOME/.guix-profile"
test -f "$HOME/.guix-profile/bin/guile"
if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null
then
- guix-package --bootstrap -i "$boot_make"
+ guix package --bootstrap -i "$boot_make"
test -f "$HOME/.guix-profile/bin/make"
first_environment="`cd $HOME/.guix-profile ; pwd`"
- guix-package --bootstrap --roll-back
+ guix package --bootstrap --roll-back
test -f "$HOME/.guix-profile/bin/guile"
! test -f "$HOME/.guix-profile/bin/make"
test "`cd $HOME/.guix-profile ; pwd`" = "$first_environment"
@@ -159,12 +159,12 @@ fi
default_profile="`readlink "$HOME/.guix-profile"`"
for i in `seq 1 3`
do
- guix-package --bootstrap --roll-back
+ guix package --bootstrap --roll-back
! test -f "$HOME/.guix-profile/bin"
! test -f "$HOME/.guix-profile/lib"
test "`readlink "$default_profile"`" = "$default_profile-0-link"
done
# Extraneous argument.
-if guix-package install foo-bar;
+if guix package install foo-bar;
then false; else true; fi
--
1.7.10.4
^ permalink raw reply related [flat|nested] 17+ messages in thread
* Re: [PATCH] Replace individual scripts with master 'guix' script
2013-02-14 9:44 ` [PATCH] Replace individual scripts with master 'guix' script Mark H Weaver
@ 2013-02-14 13:41 ` Ludovic Courtès
2013-02-14 23:13 ` Mark H Weaver
0 siblings, 1 reply; 17+ messages in thread
From: Ludovic Courtès @ 2013-02-14 13:41 UTC (permalink / raw)
To: Mark H Weaver; +Cc: bug-guix
Hi!
Mark H Weaver <mhw@netris.org> skribis:
> From 726ef0a61f943522ecb5a8d8b609c6810727b9d3 Mon Sep 17 00:00:00 2001
> From: Mark H Weaver <mhw@netris.org>
> Date: Thu, 14 Feb 2013 04:15:25 -0500
> Subject: [PATCH 1/2] PRELIMINARY: Replace individual scripts with master
> 'guix' script.
>
> TODO: Update documentation.
> TODO: Install links for 'guix-package' and friends.
>
> * scripts/guix.in: New script.
>
> * Makefile.am (bin_SCRIPTS): Add 'scripts/guix'. Remove 'guix-build',
> 'guix-download', 'guix-import', 'guix-package', and 'guix-gc'.
>
> (MODULES): Add 'guix/scripts/guix-build.scm',
> 'guix/scripts/guix-download.scm', 'guix/scripts/guix-import.scm',
> 'guix/scripts/guix-package.scm', and 'guix/scripts/guix-gc.scm'.
>
> * configure.ac (AC_CONFIG_FILES): Add 'scripts/guix'. Remove 'guix-build',
> 'guix-download', 'guix-import', 'guix-package', and 'guix-gc'.
>
> * guix-build.in, guix-download.in, guix-gc.in, guix-import.in,
> guix-package.in: Remove shell script boilerplate. Move to guix/scripts and
> change suffix from ".in" to ".scm". Change module name from (NAME) to
> (guix scripts NAME).
>
> * pre-inst-env.in: Add "@abs_top_builddir@/scripts" to the front of $PATH.
> Export $GUIX_UNINSTALLED.
>
> * .gitignore: Add '/scripts/guix'. Remove '/guix-build', '/guix-download',
> '/guix-package', '/guix-import', and '/guix-gc'.
Perfect, this is the way to go, also wrt. the forthcoming guix-pull
(which will pull Scheme code from Guix from the repo, similar to
‘apt-get update’ or ‘nix-channel --update’.)
A few remarks:
• Remove the ‘guix-’ prefix from module names, so
guix/scripts/build.scm instead of guix/scripts/guix-build.scm;
• No need to add .gitignore to change logs;
• Make sure to update po/POTFILES.in;
• Arrange commits such that everything always works; thus, update
tests to use the new command names in the same commit that changes
those commands.
+ (define (main arg0 . args)
+ (setlocale LC_ALL "") ; XXX Is there a reason not to do this?
Rather do as currently done:
(install-locale)
(textdomain "guix")
(setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF)
+ (maybe-augment-load-paths!)
+ (let ((cmd (basename arg0)))
+ (cond ((string-prefix? "guix-" cmd)
+ (run-script cmd args))
+ ((not (null? args))
+ (run-script (string-append "guix-" (car args))
+ (cdr args)))
+ (else
+ ;; TODO: Dynamically generate a summary of available commands.
Yes, that would be neat.
We also need to support --version and --help here, using SRFI-37 as is
the current scripts.
+ (format (current-error-port)
+ "Usage: guix <command> [<args>]~%")
Messages must be i18n’d, and use standard GNU notation:
Usage: guix COMMAND ARGS...
Thanks for working on that, it’s good to see that I’m becoming less of a
bottleneck! :-)
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH] Replace individual scripts with master 'guix' script
2013-02-14 13:41 ` Ludovic Courtès
@ 2013-02-14 23:13 ` Mark H Weaver
2013-02-16 20:57 ` Ludovic Courtès
2013-02-17 14:59 ` Ludovic Courtès
0 siblings, 2 replies; 17+ messages in thread
From: Mark H Weaver @ 2013-02-14 23:13 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: bug-guix
[-- Attachment #1: Type: text/plain, Size: 1655 bytes --]
Hi Ludovic,
Thanks for the quick feedback. I've attached a new patch that
incorporates almost all of your suggestions, and also includes a basic
find/replace in the manual (though more work is needed there).
> • Remove the ‘guix-’ prefix from module names, so
> guix/scripts/build.scm instead of guix/scripts/guix-build.scm;
>
> • No need to add .gitignore to change logs;
>
> • Make sure to update po/POTFILES.in;
Done.
> • Arrange commits such that everything always works; thus, update
> tests to use the new command names in the same commit that changes
> those commands.
Indeed. The reason I initially kept the test updates separated is
because I wasn't sure if we wanted to continue supporting the old style
"guix-package" and friends. However, we agreed on IRC to abandon the
old style, so that's what this patch now does.
> (install-locale)
> (textdomain "guix")
> (setvbuf (current-output-port) _IOLBF)
> (setvbuf (current-error-port) _IOLBF)
Done.
> We also need to support --version and --help here, using SRFI-37 as is
> the current scripts.
I now support --version and --help, but I didn't see how to use SRFI-37
in the main driver, because it doesn't know the full set of options to
accept.
> + (format (current-error-port)
> + "Usage: guix <command> [<args>]~%")
>
> Messages must be i18n’d, and use standard GNU notation:
>
> Usage: guix COMMAND ARGS...
Done.
Here's the new patch, compressed this time. Please let me know what you
think. I think this might be about ready to push.
Mark
[-- Attachment #2: [PATCH] Replace individual scripts with master 'guix' script --]
[-- Type: application/x-gzip, Size: 30831 bytes --]
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH] Replace individual scripts with master 'guix' script
2013-02-14 23:13 ` Mark H Weaver
@ 2013-02-16 20:57 ` Ludovic Courtès
2013-02-17 14:59 ` Ludovic Courtès
1 sibling, 0 replies; 17+ messages in thread
From: Ludovic Courtès @ 2013-02-16 20:57 UTC (permalink / raw)
To: Mark H Weaver; +Cc: bug-guix
Hi Mark!
Mark H Weaver <mhw@netris.org> skribis:
>> • Arrange commits such that everything always works; thus, update
>> tests to use the new command names in the same commit that changes
>> those commands.
>
> Indeed. The reason I initially kept the test updates separated is
> because I wasn't sure if we wanted to continue supporting the old style
> "guix-package" and friends. However, we agreed on IRC to abandon the
> old style, so that's what this patch now does.
Yes, I think it’s OK. Let’s see if someone complains. ;-)
> I now support --version and --help,
Mark --version? :-)
> but I didn't see how to use SRFI-37 in the main driver, because it
> doesn't know the full set of options to accept.
Yes, makes sense.
> Here's the new patch, compressed this time. Please let me know what you
> think. I think this might be about ready to push.
Yes, please push.
Thank you!
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH] Replace individual scripts with master 'guix' script
2013-02-14 23:13 ` Mark H Weaver
2013-02-16 20:57 ` Ludovic Courtès
@ 2013-02-17 14:59 ` Ludovic Courtès
1 sibling, 0 replies; 17+ messages in thread
From: Ludovic Courtès @ 2013-02-17 14:59 UTC (permalink / raw)
To: Mark H Weaver; +Cc: bug-guix
Mark H Weaver <mhw@netris.org> skribis:
>> (install-locale)
>> (textdomain "guix")
>> (setvbuf (current-output-port) _IOLBF)
>> (setvbuf (current-error-port) _IOLBF)
>
> Done.
FYI in commit 633f045 I removed now redundant calls like the above, and
made ‘initialize-guix’ and ‘install-locale’ private to (guix ui).
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
end of thread, other threads:[~2013-02-17 14:59 UTC | newest]
Thread overview: 17+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2013-02-12 1:45 [PATCH] Improve shell script headers and pre-inst-env handling Mark H Weaver
2013-02-12 2:24 ` Mark H Weaver
2013-02-12 4:36 ` Mark H Weaver
2013-02-12 15:53 ` Ludovic Courtès
2013-02-12 15:56 ` Ludovic Courtès
2013-02-12 18:44 ` Mark H Weaver
2013-02-12 21:48 ` Ludovic Courtès
2013-02-12 22:44 ` Mark H Weaver
2013-02-13 14:42 ` Ludovic Courtès
2013-02-13 9:55 ` Mark H Weaver
2013-02-13 20:57 ` Ludovic Courtès
2013-02-14 8:28 ` Mark H Weaver
2013-02-14 9:44 ` [PATCH] Replace individual scripts with master 'guix' script Mark H Weaver
2013-02-14 13:41 ` Ludovic Courtès
2013-02-14 23:13 ` Mark H Weaver
2013-02-16 20:57 ` Ludovic Courtès
2013-02-17 14:59 ` Ludovic Courtès
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.