summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-01-13 17:50:17 +0100
committerLudovic Courtès <ludo@gnu.org>2016-01-13 18:18:48 +0100
commit8c986ab12034d67db836a881f57c69754d8073ae (patch)
treebf5183011119695ac549d4cfff4dc2175e659397 /guix
parent203795aceaabec0e0e5818e1650ad407d825d1b3 (diff)
parent7a2eed3aac1ecd0bdf293e33a234fad58f2e5f9e (diff)
downloadguix-patches-8c986ab12034d67db836a881f57c69754d8073ae.tar
guix-patches-8c986ab12034d67db836a881f57c69754d8073ae.tar.gz
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/gnu.scm16
-rw-r--r--guix/build-system/python.scm9
-rw-r--r--guix/build/git.scm43
-rw-r--r--guix/build/pull.scm149
-rw-r--r--guix/build/ruby-build-system.scm19
-rw-r--r--guix/http-client.scm26
-rw-r--r--guix/import/cran.scm46
-rw-r--r--guix/monad-repl.scm22
-rw-r--r--guix/scripts/lint.scm13
-rw-r--r--guix/scripts/package.scm33
-rw-r--r--guix/ui.scm4
-rw-r--r--guix/utils.scm42
12 files changed, 239 insertions, 183 deletions
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index c77348bd88..afd57668e2 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -96,10 +96,11 @@ builder, or the distro's final Guile when GUILE is #f."
(package (inherit p)
(location (if (pair? loc) (source-properties->location loc) loc))
(arguments
- (let ((args (package-arguments p)))
- `(#:guile ,guile
- #:implicit-inputs? #f
- ,@args)))
+ ;; 'ensure-keyword-arguments' guarantees that this procedure is
+ ;; idempotent.
+ (ensure-keyword-arguments (package-arguments p)
+ `(#:guile ,guile
+ #:implicit-inputs? #f)))
(replacement
(let ((replacement (package-replacement p)))
(and replacement
@@ -177,9 +178,10 @@ use `--strip-all' as the arguments to `strip'."
flags)))))
(replacement (and=> (package-replacement p) static-package))))
-(define* (dist-package p source)
+(define* (dist-package p source #:key (phases '%dist-phases))
"Return a package that runs takes source files from the SOURCE directory,
-runs `make distcheck' and whose result is one or more source tarballs."
+runs `make distcheck' and whose result is one or more source tarballs. The
+exact build phases are defined by PHASES."
(let ((s source))
(package (inherit p)
(name (string-append (package-name p) "-dist"))
@@ -198,7 +200,7 @@ runs `make distcheck' and whose result is one or more source tarballs."
`((guix build gnu-dist)
,@modules))
((#:phases _)
- '%dist-phases))))
+ phases))))
(native-inputs
;; Add autotools & co. as inputs.
(let ((ref (lambda (module var)
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index 2532210a49..86efc1a715 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
@@ -41,12 +41,13 @@
;;
;; Code:
-(define (pypi-uri name version)
+(define* (pypi-uri name version #:optional (extension ".tar.gz"))
"Return a URI string for the Python package hosted on the Python Package
-Index (PyPI) corresponding to NAME and VERSION."
+Index (PyPI) corresponding to NAME and VERSION. EXTENSION is the file name
+extension, such as '.tar.gz'."
(string-append "https://pypi.python.org/packages/source/"
(string-take name 1) "/" name "/"
- name "-" version ".tar.gz"))
+ name "-" version extension))
(define %python-build-system-modules
;; Build-side modules imported by default.
diff --git a/guix/build/git.scm b/guix/build/git.scm
index 121f07a7fa..c1af545a76 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -37,23 +37,28 @@ recursively. Return #t on success, #f otherwise."
;; in advance anyway.
(setenv "GIT_SSL_NO_VERIFY" "true")
- (let ((args `("clone" ,@(if recursive? '("--recursive") '())
- ,url ,directory)))
- (and (zero? (apply system* git-command args))
- (with-directory-excursion directory
- (system* git-command "tag" "-l")
- (and (zero? (system* git-command "checkout" commit))
- (begin
- ;; The contents of '.git' vary as a function of the current
- ;; status of the Git repo. Since we want a fixed output, this
- ;; directory needs to be taken out.
- (delete-file-recursively ".git")
-
- (when recursive?
- ;; In sub-modules, '.git' is a flat file, not a directory,
- ;; so we can use 'find-files' here.
- (for-each delete-file-recursively
- (find-files directory "^\\.git$")))
- #t))))))
+ ;; We cannot use "git clone --recursive" since the following "git checkout"
+ ;; effectively removes sub-module checkouts as of Git 2.6.3.
+ (and (zero? (system* git-command "clone" url directory))
+ (with-directory-excursion directory
+ (system* git-command "tag" "-l")
+ (and (zero? (system* git-command "checkout" commit))
+ (begin
+ (when recursive?
+ ;; Now is the time to fetch sub-modules.
+ (unless (zero? (system* git-command "submodule" "update"
+ "--init" "--recursive"))
+ (error "failed to fetch sub-modules" url))
+
+ ;; In sub-modules, '.git' is a flat file, not a directory,
+ ;; so we can use 'find-files' here.
+ (for-each delete-file-recursively
+ (find-files directory "^\\.git$")))
+
+ ;; The contents of '.git' vary as a function of the current
+ ;; status of the Git repo. Since we want a fixed output, this
+ ;; directory needs to be taken out.
+ (delete-file-recursively ".git")
+ #t)))))
;;; git.scm ends here
diff --git a/guix/build/pull.scm b/guix/build/pull.scm
index 281be23aa8..4ddb12ac04 100644
--- a/guix/build/pull.scm
+++ b/guix/build/pull.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,6 +23,7 @@
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
+ #:use-module (ice-9 threads)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
@@ -33,75 +35,10 @@
;;;
;;; Code:
-(define (call-with-process thunk)
- "Run THUNK in a separate process that will return 0 if THUNK terminates
-normally, and 1 if an exception is raised."
- (match (primitive-fork)
- (0
- (catch #t
- (lambda ()
- (thunk)
- (primitive-exit 0))
- (lambda (key . args)
- (print-exception (current-error-port) #f key args)
- (primitive-exit 1))))
- (pid
- #t)))
-
-(define* (report-build-progress total completed cont
- #:optional (log-port (current-error-port)))
- "Report that COMPLETED out of TOTAL files have been completed, and call
-CONT."
- (display #\cr log-port)
- (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
- (* 100. (/ completed total)) total)
- (force-output log-port)
- (cont))
-
-(define* (p-for-each proc lst
- #:optional (max-processes (current-processor-count))
- #:key (progress report-build-progress))
- "Invoke PROC for each element of LST in a separate process, using up to
-MAX-PROCESSES processes in parallel. Call PROGRESS at each step, passing it
-the continuation. Raise an error if one of the processes exit with non-zero."
- (define total
- (length lst))
-
- (define (wait-for-one-process)
- (match (waitpid WAIT_ANY)
- ((_ . status)
- (unless (zero? (status:exit-val status))
- (error "process failed" proc status)))))
-
- (let loop ((lst lst)
- (running 0)
- (completed 0))
- (match lst
- (()
- (or (zero? running)
- (let ((running (- running 1))
- (completed (+ completed 1)))
- (wait-for-one-process)
- (progress total completed
- (lambda ()
- (loop lst running completed))))))
- ((head . tail)
- (if (< running max-processes)
- (let ((running (+ 1 running)))
- (call-with-process (cut proc head))
- (progress total completed
- (lambda ()
- (loop tail running completed))))
- (let ((running (- running 1))
- (completed (+ completed 1)))
- (wait-for-one-process)
- (progress total completed
- (lambda ()
- (loop lst running completed)))))))))
-
(define* (build-guix out source
#:key gcrypt
- (debug-port (%make-void-port "w")))
+ (debug-port (%make-void-port "w"))
+ (log-port (current-error-port)))
"Build and install Guix in directory OUT using SOURCE, a directory
containing the source code. Write any debugging output to DEBUG-PORT."
(setvbuf (current-output-port) _IOLBF)
@@ -130,33 +67,57 @@ containing the source code. Write any debugging output to DEBUG-PORT."
(set! %load-path (cons out %load-path))
(set! %load-compiled-path (cons out %load-compiled-path))
- ;; Compile the .scm files. Do that in independent processes, à la
- ;; 'make -j', to work around <http://bugs.gnu.org/15602> (FIXME).
- ;; This ensures correctness, but is overly conservative and slow.
- ;; The solution initially implemented (and described in the bug
- ;; above) was slightly faster but consumed memory proportional to the
- ;; number of modules, which quickly became unacceptable.
- (p-for-each (lambda (file)
- (let ((go (string-append (string-drop-right file 4)
- ".go")))
- (format debug-port "~%compiling '~a'...~%" file)
- (parameterize ((current-warning-port debug-port))
- (compile-file file
- #:output-file go
- #:opts
- %auto-compilation-options))))
-
- (filter (cut string-suffix? ".scm" <>)
-
- ;; Build guix/*.scm before gnu/*.scm to speed
- ;; things up.
- (sort (find-files out "\\.scm")
- (let ((guix (string-append out "/guix"))
- (gnu (string-append out "/gnu")))
- (lambda (a b)
- (or (and (string-prefix? guix a)
- (string-prefix? gnu b))
- (string<? a b))))))))
+ ;; Compile the .scm files. Load all the files before compiling them to
+ ;; work around <http://bugs.gnu.org/15602> (FIXME).
+ (let* ((files
+ ;; Load guix/ modules before gnu/ modules to get somewhat steadier
+ ;; progress reporting.
+ (sort (filter (cut string-suffix? ".scm" <>)
+ (find-files out "\\.scm"))
+ (let ((guix (string-append out "/guix"))
+ (gnu (string-append out "/gnu")))
+ (lambda (a b)
+ (or (and (string-prefix? guix a)
+ (string-prefix? gnu b))
+ (string<? a b))))))
+ (total (length files)))
+ (let loop ((files files)
+ (completed 0))
+ (match files
+ (() *unspecified*)
+ ((file . files)
+ (display #\cr log-port)
+ (format log-port "loading...\t~5,1f% of ~d files" ;FIXME: i18n
+ (* 100. (/ completed total)) total)
+ (force-output log-port)
+ (format debug-port "~%loading '~a'...~%" file)
+ ;; Turn "<out>/foo/bar.scm" into (foo bar).
+ (let* ((relative-file (string-drop file (+ (string-length out) 1)))
+ (module-path (string-drop-right relative-file 4))
+ (module-name (map string->symbol
+ (string-split module-path #\/))))
+ (parameterize ((current-warning-port debug-port))
+ (resolve-interface module-name)))
+ (loop files (+ 1 completed)))))
+ (newline)
+ (let ((mutex (make-mutex))
+ (completed 0))
+ (par-for-each
+ (lambda (file)
+ (with-mutex mutex
+ (display #\cr log-port)
+ (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
+ (* 100. (/ completed total)) total)
+ (force-output log-port)
+ (format debug-port "~%compiling '~a'...~%" file))
+ (let ((go (string-append (string-drop-right file 4) ".go")))
+ (parameterize ((current-warning-port (%make-void-port "w")))
+ (compile-file file
+ #:output-file go
+ #:opts %auto-compilation-options)))
+ (with-mutex mutex
+ (set! completed (+ 1 completed))))
+ files))))
;; Remove the "fake" (guix config).
(delete-file (string-append out "/guix/config.scm"))
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm
index 18da43866d..a4ac3b307c 100644
--- a/guix/build/ruby-build-system.scm
+++ b/guix/build/ruby-build-system.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2015 Pjotr Prins <pjotr.public01@thebird.nl>
+;;; Copyright © 2015 Ben Woodcroft <donttrustben@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -116,15 +117,19 @@ GEM-FLAGS are passed to the 'gem' invokation, if present."
(assoc-ref inputs "ruby"))
1))
(out (assoc-ref outputs "out"))
- (gem-home (string-append out "/lib/ruby/gems/" ruby-version ".0")))
-
+ (gem-home (string-append out "/lib/ruby/gems/" ruby-version ".0"))
+ (gem-name (first-matching-file "\\.gem$")))
(setenv "GEM_HOME" gem-home)
(mkdir-p gem-home)
- (zero? (apply system* "gem" "install" (first-matching-file "\\.gem$")
- "--local" "--ignore-dependencies"
- ;; Executables should go into /bin, not /lib/ruby/gems.
- "--bindir" (string-append out "/bin")
- gem-flags))))
+ (and (apply system* "gem" "install" gem-name
+ "--local" "--ignore-dependencies"
+ ;; Executables should go into /bin, not /lib/ruby/gems.
+ "--bindir" (string-append out "/bin")
+ gem-flags)
+ ;; Remove the cached gem file as this is unnecessary and contains
+ ;; timestamped files rendering builds not reproducible.
+ (begin (delete-file (string-append gem-home "/cache/" gem-name))
+ #t))))
(define %standard-phases
(modify-phases gnu:%standard-phases
diff --git a/guix/http-client.scm b/guix/http-client.scm
index c7cbc82aac..31b511eb1c 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
;;;
@@ -188,13 +188,33 @@ closes PORT, unless KEEP-ALIVE? is true."
(make-custom-binary-input-port "delimited input port" read! #f #f close))
+ (define (read-header-line port)
+ "Read an HTTP header line and return it without its final CRLF or LF.
+Raise a 'bad-header' exception if the line does not end in CRLF or LF,
+or if EOF is reached."
+ (match (%read-line port)
+ (((? string? line) . #\newline)
+ ;; '%read-line' does not consider #\return a delimiter; so if it's
+ ;; there, remove it. We are more tolerant than the RFC in that we
+ ;; tolerate LF-only endings.
+ (if (string-suffix? "\r" line)
+ (string-drop-right line 1)
+ line))
+ ((line . _) ;EOF or missing delimiter
+ ((@@ (web http) bad-header) 'read-header-line line))))
+
(unless (guile-version>? "2.0.11")
;; Guile <= 2.0.9 had a bug whereby 'response-body-port' would read more
;; than what 'content-length' says. See Guile commit 802a25b.
- ;; Guile <= 2.0.12 had a bug whereby the 'close' method of the response
+ ;; Guile <= 2.0.11 had a bug whereby the 'close' method of the response
;; body port would fail with wrong-arg-num. See Guile commit 5a10e41.
(module-set! (resolve-module '(web response))
- 'make-delimited-input-port make-delimited-input-port)))
+ 'make-delimited-input-port make-delimited-input-port)
+
+ ;; Guile <= 2.0.11 was affected by <http://bugs.gnu.org/22273>. See Guile
+ ;; commit 4c7732c.
+ (when (module-variable %web-http 'read-line*)
+ (module-set! %web-http 'read-line* read-header-line))))
;; XXX: Work around <http://bugs.gnu.org/13095>, present in Guile
;; up to 2.0.7.
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 45c679cbe2..fc2709020a 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -109,11 +109,11 @@ package definition."
(define %cran-url "http://cran.r-project.org/web/packages/")
-(define (cran-fetch name)
+(define (fetch-description base-url name)
"Return an alist of the contents of the DESCRIPTION file for the R package
NAME, or #f on failure. NAME is case-sensitive."
;; This API always returns the latest release of the module.
- (let ((url (string-append %cran-url name "/DESCRIPTION")))
+ (let ((url (string-append base-url name "/DESCRIPTION")))
(description->alist (read-string (http-fetch url)))))
(define (listify meta field)
@@ -196,7 +196,7 @@ which was derived from the R package's DESCRIPTION file."
(define (cran->guix-package package-name)
"Fetch the metadata for PACKAGE-NAME from cran.r-project.org, and return the
`package' s-expression corresponding to that package, or #f on failure."
- (let ((module-meta (cran-fetch package-name)))
+ (let ((module-meta (fetch-description %cran-url package-name)))
(and=> module-meta description->package)))
@@ -204,27 +204,33 @@ which was derived from the R package's DESCRIPTION file."
;;; Updater.
;;;
+(define (package->upstream-name package)
+ "Return the upstream name of the PACKAGE."
+ (let* ((properties (package-properties package))
+ (upstream-name (and=> properties
+ (cut assoc-ref <> 'upstream-name))))
+ (if upstream-name
+ upstream-name
+ (match (package-source package)
+ ((? origin? origin)
+ (match (origin-uri origin)
+ ((url rest ...)
+ (let ((end (string-rindex url #\_))
+ (start (string-rindex url #\/)))
+ ;; The URL ends on
+ ;; (string-append "/" name "_" version ".tar.gz")
+ (substring url start end)))
+ (_ #f)))
+ (_ #f)))))
+
(define (latest-release package)
"Return an <upstream-source> for the latest release of PACKAGE."
- (define (package->cran-name package)
- (match (package-source package)
- ((? origin? origin)
- (match (origin-uri origin)
- ((url rest ...)
- (let ((end (string-rindex url #\_))
- (start (string-rindex url #\/)))
- ;; The URL ends on
- ;; (string-append "/" name "_" version ".tar.gz")
- (substring url start end)))
- (_ #f)))
- (_ #f)))
-
- (define cran-name
- (package->cran-name (specification->package package)))
+ (define upstream-name
+ (package->upstream-name (specification->package package)))
(define meta
- (cran-fetch cran-name))
+ (fetch-description %cran-url upstream-name))
(and meta
(let ((version (assoc-ref meta "Version")))
@@ -232,7 +238,7 @@ which was derived from the R package's DESCRIPTION file."
(upstream-source
(package package)
(version version)
- (urls (cran-uri cran-name version))))))
+ (urls (cran-uri upstream-name version))))))
(define (cran-package? package)
"Return true if PACKAGE is an R package from CRAN."
diff --git a/guix/monad-repl.scm b/guix/monad-repl.scm
index ebd9151065..aefabdeebb 100644
--- a/guix/monad-repl.scm
+++ b/guix/monad-repl.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -60,11 +60,10 @@
"Return the derivation of the default "
(package-derivation store (default-guile) system))
-(define (store-monad-language)
- "Return a compiler language for the store monad."
- (let* ((store (open-connection))
- (guile (or (%guile-for-build)
- (default-guile-derivation store))))
+(define (store-monad-language store)
+ "Return a compiler language for the store monad using STORE."
+ (let ((guile (or (%guile-for-build)
+ (default-guile-derivation store))))
(monad-language %store-monad
(cut run-with-store store <>
#:guile-for-build guile)
@@ -84,10 +83,11 @@ Run EXP through the store monad."
(define-meta-command ((enter-store-monad guix) repl)
"enter-store-monad
Enter a REPL for values in the store monad."
- (let ((new (make-repl (store-monad-language))))
- ;; Force interpretation so that our specially-crafted language evaluator
- ;; is actually used.
- (repl-option-set! new 'interp #t)
- (run-repl new)))
+ (with-store store
+ (let ((new (make-repl (store-monad-language store))))
+ ;; Force interpretation so that our specially-crafted language evaluator
+ ;; is actually used.
+ (repl-option-set! new 'interp #t)
+ (run-repl new))))
;;; monad-repl.scm ends here
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index f296f8a00e..e2cc965951 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mathieu Lirzin <mthl@openmailbox.org>
;;;
;;; This file is part of GNU Guix.
@@ -593,7 +593,16 @@ Common Platform Enumeration (CPE) name."
(define package-vulnerabilities
(let ((lookup (delay (vulnerabilities->lookup-proc
- (current-vulnerabilities)))))
+ ;; Catch networking errors to allow network-less
+ ;; operation.
+ (catch 'getaddrinfo-error
+ (lambda ()
+ (current-vulnerabilities))
+ (lambda (key errcode)
+ (warn (_ "failed to lookup NIST host: ~a~%")
+ (gai-strerror errcode))
+ (warn (_ "assuming no CVE vulnerabilities~%"))
+ '()))))))
(lambda (package)
"Return a list of vulnerabilities affecting PACKAGE."
((force lookup)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index d0b5abd0e2..02eb600c43 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
@@ -230,21 +230,24 @@ specified in MANIFEST, a manifest object."
;;; Package specifications.
;;;
-(define (find-packages-by-description rx)
- "Return the list of packages whose name, synopsis, or description matches
-RX."
+(define (find-packages-by-description regexps)
+ "Return the list of packages whose name matches one of REGEXPS, or whose
+synopsis or description matches all of REGEXPS."
(define version<? (negate version>=?))
+ (define (matches-all? str)
+ (every (cut regexp-exec <> str) regexps))
+
+ (define (matches-one? str)
+ (find (cut regexp-exec <> str) regexps))
+
(sort
(fold-packages (lambda (package result)
- (define matches?
- (cut regexp-exec rx <>))
-
- (if (or (matches? (package-name package))
+ (if (or (matches-one? (package-name package))
(and=> (package-synopsis package)
- (compose matches? P_))
+ (compose matches-all? P_))
(and=> (package-description package)
- (compose matches? P_)))
+ (compose matches-all? P_)))
(cons package result)
result))
'())
@@ -696,11 +699,15 @@ processed, #f otherwise."
(package-name p2))))))
#t))
- (('search regexp)
- (let ((regexp (make-regexp* regexp regexp/icase)))
+ (('search _)
+ (let* ((patterns (filter-map (match-lambda
+ (('query 'search rx) rx)
+ (_ #f))
+ opts))
+ (regexps (map (cut make-regexp* <> regexp/icase) patterns)))
(leave-on-EPIPE
(for-each (cute package->recutils <> (current-output-port))
- (find-packages-by-description regexp)))
+ (find-packages-by-description regexps)))
#t))
(('show requested-name)
diff --git a/guix/ui.scm b/guix/ui.scm
index 35a6671a07..6fd16bb9cc 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
@@ -301,7 +301,7 @@ exiting. ARGS is the list of arguments received by the 'throw' handler."
"Display version information for COMMAND and `(exit 0)'."
(simple-format #t "~a (~a) ~a~%"
command %guix-package-name %guix-version)
- (display (_ "Copyright (C) 2015 the Guix authors
+ (display (_ "Copyright (C) 2016 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.
diff --git a/guix/utils.scm b/guix/utils.scm
index 7b589e68a8..c61f105513 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
@@ -52,6 +52,7 @@
strip-keyword-arguments
default-keyword-arguments
substitute-keyword-arguments
+ ensure-keyword-arguments
<location>
location
@@ -453,6 +454,45 @@ previous value of the keyword argument."
(()
(reverse before)))))))
+(define (delkw kw lst)
+ "Remove KW and its associated value from LST, a keyword/value list such
+as '(#:foo 1 #:bar 2)."
+ (let loop ((lst lst)
+ (result '()))
+ (match lst
+ (()
+ (reverse result))
+ ((kw? value rest ...)
+ (if (eq? kw? kw)
+ (append (reverse result) rest)
+ (loop rest (cons* value kw? result)))))))
+
+(define (ensure-keyword-arguments args kw/values)
+ "Force the keywords arguments KW/VALUES in the keyword argument list ARGS.
+For instance:
+
+ (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
+ => (#:foo 2)
+
+ (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
+ => (#:foo 2 #:bar 3)
+
+ (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))
+ => (#:foo 42 #:bar 3)
+"
+ (let loop ((args args)
+ (kw/values kw/values)
+ (result '()))
+ (match args
+ (()
+ (append (reverse result) kw/values))
+ ((kw value rest ...)
+ (match (memq kw kw/values)
+ ((_ value . _)
+ (loop rest (delkw kw kw/values) (cons* value kw result)))
+ (#f
+ (loop rest kw/values (cons* value kw result))))))))
+
(define* (nix-system->gnu-triplet
#:optional (system (%current-system)) (vendor "unknown"))
"Return a guess of the GNU triplet corresponding to Nix system