summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-11-08 21:58:09 +0100
committerLudovic Courtès <ludo@gnu.org>2013-11-08 21:58:09 +0100
commit7db9608d52ab431165ab150a0a0707c686990c1c (patch)
treeb19d49a71e71f8da939a4825b545da3a31907e65
parent7a78cc7af24a1303dd0117cb977e15ca89a5dad8 (diff)
parent6a9957545ce51e7a50381059d4509d0dfcba0aba (diff)
downloadguix-patches-7db9608d52ab431165ab150a0a0707c686990c1c.tar
guix-patches-7db9608d52ab431165ab150a0a0707c686990c1c.tar.gz
Merge branch 'master' into core-updates
Conflicts: guix/packages.scm
-rw-r--r--.dir-locals.el3
-rw-r--r--Makefile.am4
-rw-r--r--doc/guix.texi51
-rw-r--r--gnu-system.am1
-rw-r--r--gnu/packages/cmake.scm4
-rw-r--r--gnu/packages/gcc.scm30
-rw-r--r--gnu/packages/maths.scm47
-rw-r--r--gnu/packages/recutils.scm24
-rw-r--r--gnu/packages/video.scm172
-rw-r--r--guix/packages.scm81
-rw-r--r--guix/profiles.scm347
-rw-r--r--guix/scripts/package.scm387
-rw-r--r--guix/ui.scm36
-rw-r--r--tests/derivations.scm25
-rw-r--r--tests/packages.scm60
-rw-r--r--tests/profiles.scm97
-rw-r--r--tests/ui.scm17
17 files changed, 1023 insertions, 363 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index dc1a3d724d..bb4e964dd5 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -14,6 +14,9 @@
(eval . (put 'substitute* 'scheme-indent-function 1))
(eval . (put 'with-directory-excursion 'scheme-indent-function 1))
(eval . (put 'package 'scheme-indent-function 0))
+ (eval . (put 'origin 'scheme-indent-function 0))
+ (eval . (put 'manifest-entry 'scheme-indent-function 0))
+ (eval . (put 'manifest-pattern 'scheme-indent-function 0))
(eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1))
(eval . (put 'with-error-handling 'scheme-indent-function 0))
(eval . (put 'with-mutex 'scheme-indent-function 1))
diff --git a/Makefile.am b/Makefile.am
index 7a74bc8601..9462878d1c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -41,6 +41,7 @@ MODULES = \
guix/hash.scm \
guix/utils.scm \
guix/monads.scm \
+ guix/profiles.scm \
guix/serialization.scm \
guix/nar.scm \
guix/derivations.scm \
@@ -114,7 +115,8 @@ SCM_TESTS = \
tests/store.scm \
tests/monads.scm \
tests/nar.scm \
- tests/union.scm
+ tests/union.scm \
+ tests/profiles.scm
SH_TESTS = \
tests/guix-build.sh \
diff --git a/doc/guix.texi b/doc/guix.texi
index 054d0af467..4fb14063d0 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -288,9 +288,18 @@ Take users from @var{group} to run build processes (@pxref{Setting Up
the Daemon, build users}).
@item --no-substitutes
+@cindex substitutes
Do not use substitutes for build products. That is, always build things
locally instead of allowing downloads of pre-built binaries.
+By default substitutes are used, unless the client---such as the
+@command{guix package} command---is explicitly invoked with
+@code{--no-substitutes}.
+
+When the daemon runs with @code{--no-substitutes}, clients can still
+explicitly enable substitution @i{via} the @code{set-build-options}
+remote procedure call (@pxref{The Store}).
+
@item --cache-failures
Cache build failures. By default, only successful builds are cached.
@@ -446,10 +455,18 @@ scripts, etc. This direct correspondence allows users to make sure a
given package installation matches the current state of their
distribution, and helps maximize @dfn{reproducibility}.
+@cindex substitute
This foundation allows Guix to support @dfn{transparent binary/source
deployment}. When a pre-built binary for a @file{/nix/store} path is
-available from an external source, Guix just downloads it; otherwise, it
-builds the package from source, locally.
+available from an external source---a @dfn{substitute}, Guix just
+downloads it@footnote{@c XXX: Remove me when outdated.
+As of version @value{VERSION}, substitutes are downloaded from
+@url{http://hydra.gnu.org/} but are @emph{not} authenticated---i.e.,
+Guix cannot tell whether binaries it downloaded have been tampered with,
+nor whether they come from the genuine @code{gnu.org} build farm. This
+will be fixed in future versions. In the meantime, concerned users can
+opt for @code{--no-substitutes} (@pxref{Invoking guix-daemon}).};
+otherwise, it builds the package from source, locally.
@node Invoking guix package
@section Invoking @command{guix package}
@@ -540,6 +557,11 @@ multiple-output package.
@itemx -r @var{package}
Remove @var{package}.
+As for @code{--install}, @var{package} may specify a version number
+and/or output name in addition to the package name. For instance,
+@code{-r glibc:debug} would remove the @code{debug} output of
+@code{glibc}.
+
@item --upgrade[=@var{regexp}]
@itemx -u [@var{regexp}]
Upgrade all the installed packages. When @var{regexp} is specified, upgrade
@@ -593,7 +615,10 @@ When substituting a pre-built binary fails, fall back to building
packages locally.
@item --no-substitutes
-@itemx --max-silent-time=@var{seconds}
+Do not use substitutes for build products. That is, always build things
+locally instead of allowing downloads of pre-built binaries.
+
+@item --max-silent-time=@var{seconds}
Same as for @command{guix build} (@pxref{Invoking guix build}).
@item --verbose
@@ -960,6 +985,11 @@ base32 representation of the hash. You can obtain this information with
@code{guix download} (@pxref{Invoking guix download}) and @code{guix
hash} (@pxref{Invoking guix hash}).
+@cindex patches
+When needed, the @code{origin} form can also have a @code{patches} field
+listing patches to be applied, and a @code{snippet} field giving a
+Scheme expression to modify the source code.
+
@item
@cindex GNU Build System
The @code{build-system} field is set to @var{gnu-build-system}. The
@@ -1454,6 +1484,10 @@ themselves.
For instance, @code{guix build -S gcc} returns something like
@file{/nix/store/@dots{}-gcc-4.7.2.tar.bz2}, which is GCC's source tarball.
+The returned source tarball is the result of applying any patches and
+code snippets specified in the package's @code{origin} (@pxref{Defining
+Packages}).
+
@item --system=@var{system}
@itemx -s @var{system}
Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of
@@ -1490,7 +1524,8 @@ When substituting a pre-built binary fails, fall back to building
packages locally.
@item --no-substitutes
-Build instead of resorting to pre-built substitutes.
+Do not use substitutes for build products. That is, always build things
+locally instead of allowing downloads of pre-built binaries.
@item --max-silent-time=@var{seconds}
When the build or substitution process remains silent for more than
@@ -1852,6 +1887,14 @@ software distribution guidelines}. Among other things, these guidelines
reject non-free firmware, recommendations of non-free software, and
discuss ways to deal with trademarks and patents.
+Some packages contain a small and optional subset that violates the
+above guidelines, for instance because this subset is itself non-free
+code. When that happens, the offending items are removed with
+appropriate patches or code snippets in the package definition's
+@code{origin} form (@pxref{Defining Packages}). That way, @code{guix
+build --source} returns the ``freed'' source rather than the unmodified
+upstream source.
+
@node Package Naming
@subsection Package Naming
diff --git a/gnu-system.am b/gnu-system.am
index fa04f822c1..9d7d29f7f7 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -179,6 +179,7 @@ GNU_SYSTEM_MODULES = \
gnu/packages/unrtf.scm \
gnu/packages/valgrind.scm \
gnu/packages/version-control.scm \
+ gnu/packages/video.scm \
gnu/packages/vim.scm \
gnu/packages/vpn.scm \
gnu/packages/w3m.scm \
diff --git a/gnu/packages/cmake.scm b/gnu/packages/cmake.scm
index a5c3d45193..84873f4a3b 100644
--- a/gnu/packages/cmake.scm
+++ b/gnu/packages/cmake.scm
@@ -27,7 +27,7 @@
(define-public cmake
(package
(name "cmake")
- (version "2.8.10.2")
+ (version "2.8.12")
(source (origin
(method url-fetch)
(uri (string-append
@@ -36,7 +36,7 @@
(string-index version #\. (+ 1 (string-index version #\.))))
"/cmake-" version ".tar.gz"))
(sha256
- (base32 "1c8fj6i2x9sb39wc9av2ighj415mw33cxfrlfpafcvm0knrlylnf"))
+ (base32 "11q21vyrr6c6smyjy81k2k07zmn96ggjia9im9cxwvj0n88bm1fq"))
(patches (list (search-patch "cmake-fix-tests.patch")))))
(build-system gnu-build-system)
(arguments
diff --git a/gnu/packages/gcc.scm b/gnu/packages/gcc.scm
index dde0f0d934..bbc0a134d2 100644
--- a/gnu/packages/gcc.scm
+++ b/gnu/packages/gcc.scm
@@ -27,6 +27,7 @@
#:use-module (guix packages)
#:use-module (guix download)
#:use-module (guix build-system gnu)
+ #:use-module (guix utils)
#:use-module (ice-9 regex))
(define %gcc-infrastructure
@@ -211,6 +212,35 @@ Go. It also includes standard libraries for these languages.")
(base32
"1j6dwgby4g3p3lz7zkss32ghr45zpdidrg8xvazvn91lqxv25p09"))))))
+(define (custom-gcc gcc name languages)
+ "Return a custom version of GCC that supports LANGUAGES."
+ (package (inherit gcc)
+ (name name)
+ (arguments
+ (substitute-keyword-arguments `(#:modules ((guix build gnu-build-system)
+ (guix build utils)
+ (ice-9 regex)
+ (srfi srfi-1)
+ (srfi srfi-26))
+ ,@(package-arguments gcc))
+ ((#:configure-flags flags)
+ `(cons (string-append "--enable-languages="
+ ,(string-join languages ","))
+ (remove (cut string-match "--enable-languages.*" <>)
+ ,flags)))))))
+
+(define-public gfortran-4.8
+ (custom-gcc gcc-4.8 "gfortran" '("fortran")))
+
+(define-public gccgo-4.8
+ (custom-gcc gcc-4.8 "gccgo" '("go")))
+
+(define-public gcc-objc-4.8
+ (custom-gcc gcc-4.8 "gcc-objc" '("objc")))
+
+(define-public gcc-objc++-4.8
+ (custom-gcc gcc-4.8 "gcc-objc++" '("obj-c++")))
+
(define-public isl
(package
(name "isl")
diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm
index ccbb57b90f..9b2b052a52 100644
--- a/gnu/packages/maths.scm
+++ b/gnu/packages/maths.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,13 +23,16 @@
#:renamer (symbol-prefix-proc 'license:))
#:use-module (guix packages)
#:use-module (guix download)
+ #:use-module (guix build-system cmake)
#:use-module (guix build-system gnu)
#:use-module (gnu packages compression)
#:use-module ((gnu packages gettext)
#:renamer (symbol-prefix-proc 'gnu:))
+ #:use-module (gnu packages gcc)
#:use-module (gnu packages multiprecision)
#:use-module (gnu packages perl)
#:use-module (gnu packages pkg-config)
+ #:use-module (gnu packages python)
#:use-module (gnu packages readline)
#:use-module (gnu packages xml))
@@ -153,3 +157,46 @@ interoperate with Gnumeric, LibreOffice and OpenOffice. Data can be imported
from spreadsheets, text files and database sources and it can be output in
text, Postscript, PDF or HTML.")
(license license:gpl3+)))
+
+(define-public lapack
+ (package
+ (name "lapack")
+ (version "3.4.2")
+ (source
+ (origin
+ (method url-fetch)
+ (uri (string-append "http://www.netlib.org/lapack/lapack-"
+ version ".tgz"))
+ (sha256
+ (base32
+ "1w7sf8888m7fi2kyx1fzgbm22193l8c2d53m8q1ibhvfy6m5v9k0"))
+ (snippet
+ ;; Remove non-free files.
+ ;; See <http://icl.cs.utk.edu/lapack-forum/archives/lapack/msg01383.html>.
+ '(for-each (lambda (file)
+ (format #t "removing '~a'~%" file)
+ (delete-file file))
+ '("lapacke/example/example_DGESV_rowmajor.c"
+ "lapacke/example/example_ZGESV_rowmajor.c"
+ "DOCS/psfig.tex")))))
+ (build-system cmake-build-system)
+ (home-page "http://www.netlib.org/lapack/")
+ (inputs `(("fortran" ,gfortran-4.8)
+ ("python" ,python-2)))
+ (arguments
+ `(#:modules ((guix build cmake-build-system)
+ (guix build utils)
+ (srfi srfi-1))
+ #:phases (alist-cons-before
+ 'check 'patch-python
+ (lambda* (#:key inputs #:allow-other-keys)
+ (let ((python (assoc-ref inputs "python")))
+ (substitute* "lapack_testing.py"
+ (("/usr/bin/env python") python))))
+ %standard-phases)))
+ (synopsis "Library for numerical linear algebra")
+ (description
+ "LAPACK is a Fortran 90 library for solving the most commonly occurring
+problems in numerical linear algebra.")
+ (license (license:bsd-style "file://LICENSE"
+ "See LICENSE in the distribution."))))
diff --git a/gnu/packages/recutils.scm b/gnu/packages/recutils.scm
index f9c15d332c..2a3f09b2fd 100644
--- a/gnu/packages/recutils.scm
+++ b/gnu/packages/recutils.scm
@@ -24,27 +24,31 @@
#:use-module (guix build-system gnu)
#:use-module (gnu packages emacs)
#:use-module (gnu packages check)
- #:use-module (gnu packages algebra))
+ #:use-module (gnu packages algebra)
+ #:use-module (gnu packages curl)
+ #:use-module (gnu packages gnupg))
(define-public recutils
(package
(name "recutils")
- (version "1.5")
+ (version "1.6")
(source (origin
(method url-fetch)
(uri (string-append "mirror://gnu/recutils/recutils-"
version ".tar.gz"))
(sha256
(base32
- "1v2xzwwwhc5j5kmvg4sv6baxjpsfqh8ln7ilv4mgb1408rs7xmky"))
- (patches
- (list (search-patch "diffutils-gets-undeclared.patch")))))
+ "0dxmz73n4qaasqymx97nlw6in98r6lnsfp0586hwkn95d3ll306s"))))
(build-system gnu-build-system)
- (inputs `(;; TODO: Enable optional deps when they're packaged.
- ;; ("curl" ,(nixpkgs-derivation "curl"))
- ("emacs" ,emacs)
- ("check" ,check)
- ("bc" ,bc)))
+ (native-inputs `(("emacs" ,emacs)
+ ("bc" ,bc)))
+
+ ;; TODO: Add more optional inputs.
+ ;; FIXME: Our Bash doesn't have development headers (need for the 'readrec'
+ ;; built-in command), but it's not clear how to get them installed.
+ (inputs `(("curl" ,curl)
+ ("libgcrypt" ,libgcrypt)
+ ("check" ,check)))
(synopsis "Manipulate plain text files as databases")
(description
"Recutils is a set of tools and libraries for creating and
diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm
new file mode 100644
index 0000000000..aba68dd71c
--- /dev/null
+++ b/gnu/packages/video.scm
@@ -0,0 +1,172 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
+;;;
+;;; 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 (gnu packages video)
+ #:use-module ((guix licenses) #:select (gpl2+))
+ #:use-module (guix packages)
+ #:use-module (guix download)
+ #:use-module (guix build-system gnu)
+ #:use-module (gnu packages algebra)
+ #:use-module (gnu packages compression)
+ #:use-module (gnu packages fontutils)
+ #:use-module (gnu packages oggvorbis)
+ #:use-module (gnu packages openssl)
+ #:use-module (gnu packages perl)
+ #:use-module (gnu packages pkg-config)
+ #:use-module (gnu packages python)
+ #:use-module (gnu packages yasm))
+
+(define-public ffmpeg
+ (package
+ (name "ffmpeg")
+ (version "2.1")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "http://www.ffmpeg.org/releases/ffmpeg-"
+ version ".tar.bz2"))
+ (sha256
+ (base32
+ "1pv83nmjgipxwzy5s53834fq0mrqv786zz2w383ki6sfjzyh6rlj"))))
+ (build-system gnu-build-system)
+ (inputs
+ `(("bc" ,bc)
+ ("bzip2" ,bzip2)
+ ("fontconfig" ,fontconfig)
+ ("freetype" ,freetype)
+ ("libtheora" ,libtheora)
+ ("libvorbis" ,libvorbis)
+ ("perl" ,perl)
+ ("pkg-config" ,pkg-config)
+ ("python" ,python-2) ; scripts use interpreter python2
+ ("speex" ,speex)
+ ("yasm" ,yasm)
+ ("zlib", zlib)))
+ (arguments
+ `(#:phases
+ (alist-replace
+ 'configure
+ ;; configure does not work followed by "SHELL=..." and
+ ;; "CONFIG_SHELL=..."; set environment variables instead
+ (lambda* (#:key outputs configure-flags #:allow-other-keys)
+ (let ((out (assoc-ref outputs "out")))
+ (substitute* "configure"
+ (("#! /bin/sh") (string-append "#!" (which "bash"))))
+ (setenv "SHELL" (which "bash"))
+ (setenv "CONFIG_SHELL" (which "bash"))
+;; possible additional inputs:
+;; --enable-avisynth enable reading of AviSynth script files [no]
+;; --enable-frei0r enable frei0r video filtering
+;; --enable-ladspa enable LADSPA audio filtering
+;; --enable-libaacplus enable AAC+ encoding via libaacplus [no]
+;; --enable-libass enable libass subtitles rendering [no]
+;; --enable-libbluray enable BluRay reading using libbluray [no]
+;; --enable-libcaca enable textual display using libcaca
+;; --enable-libcelt enable CELT decoding via libcelt [no]
+;; --enable-libcdio enable audio CD grabbing with libcdio
+;; --enable-libdc1394 enable IIDC-1394 grabbing using libdc1394
+;; and libraw1394 [no]
+;; --enable-libfaac enable AAC encoding via libfaac [no]
+;; --enable-libfdk-aac enable AAC de/encoding via libfdk-aac [no]
+;; --enable-libflite enable flite (voice synthesis) support via libflite [no]
+;; --enable-libgme enable Game Music Emu via libgme [no]
+;; --enable-libgsm enable GSM de/encoding via libgsm [no]
+;; --enable-libiec61883 enable iec61883 via libiec61883 [no]
+;; --enable-libilbc enable iLBC de/encoding via libilbc [no]
+;; --enable-libmodplug enable ModPlug via libmodplug [no]
+;; --enable-libmp3lame enable MP3 encoding via libmp3lame [no]
+;; --enable-libnut enable NUT (de)muxing via libnut,
+;; native (de)muxer exists [no]
+;; --enable-libopencore-amrnb enable AMR-NB de/encoding via libopencore-amrnb [no]
+;; --enable-libopencore-amrwb enable AMR-WB decoding via libopencore-amrwb [no]
+;; --enable-libopencv enable video filtering via libopencv [no]
+;; --enable-libopenjpeg enable JPEG 2000 de/encoding via OpenJPEG [no]
+;; --enable-libopus enable Opus decoding via libopus [no]
+;; --enable-libpulse enable Pulseaudio input via libpulse [no]
+;; --enable-libquvi enable quvi input via libquvi [no]
+;; --enable-librtmp enable RTMP[E] support via librtmp [no]
+;; --enable-libschroedinger enable Dirac de/encoding via libschroedinger [no]
+;; --enable-libshine enable fixed-point MP3 encoding via libshine [no]
+;; --enable-libsoxr enable Include libsoxr resampling [no]
+;; --enable-libssh enable SFTP protocol via libssh [no]
+;; (libssh2 does not work)
+;; --enable-libstagefright-h264 enable H.264 decoding via libstagefright [no]
+;; --enable-libtwolame enable MP2 encoding via libtwolame [no]
+;; --enable-libutvideo enable Ut Video encoding and decoding via libutvideo [no]
+;; --enable-libv4l2 enable libv4l2/v4l-utils [no]
+;; --enable-libvidstab enable video stabilization using vid.stab [no]
+;; --enable-libvo-aacenc enable AAC encoding via libvo-aacenc [no]
+;; --enable-libvo-amrwbenc enable AMR-WB encoding via libvo-amrwbenc [no]
+;; --enable-libvpx enable VP8 and VP9 de/encoding via libvpx [no]
+;; --enable-libwavpack enable wavpack encoding via libwavpack [no]
+;; --enable-libx264 enable H.264 encoding via x264 [no]
+;; --enable-libxavs enable AVS encoding via xavs [no]
+;; --enable-libxvid enable Xvid encoding via xvidcore,
+;; native MPEG-4/Xvid encoder exists [no]
+;; --enable-libzmq enable message passing via libzmq [no]
+;; --enable-libzvbi enable teletext support via libzvbi [no]
+;; --enable-openal enable OpenAL 1.1 capture support [no]
+;; --enable-opencl enable OpenCL code
+;; --enable-x11grab enable X11 grabbing [no]
+ (zero? (system*
+ "./configure"
+ (string-append "--prefix=" out)
+ "--enable-gpl" ; enable optional gpl licensed parts
+ "--enable-shared"
+ "--enable-fontconfig"
+ ;; "--enable-gnutls" ; causes test failures
+ "--enable-libfreetype"
+ "--enable-libspeex"
+ "--enable-libtheora"
+ "--enable-libvorbis"
+ ;; drop special machine instructions not supported
+ ;; on all instances of the target
+ ,@(if (string-prefix? "x86_64"
+ (or (%current-target-system)
+ (%current-system)))
+ '()
+ '("--disable-amd3dnow"
+ "--disable-amd3dnowext"
+ "--disable-mmx"
+ "--disable-mmxext"
+ "--disable-sse"
+ "--disable-sse2"))
+ "--disable-altivec"
+ "--disable-sse3"
+ "--disable-ssse3"
+ "--disable-sse4"
+ "--disable-sse42"
+ "--disable-avx"
+ "--disable-fma4"
+ "--disable-avx2"
+ "--disable-armv5te"
+ "--disable-armv6"
+ "--disable-armv6t2"
+ "--disable-vfp"
+ "--disable-neon"
+ "--disable-vis"
+ "--disable-mips32r2"
+ "--disable-mipsdspr1"
+ "--disable-mipsdspr2"
+ "--disable-mipsfpu"))))
+ %standard-phases)))
+ (home-page "http://www.ffmpeg.org/")
+ (synopsis "Audio and video framework")
+ (description "FFmpeg is a complete, cross-platform solution to record,
+convert and stream audio and video. It includes the libavcodec
+audio/video codec library.")
+ (license gpl2+)))
diff --git a/guix/packages.scm b/guix/packages.scm
index 157013a496..9a2f08d862 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -41,6 +41,9 @@
origin-patch-flags
origin-patch-inputs
origin-patch-guile
+ origin-snippet
+ origin-modules
+ origin-imported-modules
base32
<search-path-specification>
@@ -107,6 +110,7 @@
(sha256 origin-sha256) ; bytevector
(file-name origin-file-name (default #f)) ; optional file name
(patches origin-patches (default '())) ; list of file names
+ (snippet origin-snippet (default #f)) ; sexp or #f
(patch-flags origin-patch-flags ; list of strings
(default '("-p1")))
@@ -114,6 +118,10 @@
;; used to specify these dependencies when needed.
(patch-inputs origin-patch-inputs ; input list or #f
(default #f))
+ (modules origin-modules ; list of module names
+ (default '()))
+ (imported-modules origin-imported-modules ; list of module names
+ (default '()))
(patch-guile origin-patch-guile ; package or #f
(default #f)))
@@ -272,26 +280,38 @@ corresponds to the arguments expected by `set-path-environment-variable'."
(let ((distro (resolve-interface '(gnu packages base))))
(module-ref distro 'guile-final)))
-(define* (patch-and-repack store source patches inputs
+(define* (patch-and-repack store source patches
#:key
+ (inputs '())
+ (snippet #f)
(flags '("-p1"))
+ (modules '())
+ (imported-modules '())
(guile-for-build (%guile-for-build))
(system (%current-system)))
- "Unpack SOURCE (a derivation), apply all of PATCHES, and repack the tarball
-using the tools listed in INPUTS."
+ "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
+repack the tarball using the tools listed in INPUTS. When SNIPPET is true,
+it must be an s-expression that will run from within the directory where
+SOURCE was unpacked, after all of PATCHES have been applied. MODULES and
+IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
+ (define source-file-name
+ ;; SOURCE is usually a derivation, but it could be a store file.
+ (if (derivation? source)
+ (derivation->output-path source)
+ source))
+
(define decompression-type
- (let ((out (derivation->output-path source)))
- (cond ((string-suffix? "gz" out) "gzip")
- ((string-suffix? "bz2" out) "bzip2")
- ((string-suffix? "lz" out) "lzip")
- (else "xz"))))
+ (cond ((string-suffix? "gz" source-file-name) "gzip")
+ ((string-suffix? "bz2" source-file-name) "bzip2")
+ ((string-suffix? "lz" source-file-name) "lzip")
+ (else "xz")))
(define original-file-name
- (let ((out (derivation->output-path source)))
- ;; Remove the store prefix plus the slash, hash, and hyphen.
- (let* ((sans (string-drop out (+ (string-length (%store-prefix)) 1)))
- (dash (string-index sans #\-)))
- (string-drop sans (+ 1 dash)))))
+ ;; Remove the store prefix plus the slash, hash, and hyphen.
+ (let* ((sans (string-drop source-file-name
+ (+ (string-length (%store-prefix)) 1)))
+ (dash (string-index sans #\-)))
+ (string-drop sans (+ 1 dash))))
(define patch-inputs
(map (lambda (number patch)
@@ -331,7 +351,24 @@ using the tools listed in INPUTS."
(format (current-error-port)
"source is under '~a'~%" directory)
(chdir directory)
+
(and (every apply-patch ',(map car patch-inputs))
+
+ ,@(if snippet
+ `((let ((module (make-fresh-user-module)))
+ (module-use-interfaces! module
+ (map resolve-interface
+ ',modules))
+ (module-define! module '%build-inputs
+ %build-inputs)
+ (module-define! module '%outputs %outputs)
+ ((@ (system base compile) compile)
+ ',snippet
+ #:to 'value
+ #:opts %auto-compilation-options
+ #:env module)))
+ '())
+
(begin (chdir "..") #t)
(zero? (system* tar "cvfa" out directory))))))))
@@ -351,19 +388,21 @@ using the tools listed in INPUTS."
`(("source" ,source)
,@inputs
,@patch-inputs)
+ #:modules imported-modules
#:guile-for-build guile-for-build)))
(define* (package-source-derivation store source
#:optional (system (%current-system)))
"Return the derivation path for SOURCE, a package source, for SYSTEM."
(match source
- (($ <origin> uri method sha256 name ())
- ;; No patches.
+ (($ <origin> uri method sha256 name () #f)
+ ;; No patches, no snippet: this is a fixed-output derivation.
(method store uri 'sha256 sha256 name
#:system system))
- (($ <origin> uri method sha256 name (patches ...) (flags ...)
- inputs guile-for-build)
- ;; One or more patches.
+ (($ <origin> uri method sha256 name (patches ...) snippet
+ (flags ...) inputs (modules ...) (imported-modules ...)
+ guile-for-build)
+ ;; Patches and/or a snippet.
(let ((source (method store uri 'sha256 sha256 name
#:system system))
(guile (match (or guile-for-build (%guile-for-build)
@@ -372,9 +411,13 @@ using the tools listed in INPUTS."
(package-derivation store p system))
((? derivation? drv)
drv))))
- (patch-and-repack store source patches inputs
+ (patch-and-repack store source patches
+ #:inputs inputs
+ #:snippet snippet
#:flags flags
#:system system
+ #:modules modules
+ #:imported-modules modules
#:guile-for-build guile)))
((and (? string?) (? store-path?) file)
file)
diff --git a/guix/profiles.scm b/guix/profiles.scm
new file mode 100644
index 0000000000..1f62099e45
--- /dev/null
+++ b/guix/profiles.scm
@@ -0,0 +1,347 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix profiles)
+ #:use-module (guix utils)
+ #:use-module (guix records)
+ #:use-module (guix derivations)
+ #:use-module (guix packages)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 ftw)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:export (manifest make-manifest
+ manifest?
+ manifest-entries
+
+ <manifest-entry> ; FIXME: eventually make it internal
+ manifest-entry
+ manifest-entry?
+ manifest-entry-name
+ manifest-entry-version
+ manifest-entry-output
+ manifest-entry-path
+ manifest-entry-dependencies
+
+ manifest-pattern
+ manifest-pattern?
+
+ read-manifest
+ write-manifest
+
+ manifest-remove
+ manifest-installed?
+ manifest-matching-entries
+ manifest=?
+
+ profile-manifest
+ profile-derivation
+ generation-number
+ generation-numbers
+ previous-generation-number
+ generation-time
+ generation-file-name))
+
+;;; Commentary:
+;;;
+;;; Tools to create and manipulate profiles---i.e., the representation of a
+;;; set of installed packages.
+;;;
+;;; Code:
+
+
+;;;
+;;; Manifests.
+;;;
+
+(define-record-type <manifest>
+ (manifest entries)
+ manifest?
+ (entries manifest-entries)) ; list of <manifest-entry>
+
+;; Convenient alias, to avoid name clashes.
+(define make-manifest manifest)
+
+(define-record-type* <manifest-entry> manifest-entry
+ make-manifest-entry
+ manifest-entry?
+ (name manifest-entry-name) ; string
+ (version manifest-entry-version) ; string
+ (output manifest-entry-output ; string
+ (default "out"))
+ (path manifest-entry-path) ; store path
+ (dependencies manifest-entry-dependencies ; list of store paths
+ (default '()))
+ (inputs manifest-entry-inputs ; list of inputs to build
+ (default '()))) ; this entry
+
+(define-record-type* <manifest-pattern> manifest-pattern
+ make-manifest-pattern
+ manifest-pattern?
+ (name manifest-pattern-name) ; string
+ (version manifest-pattern-version ; string | #f
+ (default #f))
+ (output manifest-pattern-output ; string | #f
+ (default "out")))
+
+(define (profile-manifest profile)
+ "Return the PROFILE's manifest."
+ (let ((file (string-append profile "/manifest")))
+ (if (file-exists? file)
+ (call-with-input-file file read-manifest)
+ (manifest '()))))
+
+(define (manifest->sexp manifest)
+ "Return a representation of MANIFEST as an sexp."
+ (define (entry->sexp entry)
+ (match entry
+ (($ <manifest-entry> name version path output (deps ...))
+ (list name version path output deps))))
+
+ (match manifest
+ (($ <manifest> (entries ...))
+ `(manifest (version 1)
+ (packages ,(map entry->sexp entries))))))
+
+(define (sexp->manifest sexp)
+ "Parse SEXP as a manifest."
+ (match sexp
+ (('manifest ('version 0)
+ ('packages ((name version output path) ...)))
+ (manifest
+ (map (lambda (name version output path)
+ (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (path path)))
+ name version output path)))
+
+ ;; Version 1 adds a list of propagated inputs to the
+ ;; name/version/output/path tuples.
+ (('manifest ('version 1)
+ ('packages ((name version output path deps) ...)))
+ (manifest
+ (map (lambda (name version output path deps)
+ (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (path path)
+ (dependencies deps)))
+ name version output path deps)))
+
+ (_
+ (error "unsupported manifest format" manifest))))
+
+(define (read-manifest port)
+ "Return the packages listed in MANIFEST."
+ (sexp->manifest (read port)))
+
+(define (write-manifest manifest port)
+ "Write MANIFEST to PORT."
+ (write (manifest->sexp manifest) port))
+
+(define (entry-predicate pattern)
+ "Return a procedure that returns #t when passed a manifest entry that
+matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they
+are ignored."
+ (match pattern
+ (($ <manifest-pattern> name version output)
+ (match-lambda
+ (($ <manifest-entry> entry-name entry-version entry-output)
+ (and (string=? entry-name name)
+ (or (not entry-output) (not output)
+ (string=? entry-output output))
+ (or (not version)
+ (string=? entry-version version))))))))
+
+(define (manifest-remove manifest patterns)
+ "Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS
+must be a manifest-pattern."
+ (define (remove-entry pattern lst)
+ (remove (entry-predicate pattern) lst))
+
+ (make-manifest (fold remove-entry
+ (manifest-entries manifest)
+ patterns)))
+
+(define (manifest-installed? manifest pattern)
+ "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
+#f otherwise."
+ (->bool (find (entry-predicate pattern)
+ (manifest-entries manifest))))
+
+(define (manifest-matching-entries manifest patterns)
+ "Return all the entries of MANIFEST that match one of the PATTERNS."
+ (define predicates
+ (map entry-predicate patterns))
+
+ (define (matches? entry)
+ (any (lambda (pred)
+ (pred entry))
+ predicates))
+
+ (filter matches? (manifest-entries manifest)))
+
+(define (manifest=? m1 m2)
+ "Return #t if manifests M1 and M2 are equal. This differs from 'equal?' in
+that the 'inputs' field is ignored for the comparison, since it is know to
+have no effect on the manifest contents."
+ (equal? (manifest->sexp m1)
+ (manifest->sexp m2)))
+
+
+;;;
+;;; Profiles.
+;;;
+
+(define* (lower-input store input #:optional (system (%current-system)))
+ "Lower INPUT so that it contains derivations instead of packages."
+ (match input
+ ((name (? package? package))
+ `(,name ,(package-derivation store package system)))
+ ((name (? package? package) output)
+ `(,name ,(package-derivation store package system)
+ ,output))
+ (_ input)))
+
+(define (profile-derivation store manifest)
+ "Return a derivation that builds a profile (aka. 'user environment') with
+the given MANIFEST."
+ (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 profile '~a' with ~a packages...~%"
+ output (length inputs))
+ (union-build output inputs
+ #:log-port (%make-void-port "w"))
+ (call-with-output-file (string-append output "/manifest")
+ (lambda (p)
+ (pretty-print ',(manifest->sexp manifest) p))))))
+
+ (build-expression->derivation store "profile"
+ (%current-system)
+ builder
+ (append-map (match-lambda
+ (($ <manifest-entry> name version
+ output path deps (inputs ..1))
+ (map (cute lower-input store <>)
+ inputs))
+ (($ <manifest-entry> name version
+ output path deps)
+ ;; Assume PATH and DEPS are
+ ;; already valid.
+ `((,name ,path) ,@deps)))
+ (manifest-entries manifest))
+ #:modules '((guix build union))))
+
+(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 (generation-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 (generation-numbers profile)
+ "Return the sorted 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
+ (sort (map (compose string->number
+ (cut match:substring <> 1)
+ (cute regexp-exec (profile-regexp profile) <>))
+ profiles)
+ <))))
+
+(define (previous-generation-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
+ (generation-numbers profile)))
+
+(define (generation-file-name profile generation)
+ "Return the file name for PROFILE's GENERATION."
+ (format #f "~a-~a-link" profile generation))
+
+(define (generation-time profile number)
+ "Return the creation time of a generation in the UTC format."
+ (make-time time-utc 0
+ (stat:ctime (stat (generation-file-name profile number)))))
+
+;;; profiles.scm ends here
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 008ae53b47..bf39259922 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -23,22 +23,19 @@
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix packages)
+ #:use-module (guix profiles)
#:use-module (guix utils)
#:use-module (guix config)
- #:use-module (guix records)
#:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
#:use-module ((guix ftp-client) #:select (ftp-open))
- #: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-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#: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))
@@ -51,7 +48,7 @@
;;;
-;;; User profile.
+;;; Profiles.
;;;
(define %user-profile-directory
@@ -69,240 +66,6 @@
;; coexist with Nix profiles.
(string-append %profile-directory "/guix-profile"))
-
-;;;
-;;; Manifests.
-;;;
-
-(define-record-type <manifest>
- (manifest entries)
- manifest?
- (entries manifest-entries)) ; list of <manifest-entry>
-
-;; Convenient alias, to avoid name clashes.
-(define make-manifest manifest)
-
-(define-record-type* <manifest-entry> manifest-entry
- make-manifest-entry
- manifest-entry?
- (name manifest-entry-name) ; string
- (version manifest-entry-version) ; string
- (output manifest-entry-output ; string
- (default "out"))
- (path manifest-entry-path) ; store path
- (dependencies manifest-entry-dependencies ; list of store paths
- (default '()))
- (inputs manifest-entry-inputs ; list of inputs to build
- (default '()))) ; this entry
-
-(define (profile-manifest profile)
- "Return the PROFILE's manifest."
- (let ((file (string-append profile "/manifest")))
- (if (file-exists? file)
- (call-with-input-file file read-manifest)
- (manifest '()))))
-
-(define (manifest->sexp manifest)
- "Return a representation of MANIFEST as an sexp."
- (define (entry->sexp entry)
- (match entry
- (($ <manifest-entry> name version path output (deps ...))
- (list name version path output deps))))
-
- (match manifest
- (($ <manifest> (entries ...))
- `(manifest (version 1)
- (packages ,(map entry->sexp entries))))))
-
-(define (sexp->manifest sexp)
- "Parse SEXP as a manifest."
- (match sexp
- (('manifest ('version 0)
- ('packages ((name version output path) ...)))
- (manifest
- (map (lambda (name version output path)
- (manifest-entry
- (name name)
- (version version)
- (output output)
- (path path)))
- name version output path)))
-
- ;; Version 1 adds a list of propagated inputs to the
- ;; name/version/output/path tuples.
- (('manifest ('version 1)
- ('packages ((name version output path deps) ...)))
- (manifest
- (map (lambda (name version output path deps)
- (manifest-entry
- (name name)
- (version version)
- (output output)
- (path path)
- (dependencies deps)))
- name version output path deps)))
-
- (_
- (error "unsupported manifest format" manifest))))
-
-(define (read-manifest port)
- "Return the packages listed in MANIFEST."
- (sexp->manifest (read port)))
-
-(define (write-manifest manifest port)
- "Write MANIFEST to PORT."
- (write (manifest->sexp manifest) port))
-
-(define (remove-manifest-entry name lst)
- "Remove the manifest entry named NAME from LST."
- (remove (match-lambda
- (($ <manifest-entry> entry-name)
- (string=? name entry-name)))
- lst))
-
-(define (manifest-remove manifest names)
- "Remove entries for each of NAMES from MANIFEST."
- (make-manifest (fold remove-manifest-entry
- (manifest-entries manifest)
- names)))
-
-(define (manifest-installed? manifest name)
- "Return #t if MANIFEST has an entry for NAME, #f otherwise."
- (define (->bool x)
- (not (not x)))
-
- (->bool (find (match-lambda
- (($ <manifest-entry> entry-name)
- (string=? entry-name name)))
- (manifest-entries manifest))))
-
-(define (manifest=? m1 m2)
- "Return #t if manifests M1 and M2 are equal. This differs from 'equal?' in
-that the 'inputs' field is ignored for the comparison, since it is know to
-have no effect on the manifest contents."
- (equal? (manifest->sexp m1)
- (manifest->sexp m2)))
-
-
-;;;
-;;; Profiles.
-;;;
-
-(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 (generation-numbers profile)
- "Return the sorted 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
- (sort (map (compose string->number
- (cut match:substring <> 1)
- (cute regexp-exec (profile-regexp profile) <>))
- profiles)
- <))))
-
-(define (previous-generation-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
- (generation-numbers profile)))
-
-(define (profile-derivation store manifest)
- "Return a derivation that builds a profile (aka. 'user environment') with
-the given MANIFEST."
- (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 profile '~a' with ~a packages...~%"
- output (length inputs))
- (union-build output inputs
- #:log-port (%make-void-port "w"))
- (call-with-output-file (string-append output "/manifest")
- (lambda (p)
- (pretty-print ',(manifest->sexp manifest) p))))))
-
- (build-expression->derivation store "profile"
- (%current-system)
- builder
- (append-map (match-lambda
- (($ <manifest-entry> name version
- output path deps (inputs ..1))
- (map (cute lower-input
- (%store) <>)
- inputs))
- (($ <manifest-entry> name version
- output path deps)
- ;; Assume PATH and DEPS are
- ;; already valid.
- `((,name ,path) ,@deps)))
- (manifest-entries manifest))
- #:modules '((guix build union))))
-
-(define (generation-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 (generation-file-name profile generation)
- "Return the file name for PROFILE's GENERATION."
- (format #f "~a-~a-link" profile generation))
-
(define (link-to-empty-profile generation)
"Link GENERATION, a string, to the empty profile."
(let* ((drv (profile-derivation (%store) (manifest '())))
@@ -340,11 +103,6 @@ the given MANIFEST."
(else
(switch-to-previous-generation profile))))) ; anything else
-(define (generation-time profile number)
- "Return the creation time of a generation in the UTC format."
- (make-time time-utc 0
- (stat:ctime (stat (generation-file-name profile number)))))
-
(define* (matching-generations str #:optional (profile %current-profile)
#:key (duration-relation <=))
"Return the list of available generations matching a pattern in STR. See
@@ -411,6 +169,50 @@ DURATION-RELATION with the current time."
filter-by-duration)
(else #f)))
+(define (show-what-to-remove/install remove install dry-run?)
+ "Given the manifest entries listed in REMOVE and INSTALL, display the
+packages that will/would be installed and removed."
+ ;; TODO: Report upgrades more clearly.
+ (match remove
+ ((($ <manifest-entry> name version output path _) ..1)
+ (let ((len (length name))
+ (remove (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>)
+ name version output path)))
+ (if dry-run?
+ (format (current-error-port)
+ (N_ "The following package would be removed:~%~{~a~%~}~%"
+ "The following packages would be removed:~%~{~a~%~}~%"
+ len)
+ remove)
+ (format (current-error-port)
+ (N_ "The following package will be removed:~%~{~a~%~}~%"
+ "The following packages will be removed:~%~{~a~%~}~%"
+ len)
+ remove))))
+ (_ #f))
+ (match install
+ ((($ <manifest-entry> name version output path _) ..1)
+ (let ((len (length name))
+ (install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>)
+ name version output path)))
+ (if dry-run?
+ (format (current-error-port)
+ (N_ "The following package would be installed:~%~{~a~%~}~%"
+ "The following packages would be installed:~%~{~a~%~}~%"
+ len)
+ install)
+ (format (current-error-port)
+ (N_ "The following package will be installed:~%~{~a~%~}~%"
+ "The following packages will be installed:~%~{~a~%~}~%"
+ len)
+ install))))
+ (_ #f)))
+
+
+;;;
+;;; Package specifications.
+;;;
+
(define (find-packages-by-description rx)
"Return the list of packages whose name, synopsis, or description matches
RX."
@@ -437,16 +239,6 @@ RX."
(package-name p2))))
same-location?))
-(define* (lower-input store input #:optional (system (%current-system)))
- "Lower INPUT so that it contains derivations instead of packages."
- (match input
- ((name (? package? package))
- `(,name ,(package-derivation store package system)))
- ((name (? package? package) output)
- `(,name ,(package-derivation store package system)
- ,output))
- (_ input)))
-
(define (input->name+path input)
"Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
(let loop ((input input))
@@ -500,11 +292,6 @@ return its return value."
(format (current-error-port) " interrupted by signal ~a~%" SIGINT)
#f))))
-
-;;;
-;;; Package specifications.
-;;;
-
(define newest-available-packages
(memoize find-newest-available-packages))
@@ -536,13 +323,8 @@ version; if SPEC does not specify an output, return OUTPUT."
(package-full-name p)
sub-drv)))
- (let*-values (((name sub-drv)
- (match (string-rindex spec #\:)
- (#f (values spec output))
- (colon (values (substring spec 0 colon)
- (substring spec (+ 1 colon))))))
- ((name version)
- (package-name->name+version name)))
+ (let-values (((name version sub-drv)
+ (package-specification->name+version+output spec)))
(match (find-best-packages-by-name name version)
((p)
(values p (ensure-output p sub-drv)))
@@ -910,6 +692,22 @@ return the new list of manifest entries."
(append to-upgrade to-install))
+(define (options->removable options manifest)
+ "Given options, return the list of manifest patterns of packages to be
+removed from MANIFEST."
+ (filter-map (match-lambda
+ (('remove . spec)
+ (call-with-values
+ (lambda ()
+ (package-specification->name+version+output spec))
+ (lambda (name version output)
+ (manifest-pattern
+ (name name)
+ (version version)
+ (output output)))))
+ (_ #f))
+ options))
+
;;;
;;; Entry point.
@@ -989,44 +787,6 @@ more information.~%"))
(and (equal? name entry-name)
(equal? output entry-output)))))
- (define (show-what-to-remove/install remove install dry-run?)
- ;; Tell the user what's going to happen in high-level terms.
- ;; TODO: Report upgrades more clearly.
- (match remove
- ((($ <manifest-entry> name version _ path _) ..1)
- (let ((len (length name))
- (remove (map (cut format #f " ~a-~a\t~a" <> <> <>)
- name version path)))
- (if dry-run?
- (format (current-error-port)
- (N_ "The following package would be removed:~% ~{~a~%~}~%"
- "The following packages would be removed:~% ~{~a~%~}~%"
- len)
- remove)
- (format (current-error-port)
- (N_ "The following package will be removed:~% ~{~a~%~}~%"
- "The following packages will be removed:~% ~{~a~%~}~%"
- len)
- remove))))
- (_ #f))
- (match install
- ((($ <manifest-entry> name version output path _) ..1)
- (let ((len (length name))
- (install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>)
- name version output path)))
- (if dry-run?
- (format (current-error-port)
- (N_ "The following package would be installed:~%~{~a~%~}~%"
- "The following packages would be installed:~%~{~a~%~}~%"
- len)
- install)
- (format (current-error-port)
- (N_ "The following package will be installed:~%~{~a~%~}~%"
- "The following packages will be installed:~%~{~a~%~}~%"
- len)
- install))))
- (_ #f)))
-
(define current-generation-number
(generation-number profile))
@@ -1095,16 +855,10 @@ more information.~%"))
opts))
(else
(let* ((manifest (profile-manifest profile))
- (install* (options->installable opts manifest))
- (remove (filter-map (match-lambda
- (('remove . package)
- package)
- (_ #f))
- opts))
- (remove* (filter (cut manifest-installed? manifest <>)
- remove))
+ (install (options->installable opts manifest))
+ (remove (options->removable opts manifest))
(entries
- (append install*
+ (append install
(fold (lambda (package result)
(match package
(($ <manifest-entry> name _ out _ ...)
@@ -1114,7 +868,7 @@ more information.~%"))
result))))
(manifest-entries
(manifest-remove manifest remove))
- install*)))
+ install)))
(new (make-manifest entries)))
(when (equal? profile %current-profile)
@@ -1122,8 +876,9 @@ more information.~%"))
(if (manifest=? new manifest)
(format (current-error-port) (_ "nothing to be done~%"))
- (let ((prof-drv (profile-derivation (%store) new)))
- (show-what-to-remove/install remove* install* dry-run?)
+ (let ((prof-drv (profile-derivation (%store) new))
+ (remove (manifest-matching-entries manifest remove)))
+ (show-what-to-remove/install remove install dry-run?)
(show-what-to-build (%store) (list prof-drv)
#:use-substitutes?
(assoc-ref opts 'substitutes?)
diff --git a/guix/ui.scm b/guix/ui.scm
index 7f8ed970d4..8a28574c3c 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -52,6 +52,7 @@
fill-paragraph
string->recutils
package->recutils
+ package-specification->name+version+output
string->generations
string->duration
args-fold*
@@ -136,6 +137,11 @@ messages."
"Display version information for COMMAND and `(exit 0)'."
(simple-format #t "~a (~a) ~a~%"
command %guix-package-name %guix-version)
+ (display (_ "Copyright (C) 2013 the Guix authors
+License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.
+"))
(exit 0))
(define (show-bug-report-information)
@@ -358,6 +364,11 @@ converted to a space; sequences of more than one line break are preserved."
((_ _ chars)
(list->string (reverse chars)))))
+
+;;;
+;;; Packages.
+;;;
+
(define (string->recutils str)
"Return a version of STR where newlines have been replaced by newlines
followed by \"+ \", which makes for a valid multi-line field value in the
@@ -472,6 +483,31 @@ following patterns: \"1d\", \"1w\", \"1m\"."
(hours->duration (* 24 30) match)))
(else #f)))
+(define* (package-specification->name+version+output spec
+ #:optional (output "out"))
+ "Parse package specification SPEC and return three value: the specified
+package name, version number (or #f), and output name (or OUTPUT). SPEC may
+optionally contain a version number and an output name, as in these examples:
+
+ guile
+ guile-2.0.9
+ guile:debug
+ guile-2.0.9:debug
+"
+ (let*-values (((name sub-drv)
+ (match (string-rindex spec #\:)
+ (#f (values spec output))
+ (colon (values (substring spec 0 colon)
+ (substring spec (+ 1 colon))))))
+ ((name version)
+ (package-name->name+version name)))
+ (values name version sub-drv)))
+
+
+;;;
+;;; Command-line option processing.
+;;;
+
(define (args-fold* options unrecognized-option-proc operand-proc . seeds)
"A wrapper on top of `args-fold' that does proper user-facing error
reporting."
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 1b32ab5ffd..273db22765 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -125,7 +125,7 @@
#:env-vars '(("HOME" . "/homeless")
("zzz" . "Z!")
("AAA" . "A!"))
- #:inputs `((,builder))))
+ #:inputs `((,%bash) (,builder))))
(succeeded?
(build-derivations %store (list drv))))
(and succeeded?
@@ -149,7 +149,8 @@
;; builder.
#:env-vars `(("in" . ,input*))
- #:inputs `((,builder)
+ #:inputs `((,%bash)
+ (,builder)
(,input))))) ; ← local file name
(and (build-derivations %store (list drv))
;; Note: we can't compare the files because the above trick alters
@@ -211,11 +212,11 @@
(final1 (derivation %store "final"
%bash `(,builder3)
#:env-vars `(("in" . ,fixed-out))
- #:inputs `((,builder3) (,fixed1))))
+ #:inputs `((,%bash) (,builder3) (,fixed1))))
(final2 (derivation %store "final"
%bash `(,builder3)
#:env-vars `(("in" . ,fixed-out))
- #:inputs `((,builder3) (,fixed2))))
+ #:inputs `((,%bash) (,builder3) (,fixed2))))
(succeeded? (build-derivations %store
(list final1 final2))))
(and succeeded?
@@ -231,7 +232,7 @@
#:env-vars '(("HOME" . "/homeless")
("zzz" . "Z!")
("AAA" . "A!"))
- #:inputs `((,builder))
+ #:inputs `((,%bash) (,builder))
#:outputs '("out" "second")))
(succeeded? (build-derivations %store (list drv))))
(and succeeded?
@@ -251,7 +252,7 @@
'()))
(drv (derivation %store "fixed"
%bash `(,builder)
- #:inputs `((,builder))
+ #:inputs `((,%bash) (,builder))
#:outputs '("out" "AAA")))
(succeeded? (build-derivations %store (list drv))))
(and succeeded?
@@ -285,7 +286,7 @@
'()))
(mdrv (derivation %store "multiple-output"
%bash `(,builder1)
- #:inputs `((,builder1))
+ #:inputs `((,%bash) (,builder1))
#:outputs '("out" "two")))
(builder2 (add-text-to-store %store "my-mo-user-builder.sh"
"read x < $one;
@@ -300,7 +301,8 @@
("two"
. ,(derivation->output-path
mdrv "two")))
- #:inputs `((,builder2)
+ #:inputs `((,%bash)
+ (,builder2)
;; two occurrences of MDRV:
(,mdrv)
(,mdrv "two")))))
@@ -417,8 +419,8 @@
(let* ((store (let ((s (open-connection)))
(set-build-options s #:max-silent-time 1)
s))
- (builder '(sleep 100))
- (drv (build-expression->derivation %store "silent"
+ (builder '(begin (sleep 100) (mkdir %output) #t))
+ (drv (build-expression->derivation store "silent"
(%current-system)
builder '()))
(out-path (derivation->output-path drv)))
@@ -426,7 +428,8 @@
(and (string-contains (nix-protocol-error-message c)
"failed")
(not (valid-path? store out-path)))))
- (build-derivations %store (list drv)))))
+ (build-derivations store (list drv))
+ #f)))
(test-assert "build-expression->derivation and derivation-prerequisites-to-build"
(let ((drv (build-expression->derivation %store "fail" (%current-system)
diff --git a/tests/packages.scm b/tests/packages.scm
index e0cf4ee001..803cabb061 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -20,6 +20,7 @@
(define-module (test-packages)
#:use-module (guix store)
#:use-module (guix utils)
+ #:use-module (guix hash)
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix build-system)
@@ -121,6 +122,65 @@
(package-source package))))
(string=? file source)))
+(test-equal "package-source-derivation, snippet"
+ "OK"
+ (let* ((file (search-bootstrap-binary "guile-2.0.7.tar.xz"
+ (%current-system)))
+ (sha256 (call-with-input-file file port-sha256))
+ (fetch (lambda* (store url hash-algo hash
+ #:optional name #:key system)
+ (pk 'fetch url hash-algo hash name system)
+ (add-to-store store (basename url) #f "sha256" url)))
+ (source (bootstrap-origin
+ (origin
+ (method fetch)
+ (uri file)
+ (sha256 sha256)
+ (patch-inputs
+ `(("tar" ,%bootstrap-coreutils&co)
+ ("xz" ,%bootstrap-coreutils&co)
+ ("patch" ,%bootstrap-coreutils&co)))
+ (patch-guile %bootstrap-guile)
+ (modules '((guix build utils)))
+ (imported-modules modules)
+ (snippet '(begin
+ ;; We end up in 'bin', because it's the first
+ ;; directory, alphabetically. Not a very good
+ ;; example but hey.
+ (chmod "." #o777)
+ (symlink "guile" "guile-rocks")
+ (copy-recursively "../share/guile/2.0/scripts"
+ "scripts")
+
+ ;; These variables must exist.
+ (pk %build-inputs %outputs))))))
+ (package (package (inherit (dummy-package "with-snippet"))
+ (source source)
+ (build-system trivial-build-system)
+ (inputs
+ `(("tar" ,(search-bootstrap-binary "tar"
+ (%current-system)))
+ ("xz" ,(search-bootstrap-binary "xz"
+ (%current-system)))))
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder
+ (let ((tar (assoc-ref %build-inputs "tar"))
+ (xz (assoc-ref %build-inputs "xz"))
+ (source (assoc-ref %build-inputs "source")))
+ (and (zero? (system* tar "xvf" source
+ "--use-compress-program" xz))
+ (string=? "guile" (readlink "bin/guile-rocks"))
+ (file-exists? "bin/scripts/compile.scm")
+ (let ((out (assoc-ref %outputs "out")))
+ (call-with-output-file out
+ (lambda (p)
+ (display "OK" p))))))))))
+ (drv (package-derivation %store package))
+ (out (derivation->output-path drv)))
+ (and (build-derivations %store (list (pk 'snippet-drv drv)))
+ (call-with-input-file out get-string-all))))
+
(test-assert "return value"
(let ((drv (package-derivation %store (dummy-package "p"))))
(and (derivation? drv)
diff --git a/tests/profiles.scm b/tests/profiles.scm
new file mode 100644
index 0000000000..8ead6e6968
--- /dev/null
+++ b/tests/profiles.scm
@@ -0,0 +1,97 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-profiles)
+ #:use-module (guix profiles)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-64))
+
+;; Test the (guix profile) module.
+
+
+;; Example manifest entries.
+
+(define guile-2.0.9
+ (manifest-entry
+ (name "guile")
+ (version "2.0.9")
+ (path "/gnu/store/...")
+ (output "out")))
+
+(define guile-2.0.9:debug
+ (manifest-entry (inherit guile-2.0.9)
+ (output "debug")))
+
+
+(test-begin "profiles")
+
+(test-assert "manifest-installed?"
+ (let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug))))
+ (and (manifest-installed? m (manifest-pattern (name "guile")))
+ (manifest-installed? m (manifest-pattern
+ (name "guile") (output "debug")))
+ (manifest-installed? m (manifest-pattern
+ (name "guile") (output "out")
+ (version "2.0.9")))
+ (not (manifest-installed?
+ m (manifest-pattern (name "guile") (version "1.8.8"))))
+ (not (manifest-installed?
+ m (manifest-pattern (name "guile") (output "foobar")))))))
+
+(test-assert "manifest-matching-entries"
+ (let* ((e (list guile-2.0.9 guile-2.0.9:debug))
+ (m (manifest e)))
+ (and (null? (manifest-matching-entries m
+ (list (manifest-pattern
+ (name "python")))))
+ (equal? e
+ (manifest-matching-entries m
+ (list (manifest-pattern
+ (name "guile")
+ (output #f)))))
+ (equal? (list guile-2.0.9)
+ (manifest-matching-entries m
+ (list (manifest-pattern
+ (name "guile")
+ (version "2.0.9"))))))))
+
+(test-assert "manifest-remove"
+ (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
+ (m1 (manifest-remove m0
+ (list (manifest-pattern (name "guile")))))
+ (m2 (manifest-remove m1
+ (list (manifest-pattern (name "guile"))))) ; same
+ (m3 (manifest-remove m2
+ (list (manifest-pattern
+ (name "guile") (output "debug")))))
+ (m4 (manifest-remove m3
+ (list (manifest-pattern (name "guile"))))))
+ (match (manifest-entries m2)
+ ((($ <manifest-entry> "guile" "2.0.9" "debug"))
+ (and (equal? m1 m2)
+ (null? (manifest-entries m3))
+ (null? (manifest-entries m4)))))))
+
+(test-end "profiles")
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))
+
+;;; Local Variables:
+;;; eval: (put 'dummy-package 'scheme-indent-function 1)
+;;; End:
diff --git a/tests/ui.scm b/tests/ui.scm
index 3d5c3e7969..08ee3967a8 100644
--- a/tests/ui.scm
+++ b/tests/ui.scm
@@ -65,6 +65,23 @@ interface, and powerful string processing.")
10)
#\newline))
+(test-equal "package-specification->name+version+output"
+ '(("guile" #f "out")
+ ("guile" "2.0.9" "out")
+ ("guile" #f "debug")
+ ("guile" "2.0.9" "debug")
+ ("guile-cairo" "1.4.1" "out"))
+ (map (lambda (spec)
+ (call-with-values
+ (lambda ()
+ (package-specification->name+version+output spec))
+ list))
+ '("guile"
+ "guile-2.0.9"
+ "guile:debug"
+ "guile-2.0.9:debug"
+ "guile-cairo-1.4.1")))
+
(test-equal "integer"
'(1)
(string->generations "1"))