> Ah so I was referring to recutils record sets (I thought you were > talking about SRFI-9 records or something.) So what’s the question? > :-)
I was trying to explain why we shouldn’t always output generations in the recutils format. It works for ‘--search’ because there’s only one record. >> I’m attaching the patch. Please don’t push it yet. I’ve just found a >> bug. On my machine, ‘guix package -p test -l 2d’ and ‘guix package -p >> test -l’ should return the same set of generations, but the fourth >> generation is shown twice in the former case. > OK. Fixed, but I found a new one. We output a human-readable date but filter generations based on ‘ctime’. This may cause problems in some cases. Let me try to demonstrate the problem. $ ./pre-inst-env guix package -p test -l Generation 1 Sep 16 2013 Generation 2 Sep 16 2013 Generation 3 Sep 16 2013 Generation 4 Sep 16 2013 Generation 5 Sep 16 2013 Generation 6 Sep 17 2013 And the last two days: $ ./pre-inst-env guix package -p test -l 2d Generation 2 Sep 16 2013 Generation 3 Sep 16 2013 Generation 4 Sep 16 2013 Generation 5 Sep 16 2013 Generation 6 Sep 17 2013 See? Even though the first five generations have the same date, the first one is not shown. I believe that this bug is now fixed. I incorporated all your suggestions except the following ones. > I’d use @table rather than @itemize. IIUC, it can be used only with the following commands: “@code, @samp, @var, @option, or @kbd.” [1] Neither command seems to match. > s/If you pass/Passing/ > s/will return/specifies/ This doesn’t sound right because the other sentences use “will.” Can I push the attached patch to ‘master’? [1] https://gnu.org/software/texinfo/manual/texinfo/texinfo.html#index-table
From 65a2d978e1b74cde953e81109dad33f2562e8294 Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <nik...@karetnikov.org>
Date: Thu, 19 Sep 2013 00:36:05 +0000
Subject: [PATCH] guix package: Add '--list-generations'.
* guix/scripts/package.scm: Import (srfi srfi-19).
(generation-time, matching-generations): New functions.
(show-help): Add '--list-generations'.
(%options): Likewise.
(guix-package)[process-query]: Add support for '--list-generations'.
* guix/ui.scm: Import (srfi srfi-19) and (ice-9 regex).
(string->generations, string->duration): New functions.
* tests/guix-package.sh: Test '--list-generations'.
* tests/ui.scm: Import (srfi srfi-19).
Test 'string->generations' and 'string->duration'.
* doc/guix.texi (Invoking guix-package): Document '--list-generations'.
---
doc/guix.texi | 33 ++++++++++++++
guix/scripts/package.scm | 107 ++++++++++++++++++++++++++++++++++++++++++++++
guix/ui.scm | 68 +++++++++++++++++++++++++++++
tests/guix-package.sh | 4 ++
tests/ui.scm | 85 ++++++++++++++++++++++++++++++++++++
5 files changed, 297 insertions(+)
diff --git a/doc/guix.texi b/doc/guix.texi
index 5d1b780..680e629 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -606,6 +606,39 @@ library are installed in the profile, then @code{--search-paths} will
suggest setting these variables to @code{@var{profile}/include} and
@code{@var{profile}/lib}, respectively.
+@item --list-generations[=@var{pattern}]
+@itemx -l [@var{pattern}]
+Return a list of generations along with their creation dates.
+
+For each installed package, print the following items, separated by
+tabs: the name of a package, its version string, the part of the package
+that is installed (@pxref{Packages with Multiple Outputs}), and the
+location of this package in the store.
+
+When @var{pattern} is used, the command returns only matching
+generations. Valid patterns include:
+
+@itemize
+@item @emph{Integers and comma-separated integers}. Both patterns denote
+generation numbers. For instance, @code{--list-generations=1} will
+return the first one.
+
+And @code{--list-generations=1,8,2} will output three generations in the
+specified order. Neither spaces nor trailing commas are allowed.
+
+@item @emph{Ranges}. @code{--list-generations=2..9} will print the
+specified generations and everything in between. Note that the
+start of a range must be lesser than its end.
+
+It is also possible to omit the endpoint. For example,
+@code{--list-generations=2..}, will output all generations starting from
+the second one.
+
+@item @emph{Durations}. You can also get the last @emph{N}@tie{}days, weeks,
+or months by passing an integer along with the first letter of the
+duration, e.g., @code{--list-generations=20d}.
+@end itemize
+
@item --profile=@var{profile}
@itemx -p @var{profile}
Use @var{profile} instead of the user's default profile.
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 1393ca3..1cff9b0 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -34,6 +34,7 @@
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
#: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)
@@ -246,6 +247,74 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(switch-link)))
(else (switch-link))))) ; 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 (format #f "~a-~a-link" profile number)))))
+
+(define* (matching-generations str #:optional (profile %current-profile))
+ "Return the list of available generations matching a pattern in STR. See
+'string->generations' and 'string->duration' for the list of valid patterns."
+ (define (valid-generations lst)
+ (define (valid-generation? n)
+ (any (cut = n <>) (generation-numbers profile)))
+
+ (fold-right (lambda (x acc)
+ (if (valid-generation? x)
+ (cons x acc)
+ acc))
+ '()
+ lst))
+
+ (define (filter-generations generations)
+ (match generations
+ (() '())
+ (('>= n)
+ (drop-while (cut > n <>)
+ (generation-numbers profile)))
+ (('<= n)
+ (valid-generations (iota n 1)))
+ ((lst ..1)
+ (valid-generations lst))
+ (_ #f)))
+
+ (define (filter-by-duration duration)
+ (define (time-at-midnight time)
+ ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and
+ ;; hours to zeros.
+ (let ((d (time-utc->date time)))
+ (date->time-utc
+ (make-date 0 0 0 0
+ (date-day d) (date-month d)
+ (date-year d) (date-zone-offset d)))))
+
+ (define generation-ctime-alist
+ (map (lambda (number)
+ (cons number
+ (time-second
+ (time-at-midnight
+ (generation-time profile number)))))
+ (generation-numbers profile)))
+
+ (match duration
+ (#f #f)
+ (res
+ (let ((s (time-second
+ (subtract-duration (time-at-midnight (current-time))
+ duration))))
+ (delete #f (map (lambda (x)
+ (and (<= s (cdr x))
+ (first x)))
+ generation-ctime-alist))))))
+
+ (cond ((string->generations str)
+ =>
+ filter-generations)
+ ((string->duration str)
+ =>
+ filter-by-duration)
+ (else #f)))
+
(define (find-packages-by-description rx)
"Search in SYNOPSIS and DESCRIPTION using RX. Return a list of
matching packages."
@@ -441,6 +510,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
--roll-back roll back to the previous generation"))
(display (_ "
--search-paths display needed environment variable definitions"))
+ (display (_ "
+ -l, --list-generations[=PATTERN]
+ list generations matching PATTERN"))
(newline)
(display (_ "
-p, --profile=PROFILE use PROFILE instead of the user's default profile"))
@@ -500,6 +572,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(option '("roll-back") #f #f
(lambda (opt name arg result)
(alist-cons 'roll-back? #t result)))
+ (option '(#\l "list-generations") #f #t
+ (lambda (opt name arg result)
+ (cons `(query list-generations ,(or arg ""))
+ result)))
(option '("search-paths") #f #f
(lambda (opt name arg result)
(cons `(query search-paths) result)))
@@ -879,6 +955,37 @@ more information.~%"))
;; actually processed, #f otherwise.
(let ((profile (assoc-ref opts 'profile)))
(match (assoc-ref opts 'query)
+ (('list-generations pattern)
+ (define (list-generation number)
+ (begin
+ (format #t "Generation ~a\t~a~%" number
+ (date->string
+ (time-utc->date
+ (generation-time profile number))
+ "~b ~d ~Y"))
+ (for-each (match-lambda
+ ((name version output location _)
+ (format #t " ~a\t~a\t~a\t~a~%"
+ name version output location)))
+ (manifest-packages
+ (profile-manifest
+ (format #f "~a-~a-link" profile number))))
+ (newline)))
+
+ (cond ((not (file-exists? profile)) ; XXX: race condition
+ (leave (_ "profile '~a' does not exist~%")
+ profile))
+ ((string-null? pattern)
+ (for-each list-generation
+ (generation-numbers profile)))
+ ((matching-generations pattern profile)
+ =>
+ (cut for-each list-generation <>))
+ (else
+ (leave (_ "invalid syntax: ~a~%")
+ pattern)))
+ #t)
+
(('list-installed regexp)
(let* ((regexp (and regexp (make-regexp regexp)))
(manifest (profile-manifest profile))
diff --git a/guix/ui.scm b/guix/ui.scm
index 720d01b..a3289b4 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -28,12 +28,14 @@
#:use-module ((guix licenses) #:select (license? license-name))
#:use-module (srfi srfi-1)
#: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)
#:autoload (ice-9 ftw) (scandir)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
+ #:use-module (ice-9 regex)
#:export (_
N_
leave
@@ -50,6 +52,8 @@
fill-paragraph
string->recutils
package->recutils
+ string->generations
+ string->duration
args-fold*
run-guix-command
program-name
@@ -404,6 +408,70 @@ WIDTH columns."
(and=> (package-description p) description->recutils))
(newline port))
+(define (string->generations str)
+ "Return the list of generations matching a pattern in STR. This function
+accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"."
+ (define (maybe-integer)
+ (let ((x (string->number str)))
+ (and (integer? x)
+ x)))
+
+ (define (maybe-comma-separated-integers)
+ (let ((lst (delete-duplicates
+ (map string->number
+ (string-split str #\,)))))
+ (and (every integer? lst)
+ lst)))
+
+ (cond ((maybe-integer)
+ =>
+ list)
+ ((maybe-comma-separated-integers)
+ =>
+ identity)
+ ((string-match "^([0-9]+)\\.\\.([0-9]+)$" str)
+ =>
+ (lambda (match)
+ (let ((s (string->number (match:substring match 1)))
+ (e (string->number (match:substring match 2))))
+ (and (every integer? (list s e))
+ (<= s e)
+ (iota (1+ (- e s)) s)))))
+ ((string-match "^([0-9]+)\\.\\.$" str)
+ =>
+ (lambda (match)
+ (let ((s (string->number (match:substring match 1))))
+ (and (integer? s)
+ `(>= ,s)))))
+ ((string-match "^\\.\\.([0-9]+)$" str)
+ =>
+ (lambda (match)
+ (let ((e (string->number (match:substring match 1))))
+ (and (integer? e)
+ `(<= ,e)))))
+ (else #f)))
+
+(define (string->duration str)
+ "Return the duration matching a pattern in STR. This function accepts the
+following patterns: \"1d\", \"1w\", \"1m\"."
+ (define (hours->duration hours match)
+ (make-time time-duration 0
+ (* 3600 hours (string->number (match:substring match 1)))))
+
+ (cond ((string-match "^([0-9]+)d$" str)
+ =>
+ (lambda (match)
+ (hours->duration 24 match)))
+ ((string-match "^([0-9]+)w$" str)
+ =>
+ (lambda (match)
+ (hours->duration (* 24 7) match)))
+ ((string-match "^([0-9]+)m$" str)
+ =>
+ (lambda (match)
+ (hours->duration (* 24 30) match)))
+ (else #f)))
+
(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/guix-package.sh b/tests/guix-package.sh
index ee186ea..f8596fa 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -81,6 +81,10 @@ then
"name: hello"
test "`guix package -s "n0t4r341p4ck4g3"`" = ""
+ # List generations.
+ test "`guix package -p "$profile" -l | cut -f1 | grep guile | head -n1`" \
+ = " guile-bootstrap"
+
# Remove a package.
guix package --bootstrap -p "$profile" -r "guile-bootstrap"
test -L "$profile-3-link"
diff --git a/tests/ui.scm b/tests/ui.scm
index 0b6f3c5..3d5c3e7 100644
--- a/tests/ui.scm
+++ b/tests/ui.scm
@@ -20,6 +20,7 @@
(define-module (test-ui)
#:use-module (guix ui)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
#:use-module (srfi srfi-64))
;; Test the (guix ui) module.
@@ -64,6 +65,90 @@ interface, and powerful string processing.")
10)
#\newline))
+(test-equal "integer"
+ '(1)
+ (string->generations "1"))
+
+(test-equal "comma-separated integers"
+ '(3 7 1 4 6)
+ (string->generations "3,7,1,4,6"))
+
+(test-equal "closed range"
+ '(4 5 6 7 8 9 10 11 12)
+ (string->generations "4..12"))
+
+(test-equal "closed range, equal endpoints"
+ '(3)
+ (string->generations "3..3"))
+
+(test-equal "indefinite end range"
+ '(>= 7)
+ (string->generations "7.."))
+
+(test-equal "indefinite start range"
+ '(<= 42)
+ (string->generations "..42"))
+
+(test-equal "integer, char"
+ #f
+ (string->generations "a"))
+
+(test-equal "comma-separated integers, consecutive comma"
+ #f
+ (string->generations "1,,2"))
+
+(test-equal "comma-separated integers, trailing comma"
+ #f
+ (string->generations "1,2,"))
+
+(test-equal "comma-separated integers, chars"
+ #f
+ (string->generations "a,b"))
+
+(test-equal "closed range, start > end"
+ #f
+ (string->generations "9..2"))
+
+(test-equal "closed range, chars"
+ #f
+ (string->generations "a..b"))
+
+(test-equal "indefinite end range, char"
+ #f
+ (string->generations "a.."))
+
+(test-equal "indefinite start range, char"
+ #f
+ (string->generations "..a"))
+
+(test-equal "duration, 1 day"
+ (make-time time-duration 0 (* 3600 24))
+ (string->duration "1d"))
+
+(test-equal "duration, 1 week"
+ (make-time time-duration 0 (* 3600 24 7))
+ (string->duration "1w"))
+
+(test-equal "duration, 1 month"
+ (make-time time-duration 0 (* 3600 24 30))
+ (string->duration "1m"))
+
+(test-equal "duration, 1 week == 7 days"
+ (string->duration "1w")
+ (string->duration "7d"))
+
+(test-equal "duration, 1 month == 30 days"
+ (string->duration "1m")
+ (string->duration "30d"))
+
+(test-equal "duration, integer"
+ #f
+ (string->duration "1"))
+
+(test-equal "duration, char"
+ #f
+ (string->duration "d"))
+
(test-end "ui")
--
1.7.9.5
pgpAzbRAON8PG.pgp
Description: PGP signature
