summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2019-11-15 20:11:35 +0100
committerMarius Bakke <mbakke@fastmail.com>2019-11-15 20:11:35 +0100
commitf056553c6b8ffa36f4ce9fb1c3602a8f4b1de242 (patch)
tree80c815216a3717cf00b615c9cb8840c113eaf79f /guix
parent2c9d34166983565120f831284df57a07e2edd2f9 (diff)
parent528b52390d216d8a8cd13dfcd1e6e40a6448e6c2 (diff)
Merge branch 'master' into staging
Diffstat (limited to 'guix')
-rw-r--r--guix/build/make-bootstrap.scm1
-rw-r--r--guix/build/svn.scm4
-rw-r--r--guix/build/syscalls.scm35
-rw-r--r--guix/derivations.scm2
-rw-r--r--guix/scripts/graph.scm105
-rw-r--r--guix/scripts/package.scm70
-rw-r--r--guix/scripts/pull.scm40
-rw-r--r--guix/scripts/system/search.scm10
-rw-r--r--guix/svn-download.scm15
-rw-r--r--guix/ui.scm64
10 files changed, 236 insertions, 110 deletions
diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm
index e5ef1d6d2b..0d29338ce3 100644
--- a/guix/build/make-bootstrap.scm
+++ b/guix/build/make-bootstrap.scm
@@ -47,7 +47,6 @@ bootstrap libc."
(install-file (pk 'src (string-append kernel-headers "/include/linux/" file))
(pk 'dest (string-append incdir "/linux"))))
'(
- "a.out.h" ; for 2.2.5
"atalk.h" ; for 2.2.5
"errno.h"
"falloc.h"
diff --git a/guix/build/svn.scm b/guix/build/svn.scm
index e3188add3e..33783f3056 100644
--- a/guix/build/svn.scm
+++ b/guix/build/svn.scm
@@ -31,6 +31,7 @@
(define* (svn-fetch url revision directory
#:key (svn-command "svn")
+ (recursive? #t)
(user-name #f)
(password #f))
"Fetch REVISION from URL into DIRECTORY. REVISION must be an integer, and a
@@ -45,6 +46,9 @@ valid Subversion revision. Return #t on success, #f otherwise."
(list (string-append "--username=" user-name)
(string-append "--password=" password))
'())
+ ,@(if recursive?
+ '()
+ (list "--ignore-externals"))
,url ,directory))
#t)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index bbf2531c79..a5a9c92a42 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -80,6 +80,7 @@
lock-file
unlock-file
with-file-lock
+ with-file-lock/no-wait
set-thread-name
thread-name
@@ -1087,10 +1088,10 @@ exception if it's already taken."
;; Presumably we got EAGAIN or so.
(throw 'flock-error err))))))
-(define (lock-file file)
+(define* (lock-file file #:key (wait? #t))
"Wait and acquire an exclusive lock on FILE. Return an open port."
(let ((port (open-file file "w0")))
- (fcntl-flock port 'write-lock)
+ (fcntl-flock port 'write-lock #:wait? wait?)
port))
(define (unlock-file port)
@@ -1119,10 +1120,40 @@ exception if it's already taken."
(when port
(unlock-file port))))))
+(define (call-with-file-lock/no-wait file thunk handler)
+ (let ((port (catch #t
+ (lambda ()
+ (lock-file file #:wait? #f))
+ (lambda (key . args)
+ (match key
+ ('flock-error
+ (handler args))
+ ('system-error
+ ;; When using the statically-linked Guile in the initrd,
+ ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore
+ ;; that error since we're typically the only process running
+ ;; at this point.
+ (if (= ENOSYS (system-error-errno (cons key args)))
+ #f
+ (apply throw args)))
+ (_ (apply throw key args)))))))
+ (dynamic-wind
+ (lambda ()
+ #t)
+ thunk
+ (lambda ()
+ (when port
+ (unlock-file port))))))
+
(define-syntax-rule (with-file-lock file exp ...)
"Wait to acquire a lock on FILE and evaluate EXP in that context."
(call-with-file-lock file (lambda () exp ...)))
+(define-syntax-rule (with-file-lock/no-wait file handler exp ...)
+ "Try to acquire a lock on FILE and evaluate EXP in that context. Execute
+handler if the lock is already held by another process."
+ (call-with-file-lock/no-wait file (lambda () exp ...) handler))
+
;;;
;;; Miscellaneous, aka. 'prctl'.
diff --git a/guix/derivations.scm b/guix/derivations.scm
index bde937044a..6cdf55b1fe 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -1208,7 +1208,7 @@ they can refer to each other."
(define %module-cache
;; Map a list of modules to its 'imported+compiled-modules' result.
- (make-weak-value-hash-table))
+ (make-hash-table))
(define* (imported+compiled-modules store modules #:key
(system (%current-system))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 2e14857f1e..7558cb1e85 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -32,6 +32,10 @@
#:use-module (gnu packages)
#:use-module (guix sets)
#:use-module ((guix utils) #:select (location-file))
+ #:use-module ((guix scripts build)
+ #:select (show-transformation-options-help
+ options->transformation
+ %transformation-options))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
@@ -446,36 +450,38 @@ package modules, while attempting to retain user package modules."
;;;
(define %options
- (list (option '(#\t "type") #t #f
- (lambda (opt name arg result)
- (alist-cons 'node-type (lookup-node-type arg)
- result)))
- (option '("list-types") #f #f
- (lambda (opt name arg result)
- (list-node-types)
- (exit 0)))
- (option '(#\b "backend") #t #f
- (lambda (opt name arg result)
- (alist-cons 'backend (lookup-backend arg)
- result)))
- (option '("list-backends") #f #f
- (lambda (opt name arg result)
- (list-backends)
- (exit 0)))
- (option '(#\e "expression") #t #f
- (lambda (opt name arg result)
- (alist-cons 'expression arg result)))
- (option '(#\s "system") #t #f
- (lambda (opt name arg result)
- (alist-cons 'system arg
- (alist-delete 'system result eq?))))
- (option '(#\h "help") #f #f
- (lambda args
- (show-help)
- (exit 0)))
- (option '(#\V "version") #f #f
- (lambda args
- (show-version-and-exit "guix edit")))))
+ (cons* (option '(#\t "type") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'node-type (lookup-node-type arg)
+ result)))
+ (option '("list-types") #f #f
+ (lambda (opt name arg result)
+ (list-node-types)
+ (exit 0)))
+ (option '(#\b "backend") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'backend (lookup-backend arg)
+ result)))
+ (option '("list-backends") #f #f
+ (lambda (opt name arg result)
+ (list-backends)
+ (exit 0)))
+ (option '(#\e "expression") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'expression arg result)))
+ (option '(#\s "system") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'system arg
+ (alist-delete 'system result eq?))))
+ (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix graph")))
+
+ %transformation-options))
(define (show-help)
;; TRANSLATORS: Here 'dot' is the name of a program; it must not be
@@ -495,6 +501,8 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
(display (G_ "
-s, --system=SYSTEM consider the graph for SYSTEM--e.g., \"i686-linux\""))
(newline)
+ (show-transformation-options-help)
+ (newline)
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
@@ -514,21 +522,28 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
(define (guix-graph . args)
(with-error-handling
- (let* ((opts (parse-command-line args %options
- (list %default-options)
- #:build-options? #f))
- (backend (assoc-ref opts 'backend))
- (type (assoc-ref opts 'node-type))
- (items (filter-map (match-lambda
- (('argument . (? store-path? item))
- item)
- (('argument . spec)
- (specification->package spec))
- (('expression . exp)
- (read/eval-package-expression exp))
- (_ #f))
- opts)))
- (with-store store
+ (define opts
+ (parse-command-line args %options
+ (list %default-options)
+ #:build-options? #f))
+ (define backend
+ (assoc-ref opts 'backend))
+ (define type
+ (assoc-ref opts 'node-type))
+
+ (with-store store
+ (let* ((transform (options->transformation opts))
+ (items (filter-map (match-lambda
+ (('argument . (? store-path? item))
+ item)
+ (('argument . spec)
+ (transform store
+ (specification->package spec)))
+ (('expression . exp)
+ (transform store
+ (read/eval-package-expression exp)))
+ (_ #f))
+ opts)))
;; Ask for absolute file names so that .drv file names passed from the
;; user to 'read-derivation' are absolute when it returns.
(with-fluids ((%file-port-name-canonicalization 'absolute))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 1a58d43e5c..bcd03a1df9 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -42,6 +42,8 @@
#:autoload (guix store roots) (gc-roots)
#:use-module ((guix build utils)
#:select (directory-exists? mkdir-p))
+ #:use-module ((guix build syscalls)
+ #:select (with-file-lock/no-wait))
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
@@ -876,36 +878,44 @@ processed, #f otherwise."
(package-version item)
(manifest-entry-version entry))))))
- ;; First, process roll-backs, generation removals, etc.
- (for-each (match-lambda
- ((key . arg)
- (and=> (assoc-ref %actions key)
- (lambda (proc)
- (proc store profile arg opts
- #:dry-run? dry-run?)))))
- opts)
-
- ;; Then, process normal package removal/installation/upgrade.
- (let* ((manifest (profile-manifest profile))
- (step1 (options->removable opts manifest
- (manifest-transaction)))
- (step2 (options->installable opts manifest step1))
- (step3 (manifest-transaction
- (inherit step2)
- (install (map transform-entry
- (manifest-transaction-install step2)))))
- (new (manifest-perform-transaction manifest step3)))
-
- (warn-about-old-distro)
-
- (unless (manifest-transaction-null? step3)
- (show-manifest-transaction store manifest step3
- #:dry-run? dry-run?)
- (build-and-use-profile store profile new
- #:allow-collisions? allow-collisions?
- #:bootstrap? bootstrap?
- #:use-substitutes? substitutes?
- #:dry-run? dry-run?))))
+
+ ;; First, acquire a lock on the profile, to ensure only one guix process
+ ;; is modifying it at a time.
+ (with-file-lock/no-wait (string-append profile ".lock")
+ (lambda (key . args)
+ (leave (G_ "profile ~a is locked by another process~%")
+ profile))
+
+ ;; Then, process roll-backs, generation removals, etc.
+ (for-each (match-lambda
+ ((key . arg)
+ (and=> (assoc-ref %actions key)
+ (lambda (proc)
+ (proc store profile arg opts
+ #:dry-run? dry-run?)))))
+ opts)
+
+ ;; Then, process normal package removal/installation/upgrade.
+ (let* ((manifest (profile-manifest profile))
+ (step1 (options->removable opts manifest
+ (manifest-transaction)))
+ (step2 (options->installable opts manifest step1))
+ (step3 (manifest-transaction
+ (inherit step2)
+ (install (map transform-entry
+ (manifest-transaction-install step2)))))
+ (new (manifest-perform-transaction manifest step3)))
+
+ (warn-about-old-distro)
+
+ (unless (manifest-transaction-null? step3)
+ (show-manifest-transaction store manifest step3
+ #:dry-run? dry-run?)
+ (build-and-use-profile store profile new
+ #:allow-collisions? allow-collisions?
+ #:bootstrap? bootstrap?
+ #:use-substitutes? substitutes?
+ #:dry-run? dry-run?)))))
;;;
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 80d070652b..92aac6066e 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -235,12 +235,18 @@ purposes."
(define title
(channel-news-entry-title entry))
- (format port " ~a~%"
- (highlight
- (string-trim-right
- (texi->plain-text (or (assoc-ref title language)
- (assoc-ref title (%default-message-language))
- ""))))))
+ (let ((title (or (assoc-ref title language)
+ (assoc-ref title (%default-message-language))
+ "")))
+ (format port " ~a~%"
+ (highlight
+ (string-trim-right
+ (catch 'parser-error
+ (lambda ()
+ (texi->plain-text title))
+
+ ;; When Texinfo markup is invalid, display it as-is.
+ (const title)))))))
(define (display-news-entry entry language port)
"Display ENTRY, a <channel-news-entry>, in LANGUAGE, a language code, to
@@ -252,14 +258,20 @@ PORT."
(format port (dim (G_ " commit ~a~%"))
(channel-news-entry-commit entry))
(newline port)
- (format port " ~a~%"
- (indented-string
- (parameterize ((%text-width (- (%text-width) 4)))
- (string-trim-right
- (texi->plain-text (or (assoc-ref body language)
- (assoc-ref body (%default-message-language))
- ""))))
- 4)))
+ (let ((body (or (assoc-ref body language)
+ (assoc-ref body (%default-message-language))
+ "")))
+ (format port " ~a~%"
+ (indented-string
+ (parameterize ((%text-width (- (%text-width) 4)))
+ (string-trim-right
+ (catch 'parser-error
+ (lambda ()
+ (texi->plain-text body))
+ (lambda _
+ ;; When Texinfo markup is invalid, display it as-is.
+ (fill-paragraph body (%text-width))))))
+ 4))))
(define* (display-channel-specific-news new old
#:key (port (current-output-port))
diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm
index 5278062edd..d2eac06cca 100644
--- a/guix/scripts/system/search.scm
+++ b/guix/scripts/system/search.scm
@@ -65,9 +65,12 @@ provided TYPE has a default value."
(define* (service-type->recutils type port
#:optional (width (%text-width))
- #:key (extra-fields '()))
+ #:key
+ (extra-fields '())
+ (hyperlinks? (supports-hyperlinks? port)))
"Write to PORT a recutils record of TYPE, arranging to fit within WIDTH
-columns."
+columns. 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.
@@ -84,7 +87,8 @@ columns."
;; Note: Don't i18n field names so that people can post-process it.
(format port "name: ~a~%" (service-type-name type))
(format port "location: ~a~%"
- (or (and=> (service-type-location type) location->string)
+ (or (and=> (service-type-location type)
+ (if hyperlinks? location->hyperlink location->string))
(G_ "unknown")))
(format port "extends: ~a~%"
diff --git a/guix/svn-download.scm b/guix/svn-download.scm
index 4139cbc2e2..59e2eb8d07 100644
--- a/guix/svn-download.scm
+++ b/guix/svn-download.scm
@@ -31,6 +31,7 @@
svn-reference?
svn-reference-url
svn-reference-revision
+ svn-reference-recursive?
svn-fetch
download-svn-to-store
@@ -39,6 +40,7 @@
svn-multi-reference-url
svn-multi-reference-revision
svn-multi-reference-locations
+ svn-multi-reference-recursive?
svn-multi-fetch))
;;; Commentary:
@@ -52,10 +54,11 @@
(define-record-type* <svn-reference>
svn-reference make-svn-reference
svn-reference?
- (url svn-reference-url) ; string
- (revision svn-reference-revision) ; number
- (user-name svn-reference-user-name (default #f))
- (password svn-reference-password (default #f)))
+ (url svn-reference-url) ; string
+ (revision svn-reference-revision) ; number
+ (recursive? svn-reference-recursive? (default #t))
+ (user-name svn-reference-user-name (default #f))
+ (password svn-reference-password (default #f)))
(define (subversion-package)
"Return the default Subversion package."
@@ -78,6 +81,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
'#$(svn-reference-revision ref)
#$output
#:svn-command (string-append #+svn "/bin/svn")
+ #:recursive? #$(svn-reference-recursive? ref)
#:user-name #$(svn-reference-user-name ref)
#:password #$(svn-reference-password ref)))))
@@ -96,6 +100,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(url svn-multi-reference-url) ; string
(revision svn-multi-reference-revision) ; number
(locations svn-multi-reference-locations) ; list of strings
+ (recursive? svn-multi-reference-recursive? (default #t))
(user-name svn-multi-reference-user-name (default #f))
(password svn-multi-reference-password (default #f)))
@@ -125,6 +130,8 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(string-append #$output "/" location)
(string-append #$output "/" (dirname location)))
#:svn-command (string-append #+svn "/bin/svn")
+ #:recursive?
+ #$(svn-multi-reference-recursive? ref)
#:user-name #$(svn-multi-reference-user-name ref)
#:password #$(svn-multi-reference-password ref)))
'#$(svn-multi-reference-locations ref)))))
diff --git a/guix/ui.scm b/guix/ui.scm
index 3e4bd5787e..eb17d274c8 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -44,7 +44,8 @@
#: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))
@@ -69,6 +70,7 @@
#: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)
@@ -108,6 +110,9 @@
package->recutils
package-specification->name+version+output
+ supports-hyperlinks?
+ location->hyperlink
+
relevance
package-relevance
display-search-results
@@ -1234,10 +1239,42 @@ followed by \"+ \", which makes for a valid multi-line field value in the
'()
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? 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 (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
+ (hyperlink (string-append "file://" (gethostname)
+ (encode-and-join-uri-path
+ (string-split 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.
@@ -1265,7 +1302,8 @@ WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit."
(((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
@@ -1278,7 +1316,11 @@ WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit."
(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~%"
@@ -1398,11 +1440,13 @@ them. If PORT is a terminal, print at most a full screen of results."
(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))