#:use-module (guix derivations)
#:use-module (guix build-system)
#:use-module (guix serialization)
- #:use-module ((guix licenses) #:select (license? license-name))
+ #: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
#:autoload (system base compile) (compile-file)
#:autoload (system repl repl) (start-repl)
#:autoload (system repl debug) (make-debug stack->vector)
+ #:autoload (web uri) (encode-and-join-uri-path)
#:use-module (texinfo)
#:use-module (texinfo plain-text)
#:use-module (texinfo string-utils)
package->recutils
package-specification->name+version+output
+ supports-hyperlinks?
+ hyperlink
+ file-hyperlink
+ location->hyperlink
+
relevance
package-relevance
display-search-results
+ with-profile-lock
string->generations
string->duration
matching-generations
roll-back*
switch-to-generation*
delete-generation*
+
+ %default-message-language
+ current-message-language
+
run-guix-command
run-guix
guix-main))
(report-error loc (G_ "~a~%") message)))
(('unbound-variable _ ...)
(report-unbound-variable-error args #:frame frame))
- (('srfi-34 obj)
+ (((or 'srfi-34 '%exception) obj)
(if (message-condition? obj)
(report-error (and (error-location? obj)
(error-location obj))
(warning loc (G_ "~a~%") message)))
(('unbound-variable _ ...)
(report-unbound-variable-error args))
- (('srfi-34 obj)
+ (((or 'srfi-34 '%exception) obj)
(if (message-condition? obj)
(warning (G_ "failed to load '~a': ~a~%")
file
report them in a user-friendly way."
(call-with-unbound-variable-handling (lambda () exp ...)))
+(define %default-message-language
+ ;; Default language to use for messages.
+ (make-parameter "en"))
+
+(define (current-message-language)
+ "Return the language used for messages according to the current locale.
+Return %DEFAULT-MESSAGE-LANGUAGE if that information could not be obtained. The
+result is an ISO-639-2 language code such as \"ar\", without the territory
+part."
+ (let ((locale (setlocale LC_MESSAGES)))
+ (match (string-index locale #\_)
+ (#f locale)
+ (index (string-take locale index)))))
+
(define (install-locale)
"Install the current locale settings."
(catch 'system-error
(match args
(('syntax-error proc message properties form . rest)
(report-error (G_ "syntax error: ~a~%") message))
- (('srfi-34 obj)
+ (((or 'srfi-34 '%exception) obj)
(if (message-condition? obj)
(report-error (G_ "~a~%")
(gettext (condition-message obj)
('profile-hook #t)
(_ #f)))
+(define (colorize-store-file-name file)
+ "Colorize FILE, a store file name, such that the hash part is less prominent
+that the rest."
+ (let ((len (string-length file))
+ (prefix (+ (string-length (%store-prefix)) 32 2)))
+ (if (< len prefix)
+ file
+ (string-append (colorize-string (string-take file prefix)
+ (color DARK))
+ (string-drop file prefix)))))
+
(define* (show-what-to-build store drv
#:key dry-run? (use-substitutes? #t)
(mode (build-mode normal)))
(substitution-oracle store inputs #:mode mode)
(const #f)))
+ (define colorized-store-item
+ (if (color-output? (current-error-port))
+ colorize-store-file-name
+ identity))
+
(let*-values (((build download)
(derivation-build-plan store inputs
#:mode mode
(N_ "~:[The following derivation would be built:~%~{ ~a~%~}~;~]"
"~:[The following derivations would be built:~%~{ ~a~%~}~;~]"
(length build))
- (null? build) build)
+ (null? build) (map colorized-store-item build))
(if display-download-size?
(format (current-error-port)
;; TRANSLATORS: "MB" is for "megabyte"; it should be
(G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]")
(null? download)
download-size
- (map substitutable-path download))
+ (map (compose colorized-store-item substitutable-path)
+ download))
(format (current-error-port)
(N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]"
"~:[The following files would be downloaded:~%~{ ~a~%~}~;~]"
(length download))
(null? download)
- (map substitutable-path download)))
+ (map (compose colorized-store-item substitutable-path)
+ download)))
(format (current-error-port)
(N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]"
"~:[The following grafts would be made:~%~{ ~a~%~}~;~]"
(length graft))
- (null? graft) graft)
+ (null? graft) (map colorized-store-item graft))
(format (current-error-port)
(N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]"
"~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]"
(length hook))
- (null? hook) hook))
+ (null? hook) (map colorized-store-item hook)))
(begin
(format (current-error-port)
(N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]"
"~:[The following derivations will be built:~%~{ ~a~%~}~;~]"
(length build))
- (null? build) build)
+ (null? build) (map colorized-store-item build))
(if display-download-size?
(format (current-error-port)
;; TRANSLATORS: "MB" is for "megabyte"; it should be
(G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]")
(null? download)
download-size
- (map substitutable-path download))
+ (map (compose colorized-store-item substitutable-path)
+ download))
(format (current-error-port)
(N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]"
"~:[The following files will be downloaded:~%~{ ~a~%~}~;~]"
(length download))
(null? download)
- (map substitutable-path download)))
+ (map (compose colorized-store-item substitutable-path)
+ download)))
(format (current-error-port)
(N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]"
"~:[The following grafts will be made:~%~{ ~a~%~}~;~]"
(length graft))
- (null? graft) graft)
+ (null? graft) (map colorized-store-item graft))
(format (current-error-port)
(N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]"
"~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]"
(length hook))
- (null? hook) hook)))
+ (null? hook) (map colorized-store-item hook))))
(check-available-space installed-size)
'()
str)))
+(define (hyperlink uri text)
+ "Return a string that denotes a hyperlink using an OSC escape sequence as
+documented at
+<https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda>."
+ (string-append "\x1b]8;;" uri "\x1b\\"
+ text "\x1b]8;;\x1b\\"))
+
+(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.)
+ ;; However, Emacs comint as of 26.3 does not ignore it and instead lets it
+ ;; through, hence the 'INSIDE_EMACS' special case below.
+ (and (isatty?* port)
+ (not (getenv "INSIDE_EMACS"))))
+
+(define* (file-hyperlink file #:optional (text file))
+ "Return TEXT with escapes for a hyperlink to FILE."
+ (hyperlink (string-append "file://" (gethostname)
+ (encode-and-join-uri-path
+ (string-split file #\/)))
+ text))
+
+(define (location->hyperlink location)
+ "Return a string corresponding to LOCATION, with escapes for a hyperlink."
+ (let ((str (location->string location))
+ (file (if (string-prefix? "/" (location-file location))
+ (location-file location)
+ (search-path %load-path (location-file location)))))
+ (if file
+ (file-hyperlink file str)
+ str)))
+
(define* (package->recutils p port #:optional (width (%text-width))
- #:key (extra-fields '()))
+ #:key
+ (hyperlinks? (supports-hyperlinks? port))
+ (extra-fields '()))
"Write to PORT a `recutils' record of package P, arranging to fit within
-WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit."
+WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit. When
+HYPERLINKS? is true, emit hyperlink escape sequences when appropriate."
(define width*
;; The available number of columns once we've taken into account space for
;; the initial "+ " prefix.
(((labels inputs . _) ...)
(dependencies->recutils (filter package? inputs)))))
(format port "location: ~a~%"
- (or (and=> (package-location p) location->string)
+ (or (and=> (package-location p)
+ (if hyperlinks? location->hyperlink location->string))
(G_ "unknown")))
;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in
(string-join (map license-name licenses)
", "))
((? license? license)
- (license-name license))
+ (let ((text (license-name license))
+ (uri (license-uri license)))
+ (if (and hyperlinks? uri (string-prefix? "http" uri))
+ (hyperlink uri text)
+ text)))
(x
(G_ "unknown"))))
(format port "synopsis: ~a~%"
(let loop ((matches matches))
(match matches
(((package . score) rest ...)
- (let ((text (call-with-output-string
- (lambda (port)
- (print package port
- #:extra-fields
- `((relevance . ,score)))))))
+ (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))
(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."
HCoop / jackhill / guix / guix.git / blobdiff