diff --git a/core/libs/package-build-badges.el b/core/libs/package-build-badges.el index bcc3cdff1..9e5e336fe 100644 --- a/core/libs/package-build-badges.el +++ b/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 @@ -26,23 +27,117 @@ ;;; Commentary: -;; In future we should provide a hook. Note also that it would be -;; straightforward to generate the SVG ourselves, which would save -;; the network overhead. +;; Create batches for packages. +;; The code in this file was lifted from `elpa-admin'. ;;; Code: (defvar package-build-stable) -(defun package-build--write-melpa-badge-image (name version target-dir) - (unless (zerop (call-process - "curl" nil nil nil "-f" "-o" - (expand-file-name (concat name "-badge.svg") target-dir) - (format "https://img.shields.io/badge/%s-%s-%s.svg" - (if package-build-stable "melpa stable" "melpa") - (url-hexify-string version) - (if package-build-stable "3e999f" "922793")))) - (message "Failed to fetch badge"))) +(defun package-build--write-melpa-badge-image ( name version target-dir + &optional archive color) + "Make badge svg file. +This is essentially a copy of `elpaa--make-badge'." + (let* ((file (expand-file-name (concat name "-badge.svg") target-dir)) + (left (or archive (if package-build-stable "melpa stable" "melpa"))) + (right (url-hexify-string version)) + (color (or color (if package-build-stable "#3e999f" "#922793"))) + (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 + "'" "\"" + " + + {left}: {right} + + + + + + + + + + + + + + + {left} + + {right} + +"))))) + (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 diff --git a/core/libs/package-recipe-mode.el b/core/libs/package-recipe-mode.el index 512937a51..f00cd2ec1 100644 --- a/core/libs/package-recipe-mode.el +++ b/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', -;; which will likely be replaced with the `emacs-lisp-mode' derived -;; `package-recipe-mode' eventually. +;; This library defines the major-mode `package-recipe-mode', which is +;; used for Melpa package recipe files. ;;; Code: (require 'package-build) -(defvar package-build-minor-mode-map - (let ((m (make-sparse-keymap))) - (define-key m (kbd "C-c C-c") 'package-build-current-recipe) - m) - "Keymap for `package-build-minor-mode'.") +;;;###autoload +(defvar package-recipe-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-c") 'package-build-current-recipe) + (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 - "Helpful functionality for building packages." - :lighter " PBuild" - (when package-build-minor-mode - (message "Use C-c C-c to build this recipe."))) +;;;###autoload +(if (fboundp 'lisp-data-mode) ; Since Emacs 28.1. + (define-derived-mode package-recipe-mode lisp-data-mode "Melpa-Recipe" + "Major mode for buffers holding Melpa package recipes." + :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) - (insert (pp-to-string `(,(intern name) - :fetcher ,fetcher - ,@(cl-case fetcher - (github (list :repo "USER/REPO")) - (t (list :url "SCM_URL_HERE")))))) - (emacs-lisp-mode) - (package-build-minor-mode) - (goto-char (point-min)))) + (with-current-buffer (find-file recipe-file) + (save-excursion + (insert (format "(%s\n" name) + (format " :fetcher %s\n" fetcher) + (if (memq fetcher package-recipe--forge-fetchers) + " :repo \"USER/REPO\")\n" + " :url \"https://TODO\")\n")))))) ;;;###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) - (view-mode))) - (when (yes-or-no-p "Install new package? ") - (package-install-file - (package-build--artifact-file - (assq (intern name) (package-build-archive-alist))))))) + (if (fboundp 'lisp-data-mode) (lisp-data-mode) (emacs-lisp-mode)) + (view-mode)) + (when (y-or-n-p "Install new package? ") + (package-install-file (package-build--artifact-file entry)) + (pop-to-buffer (get-buffer byte-compile-log-buffer)))))) (provide 'package-recipe-mode) ;;; package-recipe-mode.el ends here