Add (guix profiles).
* guix/scripts/package.scm (show-what-to-remove/install): New procedure, moved from... (guix-package): ... here. (<manifest>, make-manifest, <manifest-entry>, 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.
This commit is contained in:
Ludovic Courtès
parent
fdd6c72683
commit
cc4ecc2d88
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -0,0 +1,315 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (guix profiles)
|
||||
#:use-module (guix utils)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 ftw)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-19)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:export (manifest make-manifest
|
||||
manifest?
|
||||
manifest-entries
|
||||
|
||||
<manifest-entry> ; FIXME: eventually make it internal
|
||||
manifest-entry
|
||||
manifest-entry?
|
||||
manifest-entry-name
|
||||
manifest-entry-version
|
||||
manifest-entry-output
|
||||
manifest-entry-path
|
||||
manifest-entry-dependencies
|
||||
|
||||
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>
|
||||
(manifest entries)
|
||||
manifest?
|
||||
(entries manifest-entries)) ; list of <manifest-entry>
|
||||
|
||||
;; Convenient alias, to avoid name clashes.
|
||||
(define make-manifest manifest)
|
||||
|
||||
(define-record-type* <manifest-entry> manifest-entry
|
||||
make-manifest-entry
|
||||
manifest-entry?
|
||||
(name manifest-entry-name) ; string
|
||||
(version manifest-entry-version) ; string
|
||||
(output manifest-entry-output ; string
|
||||
(default "out"))
|
||||
(path manifest-entry-path) ; store path
|
||||
(dependencies manifest-entry-dependencies ; list of store paths
|
||||
(default '()))
|
||||
(inputs manifest-entry-inputs ; list of inputs to build
|
||||
(default '()))) ; this entry
|
||||
|
||||
(define (profile-manifest profile)
|
||||
"Return the PROFILE's manifest."
|
||||
(let ((file (string-append profile "/manifest")))
|
||||
(if (file-exists? file)
|
||||
(call-with-input-file file read-manifest)
|
||||
(manifest '()))))
|
||||
|
||||
(define (manifest->sexp manifest)
|
||||
"Return a representation of MANIFEST as an sexp."
|
||||
(define (entry->sexp entry)
|
||||
(match entry
|
||||
(($ <manifest-entry> name version path output (deps ...))
|
||||
(list name version path output deps))))
|
||||
|
||||
(match manifest
|
||||
(($ <manifest> (entries ...))
|
||||
`(manifest (version 1)
|
||||
(packages ,(map entry->sexp entries))))))
|
||||
|
||||
(define (sexp->manifest sexp)
|
||||
"Parse SEXP as a manifest."
|
||||
(match sexp
|
||||
(('manifest ('version 0)
|
||||
('packages ((name version output path) ...)))
|
||||
(manifest
|
||||
(map (lambda (name version output path)
|
||||
(manifest-entry
|
||||
(name name)
|
||||
(version version)
|
||||
(output output)
|
||||
(path path)))
|
||||
name version output path)))
|
||||
|
||||
;; Version 1 adds a list of propagated inputs to the
|
||||
;; name/version/output/path tuples.
|
||||
(('manifest ('version 1)
|
||||
('packages ((name version output path deps) ...)))
|
||||
(manifest
|
||||
(map (lambda (name version output path deps)
|
||||
(manifest-entry
|
||||
(name name)
|
||||
(version version)
|
||||
(output output)
|
||||
(path path)
|
||||
(dependencies deps)))
|
||||
name version output path deps)))
|
||||
|
||||
(_
|
||||
(error "unsupported manifest format" manifest))))
|
||||
|
||||
(define (read-manifest port)
|
||||
"Return the packages listed in MANIFEST."
|
||||
(sexp->manifest (read port)))
|
||||
|
||||
(define (write-manifest manifest port)
|
||||
"Write MANIFEST to PORT."
|
||||
(write (manifest->sexp manifest) port))
|
||||
|
||||
(define (remove-manifest-entry name lst)
|
||||
"Remove the manifest entry named NAME from LST."
|
||||
(remove (match-lambda
|
||||
(($ <manifest-entry> entry-name)
|
||||
(string=? name entry-name)))
|
||||
lst))
|
||||
|
||||
(define (manifest-remove manifest names)
|
||||
"Remove entries for each of NAMES from MANIFEST."
|
||||
(make-manifest (fold remove-manifest-entry
|
||||
(manifest-entries manifest)
|
||||
names)))
|
||||
|
||||
(define (manifest-installed? manifest name)
|
||||
"Return #t if MANIFEST has an entry for NAME, #f otherwise."
|
||||
(define (->bool x)
|
||||
(not (not x)))
|
||||
|
||||
(->bool (find (match-lambda
|
||||
(($ <manifest-entry> entry-name)
|
||||
(string=? entry-name name)))
|
||||
(manifest-entries manifest))))
|
||||
|
||||
(define (manifest=? m1 m2)
|
||||
"Return #t if manifests M1 and M2 are equal. This differs from 'equal?' in
|
||||
that the 'inputs' field is ignored for the comparison, since it is know to
|
||||
have no effect on the manifest contents."
|
||||
(equal? (manifest->sexp m1)
|
||||
(manifest->sexp m2)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Profiles.
|
||||
;;;
|
||||
|
||||
(define* (lower-input store input #:optional (system (%current-system)))
|
||||
"Lower INPUT so that it contains derivations instead of packages."
|
||||
(match input
|
||||
((name (? package? package))
|
||||
`(,name ,(package-derivation store package system)))
|
||||
((name (? package? package) output)
|
||||
`(,name ,(package-derivation store package system)
|
||||
,output))
|
||||
(_ input)))
|
||||
|
||||
(define (profile-derivation store manifest)
|
||||
"Return a derivation that builds a profile (aka. 'user environment') with
|
||||
the given MANIFEST."
|
||||
(define builder
|
||||
`(begin
|
||||
(use-modules (ice-9 pretty-print)
|
||||
(guix build union))
|
||||
|
||||
(setvbuf (current-output-port) _IOLBF)
|
||||
(setvbuf (current-error-port) _IOLBF)
|
||||
|
||||
(let ((output (assoc-ref %outputs "out"))
|
||||
(inputs (map cdr %build-inputs)))
|
||||
(format #t "building profile '~a' with ~a packages...~%"
|
||||
output (length inputs))
|
||||
(union-build output inputs
|
||||
#:log-port (%make-void-port "w"))
|
||||
(call-with-output-file (string-append output "/manifest")
|
||||
(lambda (p)
|
||||
(pretty-print ',(manifest->sexp manifest) p))))))
|
||||
|
||||
(build-expression->derivation store "profile"
|
||||
(%current-system)
|
||||
builder
|
||||
(append-map (match-lambda
|
||||
(($ <manifest-entry> name version
|
||||
output path deps (inputs ..1))
|
||||
(map (cute lower-input store <>)
|
||||
inputs))
|
||||
(($ <manifest-entry> name version
|
||||
output path deps)
|
||||
;; Assume PATH and DEPS are
|
||||
;; already valid.
|
||||
`((,name ,path) ,@deps)))
|
||||
(manifest-entries manifest))
|
||||
#:modules '((guix build union))))
|
||||
|
||||
(define (profile-regexp profile)
|
||||
"Return a regular expression that matches PROFILE's name and number."
|
||||
(make-regexp (string-append "^" (regexp-quote (basename profile))
|
||||
"-([0-9]+)")))
|
||||
|
||||
(define (generation-number profile)
|
||||
"Return PROFILE's number or 0. An absolute file name must be used."
|
||||
(or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
|
||||
(basename (readlink profile))))
|
||||
(compose string->number (cut match:substring <> 1)))
|
||||
0))
|
||||
|
||||
(define (generation-numbers profile)
|
||||
"Return the sorted list of generation numbers of PROFILE, or '(0) if no
|
||||
former profiles were found."
|
||||
(define* (scandir name #:optional (select? (const #t))
|
||||
(entry<? (@ (ice-9 i18n) string-locale<?)))
|
||||
;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
|
||||
(define (enter? dir stat result)
|
||||
(and stat (string=? dir name)))
|
||||
|
||||
(define (visit basename result)
|
||||
(if (select? basename)
|
||||
(cons basename result)
|
||||
result))
|
||||
|
||||
(define (leaf name stat result)
|
||||
(and result
|
||||
(visit (basename name) result)))
|
||||
|
||||
(define (down name stat result)
|
||||
(visit "." '()))
|
||||
|
||||
(define (up name stat result)
|
||||
(visit ".." result))
|
||||
|
||||
(define (skip name stat result)
|
||||
;; All the sub-directories are skipped.
|
||||
(visit (basename name) result))
|
||||
|
||||
(define (error name* stat errno result)
|
||||
(if (string=? name name*) ; top-level NAME is unreadable
|
||||
result
|
||||
(visit (basename name*) result)))
|
||||
|
||||
(and=> (file-system-fold enter? leaf down up skip error #f name lstat)
|
||||
(lambda (files)
|
||||
(sort files entry<?))))
|
||||
|
||||
(match (scandir (dirname profile)
|
||||
(cute regexp-exec (profile-regexp profile) <>))
|
||||
(#f ; no profile directory
|
||||
'(0))
|
||||
(() ; no profiles
|
||||
'(0))
|
||||
((profiles ...) ; former profiles around
|
||||
(sort (map (compose string->number
|
||||
(cut match:substring <> 1)
|
||||
(cute regexp-exec (profile-regexp profile) <>))
|
||||
profiles)
|
||||
<))))
|
||||
|
||||
(define (previous-generation-number profile number)
|
||||
"Return the number of the generation before generation NUMBER of
|
||||
PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
|
||||
case when generations have been deleted (there are \"holes\")."
|
||||
(fold (lambda (candidate highest)
|
||||
(if (and (< candidate number) (> candidate highest))
|
||||
candidate
|
||||
highest))
|
||||
0
|
||||
(generation-numbers profile)))
|
||||
|
||||
(define (generation-file-name profile generation)
|
||||
"Return the file name for PROFILE's GENERATION."
|
||||
(format #f "~a-~a-link" profile generation))
|
||||
|
||||
(define (generation-time profile number)
|
||||
"Return the creation time of a generation in the UTC format."
|
||||
(make-time time-utc 0
|
||||
(stat:ctime (stat (generation-file-name profile number)))))
|
||||
|
||||
;;; profiles.scm ends here
|
||||
|
|
@ -23,22 +23,19 @@
|
|||
#:use-module (guix store)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (guix profiles)
|
||||
#:use-module (guix utils)
|
||||
#:use-module (guix config)
|
||||
#:use-module (guix records)
|
||||
#:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
|
||||
#:use-module ((guix ftp-client) #:select (ftp-open))
|
||||
#:use-module (ice-9 ftw)
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-19)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-37)
|
||||
#:use-module (gnu packages)
|
||||
#:use-module ((gnu packages base) #:select (guile-final))
|
||||
|
|
@ -51,7 +48,7 @@
|
|||
|
||||
|
||||
;;;
|
||||
;;; User profile.
|
||||
;;; Profiles.
|
||||
;;;
|
||||
|
||||
(define %user-profile-directory
|
||||
|
|
@ -69,240 +66,6 @@
|
|||
;; coexist with Nix profiles.
|
||||
(string-append %profile-directory "/guix-profile"))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Manifests.
|
||||
;;;
|
||||
|
||||
(define-record-type <manifest>
|
||||
(manifest entries)
|
||||
manifest?
|
||||
(entries manifest-entries)) ; list of <manifest-entry>
|
||||
|
||||
;; Convenient alias, to avoid name clashes.
|
||||
(define make-manifest manifest)
|
||||
|
||||
(define-record-type* <manifest-entry> manifest-entry
|
||||
make-manifest-entry
|
||||
manifest-entry?
|
||||
(name manifest-entry-name) ; string
|
||||
(version manifest-entry-version) ; string
|
||||
(output manifest-entry-output ; string
|
||||
(default "out"))
|
||||
(path manifest-entry-path) ; store path
|
||||
(dependencies manifest-entry-dependencies ; list of store paths
|
||||
(default '()))
|
||||
(inputs manifest-entry-inputs ; list of inputs to build
|
||||
(default '()))) ; this entry
|
||||
|
||||
(define (profile-manifest profile)
|
||||
"Return the PROFILE's manifest."
|
||||
(let ((file (string-append profile "/manifest")))
|
||||
(if (file-exists? file)
|
||||
(call-with-input-file file read-manifest)
|
||||
(manifest '()))))
|
||||
|
||||
(define (manifest->sexp manifest)
|
||||
"Return a representation of MANIFEST as an sexp."
|
||||
(define (entry->sexp entry)
|
||||
(match entry
|
||||
(($ <manifest-entry> name version path output (deps ...))
|
||||
(list name version path output deps))))
|
||||
|
||||
(match manifest
|
||||
(($ <manifest> (entries ...))
|
||||
`(manifest (version 1)
|
||||
(packages ,(map entry->sexp entries))))))
|
||||
|
||||
(define (sexp->manifest sexp)
|
||||
"Parse SEXP as a manifest."
|
||||
(match sexp
|
||||
(('manifest ('version 0)
|
||||
('packages ((name version output path) ...)))
|
||||
(manifest
|
||||
(map (lambda (name version output path)
|
||||
(manifest-entry
|
||||
(name name)
|
||||
(version version)
|
||||
(output output)
|
||||
(path path)))
|
||||
name version output path)))
|
||||
|
||||
;; Version 1 adds a list of propagated inputs to the
|
||||
;; name/version/output/path tuples.
|
||||
(('manifest ('version 1)
|
||||
('packages ((name version output path deps) ...)))
|
||||
(manifest
|
||||
(map (lambda (name version output path deps)
|
||||
(manifest-entry
|
||||
(name name)
|
||||
(version version)
|
||||
(output output)
|
||||
(path path)
|
||||
(dependencies deps)))
|
||||
name version output path deps)))
|
||||
|
||||
(_
|
||||
(error "unsupported manifest format" manifest))))
|
||||
|
||||
(define (read-manifest port)
|
||||
"Return the packages listed in MANIFEST."
|
||||
(sexp->manifest (read port)))
|
||||
|
||||
(define (write-manifest manifest port)
|
||||
"Write MANIFEST to PORT."
|
||||
(write (manifest->sexp manifest) port))
|
||||
|
||||
(define (remove-manifest-entry name lst)
|
||||
"Remove the manifest entry named NAME from LST."
|
||||
(remove (match-lambda
|
||||
(($ <manifest-entry> entry-name)
|
||||
(string=? name entry-name)))
|
||||
lst))
|
||||
|
||||
(define (manifest-remove manifest names)
|
||||
"Remove entries for each of NAMES from MANIFEST."
|
||||
(make-manifest (fold remove-manifest-entry
|
||||
(manifest-entries manifest)
|
||||
names)))
|
||||
|
||||
(define (manifest-installed? manifest name)
|
||||
"Return #t if MANIFEST has an entry for NAME, #f otherwise."
|
||||
(define (->bool x)
|
||||
(not (not x)))
|
||||
|
||||
(->bool (find (match-lambda
|
||||
(($ <manifest-entry> entry-name)
|
||||
(string=? entry-name name)))
|
||||
(manifest-entries manifest))))
|
||||
|
||||
(define (manifest=? m1 m2)
|
||||
"Return #t if manifests M1 and M2 are equal. This differs from 'equal?' in
|
||||
that the 'inputs' field is ignored for the comparison, since it is know to
|
||||
have no effect on the manifest contents."
|
||||
(equal? (manifest->sexp m1)
|
||||
(manifest->sexp m2)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Profiles.
|
||||
;;;
|
||||
|
||||
(define (profile-regexp profile)
|
||||
"Return a regular expression that matches PROFILE's name and number."
|
||||
(make-regexp (string-append "^" (regexp-quote (basename profile))
|
||||
"-([0-9]+)")))
|
||||
|
||||
(define (generation-numbers profile)
|
||||
"Return the sorted list of generation numbers of PROFILE, or '(0) if no
|
||||
former profiles were found."
|
||||
(define* (scandir name #:optional (select? (const #t))
|
||||
(entry<? (@ (ice-9 i18n) string-locale<?)))
|
||||
;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
|
||||
(define (enter? dir stat result)
|
||||
(and stat (string=? dir name)))
|
||||
|
||||
(define (visit basename result)
|
||||
(if (select? basename)
|
||||
(cons basename result)
|
||||
result))
|
||||
|
||||
(define (leaf name stat result)
|
||||
(and result
|
||||
(visit (basename name) result)))
|
||||
|
||||
(define (down name stat result)
|
||||
(visit "." '()))
|
||||
|
||||
(define (up name stat result)
|
||||
(visit ".." result))
|
||||
|
||||
(define (skip name stat result)
|
||||
;; All the sub-directories are skipped.
|
||||
(visit (basename name) result))
|
||||
|
||||
(define (error name* stat errno result)
|
||||
(if (string=? name name*) ; top-level NAME is unreadable
|
||||
result
|
||||
(visit (basename name*) result)))
|
||||
|
||||
(and=> (file-system-fold enter? leaf down up skip error #f name lstat)
|
||||
(lambda (files)
|
||||
(sort files entry<?))))
|
||||
|
||||
(match (scandir (dirname profile)
|
||||
(cute regexp-exec (profile-regexp profile) <>))
|
||||
(#f ; no profile directory
|
||||
'(0))
|
||||
(() ; no profiles
|
||||
'(0))
|
||||
((profiles ...) ; former profiles around
|
||||
(sort (map (compose string->number
|
||||
(cut match:substring <> 1)
|
||||
(cute regexp-exec (profile-regexp profile) <>))
|
||||
profiles)
|
||||
<))))
|
||||
|
||||
(define (previous-generation-number profile number)
|
||||
"Return the number of the generation before generation NUMBER of
|
||||
PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
|
||||
case when generations have been deleted (there are \"holes\")."
|
||||
(fold (lambda (candidate highest)
|
||||
(if (and (< candidate number) (> candidate highest))
|
||||
candidate
|
||||
highest))
|
||||
0
|
||||
(generation-numbers profile)))
|
||||
|
||||
(define (profile-derivation store manifest)
|
||||
"Return a derivation that builds a profile (aka. 'user environment') with
|
||||
the given MANIFEST."
|
||||
(define builder
|
||||
`(begin
|
||||
(use-modules (ice-9 pretty-print)
|
||||
(guix build union))
|
||||
|
||||
(setvbuf (current-output-port) _IOLBF)
|
||||
(setvbuf (current-error-port) _IOLBF)
|
||||
|
||||
(let ((output (assoc-ref %outputs "out"))
|
||||
(inputs (map cdr %build-inputs)))
|
||||
(format #t "building profile '~a' with ~a packages...~%"
|
||||
output (length inputs))
|
||||
(union-build output inputs
|
||||
#:log-port (%make-void-port "w"))
|
||||
(call-with-output-file (string-append output "/manifest")
|
||||
(lambda (p)
|
||||
(pretty-print ',(manifest->sexp manifest) p))))))
|
||||
|
||||
(build-expression->derivation store "profile"
|
||||
(%current-system)
|
||||
builder
|
||||
(append-map (match-lambda
|
||||
(($ <manifest-entry> name version
|
||||
output path deps (inputs ..1))
|
||||
(map (cute lower-input
|
||||
(%store) <>)
|
||||
inputs))
|
||||
(($ <manifest-entry> name version
|
||||
output path deps)
|
||||
;; Assume PATH and DEPS are
|
||||
;; already valid.
|
||||
`((,name ,path) ,@deps)))
|
||||
(manifest-entries manifest))
|
||||
#:modules '((guix build union))))
|
||||
|
||||
(define (generation-number profile)
|
||||
"Return PROFILE's number or 0. An absolute file name must be used."
|
||||
(or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
|
||||
(basename (readlink profile))))
|
||||
(compose string->number (cut match:substring <> 1)))
|
||||
0))
|
||||
|
||||
(define (generation-file-name profile generation)
|
||||
"Return the file name for PROFILE's GENERATION."
|
||||
(format #f "~a-~a-link" profile generation))
|
||||
|
||||
(define (link-to-empty-profile generation)
|
||||
"Link GENERATION, a string, to the empty profile."
|
||||
(let* ((drv (profile-derivation (%store) (manifest '())))
|
||||
|
|
@ -340,11 +103,6 @@ the given MANIFEST."
|
|||
(else
|
||||
(switch-to-previous-generation profile))))) ; anything else
|
||||
|
||||
(define (generation-time profile number)
|
||||
"Return the creation time of a generation in the UTC format."
|
||||
(make-time time-utc 0
|
||||
(stat:ctime (stat (generation-file-name profile number)))))
|
||||
|
||||
(define* (matching-generations str #:optional (profile %current-profile)
|
||||
#:key (duration-relation <=))
|
||||
"Return the list of available generations matching a pattern in STR. See
|
||||
|
|
@ -411,6 +169,50 @@ DURATION-RELATION with the current time."
|
|||
filter-by-duration)
|
||||
(else #f)))
|
||||
|
||||
(define (show-what-to-remove/install remove install dry-run?)
|
||||
"Given the manifest entries listed in REMOVE and INSTALL, display the
|
||||
packages that will/would be installed and removed."
|
||||
;; TODO: Report upgrades more clearly.
|
||||
(match remove
|
||||
((($ <manifest-entry> name version _ path _) ..1)
|
||||
(let ((len (length name))
|
||||
(remove (map (cut format #f " ~a-~a\t~a" <> <> <>)
|
||||
name version path)))
|
||||
(if dry-run?
|
||||
(format (current-error-port)
|
||||
(N_ "The following package would be removed:~% ~{~a~%~}~%"
|
||||
"The following packages would be removed:~% ~{~a~%~}~%"
|
||||
len)
|
||||
remove)
|
||||
(format (current-error-port)
|
||||
(N_ "The following package will be removed:~% ~{~a~%~}~%"
|
||||
"The following packages will be removed:~% ~{~a~%~}~%"
|
||||
len)
|
||||
remove))))
|
||||
(_ #f))
|
||||
(match install
|
||||
((($ <manifest-entry> name version output path _) ..1)
|
||||
(let ((len (length name))
|
||||
(install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>)
|
||||
name version output path)))
|
||||
(if dry-run?
|
||||
(format (current-error-port)
|
||||
(N_ "The following package would be installed:~%~{~a~%~}~%"
|
||||
"The following packages would be installed:~%~{~a~%~}~%"
|
||||
len)
|
||||
install)
|
||||
(format (current-error-port)
|
||||
(N_ "The following package will be installed:~%~{~a~%~}~%"
|
||||
"The following packages will be installed:~%~{~a~%~}~%"
|
||||
len)
|
||||
install))))
|
||||
(_ #f)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; 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
|
||||
((($ <manifest-entry> name version _ path _) ..1)
|
||||
(let ((len (length name))
|
||||
(remove (map (cut format #f " ~a-~a\t~a" <> <> <>)
|
||||
name version path)))
|
||||
(if dry-run?
|
||||
(format (current-error-port)
|
||||
(N_ "The following package would be removed:~% ~{~a~%~}~%"
|
||||
"The following packages would be removed:~% ~{~a~%~}~%"
|
||||
len)
|
||||
remove)
|
||||
(format (current-error-port)
|
||||
(N_ "The following package will be removed:~% ~{~a~%~}~%"
|
||||
"The following packages will be removed:~% ~{~a~%~}~%"
|
||||
len)
|
||||
remove))))
|
||||
(_ #f))
|
||||
(match install
|
||||
((($ <manifest-entry> name version output path _) ..1)
|
||||
(let ((len (length name))
|
||||
(install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>)
|
||||
name version output path)))
|
||||
(if dry-run?
|
||||
(format (current-error-port)
|
||||
(N_ "The following package would be installed:~%~{~a~%~}~%"
|
||||
"The following packages would be installed:~%~{~a~%~}~%"
|
||||
len)
|
||||
install)
|
||||
(format (current-error-port)
|
||||
(N_ "The following package will be installed:~%~{~a~%~}~%"
|
||||
"The following packages will be installed:~%~{~a~%~}~%"
|
||||
len)
|
||||
install))))
|
||||
(_ #f)))
|
||||
|
||||
(define current-generation-number
|
||||
(generation-number profile))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue