From 39efcc9b3a5deda210c0f7a0031e331ee24a4c0a Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Thu, 31 Oct 2013 23:15:46 +0100 Subject: gnu: Add ffmpeg. * gnu/packages/video.scm: New file. * gnu-system.am (GNU_SYSTEM_MODULES): Add module. --- gnu-system.am | 1 + gnu/packages/video.scm | 172 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 173 insertions(+) create mode 100644 gnu/packages/video.scm diff --git a/gnu-system.am b/gnu-system.am index 4a8414951b..3b0c2b88ea 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -178,6 +178,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/video.scm b/gnu/packages/video.scm new file mode 100644 index 0000000000..20c73d14fe --- /dev/null +++ b/gnu/packages/video.scm @@ -0,0 +1,172 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Andreas Enge +;;; +;;; 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 . + +(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-amd3now" + "--disable-amd3nowext" + "--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+))) -- cgit v1.2.3 From 798e4f42b37d90efb24ff3004189ef94d78b3a64 Mon Sep 17 00:00:00 2001 From: Andreas Enge Date: Fri, 1 Nov 2013 21:08:26 +0100 Subject: gnu: ffmpeg: Fix typo in configure flags. * gnu/packages/video.scm (ffmpeg): Add "d" in "3d" in configure flags. --- gnu/packages/video.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm index 20c73d14fe..aba68dd71c 100644 --- a/gnu/packages/video.scm +++ b/gnu/packages/video.scm @@ -139,8 +139,8 @@ (or (%current-target-system) (%current-system))) '() - '("--disable-amd3now" - "--disable-amd3nowext" + '("--disable-amd3dnow" + "--disable-amd3dnowext" "--disable-mmx" "--disable-mmxext" "--disable-sse" -- cgit v1.2.3 From fdd6c72683655acf6b6e9f195c533ee7feddfbc8 Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov Date: Fri, 1 Nov 2013 20:34:24 +0000 Subject: gnu: Add GCC front ends for Fortran, Go, Objective C, and Objective C++. * gnu/packages/gcc.scm (custom-gcc, gfortran-4.8, gccgo-4.8) (gcc-objc-4.8, gcc-objc++-4.8): New variables. --- gnu/packages/gcc.scm | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) 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") -- cgit v1.2.3 From cc4ecc2d8869081483feaf47bdcb4a740c7c67f8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Nov 2013 16:31:45 +0100 Subject: Add (guix profiles). * guix/scripts/package.scm (show-what-to-remove/install): New procedure, moved from... (guix-package): ... here. (, make-manifest, , profile-manifest, manifest->sexp, sexp->manifest, read-manifest, write-manifest, remove-manifest-entry, manifest-remove, manifest-installed?, manifest=?, profile-regexp, generation-numbers, previous-generation-number, profile-derivation, generation-number, generation-file-name, generation-time, lower-input): Move to... * guix/profiles.scm: ... here. New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/profiles.scm | 315 +++++++++++++++++++++++++++++++++++++++++++ guix/scripts/package.scm | 343 +++++++---------------------------------------- 3 files changed, 362 insertions(+), 297 deletions(-) create mode 100644 guix/profiles.scm diff --git a/Makefile.am b/Makefile.am index 7a74bc8601..1960b1b76d 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 \ diff --git a/guix/profiles.scm b/guix/profiles.scm new file mode 100644 index 0000000000..528f3c574b --- /dev/null +++ b/guix/profiles.scm @@ -0,0 +1,315 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013 Nikita Karetnikov +;;; +;;; 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 . + +(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 + + ; FIXME: eventually make it internal + manifest-entry + manifest-entry? + manifest-entry-name + manifest-entry-version + manifest-entry-output + manifest-entry-path + manifest-entry-dependencies + + read-manifest + write-manifest + + manifest-remove + manifest-installed? + 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 entries) + manifest? + (entries manifest-entries)) ; list of + +;; Convenient alias, to avoid name clashes. +(define make-manifest manifest) + +(define-record-type* 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 + (($ name version path output (deps ...)) + (list name version path output deps)))) + + (match 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 + (($ 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 + (($ 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* (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 + (($ name version + output path deps (inputs ..1)) + (map (cute lower-input store <>) + inputs)) + (($ 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 (file-system-fold enter? leaf down up skip error #f name lstat) + (lambda (files) + (sort files entry)) + (#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..4dbe2b7b63 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 entries) - manifest? - (entries manifest-entries)) ; list of - -;; Convenient alias, to avoid name clashes. -(define make-manifest manifest) - -(define-record-type* 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 - (($ name version path output (deps ...)) - (list name version path output deps)))) - - (match 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 - (($ 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 - (($ 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 (file-system-fold enter? leaf down up skip error #f name lstat) - (lambda (files) - (sort files entry)) - (#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 - (($ name version - output path deps (inputs ..1)) - (map (cute lower-input - (%store) <>) - inputs)) - (($ 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 + ((($ 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 + ((($ 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)) @@ -989,44 +776,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 - ((($ 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 - ((($ 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)) -- cgit v1.2.3 From 2876b9892583bc1245d77fd10286025cd8433ede Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Nov 2013 16:57:48 +0100 Subject: ui: Factorize package specification parsing. * guix/ui.scm (package-specification->name+version+output): New procedure. * guix/scripts/package.scm (specification->package+output): Use it. * tests/ui.scm ("package-specification->name+version+output"): New test. --- guix/scripts/package.scm | 9 ++------- guix/ui.scm | 31 +++++++++++++++++++++++++++++++ tests/ui.scm | 17 +++++++++++++++++ 3 files changed, 50 insertions(+), 7 deletions(-) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4dbe2b7b63..941b2cdca7 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -323,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))) diff --git a/guix/ui.scm b/guix/ui.scm index 7f8ed970d4..ddc93f9db4 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* @@ -358,6 +359,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 +478,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/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")) -- cgit v1.2.3 From 537630c5a743251024b6bbd8b4eecf8811439cc6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Nov 2013 17:12:15 +0100 Subject: guix package: Separate '--remove' option processing. * guix/scripts/package.scm (options->removable): New procedure. (guix-package)[process-actions]: Use it. Rename 'remove*' to 'remove' and 'install*' to 'install'. --- guix/scripts/package.scm | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 941b2cdca7..e0c7b6ed15 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -692,6 +692,17 @@ return the new list of manifest entries." (append to-upgrade to-install)) +(define (options->removable options manifest) + "Given options, return the list of manifest entries to be removed from +MANIFEST." + (let ((remove (filter-map (match-lambda + (('remove . package) + package) + (_ #f)) + options))) + (filter (cut manifest-installed? manifest <>) + remove))) + ;;; ;;; Entry point. @@ -839,16 +850,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 (($ name _ out _ ...) @@ -858,7 +863,7 @@ more information.~%")) result)))) (manifest-entries (manifest-remove manifest remove)) - install*))) + install))) (new (make-manifest entries))) (when (equal? profile %current-profile) @@ -867,7 +872,7 @@ 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?) + (show-what-to-remove/install remove install dry-run?) (show-what-to-build (%store) (list prof-drv) #:use-substitutes? (assoc-ref opts 'substitutes?) -- cgit v1.2.3 From a20787706c246a9451b69db075a30ee91d28538b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Nov 2013 23:11:17 +0100 Subject: guix package: Allow removal of a specific package output. Fixes . * guix/profiles.scm (): New record type. (remove-manifest-entry): Remove. (entry-predicate, manifest-matching-entries): New procedures. (manifest-remove): Accept a list of . (manifest-installed?): Replace 'name' parameter by 'pattern', a . * guix/scripts/package.scm (options->removable): Return a list of . (guix-package)[process-action]: Use 'manifest-matching-entries' to compute the list of packages to remove. * tests/profiles.scm: New file. * Makefile.am (SCM_TESTS): Add it. --- .dir-locals.el | 2 + Makefile.am | 3 +- guix/profiles.scm | 70 ++++++++++++++++++++++++---------- guix/scripts/package.scm | 26 ++++++++----- tests/profiles.scm | 97 ++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 168 insertions(+), 30 deletions(-) create mode 100644 tests/profiles.scm diff --git a/.dir-locals.el b/.dir-locals.el index dc1a3d724d..240fae1c12 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -14,6 +14,8 @@ (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 '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 1960b1b76d..9462878d1c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -115,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/guix/profiles.scm b/guix/profiles.scm index 528f3c574b..1f62099e45 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -42,11 +42,15 @@ manifest-entry-path manifest-entry-dependencies + manifest-pattern + manifest-pattern? + read-manifest write-manifest manifest-remove manifest-installed? + manifest-matching-entries manifest=? profile-manifest @@ -90,6 +94,15 @@ (inputs manifest-entry-inputs ; list of inputs to build (default '()))) ; this entry +(define-record-type* 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"))) @@ -148,29 +161,48 @@ "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 - (($ 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 +(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 + (($ name version output) + (match-lambda + (($ 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) - names))) - -(define (manifest-installed? manifest name) - "Return #t if MANIFEST has an entry for NAME, #f otherwise." - (define (->bool x) - (not (not x))) + patterns))) - (->bool (find (match-lambda - (($ entry-name) - (string=? entry-name name))) +(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 diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index e0c7b6ed15..77406c7f39 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -693,15 +693,20 @@ return the new list of manifest entries." (append to-upgrade to-install)) (define (options->removable options manifest) - "Given options, return the list of manifest entries to be removed from -MANIFEST." - (let ((remove (filter-map (match-lambda - (('remove . package) - package) - (_ #f)) - options))) - (filter (cut manifest-installed? manifest <>) - remove))) + "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)) ;;; @@ -871,7 +876,8 @@ more information.~%")) (if (manifest=? new manifest) (format (current-error-port) (_ "nothing to be done~%")) - (let ((prof-drv (profile-derivation (%store) new))) + (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? 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 +;;; +;;; 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 . + +(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) + ((($ "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: -- cgit v1.2.3 From 1b5ba6b1e9c1e2b6e9bf4bc664c2270272103cb7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Nov 2013 23:12:36 +0100 Subject: guix package: Fix indentation of "will be removed" messages. * guix/scripts/package.scm (show-what-to-remove/install): Remove extra indentation from the removal sentences. --- guix/scripts/package.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 77406c7f39..7189256e0f 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -180,13 +180,13 @@ packages that will/would be installed and removed." 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~%~}~%" + (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~%~}~%" + (N_ "The following package will be removed:~%~{~a~%~}~%" + "The following packages will be removed:~%~{~a~%~}~%" len) remove)))) (_ #f)) -- cgit v1.2.3 From 45b418d6342006779c599ad5ff7414fedad5de62 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Nov 2013 23:59:25 +0100 Subject: guix package: Show the output name of what's being removed. * guix/scripts/package.scm (show-what-to-remove/install): Show the output name of packages being removed. --- guix/scripts/package.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 7189256e0f..bf39259922 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -174,10 +174,10 @@ DURATION-RELATION with the current time." packages that will/would be installed and removed." ;; TODO: Report upgrades more clearly. (match remove - ((($ name version _ path _) ..1) + ((($ name version output path _) ..1) (let ((len (length name)) - (remove (map (cut format #f " ~a-~a\t~a" <> <> <>) - name version path))) + (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~%~}~%" -- cgit v1.2.3 From 13ed095c50e248d265ffec6c98559abf3f023be8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 2 Nov 2013 00:01:35 +0100 Subject: doc: Document the syntax of the '--remove' argument. * doc/guix.texi (Invoking guix package): Document the syntax of '--remove' patterns. --- doc/guix.texi | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index 054d0af467..79aa71a993 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -540,6 +540,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 -- cgit v1.2.3 From a18e58336c4421ecb9da92e386250bfece06192d Mon Sep 17 00:00:00 2001 From: Cyril Roelandt Date: Sat, 2 Nov 2013 22:17:08 +0100 Subject: gnu: cmake: Bump to 2.8.12 * gnu/packages/cmake.scm: bump to 2.8.12 --- gnu/packages/cmake.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 -- cgit v1.2.3 From 64a967cc9c4563f8ebb8dbc34e9026f8e5e2d883 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Nov 2013 23:09:30 +0100 Subject: ui: Make '--version' output GCS-compliant. * guix/ui.scm (show-version-and-exit): Display copyright year, license, and LACK OF WARRANTY. --- guix/ui.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/guix/ui.scm b/guix/ui.scm index ddc93f9db4..8a28574c3c 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -137,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 +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) -- cgit v1.2.3 From b8c35278285cd987732236c22cf8cdba7deae105 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Nov 2013 23:24:16 +0100 Subject: gnu: recutils: Upgrade to 1.6. * gnu/packages/recutils.scm (recutils): Upgrade to 1.6. Add cURL and libgcrypt as inputs. --- gnu/packages/recutils.scm | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) 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 -- cgit v1.2.3 From bde2d9cf8d4cbb2fdd12fc6cafc96f20d56d73a3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Nov 2013 23:06:13 +0100 Subject: tests: Add the builder as an input to raw derivations. * tests/derivations.scm ("build derivation with 1 source", "derivation with local file as input", "derivation with a fixed-output input", "multiple-output derivation", "multiple-output derivation, non-alphabetic order", "user of multiple-output derivation"): Add %BASH as an input, needed in chroot builds. --- tests/derivations.scm | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/tests/derivations.scm b/tests/derivations.scm index 1b32ab5ffd..5f1ca56b50 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"))))) -- cgit v1.2.3 From 01e82af55fa9823be36e2bd94868bb7b32f0fd73 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Nov 2013 23:41:33 +0100 Subject: tests: Fix max-silent-time test. * tests/derivations.scm ("build-expression->derivation and max-silent-time"): Use STORE instead of %STORE. Change BUILDER to succeed by default. Return #f when no exception is raised. --- tests/derivations.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/tests/derivations.scm b/tests/derivations.scm index 5f1ca56b50..273db22765 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -419,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))) @@ -428,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) -- cgit v1.2.3 From 35ef3633001b05c25324c6e5a69d635ddc62cb6d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Nov 2013 00:18:20 +0100 Subject: Add indentation rule for 'origin'. --- .dir-locals.el | 1 + 1 file changed, 1 insertion(+) diff --git a/.dir-locals.el b/.dir-locals.el index 240fae1c12..bb4e964dd5 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -14,6 +14,7 @@ (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)) -- cgit v1.2.3 From da95c8170aaa24a91cf0db35ff4db7ac7c2136f6 Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov Date: Mon, 4 Nov 2013 18:58:54 +0000 Subject: gnu: Add LAPACK. * gnu/packages/maths.scm (lapack): New variable. --- gnu/packages/maths.scm | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index ccbb57b90f..27d83f0f6f 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 +;;; Copyright © 2013 Nikita Karetnikov ;;; ;;; 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,48 @@ 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")))) + (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 + ;; See . + 'configure 'remove-non-free-files + (lambda _ + (for-each (lambda (file) + (begin + (format #t "removing '~a'~%" file) + (delete-file file))) + '("lapacke/example/example_DGESV_rowmajor.c" + "lapacke/example/example_ZGESV_rowmajor.c" + "DOCS/psfig.tex"))) + (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.")))) -- cgit v1.2.3 From b5385b528cd4b2674e0c656ea99d7ecd81ffe41d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Nov 2013 21:57:53 +0100 Subject: doc: Improve documentation of '--no-substitutes'. Suggested by Mark H. Weaver . * doc/guix.texi (Invoking guix package): Spell out the --no-substitutes documentation. (Invoking guix build): Use the more complete --no-substitutes documentation. (Invoking guix-daemon): Explain the interaction with what clients ask for. --- doc/guix.texi | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 79aa71a993..64b18b4416 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. @@ -598,7 +607,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 @@ -1495,7 +1507,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 -- cgit v1.2.3 From 18f2887bffeda697bf5ba227c75e303aad04898a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Nov 2013 22:18:24 +0100 Subject: doc: Document current security issue with substitutes. Suggested by Mark H. Weaver . * doc/guix.texi (Features): Add note about unauthenticated binaries. --- doc/guix.texi | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 64b18b4416..43e7935b4c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -455,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} -- cgit v1.2.3 From f9cc897105850dbbf5e12df63e800cb28b0f293f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Nov 2013 22:41:21 +0100 Subject: packages: Add a 'snippet' field to . * guix/packages.scm (): Add 'snippet', 'modules', and 'imported-modules' fields. (patch-and-repack): Make 'inputs' a keyword parameter. Add 'snippet', 'modules', and 'imported-modules' parameters. Accept SOURCE as a raw file name. Insert SNIPPET in BUILDER. Pass IMPORTED-MODULES to 'build-expression->derivation'. (package-source-derivation): Pass the extra arguments to 'patch-and-repack'. * tests/packages.scm ("package-source-derivation, snippet"): New test. * doc/guix.texi (Defining Packages): Mention the 'patches' and 'snippet' fields. (Invoking guix build): Tell that --source has patches and snippets applied. (Software Freedom): Mention packages that contain non-free code. --- doc/guix.texi | 17 ++++++++++++ guix/packages.scm | 81 +++++++++++++++++++++++++++++++++++++++++------------- tests/packages.scm | 61 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 140 insertions(+), 19 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 43e7935b4c..4fb14063d0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -985,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 @@ -1479,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 @@ -1878,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/guix/packages.scm b/guix/packages.scm index 44f683f776..d4a295e3ac 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 @@ -107,10 +110,15 @@ (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"))) (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 ; derivation or #f (default #f))) @@ -270,26 +278,38 @@ corresponds to the arguments expected by `set-path-environment-variable'." (guile (module-ref distro 'guile-final))) (package-derivation store guile system))) -(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) @@ -329,7 +349,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)))))))) @@ -349,24 +386,30 @@ 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 - (($ uri method sha256 name ()) - ;; No patches. + (($ uri method sha256 name () #f) + ;; No patches, no snippet: this is a fixed-output derivation. (method store uri 'sha256 sha256 name #:system system)) - (($ uri method sha256 name (patches ...) (flags ...) - inputs guile-for-build) - ;; One or more patches. + (($ 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))) - (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 (or guile-for-build (%guile-for-build) (default-guile store system))))) diff --git a/tests/packages.scm b/tests/packages.scm index e0cf4ee001..7c5dd9f4e1 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,66 @@ (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 (package-derivation %store + %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) -- cgit v1.2.3 From 6a9957545ce51e7a50381059d4509d0dfcba0aba Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 7 Nov 2013 23:07:45 +0100 Subject: gnu: lapack: Use origin snippet to remove the non-free files. * gnu/packages/maths.scm (lapack): Add 'snippet' field with contents of former 'remove-non-free-files' phase; remove that phase. --- gnu/packages/maths.scm | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 27d83f0f6f..9b2b052a52 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -169,7 +169,16 @@ text, Postscript, PDF or HTML.") version ".tgz")) (sha256 (base32 - "1w7sf8888m7fi2kyx1fzgbm22193l8c2d53m8q1ibhvfy6m5v9k0")))) + "1w7sf8888m7fi2kyx1fzgbm22193l8c2d53m8q1ibhvfy6m5v9k0")) + (snippet + ;; Remove non-free files. + ;; See . + '(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) @@ -179,23 +188,12 @@ text, Postscript, PDF or HTML.") (guix build utils) (srfi srfi-1)) #:phases (alist-cons-before - ;; See . - 'configure 'remove-non-free-files - (lambda _ - (for-each (lambda (file) - (begin - (format #t "removing '~a'~%" file) - (delete-file file))) - '("lapacke/example/example_DGESV_rowmajor.c" - "lapacke/example/example_ZGESV_rowmajor.c" - "DOCS/psfig.tex"))) - (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)))) + '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 -- cgit v1.2.3