Merge branch 'master' into staging

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))