package-build-badges.el

;;; package-build-badges.el --- Create badges for packages  -*- lexical-binding:t; coding:utf-8 -*-

;; Copyright (C) 2011-2024 Donald Ephraim Curtis
;; Copyright (C) 2012-2024 Steve Purcell
;; Copyright (C) 2018-2024 Jonas Bernoulli
;; Copyright (C) 2021-2023 Free Software Foundation, Inc
;; Copyright (C) 2009 Phil Hagelberg

;; Author: Donald Ephraim Curtis <dcurtis@milkbox.net>
;; Maintainer: Jonas Bernoulli <emacs.package-build@jonas.bernoulli.dev>
;; Homepage: https://github.com/melpa/package-build
;; Keywords: maint tools

;; SPDX-License-Identifier: GPL-3.0-or-later

;; This file is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this file.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Create badges for packages.
;; The code in this file was lifted from `elpa-admin'.

;;; Code:

(defvar package-build-badge-data)

(defun package-build--write-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 (car package-build-badge-data) "myElpa"))
         (right version)
         (color (or color (cadr package-build-badge-data) "#ff491b"))
         (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