;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
#:use-module ((guix licenses)
#:select (license? license-name license-uri))
#:use-module ((guix build syscalls)
- #:select (free-disk-space terminal-columns
- terminal-rows))
+ #:select (free-disk-space terminal-columns terminal-rows
+ with-file-lock/no-wait))
#:use-module ((guix build utils)
;; XXX: All we need are the bindings related to
;; '&invoke-error'. However, to work around the bug described
;; in 5d669883ecc104403c5d3ba7d172e9c02234577c, #:hide
;; unwanted bindings instead of #:select'ing the needed
;; bindings.
- #:hide (package-name->name+version))
+ #:hide (package-name->name+version
+ ;; Avoid "overrides core binding" warning.
+ delete))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 regex)
+ #:autoload (ice-9 popen) (open-pipe* close-pipe)
#:autoload (system base compile) (compile-file)
#:autoload (system repl repl) (start-repl)
#:autoload (system repl debug) (make-debug stack->vector)
string->number*
size->number
show-derivation-outputs
+ build-notifier
show-what-to-build
show-what-to-build*
show-manifest-transaction
read/eval
read/eval-package-expression
check-available-space
+ indented-string
fill-paragraph
%text-width
texi->plain-text
package-specification->name+version+output
supports-hyperlinks?
+ hyperlink
file-hyperlink
location->hyperlink
package-relevance
display-search-results
+ with-profile-lock
string->generations
string->duration
matching-generations
(previous frame))
(if (not frame)
previous
- (if (frame-source frame)
+
+ ;; On Guile 3, the latest frame with source may be that of
+ ;; 'raise-exception' in boot-9.scm. Skip it.
+ (if (and (frame-source frame)
+ (not (eq? 'raise-exception (frame-procedure-name frame))))
frame
(loop (frame-previous frame) frame)))))
;; Give 'load' an absolute file name so that it doesn't try to
;; search for FILE in %LOAD-PATH. Note: use 'load', not
- ;; 'primitive-load', so that FILE is compiled, which then allows us
- ;; to provide better error reporting with source line numbers.
+ ;; 'primitive-load', so that FILE is compiled, which then allows
+ ;; us to provide better error reporting with source line numbers.
(load (canonicalize-path file)))
(const #f))))))
(lambda _
(format (current-error-port) (G_ "~amissing closing parenthesis~%")
location))
(apply throw args)))
- (('syntax-error proc message properties form . rest)
+ (('syntax-error proc message properties form subform . rest)
(let ((loc (source-properties->location properties)))
- (report-error loc (G_ "~a~%") message)))
+ (report-error loc (G_ "~s: ~a~%")
+ (or subform form) message)))
(('unbound-variable _ ...)
(report-unbound-variable-error args #:frame frame))
(((or 'srfi-34 '%exception) obj)
"Display version information for COMMAND and `(exit 0)'."
(simple-format #t "~a (~a) ~a~%"
command %guix-package-name %guix-version)
- (format #t "Copyright ~a 2019 ~a"
+ (format #t "Copyright ~a 2020 ~a"
;; TRANSLATORS: Translate "(C)" to the copyright symbol
;; (C-in-a-circle), if this symbol is available in the user's
;; locale. Otherwise, do not translate "(C)"; leave it as-is. */
\"1MiB\", to a number of bytes. Raise an error if STR could not be
interpreted."
(define unit-pos
- (string-rindex str char-set:digit))
+ (string-rindex str
+ (char-set-union (char-set #\.) char-set:digit)))
(define unit
(and unit-pos (substring str (+ 1 unit-pos))))
(gettext (condition-message c) %gettext-domain))
(display-hint (condition-fix-hint c))
(exit 1))
+
+ ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are
+ ;; compound and include a '&message'. However, that message only
+ ;; contains the format string. Thus, special-case it here to
+ ;; avoid displaying a bare format string.
+ ((cond-expand
+ (guile-3
+ ((exception-predicate &exception-with-kind-and-args) c))
+ (else #f))
+ (raise c))
+
((message-condition? c)
;; Normally '&message' error conditions have an i18n'd message.
(leave (G_ "~a~%")
(apply format #f format-string format-args))))))
(define-syntax-rule (leave-on-EPIPE exp ...)
- "Run EXP... in a context when EPIPE errors are caught and lead to 'exit'
+ "Run EXP... in a context where EPIPE errors are caught and lead to 'exit'
with successful exit code. This is useful when writing to the standard output
may lead to EPIPE, because the standard output is piped through 'head' or
similar."
derivations listed in DRV using MODE, a 'build-mode' value. The elements of
DRV can be either derivations or derivation inputs.
-Return #t if there's something to build, #f otherwise. When USE-SUBSTITUTES?,
-check and report what is prerequisites are available for download."
+Return two values: a Boolean indicating whether there's something to build,
+and a Boolean indicating whether there's something to download. When
+USE-SUBSTITUTES?, check and report what is prerequisites are available for
+download."
(define inputs
(map (match-lambda
((? derivation? drv) (derivation-input drv))
drv))
(define substitutable-info
- ;; Call 'substitutation-oracle' upfront so we don't end up launching the
+ ;; Call 'substitution-oracle' upfront so we don't end up launching the
;; substituter many times. This makes a big difference, especially when
;; DRV is a long list as is the case with 'guix environment'.
(if use-substitutes?
colorize-store-file-name
identity))
- (let*-values (((build download)
+ (let*-values (((build/full download)
(derivation-build-plan store inputs
#:mode mode
#:substitutable-info
#:hook ,hook
#:build ,(cons file build))))))))
'(#:graft () #:hook () #:build ())
- build)
+ build/full)
((#:graft graft #:hook hook #:build build)
(values graft hook build)))))
(define installed-size
(check-available-space installed-size)
- (pair? build)))
+ (values (pair? build/full) (pair? download))))
(define show-what-to-build*
(store-lift show-what-to-build))
+(define* (build-notifier #:key (dry-run? #f) (use-substitutes? #t))
+ "Return a procedure suitable for 'with-build-handler' that, when
+'build-things' is called, invokes 'show-what-to-build' to display the build
+plan. When DRY-RUN? is true, the 'with-build-handler' form returns without
+any build happening."
+ (define not-comma
+ (char-set-complement (char-set #\,)))
+
+ (define (read-derivation-from-file* item)
+ (catch 'system-error
+ (lambda ()
+ (read-derivation-from-file item))
+ (const #f)))
+
+ (lambda (continue store things mode)
+ (define inputs
+ ;; List of derivation inputs to build. Filter out non-existent '.drv'
+ ;; files because the daemon transparently tries to substitute them.
+ (filter-map (match-lambda
+ (((? derivation-path? drv) . output)
+ (let ((drv (read-derivation-from-file* drv))
+ (outputs (string-tokenize output not-comma)))
+ (and drv (derivation-input drv outputs))))
+ ((? derivation-path? drv)
+ (and=> (read-derivation-from-file* drv)
+ derivation-input))
+ (_
+ #f))
+ things))
+
+ (let-values (((build? download?)
+ (show-what-to-build store inputs
+ #:dry-run? dry-run?
+ #:use-substitutes? use-substitutes?
+ #:mode mode)))
+
+ (unless (and (or build? download?)
+ dry-run?)
+ (continue #t)))))
+
(define (right-arrow port)
"Return either a string containing the 'RIGHT ARROW' character, or an ASCII
replacement if PORT is not Unicode-capable."
(lambda (key . args)
"->"))))
+(define* (tabulate rows #:key (initial-indent 0) (max-width 25)
+ (inter-column " "))
+ "Return a list of strings where each string is a tabulated representation of
+an element of ROWS. All the ROWS must be lists of the same number of cells.
+
+Add INITIAL-INDENT white space at the beginning of each row. Ensure that
+columns are at most MAX-WIDTH characters wide. Use INTER-COLUMN as a
+separator between subsequent columns."
+ (define column-widths
+ ;; List of column widths.
+ (let loop ((rows rows)
+ (widths '()))
+ (match rows
+ (((? null?) ...)
+ (reverse widths))
+ (((column rest ...) ...)
+ (loop rest
+ (cons (min (apply max (map string-length column))
+ max-width)
+ widths))))))
+
+ (define indent
+ (make-string initial-indent #\space))
+
+ (define (string-pad-right* str len)
+ (if (> (string-length str) len)
+ str
+ (string-pad-right str len)))
+
+ (map (lambda (row)
+ (string-trim-right
+ (string-append indent
+ (string-join
+ (map string-pad-right* row column-widths)
+ inter-column))))
+ rows))
+
(define* (show-manifest-transaction store manifest transaction
#:key dry-run?)
"Display what will/would be installed/removed from MANIFEST by TRANSACTION."
- (define (package-strings name version output item)
- (map (lambda (name version output item)
- (format #f " ~a~:[:~a~;~*~]\t~a\t~a"
- name
- (equal? output "out") output version
- (if (package? item)
- (package-output store item output)
- item)))
- name version output item))
+ (define (package-strings names versions outputs)
+ (tabulate (zip (map (lambda (name output)
+ (if (string=? output "out")
+ name
+ (string-append name ":" output)))
+ names outputs)
+ versions)
+ #:initial-indent 3))
(define → ;an arrow that can be represented on stderr
(right-arrow (current-error-port)))
- (define (upgrade-string name old-version new-version output item)
- (format #f " ~a~:[:~a~;~*~]\t~a ~a ~a\t~a"
- name (equal? output "out") output
- old-version → new-version
- (if (package? item)
- (package-output store item output)
- item)))
+ (define (upgrade-string names old-version new-version outputs)
+ (tabulate (zip (map (lambda (name output)
+ (if (string=? output "out")
+ name
+ (string-append name ":" output)))
+ names outputs)
+ (map (lambda (old new)
+ (if (string=? old new)
+ (G_ "(dependencies or package changed)")
+ (string-append old " " → " " new)))
+ old-version new-version))
+ #:initial-indent 3))
(let-values (((remove install upgrade downgrade)
(manifest-transaction-effects manifest transaction)))
(match remove
((($ <manifest-entry> name version output item) ..1)
(let ((len (length name))
- (remove (package-strings name version output item)))
+ (remove (package-strings name version output)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be removed:~%~{~a~%~}~%"
(((($ <manifest-entry> name old-version)
. ($ <manifest-entry> _ new-version output item)) ..1)
(let ((len (length name))
- (downgrade (map upgrade-string
- name old-version new-version output item)))
+ (downgrade (upgrade-string name old-version new-version
+ output)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be downgraded:~%~{~a~%~}~%"
(((($ <manifest-entry> name old-version)
. ($ <manifest-entry> _ new-version output item)) ..1)
(let ((len (length name))
- (upgrade (map upgrade-string
- name old-version new-version output item)))
+ (upgrade (upgrade-string name
+ old-version new-version
+ output)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be upgraded:~%~{~a~%~}~%"
(match install
((($ <manifest-entry> name version output item _) ..1)
(let ((len (length name))
- (install (package-strings name version output item)))
+ (install (package-strings name version output)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be installed:~%~{~a~%~}~%"
(lambda ()
body ...)))))
+(define* (indented-string str indent
+ #:key (initial-indent? #t))
+ "Return STR with each newline preceded by INDENT spaces. When
+INITIAL-INDENT? is true, the first line is also indented."
+ (define indent-string
+ (make-list indent #\space))
+
+ (list->string
+ (string-fold-right (lambda (chr result)
+ (if (eqv? chr #\newline)
+ (cons chr (append indent-string result))
+ (cons chr result)))
+ '()
+ (if initial-indent?
+ (string-append (list->string indent-string) str)
+ str))))
+
(define* (fill-paragraph str width #:optional (column 0))
"Fill STR such that each line contains at most WIDTH characters, assuming
that the first character is at COLUMN.
;;;
(define %text-width
- (make-parameter (terminal-columns)))
-
-(set! (@@ (texinfo plain-text) wrap*)
- ;; XXX: Monkey patch this private procedure to let 'package->recutils'
- ;; parameterize the fill of description field correctly.
- (lambda strings
- (let ((indent (fluid-ref (@@ (texinfo plain-text) *indent*))))
- (fill-string (string-concatenate strings)
- #:line-width (%text-width) #:initial-indent indent
- #:subsequent-indent indent))))
+ ;; '*line-width*' was introduced in Guile 2.2.7/3.0.1. On older versions of
+ ;; Guile, monkey-patch 'wrap*' below.
+ (if (defined? '*line-width*)
+ (let ((parameter (fluid->parameter *line-width*)))
+ (parameter (terminal-columns))
+ parameter)
+ (make-parameter (terminal-columns))))
+
+(unless (defined? '*line-width*) ;Guile < 2.2.7
+ (set! (@@ (texinfo plain-text) wrap*)
+ ;; XXX: Monkey patch this private procedure to let 'package->recutils'
+ ;; parameterize the fill of description field correctly.
+ (lambda strings
+ (let ((indent (fluid-ref (@@ (texinfo plain-text) *indent*))))
+ (fill-string (string-concatenate strings)
+ #:line-width (%text-width) #:initial-indent indent
+ #:subsequent-indent indent)))))
(define (texi->plain-text str)
"Return a plain-text representation of texinfo fragment STR."
(string-append "\x1b]8;;" uri "\x1b\\"
text "\x1b]8;;\x1b\\"))
-(define (supports-hyperlinks? port)
+(define* (supports-hyperlinks? #:optional (port (current-output-port)))
"Return true if PORT is a terminal that supports hyperlink escapes."
;; Note that terminals are supposed to ignore OSC escapes they don't
;; understand (this is the case of xterm as of version 349, for instance.)
(,(lambda (package)
(filter (lambda (output)
(not (member output
- ;; Some common outpus shared by many packages.
+ ;; Some common outputs shared by many packages.
'("out" "doc" "debug" "lib" "include" "bin"))))
(package-outputs package)))
. 1)
zero means that PACKAGE does not match any of REGEXPS."
(relevance package regexps %package-metrics))
+(define (call-with-paginated-output-port proc)
+ (if (isatty?* (current-output-port))
+ ;; Set 'LESS' so that 'less' exits if everything fits on the screen (F),
+ ;; lets ANSI escapes through (r), does not send the termcap
+ ;; initialization string (X).
+ (let ((pager (with-environment-variables `(("LESS"
+ ,(or (getenv "LESS") "FrX")))
+ (open-pipe* OPEN_WRITE
+ (or (getenv "GUIX_PAGER") (getenv "PAGER")
+ "less")))))
+ (dynamic-wind
+ (const #t)
+ (lambda () (proc pager))
+ (lambda () (close-pipe pager))))
+ (proc (current-output-port))))
+
+(define-syntax-rule (with-paginated-output-port port exp ...)
+ "Evaluate EXP... with PORT bound to a port that talks to the pager if
+standard output is a tty, or with PORT set to the current output port."
+ (call-with-paginated-output-port (lambda (port) exp ...)))
+
(define* (display-search-results matches port
#:key
(command "guix search")
(define (line-count str)
(string-count str #\newline))
- (let loop ((matches matches))
- (match matches
- (((package . score) rest ...)
- (let* ((links? (supports-hyperlinks? port))
- (text (call-with-output-string
- (lambda (port)
- (print package port
- #:hyperlinks? links?
- #:extra-fields
- `((relevance . ,score)))))))
- (if (and max-rows
- (> (port-line port) first-line) ;print at least one result
- (> (+ 4 (line-count text) (port-line port))
- max-rows))
- (unless (null? rest)
- (display-hint (format #f (G_ "Run @code{~a ... | less} \
-to view all the results.")
- command)))
- (begin
- (display text port)
- (loop rest)))))
- (()
- #t))))
+ (with-paginated-output-port paginated
+ (let loop ((matches matches))
+ (match matches
+ (((package . score) rest ...)
+ (let* ((links? (supports-hyperlinks? port)))
+ (print package paginated
+ #:hyperlinks? links?
+ #:extra-fields `((relevance . ,score)))
+ (loop rest)))
+ (()
+ #t)))))
\f
(define (string->generations str)
(define (display-generation profile number)
"Display a one-line summary of generation NUMBER of PROFILE."
(unless (zero? number)
- (let ((header (format #f (highlight (G_ "Generation ~a\t~a")) number
- (date->string
- (time-utc->date
- (generation-time profile number))
- ;; TRANSLATORS: This is a format-string for date->string.
- ;; Please choose a format that corresponds to the
- ;; usual way of presenting dates in your locale.
- ;; See https://www.gnu.org/software/guile/manual/html_node/SRFI_002d19-Date-to-string.html
- ;; for details.
- (G_ "~b ~d ~Y ~T"))))
- (current (generation-number profile)))
+ (let* ((file (generation-file-name profile number))
+ (link (if (supports-hyperlinks?)
+ (cut file-hyperlink file <>)
+ identity))
+ (header (format #f (link (highlight (G_ "Generation ~a\t~a")))
+ number
+ (date->string
+ (time-utc->date
+ (generation-time profile number))
+ ;; TRANSLATORS: This is a format-string for date->string.
+ ;; Please choose a format that corresponds to the
+ ;; usual way of presenting dates in your locale.
+ ;; See https://www.gnu.org/software/guile/manual/html_node/SRFI_002d19-Date-to-string.html
+ ;; for details.
+ (G_ "~b ~d ~Y ~T"))))
+ (current (generation-number profile)))
(if (= number current)
;; TRANSLATORS: The word "current" here is an adjective for
;; "Generation", as in "current generation". Use the appropriate
(display-diff profile gen1 gen2))
+(define (profile-lock-handler profile errno . _)
+ "Handle failure to acquire PROFILE's lock."
+ ;; NFS mounts can return ENOLCK. When that happens, there's not much that
+ ;; can be done, so warn the user and keep going.
+ (if (= errno ENOLCK)
+ (warning (G_ "cannot lock profile ~a: ~a~%")
+ profile (strerror errno))
+ (leave (G_ "profile ~a is locked by another process~%")
+ profile)))
+
+(define profile-lock-file
+ (cut string-append <> ".lock"))
+
+(define-syntax-rule (with-profile-lock profile exp ...)
+ "Grab PROFILE's lock and evaluate EXP... Call 'leave' if the lock is
+already taken."
+ (with-file-lock/no-wait (profile-lock-file profile)
+ (cut profile-lock-handler profile <...>)
+ exp ...))
+
(define (display-profile-content profile number)
"Display the packages in PROFILE, generation NUMBER, in a human-readable
way."
(define (run-guix . args)
"Run the 'guix' command defined by command line ARGS.
Unlike 'guix-main', this procedure assumes that locale, i18n support,
-and signal handling has already been set up."
+and signal handling have already been set up."
(define option? (cut string-prefix? "-" <>))
;; The default %LOAD-EXTENSIONS includes the empty string, which doubles the
HCoop / jackhill / guix / guix.git / blobdiff