[bot] built_in_updates (#15910)

Co-authored-by: SpacemacsBot <not@an.actual.email.beep.boop>

core/libs/package-build-badges.el

@@ -3,6 +3,7 @@
 ;; Copyright (C) 2011-2023 Donald Ephraim Curtis
 ;; Copyright (C) 2012-2023 Steve Purcell
 ;; Copyright (C) 2018-2023 Jonas Bernoulli
+;; Copyright (C) 2021-2023 Free Software Foundation, Inc
 ;; Copyright (C) 2009 Phil Hagelberg
 
 ;; Author: Donald Ephraim Curtis <dcurtis@milkbox.net>
@@ -26,23 +27,117 @@
 
 ;;; Commentary:
 
-;; In future we should provide a hook.  Note also that it would be
+;; Create batches for packages.
-;; straightforward to generate the SVG ourselves, which would save
+;; The code in this file was lifted from `elpa-admin'.
-;; the network overhead.
 
 ;;; Code:
 
 (defvar package-build-stable)
 
-(defun package-build--write-melpa-badge-image (name version target-dir)
+(defun package-build--write-melpa-badge-image ( name version target-dir
-  (unless (zerop (call-process
+                                                &optional archive color)
-                  "curl" nil nil nil "-f" "-o"
+  "Make badge svg file.
-                  (expand-file-name (concat name "-badge.svg") target-dir)
+This is essentially a copy of `elpaa--make-badge'."
-                  (format "https://img.shields.io/badge/%s-%s-%s.svg"
+  (let* ((file (expand-file-name (concat name "-badge.svg") target-dir))
-                          (if package-build-stable "melpa stable" "melpa")
+         (left (or archive (if package-build-stable "melpa stable" "melpa")))
-                          (url-hexify-string version)
+         (right (url-hexify-string version))
-                          (if package-build-stable "3e999f" "922793"))))
+         (color (or color (if package-build-stable "#3e999f" "#922793")))
-    (message "Failed to fetch badge")))
+         (lw (package-build-badge--string-width left))
+         (rw (package-build-badge--string-width right))
+         (pad (package-build-badge--string-width "x"))
+         (width (/ (+ lw rw (* 4 pad)) 10))
+         (offset -10) ;; Small alignment correction
+         (ctx `((offset . ,offset)
+                (left . ,left)
+                (right . ,right)
+                (lw . ,lw)
+                (rw . ,rw)
+                (width . ,width)
+                (color . ,color)
+                (pad . ,pad))))
+    (with-temp-buffer
+      (insert
+       (replace-regexp-in-string
+        "{\\([^}]+\\)}"
+        (lambda (str)
+          (url-insert-entities-in-string
+           (format "%s" (eval (read (match-string 1 str)) ctx))))
+        (eval-when-compile
+          (replace-regexp-in-string
+           "[ \t\n]+" " "
+           (replace-regexp-in-string
+            "'" "\""
+            "<?xml version='1.0'?>
+<svg xmlns='http://www.w3.org/2000/svg'
+     xmlns:xlink='http://www.w3.org/1999/xlink'
+     width='{width}'
+     height='20'
+     role='img'
+     aria-label='{left}: {right}'>
+  <title>{left}: {right}</title>
+  <linearGradient id='s' x2='0' y2='100%'>
+    <stop offset='0' stop-color='#bbb' stop-opacity='.1'/>
+    <stop offset='1' stop-opacity='.1'/>
+  </linearGradient>
+  <clipPath id='r'>
+    <rect width='{width}' height='20' rx='3' fill='#fff'/>
+  </clipPath>
+  <g clip-path='url(#r)'>
+    <rect width='{(/ (+ lw (* 2 pad)) 10)}'
+          height='20' fill='#555'/>
+    <rect x='{(1- (/ (+ lw (* 2 pad)) 10))}'
+          width='{width}' height='20' fill='{color}'/>
+    <rect width='{width}' height='20' fill='url(#s)'/>
+  </g>
+  <g fill='#fff'
+     text-anchor='middle'
+     font-family='Verdana,Geneva,DejaVu Sans,sans-serif'
+     font-size='110'
+     text-rendering='geometricPrecision'>
+    <text aria-hidden='true'
+          x='{(+ (/ lw 2) pad offset)}'
+          y='150'
+          fill='#010101' fill-opacity='.3'
+          transform='scale(.1)' textLength='{lw}'>{left}</text>
+    <text x='{(+ (/ lw 2) pad offset)}'
+          y='140' transform='scale(.1)'
+          fill='#fff'
+          textLength='{lw}'>{left}</text>
+    <text aria-hidden='true'
+          x='{(+ lw (/ rw 2) (* 3 pad) offset)}'
+          y='150'
+          fill='#010101'  fill-opacity='.3'
+          transform='scale(.1)' textLength='{rw}'>{right}</text>
+    <text x='{(+ lw (/ rw 2) (* 3 pad) offset)}'
+          y='140'
+          transform='scale(.1)'
+          fill='#fff' textLength='{rw}'>{right}</text>
+  </g>
+</svg>")))))
+      (write-region (point-min) (point-max) file))))
+
+(defun package-build-badge--string-width (str)
+  "Determine string width in pixels of STR."
+  (with-temp-buffer
+    ;; ImageMagick 7.1.0 or later requires using the "magick" driver,
+    ;; rather than "convert" directly, but Debian doesn't provide it
+    ;; yet (2021).
+    (let ((args `(,@(if (executable-find "magick")
+                        '("magick" "convert")
+                      '("convert"))
+                  "-debug" "annotate" "xc:" "-font" "DejaVu-Sans"
+                  "-pointsize" "110" "-annotate" "0" ,str "null:")))
+      (apply #'call-process (car args) nil t nil (delq nil (cdr args)))
+      (goto-char (point-min))
+      (if (not (re-search-forward "Metrics:.*?width: \\([0-9]+\\)"))
+          (error "Could not determine string width")
+        (let ((width (string-to-number (match-string 1))))
+          ;; This test aims to catch the case where the font is missing,
+          ;; but it seems it only works in some cases :-(
+          (if (and (> (string-width str) 0) (not (> width 0)))
+              (progn (message "convert:\n%s" (buffer-string))
+                     (error "Could not determine string width"))
+            width))))))
 
 (provide 'package-build-badges)
 ;;; package-badges.el ends here

core/libs/package-recipe-mode.el

@@ -1,4 +1,4 @@
-;;; package-recipe-mode.el --- Minor mode for editing package recipes  -*- lexical-binding:t; coding:utf-8 -*-
+;;; package-recipe-mode.el --- Major-mode for editing package recipes  -*- lexical-binding:t; coding:utf-8 -*-
 
 ;; Copyright (C) 2011-2023 Donald Ephraim Curtis
 ;; Copyright (C) 2012-2023 Steve Purcell
@@ -26,25 +26,43 @@
 
 ;;; Commentary:
 
-;; This library defines the minor mode `package-build-minor-mode',
+;; This library defines the major-mode `package-recipe-mode', which is
-;; which will likely be replaced with the `emacs-lisp-mode' derived
+;; used for Melpa package recipe files.
-;; `package-recipe-mode' eventually.
 
 ;;; Code:
 
 (require 'package-build)
 
-(defvar package-build-minor-mode-map
+;;;###autoload
-  (let ((m (make-sparse-keymap)))
+(defvar package-recipe-mode-map
-    (define-key m (kbd "C-c C-c") 'package-build-current-recipe)
+  (let ((map (make-sparse-keymap)))
-    m)
+    (define-key map (kbd "C-c C-c") 'package-build-current-recipe)
-  "Keymap for `package-build-minor-mode'.")
+    (define-key map (kbd "C-c C-n") 'package-build-create-recipe)
+    map)
+  "Keymap for `package-recipe-mode'.")
 
-(define-minor-mode package-build-minor-mode
+;;;###autoload
-  "Helpful functionality for building packages."
+(if (fboundp 'lisp-data-mode) ; Since Emacs 28.1.
-  :lighter " PBuild"
+    (define-derived-mode package-recipe-mode lisp-data-mode "Melpa-Recipe"
-  (when package-build-minor-mode
+      "Major mode for buffers holding Melpa package recipes."
-    (message "Use C-c C-c to build this recipe.")))
+      :group 'package-build
+      (package-recipe-mode--enable))
+  (define-derived-mode package-recipe-mode emacs-lisp-mode "Melpa-Recipe"
+    "Major mode for buffers holding Melpa package recipes."
+    :group 'package-build
+    (package-recipe-mode--enable)))
+
+(defun package-recipe-mode--enable ()
+  (setq-local package-build-recipes-dir default-directory)
+  (setq-local package-build-working-dir (expand-file-name "../working/"))
+  (setq-local package-build-archive-dir (expand-file-name "../packages/"))
+  (setq-local flycheck-checkers nil)
+  (setq-local indent-tabs-mode nil)
+  (setq-local require-final-newline t)
+  (add-hook 'before-save-hook #'whitespace-cleanup)
+  (message "%s" (substitute-command-keys "\
+Use \\[package-build-current-recipe] to build this recipe, \
+\\[package-build-create-recipe] to create a new recipe")))
 
 ;;;###autoload
 (defun package-build-create-recipe (name fetcher)
@@ -56,15 +74,13 @@
   (let ((recipe-file (expand-file-name name package-build-recipes-dir)))
     (when (file-exists-p recipe-file)
       (error "Recipe already exists"))
-    (find-file recipe-file)
+    (with-current-buffer (find-file recipe-file)
-    (insert (pp-to-string `(,(intern name)
+      (save-excursion
-                            :fetcher ,fetcher
+        (insert (format "(%s\n" name)
-                            ,@(cl-case fetcher
+                (format " :fetcher %s\n" fetcher)
-                                (github (list :repo "USER/REPO"))
+                (if (memq fetcher package-recipe--forge-fetchers)
-                                (t (list :url "SCM_URL_HERE"))))))
+                    " :repo \"USER/REPO\")\n"
-    (emacs-lisp-mode)
+                  " :url \"https://TODO\")\n"))))))
-    (package-build-minor-mode)
-    (goto-char (point-min))))
 
 ;;;###autoload
 (defun package-build-current-recipe ()
@@ -81,19 +97,19 @@
   (check-parens)
   (let ((name (file-name-nondirectory (buffer-file-name))))
     (package-build-archive name t)
-    (let ((output-buffer-name "*package-build-result*"))
+    (let ((entry (assq (intern name) (package-build-archive-alist)))
+          (output-buffer-name "*package-build-archive-entry*"))
       (with-output-to-temp-buffer output-buffer-name
         (princ ";; Please check the following package descriptor.\n")
         (princ ";; If the correct package description or dependencies are missing,\n")
         (princ ";; then the source .el file is likely malformed, and should be fixed.\n")
-        (pp (assoc (intern name) (package-build-archive-alist))))
+        (pp entry))
       (with-current-buffer output-buffer-name
-        (emacs-lisp-mode)
+        (if (fboundp 'lisp-data-mode) (lisp-data-mode) (emacs-lisp-mode))
-        (view-mode)))
+        (view-mode))
-    (when (yes-or-no-p "Install new package? ")
+      (when (y-or-n-p "Install new package? ")
-      (package-install-file
+        (package-install-file (package-build--artifact-file entry))
-       (package-build--artifact-file
+        (pop-to-buffer (get-buffer byte-compile-log-buffer))))))
-        (assq (intern name) (package-build-archive-alist)))))))
 
 (provide 'package-recipe-mode)
 ;;; package-recipe-mode.el ends here