diff options
Diffstat (limited to 'lisp/emacs-lisp/package-vc.el')
| -rw-r--r-- | lisp/emacs-lisp/package-vc.el | 393 |
1 files changed, 393 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..dfa8094e614 --- /dev/null +++ b/lisp/emacs-lisp/package-vc.el @@ -0,0 +1,393 @@ +;;; 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 TODO +;; * Detect merge conflicts TODO +;; * Check if there are upstream changes TODO +;; - Allow finding revisions that bump the version tag TODO +;; * Allow for `package-vc-install' to use the version +;; of the package if already installed. +;; - Allow for ELPA specifications to be respected without TODO +;; endangering the user with arbitrary code execution + +;;; Code: + +(eval-when-compile (require 'rx)) +(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") + +(defcustom package-vc-heusitic-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") + +(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-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))) + (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)))) + +(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) + (vc-ignore (concat "/" (file-relative-name + (expand-file-name (format "%s-autoloads.el" name)) + default-directory))) + + ;; Generate package file + (package-vc-generate-description-file pkg-desc pkg-file) + (vc-ignore (concat "/" (file-relative-name pkg-file default-directory))) + + ;; Detect a manual + (when (executable-find "install-info") + ;; Only proceed if we can find an unambiguous TeXinfo file + (let ((texi-files (directory-files pkg-dir t "\\.texi\\'")) + (dir-file (expand-file-name "dir" pkg-dir))) + (when (length= texi-files 1) + (call-process "install-info" nil nil nil + (concat "--dir=" dir-file) + (car texi-files))) + (vc-ignore "/dir")))) + + ;; 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))) + +(defun package-vc-unpack (pkg-desc) + "Install the package described by PKG-DESC." + (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* ((attr (package-desc-extras pkg-desc)) + (`(,backend ,repo ,dir ,branch) + (or (alist-get :upstream attr) + (error "Source package has no repository"))) + (repo-dir + (if (null 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 repo))))) + + ;; Clone the repository into `repo-dir'. + (make-directory (file-name-directory repo-dir) t) + (unless (setf (car (alist-get :upstream attr)) + (vc-clone backend repo repo-dir)) + (error "Failed to clone %s from %s" name repo)) + + (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 dir) pkg-dir)) + (when-let ((default-directory repo-dir) + (rev (or (alist-get :rev attr) branch))) + (vc-retrieve-tag pkg-dir rev))) + + (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) + (let ((extras (package-desc-extras (cadr pkg)))) + (or (alist-get :vc extras) + ;; 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* ((url (alist-get :url extras)) + (backend (alist-get url package-vc-heusitic-alist + nil nil #'string-match-p))) + (setf (alist-get :vc (package-desc-extras (cadr pkg))) + (list backend url)) + t)))) + 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)))) + + +;;;###autoload +(defun package-vc-install (name-or-url &optional name rev) + "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." + (interactive + (progn + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (package--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)))))) + (package--archives-initialize) + (package-vc-unpack + (cond + ((and (stringp name-or-url) + (url-type (url-generic-parse-url name-or-url))) + (package-desc-create + :name (or name (intern (file-name-base name-or-url))) + :kind 'vc + :extras `((:upstream . ,(list nil name-or-url nil nil)) + (:rev . ,rev)))) + ((when-let* ((desc (cadr (assoc name-or-url package-archive-contents + #'string=))) + (upstream (or (alist-get :vc (package-desc-extras desc)) + (user-error "Package has no VC data")))) + (package-desc-create + :name (if (stringp name-or-url) + (intern name-or-url) + name-or-url) + :kind 'vc + :extras `((:upstream . ,upstream) + (:rev . ,rev))))) + ((user-error "Unknown package to fetch: %s" name-or-url))))) + +;;;###autoload +(defalias 'package-checkout #'package-vc-install) + +(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--archives-initialize) + (let* ((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 |