[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Replace individual scripts with master 'guix' script
|
From: |
Mark H Weaver |
|
Subject: |
[PATCH] Replace individual scripts with master 'guix' script |
|
Date: |
Thu, 14 Feb 2013 04:44:54 -0500 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.2 (gnu/linux) |
I wrote:
> address@hidden (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
>From 726ef0a61f943522ecb5a8d8b609c6810727b9d3 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
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 address@hidden@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <address@hidden>
-;;; Copyright © 2013 Mark H Weaver <address@hidden>
-;;;
-;;; 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))))
-
-
-;;;
-;;; 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)))))))
-
-
-;;;
-;;; 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 address@hidden@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <address@hidden>
-;;;
-;;; 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))))))
-
-;;;
-;;; 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")))))
-
-
-;;;
-;;; 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 address@hidden@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <address@hidden>
-;;;
-;;; 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))
-
-
-;;;
-;;; 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))))))
-
-
-;;;
-;;; 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 address@hidden@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <address@hidden>
-;;;
-;;; 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))
-
-
-;;;
-;;; 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"))
-
-
-;;;
-;;; 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")))))
-
-
-;;;
-;;; 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 address@hidden@} -L "@guilemoduledir@" -l "$0" \
- -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <address@hidden>
-;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
-;;; Copyright © 2013 Mark H Weaver <address@hidden>
-;;;
-;;; 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))
-
-
-;;;
-;;; 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))))))
-
-
-;;;
-;;; 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)))))
-
-
-;;;
-;;; 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 <address@hidden>
+;;; Copyright © 2013 Mark H Weaver <address@hidden>
+;;;
+;;; 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))))
+
+
+;;;
+;;; 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)))))))
+
+
+;;;
+;;; 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 <address@hidden>
+;;;
+;;; 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))))))
+
+;;;
+;;; 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")))))
+
+
+;;;
+;;; 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 <address@hidden>
+;;;
+;;; 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))
+
+
+;;;
+;;; 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))))))
+
+
+;;;
+;;; 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 <address@hidden>
+;;;
+;;; 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))
+
+
+;;;
+;;; 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"))
+
+
+;;;
+;;; 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")))))
+
+
+;;;
+;;; 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 <address@hidden>
+;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
+;;; Copyright © 2013 Mark H Weaver <address@hidden>
+;;;
+;;; 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))
+
+
+;;;
+;;; 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))))))
+
+
+;;;
+;;; 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)))))
+
+
+;;;
+;;; 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="@address@hidden:+:}$GUILE
GUILE_LOAD_PATH="@abs_top_builddir@:@address@hidden:+:}:$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 @@
address@hidden@ -s
+-*- scheme -*-
+!#
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Mark H Weaver <address@hidden>
+;;;
+;;; 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
>From 7a71391a2b24dcfaf4a94e9ecb657f3edfb565ad Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
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
- Re: [PATCH] Improve shell script headers and pre-inst-env handling, (continued)
- Re: [PATCH] Improve shell script headers and pre-inst-env handling, Ludovic Courtès, 2013/02/12
- Re: [PATCH] Improve shell script headers and pre-inst-env handling, Mark H Weaver, 2013/02/12
- Re: [PATCH] Improve shell script headers and pre-inst-env handling, Mark H Weaver, 2013/02/13
- Re: [PATCH] Improve shell script headers and pre-inst-env handling, Ludovic Courtès, 2013/02/13
- Re: [PATCH] Improve shell script headers and pre-inst-env handling, Mark H Weaver, 2013/02/14
- [PATCH] Replace individual scripts with master 'guix' script,
Mark H Weaver <=
- Re: [PATCH] Replace individual scripts with master 'guix' script, Ludovic Courtès, 2013/02/14
- Re: [PATCH] Replace individual scripts with master 'guix' script, Mark H Weaver, 2013/02/14
- Re: [PATCH] Replace individual scripts with master 'guix' script, Ludovic Courtès, 2013/02/16
- Re: [PATCH] Replace individual scripts with master 'guix' script, Ludovic Courtès, 2013/02/17