diff options
Diffstat (limited to 'lisp/emacs-lisp/package-vc.el')
| -rw-r--r-- | lisp/emacs-lisp/package-vc.el | 615 |
1 files changed, 615 insertions, 0 deletions
diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el new file mode 100644 index 00000000000..52e7e25e9f1 --- /dev/null +++ b/lisp/emacs-lisp/package-vc.el @@ -0,0 +1,615 @@ +;;; package-vc.el --- Manage packages from VC checkouts -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Philip Kaludercic <philipk@posteo.net> +;; Keywords: tools + +;; This program 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 program 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 program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; While packages managed by package.el use tarballs for distributing +;; the source code, this extension allows for packages to be fetched +;; and updated directly from a version control system. + +;;; TODO: + +;; - Allow for automatic updating +;; * Detect merge conflicts +;; * Check if there are upstream changes +;; - Allow finding revisions that bump the version tag +;; * Allow for `package-vc-install' to use the version +;; of the package if already installed. +;; - Allow for ELPA specifications to be respected without +;; endangering the user with arbitrary code execution +;; - Allow maintaining patches that are ported back onto regular +;; packages and maintained between versions. +;; - Allow locking the specific revisions of sourced packages +;; (comparable to `package-selected-packages') so that specific +;; revisions can be re-installed. + +;;; Code: + +(eval-when-compile (require 'rx)) +(eval-when-compile (require 'inline)) +(eval-when-compile (require 'map)) +(require 'package) +(require 'lisp-mnt) +(require 'vc) +(require 'seq) +(require 'xdg) + +(defgroup package-vc nil + "Manage packages from VC checkouts." + :group 'package + :version "29.1") + +(defconst package-vc-elpa-packages-version 1 + "Version number of the package specification format understood by package-vc.") + +(defcustom package-vc-heuristic-alist + `((,(rx bos "http" (? "s") "://" + (or (: (? "www.") "github.com" + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "codeberg.org" + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: (? "www.") "gitlab" (+ "." (+ alnum)) + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "git.sr.ht" + "/~" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/" + (or "r" "git") "/" + (+ (or alnum "-" "." "_")) (? "/"))) + (or (? "/") ".git") eos) + . Git) + (,(rx bos "http" (? "s") "://" + (or (: "hg.sr.ht" + "/~" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/" + (+ (or alnum "-" "." "_")) (? "/"))) + eos) + . Hg) + (,(rx bos "http" (? "s") "://" + (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/" + (+ (or alnum "-" "." "_")) (? "/"))) + eos) + . Bzr)) + "Heuristic mapping URL regular expressions to VC backends." + :type `(alist :key-type (regexp :tag "Regular expression matching URLs") + :value-type (choice :tag "VC Backend" + ,@(mapcar (lambda (b) `(const ,b)) + vc-handled-backends))) + :version "29.1") + +(defcustom package-vc-repository-store + (expand-file-name "emacs/vc-packages" (xdg-data-home)) + "Directory used by `package-vc-unpack' to store repositories." + :type 'directory + :version "29.1") + +(defcustom package-vc-default-backend 'Git + "Default VC backend used when cloning a package repository. +If no repository type was specified or could be guessed by +`package-vc-heuristic-alist', the VC backend denoted by this +symbol is used. The value must be a member of +`vc-handled-backends' that implements the `clone' function." + :type `(choice ,@(mapcar (lambda (b) (list 'const b)) + vc-handled-backends)) + :version "29.1") + +(defvar package-vc-archive-spec-alist nil + "List of package specifications for each archive. +The list maps package names as string to plist. Valid keys +include + + `:url' (string) + +The URL of the repository used to fetch the package source. + + `:branch' (string) + +If given, the branch to check out after cloning the directory. + + `:lisp-dir' (string) + +The repository-relative directory to use for loading the Lisp +sources. If not given, the value defaults to the root directory +of the repository. + + `:main-file' (string) + +The main file of the project, relevant to gather package +metadata. If not given, the assumed default is the package named +with \".el\" concatenated to the end. + + `:vc-backend' (symbol) + +A symbol indicating what the VC backend to use for cloning a +package. The value ought to be a member of +`vc-handled-backends'. If missing, `vc-clone' will fall back +onto the archive default or `package-vc-default-backend'. + +All other values are ignored.") + +(defvar package-vc-archive-data-alist nil + "List of package specification archive metadata. +Each element of the list has the form (ARCHIVE . PLIST), where +PLIST keys are one of: + + `:version' (integer) + +Indicating the version of the file formatting, to be compared +with `package-vc-elpa-packages-version'. + + `:vc-backend' (symbol) + +A symbol indicating what the default VC backend to use if a +package specification does not indicate anything. The value +ought to be a member of `vc-handled-backends'. If missing, +`vc-clone' will fall back onto `package-vc-default-backend'. + +All other values are ignored.") + +(defun package-vc-desc->spec (pkg-desc &optional name) + "Retrieve the package specification for PKG-DESC. +The optional argument NAME can be used to override the default +name for PKG-DESC." + (alist-get + (or name (package-desc-name pkg-desc)) + (if (package-desc-archive pkg-desc) + (alist-get (intern (package-desc-archive pkg-desc)) + package-vc-archive-spec-alist) + (mapcan #'append (mapcar #'cdr package-vc-archive-spec-alist))) + nil nil #'string=)) + +(define-inline package-vc-query-spec (pkg-desc prop) + "Query the property PROP for the package specification for PKG-DESC. +If no package specification can be determined, the function will +return nil." + (inline-letevals (pkg-desc prop) + (inline-quote (plist-get (package-vc-desc->spec ,pkg-desc) ,prop)))) + +(defun package-vc--read-archive-data (archive) + "Update `package-vc-archive-spec-alist' with the contents of ARCHIVE. +This function is meant to be used as a hook for +`package--read-archive-hook'." + (let* ((contents-file (expand-file-name + (format "archives/%s/elpa-packages.eld" archive) + package-user-dir))) + (when (file-exists-p contents-file) + (with-temp-buffer + (let ((coding-system-for-read 'utf-8)) + (insert-file-contents contents-file) + ;; The response from the server is expected to have the form + ;; + ;; ((("foo" :url "..." ...) ...) + ;; :version 1 + ;; :default-vc Git) + (let ((spec (read (current-buffer)))) + (when (eq package-vc-elpa-packages-version + (plist-get (cdr spec) :version)) + (setf (alist-get (intern archive) package-vc-archive-spec-alist) + (car spec))) + (setf (alist-get (intern archive) package-vc-archive-data-alist) + (cdr spec)) + (when-let ((default-vc (plist-get (cdr spec) :default-vc)) + ((not (memq default-vc vc-handled-backends)))) + (warn "Archive `%S' expects missing VC backend %S" + archive (plist-get (cdr spec) :default-vc))))))))) + +(defun package-vc--download-and-read-archives (&optional async) + "Download specifications of all `package-archives' and read them. +Populate `package-vc-archive-spec-alist' with the result. + +If optional argument ASYNC is non-nil, perform the downloads +asynchronously." + (dolist (archive package-archives) + (condition-case-unless-debug nil + (package--download-one-archive archive "elpa-packages.eld" async) + (error (message "Failed to download `%s' archive." (car archive)))))) + +(add-hook 'package-read-archive-hook #'package-vc--read-archive-data 20) +(add-hook 'package-refresh-contents-hook #'package-vc--download-and-read-archives 20) + +(defun package-vc-commit (pkg) + "Extract the commit of a development package PKG." + (cl-assert (package-vc-p pkg)) + ;; FIXME: vc should be extended to allow querying the commit of a + ;; directory (as is possible when dealing with git repositores). + ;; This should be a fallback option. + (cl-loop with dir = (package-desc-dir pkg) + for file in (directory-files dir t "\\.el\\'" t) + when (vc-working-revision file) return it + finally return "unknown")) + +(defun package-vc-version (pkg) + "Extract the commit of a development package PKG." + (cl-assert (package-vc-p pkg)) + (cl-loop with dir = (package-desc-dir pkg) ;FIXME: dir is nil + for file in (sort (directory-files dir t "\\.el\\'") + (lambda (s1 s2) + (< (length s1) (length s2)))) + when (with-temp-buffer + (insert-file-contents file) + (package-strip-rcs-id + (or (lm-header "package-version") + (lm-header "version")))) + return it + finally return "0")) + +(defun package-vc-main-file (pkg-desc) + "Return the main file for PKG-DESC." + (cl-assert (package-vc-p pkg-desc)) + (let ((pkg-spec (package-vc-desc->spec pkg-desc))) + (or (plist-get pkg-spec :main-file) + (expand-file-name + (format "%s.el" (package-desc-name pkg-desc)) + (file-name-concat + (or (package-desc-dir pkg-desc) + (expand-file-name + (package-desc-name pkg-desc) + package-user-dir)) + (plist-get pkg-spec :lisp-dir)))))) + +(defun package-vc-generate-description-file (pkg-desc pkg-file) + "Generate a package description file for PKG-DESC. +The output is written out into PKG-FILE." + (let ((name (package-desc-name pkg-desc))) + ;; Infer the subject if missing. + (unless (package-desc-summary pkg-desc) + (setf (package-desc-summary pkg-desc) + (let ((main-file (package-vc-main-file pkg-desc))) + (or (package-desc-summary pkg-desc) + (and-let* ((pkg (cadr (assq name package-archive-contents)))) + (package-desc-summary pkg)) + (and main-file (file-exists-p main-file) + (lm-summary main-file)) + package--default-summary)))) + (let ((print-level nil) + (print-quoted t) + (print-length nil)) + (write-region + (concat + ";;; Generated package description from " + (replace-regexp-in-string + "-pkg\\.el\\'" ".el" + (file-name-nondirectory pkg-file)) + " -*- no-byte-compile: t -*-\n" + (prin1-to-string + (nconc + (list 'define-package + (symbol-name name) + (cons 'vc (package-vc-version pkg-desc)) + (package-desc-summary pkg-desc) + (let ((requires (package-desc-reqs pkg-desc))) + (list 'quote + ;; Turn version lists into string form. + (mapcar + (lambda (elt) + (list (car elt) + (package-version-join (cadr elt)))) + requires)))) + (package--alist-to-plist-args + (package-desc-extras pkg-desc)))) + "\n") + nil pkg-file nil 'silent)))) + +(declare-function org-export-to-file "ox" (backend file)) + +(defun package-vc-build-documentation (pkg-desc file) + "Build documentation FILE for PKG-DESC." + (let ((pkg-dir (package-desc-dir pkg-desc))) + (when (string-match-p "\\.org\\'" file) + (require 'ox) + (require 'ox-texinfo) + (with-temp-buffer + (insert-file-contents file) + (setq file (make-temp-file "ox-texinfo-")) + (org-export-to-file 'texinfo file))) + (call-process "install-info" nil nil nil + file pkg-dir))) + +(defun package-vc-unpack-1 (pkg-desc pkg-dir) + "Install PKG-DESC that is already located in PKG-DIR." + ;; In case the package was installed directly from source, the + ;; dependency list wasn't know beforehand, and they might have + ;; to be installed explicitly. + (let (deps) + (dolist (file (directory-files pkg-dir t "\\.el\\'" t)) + (with-temp-buffer + (insert-file-contents file) + (when-let* ((require-lines (lm-header-multiline "package-requires"))) + (thread-last + (mapconcat #'identity require-lines " ") + package-read-from-string + package--prepare-dependencies + (nconc deps) + (setq deps))))) + (dolist (dep deps) + (cl-callf version-to-list (cadr dep))) + (package-download-transaction + (package-compute-transaction nil (delete-dups deps)))) + + (let ((default-directory (file-name-as-directory pkg-dir)) + (name (package-desc-name pkg-desc)) + (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir))) + ;; Generate autoloads + (package-generate-autoloads name pkg-dir) + + ;; Generate package file + (package-vc-generate-description-file pkg-desc pkg-file) + + ;; Detect a manual + (when-let ((pkg-spec (package-vc-desc->spec pkg-desc)) + ((executable-find "install-info"))) + (dolist (doc-file (ensure-list (plist-get pkg-spec :doc))) + (package-vc-build-documentation pkg-desc doc-file)))) + + ;; Update package-alist. + (let ((new-desc (package-load-descriptor pkg-dir))) + ;; Activation has to be done before compilation, so that if we're + ;; upgrading and macros have changed we load the new definitions + ;; before compiling. + (when (package-activate-1 new-desc :reload :deps) + ;; FIXME: Compilation should be done as a separate, optional, step. + ;; E.g. for multi-package installs, we should first install all packages + ;; and then compile them. + (package--compile new-desc) + (when package-native-compile + (package--native-compile-async new-desc)) + ;; After compilation, load again any files loaded by + ;; `activate-1', so that we use the byte-compiled definitions. + (package--reload-previously-loaded new-desc))) + + ;; Mark package as selected + (package--save-selected-packages + (cons (package-desc-name pkg-desc) + package-selected-packages)) + + ;; Confirm that the installation was successful + (let ((main-file (package-vc-main-file pkg-desc))) + (message "Source package `%s' installed (Version %s, Revision %S)." + (package-desc-name pkg-desc) + (lm-with-file main-file + (package-strip-rcs-id + (or (lm-header "package-version") + (lm-header "version")))) + (vc-working-revision main-file))) + t) + +(defun package-vc-guess-backend (url) + "Guess the VC backend for URL. +This function will internally query `package-vc-heuristic-alist' +and return nil if no reasonable guess can be made." + (and url (alist-get url package-vc-heuristic-alist + nil nil #'string-match-p))) + +(defun package-vc-unpack (pkg-desc pkg-spec &optional rev) + "Install the package described by PKG-DESC. +PKG-SPEC is a package specification is a property list describing +how to fetch and build the package PKG-DESC. See +`package-vc-archive-spec-alist' for details. The optional argument +REV specifies a specific revision to checkout. This overrides +the `:brach' attribute in PKG-SPEC." + (let* ((name (package-desc-name pkg-desc)) + (dirname (package-desc-full-name pkg-desc)) + (pkg-dir (expand-file-name dirname package-user-dir))) + (setf (package-desc-dir pkg-desc) pkg-dir) + (when (file-exists-p pkg-dir) + (if (yes-or-no-p "Overwrite previous checkout?") + (package--delete-directory pkg-dir pkg-desc) + (error "There already exists a checkout for %s" name))) + (pcase-let* (((map :url :branch :lisp-dir) pkg-spec) + (repo-dir + (if (null lisp-dir) + pkg-dir + (unless (file-exists-p package-vc-repository-store) + (make-directory package-vc-repository-store t)) + (file-name-concat + package-vc-repository-store + ;; FIXME: We aren't sure this directory + ;; will be unique, but we can try other + ;; names to avoid an unnecessary error. + (file-name-base url))))) + + ;; Clone the repository into `repo-dir' if necessary + (unless (file-exists-p repo-dir) + (make-directory (file-name-directory repo-dir) t) + (let ((backend (or (plist-get pkg-spec :vc-backend) + (package-vc-query-spec pkg-desc :vc-backend) + (package-vc-guess-backend url) + (plist-get (alist-get (package-desc-archive pkg-desc) + package-vc-archive-data-alist + nil nil #'string=) + :vc-backend) + package-vc-default-backend))) + (unless (vc-clone url backend repo-dir + (or (and (not (eq rev :last-release)) rev) branch)) + (error "Failed to clone %s from %s" name url)))) + + ;; Check out the latest release if requested + (when (eq rev :last-release) + (if-let ((release-rev (package-vc-release-rev pkg-desc))) + (vc-retrieve-tag pkg-dir release-rev) + (message "No release revision was found, continuing..."))) + + (unless (eq pkg-dir repo-dir) + ;; Link from the right position in `repo-dir' to the package + ;; directory in the ELPA store. + (make-symbolic-link (file-name-concat repo-dir lisp-dir) pkg-dir))) + (package-vc-unpack-1 pkg-desc pkg-dir))) + +(defun package-vc-sourced-packages-list () + "Generate a list of packages with VC data." + (seq-filter + (lambda (pkg) + (or (package-vc-desc->spec (cadr pkg)) + ;; If we have no explicit VC data, we can try a kind of + ;; heuristic and use the URL header, that might already be + ;; pointing towards a repository, and use that as a backup + (and-let* ((extras (package-desc-extras (cadr pkg))) + (url (alist-get :url extras)) + ((package-vc-guess-backend url)))))) + package-archive-contents)) + +(defun package-vc-update (pkg-desc) + "Attempt to update the packager PKG-DESC." + (let* ((default-directory (package-desc-dir pkg-desc)) + (ret (with-demoted-errors "Error during package update: %S" + (vc-pull))) + (buf (cond + ((processp ret) (process-buffer ret)) + ((bufferp ret) ret)))) + (if buf + (with-current-buffer buf + (vc-run-delayed + (package-vc-unpack-1 pkg-desc default-directory))) + (package-vc-unpack-1 pkg-desc default-directory)))) + +(defun package-vc--archives-initialize () + "Initialise package.el and fetch package specifications." + (package--archives-initialize) + (unless package-vc-archive-data-alist + (package-vc--download-and-read-archives))) + +(defun package-vc-release-rev (pkg-desc) + "Find the latest revision that bumps the \"Version\" tag for PKG-DESC. +If no such revision can be found, return nil." + (with-current-buffer (find-file-noselect (package-vc-main-file pkg-desc)) + (vc-buffer-sync) + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t)) + (when (cond + ((re-search-forward + (concat (lm-get-header-re "package-version") ".*$") + (lm-code-start) t)) + ((re-search-forward + (concat (lm-get-header-re "version") ".*$") + (lm-code-start) t))) + (ignore-error vc-not-supported + (vc-call-backend (vc-backend (buffer-file-name)) + 'last-change + (buffer-file-name) + (line-number-at-pos nil t)))))))) + +;;;###autoload +(defun package-vc-install (name-or-url &optional name rev backend) + "Fetch the source of NAME-OR-URL. +If NAME-OR-URL is a URL, then the package will be downloaded from +the repository indicated by the URL. The function will try to +guess the name of the package using `file-name-base'. This can +be overridden by manually passing the optional NAME. Otherwise +NAME-OR-URL is taken to be a package name, and the package +metadata will be consulted for the URL. An explicit revision can +be requested using REV. If the command is invoked with a prefix +argument, the revision used for the last release in the package +archive is used. This can also be reproduced by passing the +special value `:last-release' as REV. If a NAME-OR-URL is a URL, +that is to say a string, the VC backend used to clone the +repository can be set by BACKEND. If missing, +`package-vc-guess-backend' will be used." + (interactive + (progn + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (package-vc--archives-initialize) + (let* ((packages (package-vc-sourced-packages-list)) + (input (completing-read + "Fetch package source (name or URL): " packages)) + (name (file-name-base input))) + (list input (intern (string-remove-prefix "emacs-" name)) + (and current-prefix-arg :last-release))))) + (package-vc--archives-initialize) + (cond + ((and-let* ((stringp name-or-url) + (backend (or backend (package-vc-guess-backend name-or-url)))) + (package-vc-unpack + (package-desc-create + :name (or name (intern (file-name-base name-or-url))) + :kind 'vc) + (list :vc-backend backend :url name-or-url) + rev))) + ((and-let* ((desc (assoc name-or-url package-archive-contents #'string=))) + (package-vc-unpack + (let ((copy (copy-package-desc (cadr desc)))) + (setf (package-desc-kind copy) 'vc) + copy) + (or (package-vc-desc->spec (cadr desc)) + (and-let* ((extras (package-desc-extras (cadr desc))) + (url (alist-get :url extras)) + (backend (package-vc-guess-backend url))) + (list :vc-backend backend :url url)) + (user-error "Package has no VC data")) + rev))) + ((user-error "Unknown package to fetch: %s" name-or-url)))) + +(defun package-vc-link-directory (dir name) + "Install the package NAME in DIR by linking it into the ELPA directory. +If invoked interactively with a prefix argument, the user will be +prompted for the package NAME. Otherwise it will be inferred +from the base name of DIR." + (interactive (let ((dir (read-directory-name "Directory: "))) + (list dir + (if current-prefix-arg + (read-string "Package name: ") + (file-name-base (directory-file-name dir)))))) + (unless (vc-responsible-backend dir) + (user-error "Directory %S is not under version control" dir)) + (package-vc--archives-initialize) + (let* ((name (or name (file-name-base (directory-file-name dir)))) + (pkg-dir (expand-file-name name package-user-dir))) + (make-symbolic-link dir pkg-dir) + (package-vc-unpack-1 (package-desc-create + :name (intern name) + :kind 'vc) + pkg-dir))) + +(defun package-vc-refresh (pkg-desc) + "Refresh the installation for PKG-DESC." + (interactive (package-vc-read-pkg "Refresh package: ")) + (package-vc-unpack-1 pkg-desc (package-desc-dir pkg-desc))) + +(defun package-vc-read-pkg (prompt) + "Query for a source package description with PROMPT." + (cadr (assoc (completing-read + prompt + package-alist + (lambda (pkg) (package-vc-p (cadr pkg))) + t) + package-alist + #'string=))) + +;;;###autoload +(defun package-vc-prepare-patch (pkg subject revisions) + "Send a patch to the maintainer of a package PKG. +SUBJECT and REVISIONS are used passed on to `vc-prepare-patch'. +PKG must be a package description." + (interactive + (list (package-vc-read-pkg "Package to prepare a patch for: ") + (and (not vc-prepare-patches-separately) + (read-string "Subject: " "[PATCH] " nil nil t)) + (or (log-view-get-marked) + (vc-read-multiple-revisions "Revisions: ")))) + (vc-prepare-patch (package-maintainers pkg t) + subject revisions)) + +(provide 'package-vc) +;;; package-vc.el ends here |