From 3972dc5d43ea824ee4ab78592e759f62ce90bf6a Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 24 Sep 2019 17:50:48 +0200
Subject: guix package: Add '--list-profiles'.

* guix/scripts/package.scm (show-help, %options): Add '--list-profiles'.
(process-query): Honor it.
* tests/guix-package.sh: Add test.
---
 guix/scripts/package.scm | 21 +++++++++++++++++++++
 1 file changed, 21 insertions(+)

(limited to 'guix/scripts/package.scm')

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index f03741aa9e..1a58d43e5c 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -39,6 +39,7 @@
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
   #:autoload   (guix describe) (package-provenance)
+  #:autoload   (guix store roots) (gc-roots)
   #:use-module ((guix build utils)
                 #:select (directory-exists? mkdir-p))
   #:use-module (ice-9 format)
@@ -359,6 +360,8 @@ Install, remove, or upgrade packages in a single transaction.\n"))
                          switch to a generation matching PATTERN"))
   (display (G_ "
   -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
+  (display (G_ "
+      --list-profiles    list the user's profiles"))
   (newline)
   (display (G_ "
       --allow-collisions do not treat collisions in the profile as an error"))
@@ -458,6 +461,11 @@ command-line option~%")
                    (values (cons `(query list-generations ,arg)
                                  result)
                            #f)))
+         (option '("list-profiles") #f #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (cons `(query list-profiles #t)
+                                 result)
+                           #f)))
          (option '(#\d "delete-generations") #f #t
                  (lambda (opt name arg result arg-handler)
                    (values (alist-cons 'delete-generations arg
@@ -750,6 +758,19 @@ processed, #f otherwise."
                              (string<? name1 name2))))))
          #t))
 
+      (('list-profiles _)
+       (let ((profiles (delete-duplicates
+                        (filter-map (lambda (root)
+                                      (and (or (zero? (getuid))
+                                               (user-owned? root))
+                                           (generation-profile root)))
+                                    (gc-roots)))))
+         (leave-on-EPIPE
+          (for-each (lambda (profile)
+                      (display (user-friendly-profile profile))
+                      (newline))
+                    (sort profiles string<?)))))
+
       (('search _)
        (let* ((patterns (filter-map (match-lambda
                                       (('query 'search rx) rx)
-- 
cgit v1.2.3