me
/
guix
Archived
1
0
Fork 0

guix package: Allow removal of a specific package output.

Fixes <http://bugs.gnu.org/15756>.

* guix/profiles.scm (<manifest-pattern>): New record type.
  (remove-manifest-entry): Remove.
  (entry-predicate, manifest-matching-entries): New procedures.
  (manifest-remove): Accept a list of <manifest-pattern>.
  (manifest-installed?): Replace 'name' parameter by 'pattern', a
  <manifest-pattern>.
* guix/scripts/package.scm (options->removable): Return a list of
  <manifest-pattern>.
  (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.
master
Ludovic Courtès 2013-11-01 23:11:17 +01:00
parent 537630c5a7
commit a20787706c
5 changed files with 167 additions and 29 deletions

View File

@ -14,6 +14,8 @@
(eval . (put 'substitute* 'scheme-indent-function 1)) (eval . (put 'substitute* 'scheme-indent-function 1))
(eval . (put 'with-directory-excursion 'scheme-indent-function 1)) (eval . (put 'with-directory-excursion 'scheme-indent-function 1))
(eval . (put 'package 'scheme-indent-function 0)) (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 'substitute-keyword-arguments 'scheme-indent-function 1))
(eval . (put 'with-error-handling 'scheme-indent-function 0)) (eval . (put 'with-error-handling 'scheme-indent-function 0))
(eval . (put 'with-mutex 'scheme-indent-function 1)) (eval . (put 'with-mutex 'scheme-indent-function 1))

View File

@ -115,7 +115,8 @@ SCM_TESTS = \
tests/store.scm \ tests/store.scm \
tests/monads.scm \ tests/monads.scm \
tests/nar.scm \ tests/nar.scm \
tests/union.scm tests/union.scm \
tests/profiles.scm
SH_TESTS = \ SH_TESTS = \
tests/guix-build.sh \ tests/guix-build.sh \

View File

@ -42,11 +42,15 @@
manifest-entry-path manifest-entry-path
manifest-entry-dependencies manifest-entry-dependencies
manifest-pattern
manifest-pattern?
read-manifest read-manifest
write-manifest write-manifest
manifest-remove manifest-remove
manifest-installed? manifest-installed?
manifest-matching-entries
manifest=? manifest=?
profile-manifest profile-manifest
@ -90,6 +94,15 @@
(inputs manifest-entry-inputs ; list of inputs to build (inputs manifest-entry-inputs ; list of inputs to build
(default '()))) ; this entry (default '()))) ; this entry
(define-record-type* <manifest-pattern> manifest-pattern
make-manifest-pattern
manifest-pattern?
(name manifest-pattern-name) ; string
(version manifest-pattern-version ; string | #f
(default #f))
(output manifest-pattern-output ; string | #f
(default "out")))
(define (profile-manifest profile) (define (profile-manifest profile)
"Return the PROFILE's manifest." "Return the PROFILE's manifest."
(let ((file (string-append profile "/manifest"))) (let ((file (string-append profile "/manifest")))
@ -148,29 +161,48 @@
"Write MANIFEST to PORT." "Write MANIFEST to PORT."
(write (manifest->sexp manifest) port)) (write (manifest->sexp manifest) port))
(define (remove-manifest-entry name lst) (define (entry-predicate pattern)
"Remove the manifest entry named NAME from LST." "Return a procedure that returns #t when passed a manifest entry that
(remove (match-lambda matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they
(($ <manifest-entry> entry-name) are ignored."
(string=? name entry-name))) (match pattern
lst)) (($ <manifest-pattern> name version output)
(match-lambda
(($ <manifest-entry> entry-name entry-version entry-output)
(and (string=? entry-name name)
(or (not entry-output) (not output)
(string=? entry-output output))
(or (not version)
(string=? entry-version version))))))))
(define (manifest-remove manifest names) (define (manifest-remove manifest patterns)
"Remove entries for each of NAMES from MANIFEST." "Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS
(make-manifest (fold remove-manifest-entry must be a manifest-pattern."
(define (remove-entry pattern lst)
(remove (entry-predicate pattern) lst))
(make-manifest (fold remove-entry
(manifest-entries manifest) (manifest-entries manifest)
names))) patterns)))
(define (manifest-installed? manifest name) (define (manifest-installed? manifest pattern)
"Return #t if MANIFEST has an entry for NAME, #f otherwise." "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
(define (->bool x) #f otherwise."
(not (not x))) (->bool (find (entry-predicate pattern)
(->bool (find (match-lambda
(($ <manifest-entry> entry-name)
(string=? entry-name name)))
(manifest-entries manifest)))) (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) (define (manifest=? m1 m2)
"Return #t if manifests M1 and M2 are equal. This differs from 'equal?' in "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 that the 'inputs' field is ignored for the comparison, since it is know to

View File

@ -693,15 +693,20 @@ return the new list of manifest entries."
(append to-upgrade to-install)) (append to-upgrade to-install))
(define (options->removable options manifest) (define (options->removable options manifest)
"Given options, return the list of manifest entries to be removed from "Given options, return the list of manifest patterns of packages to be
MANIFEST." removed from MANIFEST."
(let ((remove (filter-map (match-lambda (filter-map (match-lambda
(('remove . package) (('remove . spec)
package) (call-with-values
(_ #f)) (lambda ()
options))) (package-specification->name+version+output spec))
(filter (cut manifest-installed? manifest <>) (lambda (name version output)
remove))) (manifest-pattern
(name name)
(version version)
(output output)))))
(_ #f))
options))
;;; ;;;
@ -871,7 +876,8 @@ more information.~%"))
(if (manifest=? new manifest) (if (manifest=? new manifest)
(format (current-error-port) (_ "nothing to be done~%")) (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-remove/install remove install dry-run?)
(show-what-to-build (%store) (list prof-drv) (show-what-to-build (%store) (list prof-drv)
#:use-substitutes? #:use-substitutes?

97
tests/profiles.scm 100644
View File

@ -0,0 +1,97 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-profiles)
#:use-module (guix profiles)
#:use-module (ice-9 match)
#:use-module (srfi srfi-64))
;; Test the (guix profile) module.
;; Example manifest entries.
(define guile-2.0.9
(manifest-entry
(name "guile")
(version "2.0.9")
(path "/gnu/store/...")
(output "out")))
(define guile-2.0.9:debug
(manifest-entry (inherit guile-2.0.9)
(output "debug")))
(test-begin "profiles")
(test-assert "manifest-installed?"
(let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug))))
(and (manifest-installed? m (manifest-pattern (name "guile")))
(manifest-installed? m (manifest-pattern
(name "guile") (output "debug")))
(manifest-installed? m (manifest-pattern
(name "guile") (output "out")
(version "2.0.9")))
(not (manifest-installed?
m (manifest-pattern (name "guile") (version "1.8.8"))))
(not (manifest-installed?
m (manifest-pattern (name "guile") (output "foobar")))))))
(test-assert "manifest-matching-entries"
(let* ((e (list guile-2.0.9 guile-2.0.9:debug))
(m (manifest e)))
(and (null? (manifest-matching-entries m
(list (manifest-pattern
(name "python")))))
(equal? e
(manifest-matching-entries m
(list (manifest-pattern
(name "guile")
(output #f)))))
(equal? (list guile-2.0.9)
(manifest-matching-entries m
(list (manifest-pattern
(name "guile")
(version "2.0.9"))))))))
(test-assert "manifest-remove"
(let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
(m1 (manifest-remove m0
(list (manifest-pattern (name "guile")))))
(m2 (manifest-remove m1
(list (manifest-pattern (name "guile"))))) ; same
(m3 (manifest-remove m2
(list (manifest-pattern
(name "guile") (output "debug")))))
(m4 (manifest-remove m3
(list (manifest-pattern (name "guile"))))))
(match (manifest-entries m2)
((($ <manifest-entry> "guile" "2.0.9" "debug"))
(and (equal? m1 m2)
(null? (manifest-entries m3))
(null? (manifest-entries m4)))))))
(test-end "profiles")
(exit (= (test-runner-fail-count (test-runner-current)) 0))
;;; Local Variables:
;;; eval: (put 'dummy-package 'scheme-indent-function 1)
;;; End: