futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

guix-package: Add `--list-installed'.

Browse Source 
* guix-package.in (show-help, %options): Add `--list-installed'.
  (guix-package): Move main body to...
  [process-actions]: ... here.  New internal procedure.
  [process-query]: New procedure.
* tests/guix-package.sh: Add tests for `--list-installed'.
* doc/guix.texi (Invoking guix-package): Document it.
This commit is contained in:
Ludovic Courtès 2012-11-19 22:39:45 +01:00
parent c6f09dfade
commit 733b4130d7
3 changed files with 127 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
doc/guix.texi
View File

@ -239,7 +239,25 @@ useful to distribution developers.
@end table @end table
In addition to these actions @command{guix-package} supports the
following options to query the current state of a profile, or the
availability of packages:
@table @option
@item --list-installed[=@var{regexp}]
@itemx -I [@var{regexp}]
List currently installed packages in the specified profile. When
@var{regexp} is specified, list only installed packages whose name
matches @var{regexp}.
For each installed package, print the following items, separated by
tabs: the package name, its version string, the part of the package that
is installed (for instance, @code{out} for the default output,
@code{include} for its headers, etc.), and the path of this package in
the store.
@end table

159
guix-package.in
View File

@ -202,6 +202,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
-b, --bootstrap use the bootstrap Guile to build the profile")) -b, --bootstrap use the bootstrap Guile to build the profile"))
(newline) (newline)
(display (_ " (display (_ "
-I, --list-installed[=REGEXP]
list installed packages matching REGEXP"))
(newline)
(display (_ "
-h, --help display this help and exit")) -h, --help display this help and exit"))
(display (_ " (display (_ "
-V, --version display version information and exit")) -V, --version display version information and exit"))
@ -234,7 +238,11 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
(alist-cons 'dry-run? #t result))) (alist-cons 'dry-run? #t result)))
(option '(#\b "bootstrap") #f #f (option '(#\b "bootstrap") #f #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'bootstrap? #t result))))) (alist-cons 'bootstrap? #t result)))
(option '(#\I "list-installed") #f #t
(lambda (opt name arg result)
(cons `(query list-installed ,(or arg ""))
result)))))
;;; ;;;
@ -302,6 +310,84 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
(() (()
(leave (_ "~a: package not found~%") request))))) (leave (_ "~a: package not found~%") request)))))
(define (process-actions opts)
;; Process any install/remove/upgrade action from OPTS.
(let* ((dry-run? (assoc-ref opts 'dry-run?))
(profile (assoc-ref opts 'profile))
(install (filter-map (match-lambda
(('install . (? store-path?))
#f)
(('install . package)
(find-package package))
(_ #f))
opts))
(drv (filter-map (match-lambda
((name version sub-drv
(? package? package))
(package-derivation %store package))
(_ #f))
install))
(install* (append
(filter-map (match-lambda
(('install . (? store-path? path))
`(,(store-path-package-name path)
#f #f ,path))
(_ #f))
opts)
(map (lambda (tuple drv)
(match tuple
((name version sub-drv _)
(let ((output-path
(derivation-path->output-path
drv sub-drv)))
`(,name ,version ,sub-drv ,output-path)))))
install drv)))
(remove (filter-map (match-lambda
(('remove . package)
package)
(_ #f))
opts))
(packages (append install*
(fold alist-delete
(manifest-packages
(profile-manifest profile))
remove))))
(show-what-to-build drv dry-run?)
(or dry-run?
(and (build-derivations %store drv)
(let* ((prof-drv (profile-derivation %store packages))
(prof (derivation-path->output-path prof-drv))
(number (latest-profile-number profile))
(name (format #f "~a/~a-~a-link"
(dirname profile)
(basename profile) (+ 1 number))))
(and (build-derivations %store (list prof-drv))
(begin
(symlink prof name)
(when (file-exists? profile)
(delete-file profile))
(symlink name profile))))))))
(define (process-query opts)
;; Process any query specified by OPTS. Return #t when a query was
;; actually processed, #f otherwise.
(let ((profile (assoc-ref opts 'profile)))
(match (assoc-ref opts 'query)
(('list-installed regexp)
(let* ((regexp (and regexp (make-regexp regexp)))
(manifest (profile-manifest profile))
(installed (manifest-packages manifest)))
(for-each (match-lambda
((name version output path)
(when (or (not regexp)
(regexp-exec regexp name))
(format #t "~a\t~a\t~a\t~a~%"
name (or version "?") output path))))
installed)))
(_ #f))))
(setlocale LC_ALL "") (setlocale LC_ALL "")
(textdomain "guix") (textdomain "guix")
(setvbuf (current-output-port) _IOLBF) (setvbuf (current-output-port) _IOLBF)
@ -309,69 +395,14 @@ Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
(let ((opts (parse-options))) (let ((opts (parse-options)))
(with-error-handling (with-error-handling
(parameterize ((%guile-for-build (or (process-query opts)
(package-derivation %store (parameterize ((%guile-for-build
(if (assoc-ref opts 'bootstrap?) (package-derivation %store
(@@ (distro packages base) (if (assoc-ref opts 'bootstrap?)
%bootstrap-guile) (@@ (distro packages base)
guile-2.0)))) %bootstrap-guile)
(let* ((dry-run? (assoc-ref opts 'dry-run?)) guile-2.0))))
(profile (assoc-ref opts 'profile)) (process-actions opts))))))
(install (filter-map (match-lambda
(('install . (? store-path?))
#f)
(('install . package)
(find-package package))
(_ #f))
opts))
(drv (filter-map (match-lambda
((name version sub-drv
(? package? package))
(package-derivation %store package))
(_ #f))
install))
(install* (append
(filter-map (match-lambda
(('install . (? store-path? path))
`(,(store-path-package-name path)
#f #f ,path))
(_ #f))
opts)
(map (lambda (tuple drv)
(match tuple
((name version sub-drv _)
(let ((output-path
(derivation-path->output-path
drv sub-drv)))
`(,name ,version ,sub-drv ,output-path)))))
install drv)))
(remove (filter-map (match-lambda
(('remove . package)
package)
(_ #f))
opts))
(packages (append install*
(fold alist-delete
(manifest-packages
(profile-manifest profile))
remove))))
(show-what-to-build drv dry-run?)
(or dry-run?
(and (build-derivations %store drv)
(let* ((prof-drv (profile-derivation %store packages))
(prof (derivation-path->output-path prof-drv))
(number (latest-profile-number profile))
(name (format #f "~a/~a-~a-link"
(dirname profile)
(basename profile) (+ 1 number))))
(and (build-derivations %store (list prof-drv))
(begin
(symlink prof name)
(when (file-exists? profile)
(delete-file profile))
(symlink name profile)))))))))))
;; Local Variables: ;; Local Variables:
;; eval: (put 'guard 'scheme-indent-function 1) ;; eval: (put 'guard 'scheme-indent-function 1)

14
tests/guix-package.sh
View File

@ -36,6 +36,20 @@ guix-package -b -p "$profile" \
test -L "$profile-2-link" test -L "$profile-2-link"
test -f "$profile/bin/make" && test -f "$profile/bin/guile" test -f "$profile/bin/make" && test -f "$profile/bin/guile"
# Check whether `--list-installed' works.
# XXX: Change the tests when `--install' properly extracts the package
# name and version string.
installed="`guix-package -p "$profile" --list-installed | cut -f1 | xargs echo | sort`"
case "x$installed" in
"guile* make*") true;;
"make* guile*") true;;
"*") false;;
esac
test "`guix-package -p "$profile" -I 'g.*e' | cut -f1`" = "guile-bootstrap-2.0"
# Remove a package.
guix-package -b -p "$profile" -r "guile-bootstrap-2.0" guix-package -b -p "$profile" -r "guile-bootstrap-2.0"
test -L "$profile-3-link" test -L "$profile-3-link"
test -f "$profile/bin/make" && ! test -f "$profile/bin/guile" test -f "$profile/bin/make" && ! test -f "$profile/bin/guile"