219 lines
8.3 KiB
EmacsLisp
219 lines
8.3 KiB
EmacsLisp
;;; package-recipe.el --- Package recipes as EIEIO objects -*- lexical-binding:t; coding:utf-8 -*-
|
|
|
|
;; Copyright (C) 2018-2023 Jonas Bernoulli
|
|
|
|
;; Author: Jonas Bernoulli <jonas@bernoul.li>
|
|
;; 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:
|
|
|
|
;; Package recipes as EIEIO objects.
|
|
|
|
;;; Code:
|
|
|
|
(require 'eieio)
|
|
(require 'subr-x)
|
|
(require 'url-parse)
|
|
|
|
(defvar package-build-use-git-remote-hg)
|
|
(defvar package-build-recipes-dir)
|
|
(defvar package-build-working-dir)
|
|
|
|
;;; Classes
|
|
|
|
(defclass package-recipe ()
|
|
((url-format :allocation :class :initform nil)
|
|
(repopage-format :allocation :class :initform nil)
|
|
(stable-p :allocation :class :initform nil)
|
|
(name :initarg :name :initform nil)
|
|
(url :initarg :url :initform nil)
|
|
(repo :initarg :repo :initform nil)
|
|
(repopage :initarg :repopage :initform nil)
|
|
(files :initarg :files :initform nil)
|
|
(branch :initarg :branch :initform nil)
|
|
(commit :initarg :commit :initform nil)
|
|
(time :initform nil)
|
|
(version :initform nil)
|
|
(version-regexp :initarg :version-regexp :initform nil)
|
|
(old-names :initarg :old-names :initform nil))
|
|
:abstract t)
|
|
|
|
;;;; Git
|
|
|
|
(defclass package-git-recipe (package-recipe) ())
|
|
|
|
(defclass package-github-recipe (package-git-recipe)
|
|
((url-format :initform "https://github.com/%s.git")
|
|
(repopage-format :initform "https://github.com/%s")))
|
|
|
|
(defclass package-gitlab-recipe (package-git-recipe)
|
|
((url-format :initform "https://gitlab.com/%s.git")
|
|
(repopage-format :initform "https://gitlab.com/%s")))
|
|
|
|
(defclass package-codeberg-recipe (package-git-recipe)
|
|
((url-format :initform "https://codeberg.org/%s.git")
|
|
(repopage-format :initform "https://codeberg.org/%s")))
|
|
|
|
(defclass package-sourcehut-recipe (package-git-recipe)
|
|
((url-format :initform "https://git.sr.ht/~%s")
|
|
(repopage-format :initform "https://git.sr.ht/~%s")))
|
|
|
|
;;;; Mercurial
|
|
|
|
(defclass package-hg-recipe (package-recipe) ())
|
|
|
|
(defclass package-git-remote-hg-recipe (package-git-recipe) ())
|
|
|
|
;;; Methods
|
|
|
|
(cl-defmethod package-recipe--working-tree ((rcp package-recipe))
|
|
(file-name-as-directory
|
|
(expand-file-name (oref rcp name) package-build-working-dir)))
|
|
|
|
(cl-defmethod package-recipe--upstream-url ((rcp package-recipe))
|
|
(or (oref rcp url)
|
|
(format (oref rcp url-format)
|
|
(oref rcp repo))))
|
|
|
|
(cl-defmethod package-recipe--upstream-url ((rcp package-git-remote-hg-recipe))
|
|
(concat "hg::" (oref rcp url)))
|
|
|
|
(cl-defmethod package-recipe--upstream-protocol ((rcp package-recipe))
|
|
(let ((url (package-recipe--upstream-url rcp)))
|
|
(cond ((string-match "\\`\\([a-z]+\\)://" url)
|
|
(match-string 1 url))
|
|
((string-match "\\`[^:/ ]+:" url) "ssh")
|
|
(t "file"))))
|
|
|
|
(cl-defmethod package-recipe--fetcher ((rcp package-recipe))
|
|
(substring (symbol-name (eieio-object-class rcp)) 8 -7))
|
|
|
|
;;; Constants
|
|
|
|
(defconst package-recipe--forge-fetchers
|
|
'(github gitlab codeberg sourcehut))
|
|
|
|
(defconst package-recipe--fetchers
|
|
(append '(git hg) package-recipe--forge-fetchers))
|
|
|
|
;;; Interface
|
|
|
|
(defun package-recipe-recipes ()
|
|
"Return a list of the names of packages with available recipes."
|
|
(directory-files package-build-recipes-dir nil "^[^.]"))
|
|
|
|
(defun package-recipe-read-name ()
|
|
"Read the name of a package for which a recipe is available."
|
|
(completing-read "Package: " (package-recipe-recipes)))
|
|
|
|
(defun package-recipe-lookup (name)
|
|
"Return a recipe object for the package named NAME.
|
|
If no such recipe file exists or if the contents of the recipe
|
|
file is invalid, then raise an error."
|
|
(let ((file (expand-file-name name package-build-recipes-dir)))
|
|
(if (file-exists-p file)
|
|
(let* ((recipe (with-temp-buffer
|
|
(insert-file-contents file)
|
|
(read (current-buffer))))
|
|
(plist (cdr recipe))
|
|
(fetcher (plist-get plist :fetcher))
|
|
key val args)
|
|
(package-recipe--validate recipe name)
|
|
(while (and (setq key (pop plist))
|
|
(setq val (pop plist)))
|
|
(unless (eq key :fetcher)
|
|
(push val args)
|
|
(push key args)))
|
|
(when (and package-build-use-git-remote-hg (eq fetcher 'hg))
|
|
(setq fetcher 'git-remote-hg))
|
|
(apply (intern (format "package-%s-recipe" fetcher))
|
|
name :name name args))
|
|
(error "No such recipe: %s" name))))
|
|
|
|
;;; Validation
|
|
|
|
(defun package-recipe-validate-all ()
|
|
"Validate all recipes."
|
|
(interactive)
|
|
(dolist (name (package-recipe-recipes))
|
|
(condition-case err
|
|
(package-recipe-lookup name)
|
|
(error (message "Invalid recipe for %s: %S" name (cdr err))))))
|
|
|
|
(defun package-recipe--validate (recipe name)
|
|
"Perform some basic checks on the raw RECIPE for the package named NAME."
|
|
(pcase-let ((`(,ident . ,plist) recipe))
|
|
(cl-assert ident)
|
|
(cl-assert (symbolp ident))
|
|
(cl-assert (string= (symbol-name ident) name)
|
|
nil "Recipe '%s' contains mismatched package name '%s'"
|
|
name ident)
|
|
(cl-assert plist)
|
|
(let* ((symbol-keys '(:fetcher))
|
|
(string-keys '(:url :repo :commit :branch :version-regexp))
|
|
(list-keys '(:files :old-names))
|
|
(all-keys (append symbol-keys string-keys list-keys)))
|
|
(dolist (thing plist)
|
|
(when (keywordp thing)
|
|
(cl-assert (memq thing all-keys) nil "Unknown keyword %S" thing)))
|
|
(let ((fetcher (plist-get plist :fetcher)))
|
|
(cl-assert fetcher nil ":fetcher is missing")
|
|
(if (memq fetcher package-recipe--forge-fetchers)
|
|
(progn
|
|
(cl-assert (plist-get plist :repo) ":repo is missing")
|
|
(cl-assert (not (plist-get plist :url)) ":url is redundant"))
|
|
(cl-assert (plist-get plist :url) ":url is missing")))
|
|
(dolist (key symbol-keys)
|
|
(let ((val (plist-get plist key)))
|
|
(when val
|
|
(cl-assert (symbolp val) nil "%s must be a symbol but is %S" key val))))
|
|
(dolist (key list-keys)
|
|
(let ((val (plist-get plist key)))
|
|
(when val
|
|
(cl-assert (listp val) nil "%s must be a list but is %S" key val))))
|
|
(dolist (key string-keys)
|
|
(let ((val (plist-get plist key)))
|
|
(when val
|
|
(cl-assert (stringp val) nil "%s must be a string but is %S" key val))))
|
|
(when-let ((spec (plist-get plist :files)))
|
|
;; `:defaults' is only allowed as the first element.
|
|
;; If we find it in that position, skip over it.
|
|
(when (eq (car spec) :defaults)
|
|
(setq spec (cdr spec)))
|
|
;; All other elements have to be strings or lists of strings.
|
|
;; A list whose first element is `:exclude' is also valid.
|
|
(dolist (entry spec)
|
|
(unless (or (and (stringp entry)
|
|
(not (equal entry "*")))
|
|
(and (listp entry)
|
|
(or (eq (car entry) :exclude)
|
|
(stringp (car entry)))
|
|
(seq-every-p (lambda (e)
|
|
(and (stringp e)
|
|
(not (equal e "*"))))
|
|
(cdr entry))))
|
|
(error "Invalid files spec entry %S" entry))))
|
|
;; Silence byte compiler of Emacs 28. It appears that uses
|
|
;; inside cl-assert sometimes, but not always, do not count.
|
|
(list name ident all-keys))
|
|
recipe))
|
|
|
|
(provide 'package-recipe)
|
|
;;; package-recipe.el ends here
|