mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2025-01-27 04:59:27 -05:00
guix package: Move a couple of procedures out of sight.
* guix/scripts/package.scm (ensure-default-profile, process-query): New procedures, moved from... (guix-package): ... here.
This commit is contained in:
Ludovic Courtès
parent
0993f94267
commit
2cc10077f3
1 changed files with 152 additions and 153 deletions
|
|
@ -94,6 +94,53 @@ (define (user-friendly-profile profile)
|
||||||
%user-profile-directory
|
%user-profile-directory
|
||||||
profile))
|
profile))
|
||||||
|
|
||||||
|
(define (ensure-default-profile)
|
||||||
|
"Ensure the default profile symlink and directory exist and are writable."
|
||||||
|
|
||||||
|
(define (rtfm)
|
||||||
|
(format (current-error-port)
|
||||||
|
(_ "Try \"info '(guix) Invoking guix package'\" for \
|
||||||
|
more information.~%"))
|
||||||
|
(exit 1))
|
||||||
|
|
||||||
|
;; Create ~/.guix-profile if it doesn't exist yet.
|
||||||
|
(when (and %user-profile-directory
|
||||||
|
%current-profile
|
||||||
|
(not (false-if-exception
|
||||||
|
(lstat %user-profile-directory))))
|
||||||
|
(symlink %current-profile %user-profile-directory))
|
||||||
|
|
||||||
|
(let ((s (stat %profile-directory #f)))
|
||||||
|
;; Attempt to create /…/profiles/per-user/$USER if needed.
|
||||||
|
(unless (and s (eq? 'directory (stat:type s)))
|
||||||
|
(catch 'system-error
|
||||||
|
(lambda ()
|
||||||
|
(mkdir-p %profile-directory))
|
||||||
|
(lambda args
|
||||||
|
;; Often, we cannot create %PROFILE-DIRECTORY because its
|
||||||
|
;; parent directory is root-owned and we're running
|
||||||
|
;; unprivileged.
|
||||||
|
(format (current-error-port)
|
||||||
|
(_ "error: while creating directory `~a': ~a~%")
|
||||||
|
%profile-directory
|
||||||
|
(strerror (system-error-errno args)))
|
||||||
|
(format (current-error-port)
|
||||||
|
(_ "Please create the `~a' directory, with you as the owner.~%")
|
||||||
|
%profile-directory)
|
||||||
|
(rtfm))))
|
||||||
|
|
||||||
|
;; Bail out if it's not owned by the user.
|
||||||
|
(unless (or (not s) (= (stat:uid s) (getuid)))
|
||||||
|
(format (current-error-port)
|
||||||
|
(_ "error: directory `~a' is not owned by you~%")
|
||||||
|
%profile-directory)
|
||||||
|
(format (current-error-port)
|
||||||
|
(_ "Please change the owner of `~a' to user ~s.~%")
|
||||||
|
%profile-directory (or (getenv "USER")
|
||||||
|
(getenv "LOGNAME")
|
||||||
|
(getuid)))
|
||||||
|
(rtfm))))
|
||||||
|
|
||||||
(define (delete-generations store profile generations)
|
(define (delete-generations store profile generations)
|
||||||
"Delete GENERATIONS from PROFILE.
|
"Delete GENERATIONS from PROFILE.
|
||||||
GENERATIONS is a list of generation numbers."
|
GENERATIONS is a list of generation numbers."
|
||||||
|
|
@ -534,6 +581,111 @@ (define absolute
|
||||||
|
|
||||||
(add-indirect-root store absolute))
|
(add-indirect-root store absolute))
|
||||||
|
|
||||||
|
(define (process-query opts)
|
||||||
|
"Process any query specified by OPTS. Return #t when a query was actually
|
||||||
|
processed, #f otherwise."
|
||||||
|
(let* ((profiles (match (filter-map (match-lambda
|
||||||
|
(('profile . p) p)
|
||||||
|
(_ #f))
|
||||||
|
opts)
|
||||||
|
(() (list %current-profile))
|
||||||
|
(lst lst)))
|
||||||
|
(profile (match profiles
|
||||||
|
((head tail ...) head))))
|
||||||
|
(match (assoc-ref opts 'query)
|
||||||
|
(('list-generations pattern)
|
||||||
|
(define (list-generation number)
|
||||||
|
(unless (zero? number)
|
||||||
|
(display-generation profile number)
|
||||||
|
(display-profile-content profile number)
|
||||||
|
(newline)))
|
||||||
|
|
||||||
|
(cond ((not (file-exists? profile)) ; XXX: race condition
|
||||||
|
(raise (condition (&profile-not-found-error
|
||||||
|
(profile profile)))))
|
||||||
|
((string-null? pattern)
|
||||||
|
(for-each list-generation (profile-generations profile)))
|
||||||
|
((matching-generations pattern profile)
|
||||||
|
=>
|
||||||
|
(lambda (numbers)
|
||||||
|
(if (null-list? numbers)
|
||||||
|
(exit 1)
|
||||||
|
(leave-on-EPIPE
|
||||||
|
(for-each list-generation numbers)))))
|
||||||
|
(else
|
||||||
|
(leave (_ "invalid syntax: ~a~%")
|
||||||
|
pattern)))
|
||||||
|
#t)
|
||||||
|
|
||||||
|
(('list-installed regexp)
|
||||||
|
(let* ((regexp (and regexp (make-regexp* regexp)))
|
||||||
|
(manifest (profile-manifest profile))
|
||||||
|
(installed (manifest-entries manifest)))
|
||||||
|
(leave-on-EPIPE
|
||||||
|
(for-each (match-lambda
|
||||||
|
(($ <manifest-entry> 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))))
|
||||||
|
|
||||||
|
;; Show most recently installed packages last.
|
||||||
|
(reverse installed)))
|
||||||
|
#t))
|
||||||
|
|
||||||
|
(('list-available regexp)
|
||||||
|
(let* ((regexp (and regexp (make-regexp* regexp)))
|
||||||
|
(available (fold-packages
|
||||||
|
(lambda (p r)
|
||||||
|
(let ((n (package-name p)))
|
||||||
|
(if (supported-package? p)
|
||||||
|
(if regexp
|
||||||
|
(if (regexp-exec regexp n)
|
||||||
|
(cons p r)
|
||||||
|
r)
|
||||||
|
(cons p r))
|
||||||
|
r)))
|
||||||
|
'())))
|
||||||
|
(leave-on-EPIPE
|
||||||
|
(for-each (lambda (p)
|
||||||
|
(format #t "~a\t~a\t~a\t~a~%"
|
||||||
|
(package-name p)
|
||||||
|
(package-version p)
|
||||||
|
(string-join (package-outputs p) ",")
|
||||||
|
(location->string (package-location p))))
|
||||||
|
(sort available
|
||||||
|
(lambda (p1 p2)
|
||||||
|
(string<? (package-name p1)
|
||||||
|
(package-name p2))))))
|
||||||
|
#t))
|
||||||
|
|
||||||
|
(('search regexp)
|
||||||
|
(let ((regexp (make-regexp* regexp regexp/icase)))
|
||||||
|
(leave-on-EPIPE
|
||||||
|
(for-each (cute package->recutils <> (current-output-port))
|
||||||
|
(find-packages-by-description regexp)))
|
||||||
|
#t))
|
||||||
|
|
||||||
|
(('show requested-name)
|
||||||
|
(let-values (((name version)
|
||||||
|
(package-name->name+version requested-name)))
|
||||||
|
(leave-on-EPIPE
|
||||||
|
(for-each (cute package->recutils <> (current-output-port))
|
||||||
|
(find-packages-by-name name version)))
|
||||||
|
#t))
|
||||||
|
|
||||||
|
(('search-paths kind)
|
||||||
|
(let* ((manifests (map profile-manifest profiles))
|
||||||
|
(entries (append-map manifest-entries manifests))
|
||||||
|
(profiles (map user-friendly-profile profiles))
|
||||||
|
(settings (search-path-environment-variables entries profiles
|
||||||
|
(const #f)
|
||||||
|
#:kind kind)))
|
||||||
|
(format #t "~{~a~%~}" settings)
|
||||||
|
#t))
|
||||||
|
|
||||||
|
(_ #f))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Entry point.
|
;;; Entry point.
|
||||||
|
|
@ -546,54 +698,6 @@ (define (handle-argument arg result arg-handler)
|
||||||
(arg-handler arg result)
|
(arg-handler arg result)
|
||||||
(leave (_ "~A: extraneous argument~%") arg)))
|
(leave (_ "~A: extraneous argument~%") arg)))
|
||||||
|
|
||||||
(define (ensure-default-profile)
|
|
||||||
;; Ensure the default profile symlink and directory exist and are
|
|
||||||
;; writable.
|
|
||||||
|
|
||||||
(define (rtfm)
|
|
||||||
(format (current-error-port)
|
|
||||||
(_ "Try \"info '(guix) Invoking guix package'\" for \
|
|
||||||
more information.~%"))
|
|
||||||
(exit 1))
|
|
||||||
|
|
||||||
;; Create ~/.guix-profile if it doesn't exist yet.
|
|
||||||
(when (and %user-profile-directory
|
|
||||||
%current-profile
|
|
||||||
(not (false-if-exception
|
|
||||||
(lstat %user-profile-directory))))
|
|
||||||
(symlink %current-profile %user-profile-directory))
|
|
||||||
|
|
||||||
(let ((s (stat %profile-directory #f)))
|
|
||||||
;; Attempt to create /…/profiles/per-user/$USER if needed.
|
|
||||||
(unless (and s (eq? 'directory (stat:type s)))
|
|
||||||
(catch 'system-error
|
|
||||||
(lambda ()
|
|
||||||
(mkdir-p %profile-directory))
|
|
||||||
(lambda args
|
|
||||||
;; Often, we cannot create %PROFILE-DIRECTORY because its
|
|
||||||
;; parent directory is root-owned and we're running
|
|
||||||
;; unprivileged.
|
|
||||||
(format (current-error-port)
|
|
||||||
(_ "error: while creating directory `~a': ~a~%")
|
|
||||||
%profile-directory
|
|
||||||
(strerror (system-error-errno args)))
|
|
||||||
(format (current-error-port)
|
|
||||||
(_ "Please create the `~a' directory, with you as the owner.~%")
|
|
||||||
%profile-directory)
|
|
||||||
(rtfm))))
|
|
||||||
|
|
||||||
;; Bail out if it's not owned by the user.
|
|
||||||
(unless (or (not s) (= (stat:uid s) (getuid)))
|
|
||||||
(format (current-error-port)
|
|
||||||
(_ "error: directory `~a' is not owned by you~%")
|
|
||||||
%profile-directory)
|
|
||||||
(format (current-error-port)
|
|
||||||
(_ "Please change the owner of `~a' to user ~s.~%")
|
|
||||||
%profile-directory (or (getenv "USER")
|
|
||||||
(getenv "LOGNAME")
|
|
||||||
(getuid)))
|
|
||||||
(rtfm))))
|
|
||||||
|
|
||||||
(define (process-actions opts)
|
(define (process-actions opts)
|
||||||
;; Process any install/remove/upgrade action from OPTS.
|
;; Process any install/remove/upgrade action from OPTS.
|
||||||
|
|
||||||
|
|
@ -703,111 +807,6 @@ (define (build-and-use-profile manifest)
|
||||||
#:dry-run? dry-run?)
|
#:dry-run? dry-run?)
|
||||||
(build-and-use-profile new))))))
|
(build-and-use-profile new))))))
|
||||||
|
|
||||||
(define (process-query opts)
|
|
||||||
;; Process any query specified by OPTS. Return #t when a query was
|
|
||||||
;; actually processed, #f otherwise.
|
|
||||||
(let* ((profiles (match (filter-map (match-lambda
|
|
||||||
(('profile . p) p)
|
|
||||||
(_ #f))
|
|
||||||
opts)
|
|
||||||
(() (list %current-profile))
|
|
||||||
(lst lst)))
|
|
||||||
(profile (match profiles
|
|
||||||
((head tail ...) head))))
|
|
||||||
(match (assoc-ref opts 'query)
|
|
||||||
(('list-generations pattern)
|
|
||||||
(define (list-generation number)
|
|
||||||
(unless (zero? number)
|
|
||||||
(display-generation profile number)
|
|
||||||
(display-profile-content profile number)
|
|
||||||
(newline)))
|
|
||||||
|
|
||||||
(cond ((not (file-exists? profile)) ; XXX: race condition
|
|
||||||
(raise (condition (&profile-not-found-error
|
|
||||||
(profile profile)))))
|
|
||||||
((string-null? pattern)
|
|
||||||
(for-each list-generation (profile-generations profile)))
|
|
||||||
((matching-generations pattern profile)
|
|
||||||
=>
|
|
||||||
(lambda (numbers)
|
|
||||||
(if (null-list? numbers)
|
|
||||||
(exit 1)
|
|
||||||
(leave-on-EPIPE
|
|
||||||
(for-each list-generation numbers)))))
|
|
||||||
(else
|
|
||||||
(leave (_ "invalid syntax: ~a~%")
|
|
||||||
pattern)))
|
|
||||||
#t)
|
|
||||||
|
|
||||||
(('list-installed regexp)
|
|
||||||
(let* ((regexp (and regexp (make-regexp* regexp)))
|
|
||||||
(manifest (profile-manifest profile))
|
|
||||||
(installed (manifest-entries manifest)))
|
|
||||||
(leave-on-EPIPE
|
|
||||||
(for-each (match-lambda
|
|
||||||
(($ <manifest-entry> 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))))
|
|
||||||
|
|
||||||
;; Show most recently installed packages last.
|
|
||||||
(reverse installed)))
|
|
||||||
#t))
|
|
||||||
|
|
||||||
(('list-available regexp)
|
|
||||||
(let* ((regexp (and regexp (make-regexp* regexp)))
|
|
||||||
(available (fold-packages
|
|
||||||
(lambda (p r)
|
|
||||||
(let ((n (package-name p)))
|
|
||||||
(if (supported-package? p)
|
|
||||||
(if regexp
|
|
||||||
(if (regexp-exec regexp n)
|
|
||||||
(cons p r)
|
|
||||||
r)
|
|
||||||
(cons p r))
|
|
||||||
r)))
|
|
||||||
'())))
|
|
||||||
(leave-on-EPIPE
|
|
||||||
(for-each (lambda (p)
|
|
||||||
(format #t "~a\t~a\t~a\t~a~%"
|
|
||||||
(package-name p)
|
|
||||||
(package-version p)
|
|
||||||
(string-join (package-outputs p) ",")
|
|
||||||
(location->string (package-location p))))
|
|
||||||
(sort available
|
|
||||||
(lambda (p1 p2)
|
|
||||||
(string<? (package-name p1)
|
|
||||||
(package-name p2))))))
|
|
||||||
#t))
|
|
||||||
|
|
||||||
(('search regexp)
|
|
||||||
(let ((regexp (make-regexp* regexp regexp/icase)))
|
|
||||||
(leave-on-EPIPE
|
|
||||||
(for-each (cute package->recutils <> (current-output-port))
|
|
||||||
(find-packages-by-description regexp)))
|
|
||||||
#t))
|
|
||||||
|
|
||||||
(('show requested-name)
|
|
||||||
(let-values (((name version)
|
|
||||||
(package-name->name+version requested-name)))
|
|
||||||
(leave-on-EPIPE
|
|
||||||
(for-each (cute package->recutils <> (current-output-port))
|
|
||||||
(find-packages-by-name name version)))
|
|
||||||
#t))
|
|
||||||
|
|
||||||
(('search-paths kind)
|
|
||||||
(let* ((manifests (map profile-manifest profiles))
|
|
||||||
(entries (append-map manifest-entries manifests))
|
|
||||||
(profiles (map user-friendly-profile profiles))
|
|
||||||
(settings (search-path-environment-variables entries profiles
|
|
||||||
(const #f)
|
|
||||||
#:kind kind)))
|
|
||||||
(format #t "~{~a~%~}" settings)
|
|
||||||
#t))
|
|
||||||
|
|
||||||
(_ #f))))
|
|
||||||
|
|
||||||
(let ((opts (parse-command-line args %options (list %default-options #f)
|
(let ((opts (parse-command-line args %options (list %default-options #f)
|
||||||
#:argument-handler handle-argument)))
|
#:argument-handler handle-argument)))
|
||||||
(with-error-handling
|
(with-error-handling
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue