Merge branch 'staging' into core-updates.

5 files changed, 123 insertions, 36 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 7c310e94f1..41583e8143 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2021 Timothy Sample <samplet@ngyro.com>
@@ -28,6 +28,7 @@
   #:use-module (guix ftp-client)
   #:use-module (guix build utils)
   #:use-module (guix progress)
+  #:use-module (guix memoization)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
@@ -177,27 +178,30 @@ name decoding bug described at
   (let ((data (call-with-input-file file get-bytevector-all)))
     (set-certificate-credentials-x509-trust-data! cred data format)))
 
-(define (make-credendials-with-ca-trust-files directory)
-  "Return certificate credentials with X.509 authority certificates read from
+(define make-credentials-with-ca-trust-files
+  (mlambda (directory)
+    "Return certificate credentials with X.509 authority certificates read from
 DIRECTORY.  Those authority certificates are checked when
 'peer-certificate-status' is later called."
-  (let ((cred  (make-certificate-credentials))
-        (files (match (scandir directory (cut string-suffix? ".pem" <>))
-                 ((or #f ())
-                  ;; Some distros provide nothing but bundles (*.crt) under
-                  ;; /etc/ssl/certs, so look for them.
-                  (or (scandir directory (cut string-suffix? ".crt" <>))
-                      '()))
-                 (pem pem))))
-    (for-each (lambda (file)
-                (let ((file (string-append directory "/" file)))
-                  ;; Protect against dangling symlinks.
-                  (when (file-exists? file)
-                    (set-certificate-credentials-x509-trust-file!*
-                     cred file
-                     x509-certificate-format/pem))))
-              files)
-    cred))
+    ;; Memoize the result to avoid scanning all the certificates every time a
+    ;; connection is made.
+    (let ((cred  (make-certificate-credentials))
+          (files (match (scandir directory (cut string-suffix? ".pem" <>))
+                   ((or #f ())
+                    ;; Some distros provide nothing but bundles (*.crt) under
+                    ;; /etc/ssl/certs, so look for them.
+                    (or (scandir directory (cut string-suffix? ".crt" <>))
+                        '()))
+                   (pem pem))))
+      (for-each (lambda (file)
+                  (let ((file (string-append directory "/" file)))
+                    ;; Protect against dangling symlinks.
+                    (when (file-exists? file)
+                      (set-certificate-credentials-x509-trust-file!*
+                       cred file
+                       x509-certificate-format/pem))))
+                files)
+      cred)))
 
 (define (peer-certificate session)
   "Return the certificate of the remote peer in SESSION."
@@ -273,7 +277,7 @@ host name without trailing dot."
 
     (set-session-credentials! session
                               (if (and verify-certificate? ca-certs)
-                                  (make-credendials-with-ca-trust-files
+                                  (make-credentials-with-ca-trust-files
                                    ca-certs)
                                   (make-certificate-credentials)))
 
@@ -431,8 +435,7 @@ ETIMEDOUT error is raised."
                                   #:key
                                   timeout
                                   (verify-certificate? #t))
-  "Like 'open-socket-for-uri', but also handle HTTPS connections.  The
-resulting port must be closed with 'close-connection'.  When
+  "Like 'open-socket-for-uri', but also handle HTTPS connections.  When
 VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
   ;; Note: Guile 2.2.0's (web client) has a same-named export that's actually
   ;; undefined.  See Guile commit 011669af3b428e5626f7bbf66b11d57d9768c047.
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index ab77e57f33..6a6918bfdd 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -140,6 +140,79 @@ store in '.el' files."
           (substitute-program-names))))
     #t))
 
+(define (find-root-library-file name)
+  (let loop ((parts (string-split
+                     (package-name-version->elpa-name-version name) #\-))
+             (candidate ""))
+    (cond
+     ;; at least one version part is given, so we don't terminate "early"
+     ((null? parts) #f)
+     ((string-null? candidate) (loop (cdr parts) (car parts)))
+     ((file-exists? (string-append candidate ".el")) candidate)
+     (else
+      (loop (cdr parts) (string-append candidate "-" (car parts)))))))
+
+(define* (ensure-package-description #:key outputs #:allow-other-keys)
+  (define (write-pkg-file name)
+    (define summary-regexp
+      "^;;; [^ ]*\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$")
+    (define %write-pkg-file-form
+      `(progn
+        (require 'lisp-mnt)
+        (require 'package)
+
+        (defun build-package-desc-from-library (name)
+          (package-desc-from-define
+           name
+           ;; Workaround for malformed version string (for example "24 (beta)"
+           ;; in paredit.el), try to parse version obtained by lm-version,
+           ;; before trying to create package-desc.  Otherwise the whole process
+           ;; of generation -pkg.el will fail.
+           (condition-case
+            nil
+            (let ((version (lm-version)))
+              ;; raises an error if version is invalid
+              (and (version-to-list version) version))
+            (error "0.0.0"))
+           (or (save-excursion
+                (goto-char (point-min))
+                (and (re-search-forward ,summary-regexp nil t)
+                     (match-string-no-properties 1)))
+               package--default-summary)
+           (let ((require-lines (lm-header-multiline "package-requires")))
+             (and require-lines
+                  (package--prepare-dependencies
+                   (package-read-from-string
+                    (mapconcat 'identity require-lines " ")))))
+           :kind       'single
+           :url        (lm-homepage)
+           :keywords   (lm-keywords-list)
+           :maintainer (lm-maintainer)
+           :authors    (lm-authors)))
+
+        (defun generate-package-description-file (name)
+          (package-generate-description-file
+           (build-package-desc-from-library name)
+           (concat name "-pkg.el")))
+
+        (condition-case
+         err
+         (let ((name (file-name-base (buffer-file-name))))
+           (generate-package-description-file name)
+           (message (concat name "-pkg.el file generated.")))
+         (error
+          (message "There are some errors during generation of -pkg.el file:")
+          (message "%s" (error-message-string err))))))
+
+    (unless (file-exists? (string-append name "-pkg.el"))
+      (emacs-batch-edit-file (string-append name ".el")
+        %write-pkg-file-form)))
+
+  (let* ((out (assoc-ref outputs "out"))
+         (elpa-name-ver (store-directory->elpa-name-version out)))
+    (with-directory-excursion (elpa-directory out)
+      (and=> (find-root-library-file elpa-name-ver) write-pkg-file))))
+
 (define* (check #:key tests? (test-command '("make" "check"))
                 (parallel-tests? #t) #:allow-other-keys)
   "Run the tests by invoking TEST-COMMAND.
@@ -279,8 +352,10 @@ for libraries following the ELPA convention."
     (add-after 'make-autoloads 'enable-autoloads-compilation
       enable-autoloads-compilation)
     (add-after 'enable-autoloads-compilation 'patch-el-files patch-el-files)
+    (add-after 'patch-el-files 'ensure-package-description
+      ensure-package-description)
     ;; The .el files are byte compiled directly in the store.
-    (add-after 'patch-el-files 'build build)
+    (add-after 'ensure-package-description 'build build)
     (add-after 'build 'validate-compiled-autoloads validate-compiled-autoloads)
     (add-after 'validate-compiled-autoloads 'move-doc move-doc)))
 
diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm
index 03d669be64..b0dac154e9 100644
--- a/guix/build/julia-build-system.scm
+++ b/guix/build/julia-build-system.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2019, 2020 Nicolò Balzarotti <nicolo@nixo.xyz>
 ;;; Copyright © 2021 Jean-Baptiste Volatier <jbv@pm.me>
 ;;; Copyright © 2021, 2022 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2022 Efraim Flashner <efraim@flashner.co.il>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -111,9 +112,9 @@ Project.toml)."
            (job-count (if parallel-tests?
                           (parallel-job-count)
                           1))
-           ;; The --proc argument of Julia *adds* extra processors rather than
-           ;; specify the exact count to use, so zero must be specified to
-           ;; disable parallel processing...
+           ;; The --procs argument of Julia *adds* extra processors rather
+           ;; than specify the exact count to use, so zero must be specified
+           ;; to disable parallel processing...
            (additional-procs (max 0 (1- job-count))))
       ;; With a patch, SOURCE_DATE_EPOCH is honored
       (setenv "SOURCE_DATE_EPOCH" "1")
@@ -126,7 +127,7 @@ Project.toml)."
       (setenv "HOME" "/tmp")
       (apply invoke "julia"
              `("--depwarn=yes"
-               ,@(if parallel-tests?
+               ,@(if (and parallel-tests? (< 0 additional-procs))
                      ;; XXX: ... but '--procs' doesn't accept 0 as a valid
                      ;; value, so just omit the argument entirely.
                      (list (string-append  "--procs="
@@ -136,7 +137,8 @@ Project.toml)."
                                package "/test/runtests.jl"))))))
 
 (define* (link-depot #:key source inputs outputs
-                     julia-package-name julia-package-uuid  #:allow-other-keys)
+                     julia-package-name julia-package-uuid
+                     julia-package-dependencies #:allow-other-keys)
   (let* ((out (assoc-ref outputs "out"))
          (name+version (strip-store-file-name out))
          (version (last (string-split name+version #\-)))
@@ -156,6 +158,7 @@ println(Base.version_slug(Base.UUID(\"~a\"),
         (julia-create-package-toml (getcwd)
                                    julia-package-name julia-package-uuid
                                    version
+                                   julia-package-dependencies
                                    #:file "Project.toml"))
 
     ;; When installing a package, julia looks first at in the JULIA_DEPOT_PATH
@@ -186,9 +189,10 @@ version = \"" version "\"
 ") f)
     (when (not (null? deps))
       (display "[deps]\n" f)
-      (for-each (lambda dep
-                  (display (string-append (car (car dep)) " = \"" (cdr (car dep)) "\"\n")
-                           f))
+      (for-each (match-lambda
+                  ((name . uuid)
+                   (display (string-append name " = \"" uuid "\"\n")
+                            f)))
                 deps))
     (close-port f)))
 
@@ -207,6 +211,7 @@ version = \"" version "\"
     (delete 'build)))
 
 (define* (julia-build #:key inputs julia-package-name julia-package-uuid
+                      julia-package-dependencies
                       (phases %standard-phases)
                       #:allow-other-keys #:rest args)
   "Build the given Julia package, applying all of PHASES in order."
@@ -214,4 +219,5 @@ version = \"" version "\"
          #:inputs inputs #:phases phases
          #:julia-package-name julia-package-name
          #:julia-package-uuid julia-package-uuid
+         #:julia-package-dependencies julia-package-dependencies
          args))
diff --git a/guix/build/maven/java.scm b/guix/build/maven/java.scm
index daa4c88045..f8c8e5745d 100644
--- a/guix/build/maven/java.scm
+++ b/guix/build/maven/java.scm
@@ -31,11 +31,14 @@
                                         (? (and (ignore "static") (* WS)))
                                         package-name
                                         (* WS) (ignore ";")))
-(define-peg-pattern comment all (and (? (and annotation-pat (* WS))) (ignore "/*")
-                                     comment-part))
+(define-peg-pattern comment all (or                                            
+                                  (and (? (and annotation-pat (* WS))) (ignore "/*")
+                                       comment-part)                           
+                                  (and (ignore "//") (* (or "\t" (range #\  #\xffff)))
+                                       (or (ignore "\n") (ignore "\r")) (* WS))))
 (define-peg-pattern comment-part body (or (ignore (and (* "*") "/"))
                                           (and (* "*") (+ comment-chr) comment-part)))
-(define-peg-pattern comment-chr body (or "\t" "\n" (range #\ #\)) (range #\+ #\xffff)))
+(define-peg-pattern comment-chr body (or "\t" "\n" "\r" (range #\  #\)) (range #\+ #\xffff)))
 (define-peg-pattern inline-comment none (and (ignore "//") (* inline-comment-chr)
                                             (ignore "\n")))
 (define-peg-pattern inline-comment-chr body (range #\ #\xffff))
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index 01e1f41870..657a91f324 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -140,7 +140,7 @@ It is meant as an internal format."
                      refs)))))))
 
 (define (file-size file)
-  "Return the size of bytes of FILE, entering it if FILE is a directory."
+  "Return the size in bytes of FILE, entering it if FILE is a directory."
   (file-system-fold (const #t)
                     (lambda (file stat result)    ;leaf
                       (+ (stat:size stat) result))