diff options
Diffstat (limited to 'lisp/emacs-lisp/package-vc.el')
-rw-r--r-- | lisp/emacs-lisp/package-vc.el | 931 |
1 files changed, 931 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..b753adcb8a0 --- /dev/null +++ b/lisp/emacs-lisp/package-vc.el @@ -0,0 +1,931 @@ +;;; package-vc.el --- Manage packages from VC checkouts -*- lexical-binding: t; -*- + +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. + +;; Author: Philip Kaludercic <philipk@posteo.net> +;; Keywords: tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. + +;; GNU Emacs 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 GNU Emacs. 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. +;; +;; To install a package from source use `package-vc-install'. If you +;; aren't interested in activating a package, you can use +;; `package-vc-checkout' instead, which will prompt you for a target +;; directory. If you wish to re-use an existing checkout, the command +;; `package-vc-install-from-checkout' will create a symbolic link and +;; prepare the package. +;; +;; If you make local changes that you wish to share with an upstream +;; maintainer, the command `package-vc-prepare-patch' can prepare +;; these as patches to send via Email. + +;;; TODO: + +;; - Allow maintaining patches that are ported back onto regular +;; packages and maintained between versions. +;; +;; - Add a heuristic for guessing a `:lisp-dir' when cloning directly +;; from a URL. + +;;; Code: + +(eval-when-compile (require 'rx)) +(eval-when-compile (require 'inline)) +(eval-when-compile (require 'map)) +(eval-when-compile (require 'cl-lib)) +(require 'package) +(require 'lisp-mnt) +(require 'vc) +(require 'seq) + +(defgroup package-vc nil + "Manage packages from VC checkouts." + :group 'package + :link '(custom-manual "(emacs) Package from Source") + :prefix "package-vc-" + :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-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', this is the default VC backend +used as fallback. The value must be a member of +`vc-handled-backends' and the named backend must implement +the `clone' function." + :type `(choice ,@(mapcar (lambda (b) (list 'const b)) + vc-handled-backends)) + :version "29.1") + +(defvar package-vc-selected-packages) ; pacify byte-compiler + +;;;###autoload +(defun package-vc-install-selected-packages () + "Ensure packages specified in `package-vc-selected-packages' are installed." + (interactive) + (pcase-dolist (`(,name . ,spec) package-vc-selected-packages) + (when (stringp name) + (setq name (intern name))) + (let ((pkg-descs (assoc name package-alist #'string=))) + (unless (seq-some #'package-vc-p (cdr pkg-descs)) + (cond + ((null spec) + (package-vc-install name)) + ((stringp spec) + (package-vc-install name spec)) + ((listp spec) + (package-vc--archives-initialize) + (package-vc--unpack + (or (cadr (assoc name package-archive-contents)) + (package-desc-create :name name :kind 'vc)) + spec))))))) + +;;;###autoload +(defcustom package-vc-selected-packages '() + "List of packages that must be installed. +Each member of the list is of the form (NAME . SPEC), where NAME +is a symbol designating the package and SPEC is one of: + +- nil, if any package version can be installed; +- a version string, if that specific revision is to be installed; +- a property list, describing a package specification. Valid + key/value pairs are + + `:url' (string) + The URL of the repository used to fetch the package source. + + `:branch' (string) + If given, the name of the branch to checkout after cloning the directory. + + `:lisp-dir' (string) + The repository-relative name of the 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 name with \".el\" + appended to it. + + `:vc-backend' (symbol) + A symbol of the VC backend to use for cloning the package. The + value ought to be a member of `vc-handled-backends'. If omitted, + `vc-clone' will fall back onto the archive default or on + `package-vc-default-backend'. + + All other keys are ignored. + +This user option differs from `package-selected-packages' in that +it is meant to be specified manually. If you want to install all +the packages in the list, you cal also use +`package-vc-install-selected-packages'. + +Note that this option will not override an existing source +package installation or revert the checked out revision." + :type '(alist :tag "List of packages you want to be installed" + :key-type (symbol :tag "Package") + :value-type + (choice (const :tag "Any revision" nil) + (string :tag "Specific revision") + (plist :options ((:url string) + (:branch string) + (:lisp-dir string) + (:main-file string) + (:vc-backend symbol))))) + :initialize #'custom-initialize-default + :set (lambda (sym val) + (custom-set-default sym val) + (package-vc-install-selected-packages)) + :version "29.1") + +(defvar package-vc--archive-spec-alist nil + "List of package specifications for each archive. +The list maps each package name, as a string, to a plist as +specified in `package-vc-selected-packages'.") + +(defvar package-vc--archive-data-alist nil + "List of package specification metadata for archives. +Each element of the list has the form (ARCHIVE . PLIST), where +PLIST keys are one of: + + `:version' (integer) + Indicates the version of the file formatting, to be compared + with `package-vc--elpa-packages-version'. + + `:vc-backend' (symbol) + A symbol of the default VC backend to use if a package specification + does not indicate a backend. The value ought to be a member of + `vc-handled-backends'. If omitted, `vc-clone' will fall back on + `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) + (apply #'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 of 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' for 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 err + (package--download-one-archive archive "elpa-packages.eld" async) + (error (message "Failed to download `%s' archive: %S" (car archive) err))))) + +(add-hook 'package-read-archive-hook #'package-vc--read-archive-data 20) + +(defun package-vc-commit (pkg) + "Return the last 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 repositories). + ;; 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) + "Return the version number for the VC package PKG." + (cl-assert (package-vc-p pkg)) + (if-let ((main-file (package-vc--main-file pkg))) + (with-temp-buffer + (insert-file-contents main-file) + (package-strip-rcs-id + (or (lm-header "package-version") + (lm-header "version") + "0"))) + "0")) + +(defun package-vc--main-file (pkg-desc) + "Return the name of the main file for PKG-DESC." + (cl-assert (package-vc-p pkg-desc)) + (let* ((pkg-spec (package-vc--desc->spec pkg-desc)) + (name (symbol-name (package-desc-name pkg-desc))) + (directory (file-name-concat + (or (package-desc-dir pkg-desc) + (expand-file-name name package-user-dir)) + (plist-get pkg-spec :lisp-dir) + (and-let* ((extras (package-desc-extras pkg-desc))) + (alist-get :lisp-dir extras)))) + (file (or (plist-get pkg-spec :main-file) + (expand-file-name + (concat name ".el") + directory)))) + (if (file-exists-p file) file + ;; The following heuristic is only necessary when fetching a + ;; repository with URL that would break the above assumptions. + ;; Concrete example: https://github.com/sachac/waveform-el does + ;; not have a file waveform-el.el, but a file waveform.el, so we + ;; try and find the closest match. + (let ((distance most-positive-fixnum) (best nil)) + (dolist (alt (directory-files directory t "\\.el\\'" t)) + (let ((sd (string-distance file alt))) + (when (and (not (string-match-p (rx (or (: "-autoloads.el") + (: "-pkg.el")) + eos) + alt)) + (< sd distance)) + (when (< sd distance) + (setq distance (string-distance file alt) + best alt))))) + best)))) + +(defun package-vc--generate-description-file (pkg-desc pkg-file) + "Generate a package description file for PKG-DESC and write it to 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) + (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)))) + (list :kind 'vc) + (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 for package PKG-DESC from documentation source in FILE. +FILE can be an Org file, indicated by its \".org\" extension, +otherwise it's assumed to be an Info file." + (let* ((pkg-name (package-desc-name pkg-desc)) + (default-directory (package-desc-dir pkg-desc)) + (output (expand-file-name (format "%s.info" pkg-name))) + clean-up) + (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) + (setq clean-up t))) + (with-current-buffer (get-buffer-create " *package-vc doc*") + (erase-buffer) + (cond + ((/= 0 (call-process "makeinfo" nil t nil + "--no-split" file "-o" output)) + (message "Failed to build manual %s, see buffer %S" + file (buffer-name))) + ((/= 0 (call-process "install-info" nil t nil + output (expand-file-name "dir"))) + (message "Failed to install manual %s, see buffer %S" + output (buffer-name))) + ((kill-buffer)))) + (when clean-up + (delete-file file)))) + +(defun package-vc-install-dependencies (requirements) + "Install missing dependencies, and return missing ones. +The return value will be nil if everything was found, or a list +of (NAME VERSION) pairs of all packages that couldn't be found. + +REQUIREMENTS should be a list of additional requirements; each +element in this list should have the form (PACKAGE VERSION-LIST), +where PACKAGE is a package name and VERSION-LIST is the required +version of that package." + (let ((to-install '()) (missing '())) + (cl-labels ((search (pkg) + "Attempt to find all dependencies for PKG." + (cond + ((assq (car pkg) to-install)) ;inhibit cycles + ((package-installed-p (car pkg))) + ((let* ((pac package-archive-contents) + (desc (cadr (assoc (car pkg) pac)))) + (if desc + (let ((reqs (package-desc-reqs desc))) + (push desc to-install) + (mapc #'search reqs)) + (push pkg missing)))))) + (version-order (a b) + "Predicate to sort packages in order." + (version-list-< + (package-desc-version b) + (package-desc-version a))) + (duplicate-p (a b) + "Are A and B the same package?" + (eq (package-desc-name a) (package-desc-name b))) + (depends-on-p (target package) + "Does PACKAGE depend on TARGET?" + (or (eq target package) + (let* ((pac package-archive-contents) + (desc (cadr (assoc package pac)))) + (and desc (seq-some + (apply-partially #'depends-on-p target) + (package-desc-reqs desc)))))) + (dependent-order (a b) + (let ((desc-a (package-desc-name a)) + (desc-b (package-desc-name b))) + (or (not desc-a) (not desc-b) + (not (depends-on-p desc-b desc-a)) + (depends-on-p desc-a desc-b))))) + (mapc #'search requirements) + (cl-callf sort to-install #'version-order) + (cl-callf seq-uniq to-install #'duplicate-p) + (cl-callf sort to-install #'dependent-order)) + (mapc #'package-install-from-archive to-install) + missing)) + +(defun package-vc--unpack-1 (pkg-desc pkg-dir) + "Prepare PKG-DESC that is already checked-out in PKG-DIR. +This includes downloading missing dependencies, generating +autoloads, generating a package description file (used to +identify a package as a VC package later on), building +documentation and marking the package as installed." + (let (missing) + ;; Remove any previous instance of PKG-DESC from `package-alist' + (let ((pkgs (assq (package-desc-name pkg-desc) package-alist))) + (when pkgs + (setf (cdr pkgs) (seq-remove #'package-vc-p (cdr pkgs))))) + + ;; 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))) + (setf missing (package-vc-install-dependencies (delete-dups deps))) + (setf missing (delq (assq (package-desc-name pkg-desc) + missing) + missing))) + + (let ((default-directory (file-name-as-directory pkg-dir)) + (pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir))) + ;; Generate autoloads + (let* ((name (package-desc-name pkg-desc)) + (auto-name (format "%s-autoloads.el" name)) + (extras (package-desc-extras pkg-desc)) + (lisp-dir (alist-get :lisp-dir extras))) + (package-generate-autoloads + name (file-name-concat pkg-dir lisp-dir)) + (when lisp-dir + (write-region + (with-temp-buffer + (insert ";; Autoload indirection for package-vc\n\n") + (prin1 `(load (expand-file-name + ,(file-name-concat lisp-dir auto-name) + (or (and load-file-name + (file-name-directory load-file-name)) + (car load-path)))) + (current-buffer)) + (buffer-string)) + nil (expand-file-name auto-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)) + (package--quickstart-maybe-refresh) + + ;; Confirm that the installation was successful + (let ((main-file (package-vc--main-file pkg-desc))) + (message "VC package `%s' installed (Version %s, Revision %S).%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) + (if missing + (format + " Failed to install the following dependencies: %s" + (mapconcat + (lambda (p) + (format "%s (%s)" (car p) (cadr p))) + missing ", ")) + ""))) + 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 it cannot reasonably guess." + (and url (alist-get url package-vc-heuristic-alist + nil nil #'string-match-p))) + +(defun package-vc--clone (pkg-desc pkg-spec dir rev) + "Clone the package PKG-DESC whose spec is PKG-SPEC into the directory DIR. +REV specifies a specific revision to checkout. This overrides the `:branch' +attribute in PKG-SPEC." + (pcase-let* ((name (package-desc-name pkg-desc)) + ((map :url :branch) pkg-spec)) + + ;; Clone the repository into `repo-dir' if necessary + (unless (file-exists-p dir) + (make-directory (file-name-directory 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 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 dir release-rev) + (message "No release revision was found, continuing..."))))) + +(defvar package-vc-non-code-file-names + '(".dir-locals.el" ".dir-locals-2.el") + "List of file names that do not contain Emacs Lisp code. +This list is used by `package-vc--unpack' to better check if the +user is fetching code from a repository that does not contain any +Emacs Lisp files.") + +(defun package-vc--unpack (pkg-desc pkg-spec &optional rev) + "Install the package described by PKG-DESC. +PKG-SPEC is a package specification, a property list describing +how to fetch and build the package. See `package-vc--archive-spec-alist' +for details. The optional argument REV specifies a specific revision to +checkout. This overrides the `:branch' attribute in PKG-SPEC." + (pcase-let* (((map :lisp-dir) pkg-spec) + (name (package-desc-name pkg-desc)) + (dirname (package-desc-full-name pkg-desc)) + (pkg-dir (file-name-as-directory (expand-file-name dirname package-user-dir)))) + (when (string-empty-p name) + (user-error "Empty package name")) + (setf (package-desc-dir pkg-desc) pkg-dir) + (when (file-exists-p pkg-dir) + (if (yes-or-no-p (format "Overwrite previous checkout for package `%s'?" name)) + (package--delete-directory pkg-dir) + (error "There already exists a checkout for %s" name))) + (package-vc--clone pkg-desc pkg-spec pkg-dir rev) + (when (directory-empty-p pkg-dir) + (delete-directory pkg-dir) + (error "Empty checkout for %s" name)) + (unless (seq-remove + (lambda (file) + (member (file-name-nondirectory file) package-vc-non-code-file-names)) + (directory-files-recursively pkg-dir "\\.el\\'" nil)) + (when (yes-or-no-p (format "No Emacs Lisp files found when fetching \"%s\", \ +abort installation?" name)) + (delete-directory pkg-dir t) + (user-error "Installation aborted"))) + + ;; When nothing is specified about a `lisp-dir', then should + ;; heuristically check if there is a sub-directory with lisp + ;; files. These are conventionally just called "lisp" or "src". + ;; If this directory exists and contains non-zero number of lisp + ;; files, we will use that instead of `pkg-dir'. + (catch 'done + (dolist (name '("lisp" "src")) + (when-let* (((null lisp-dir)) + (dir (expand-file-name name pkg-dir)) + ((file-directory-p dir)) + ((directory-files dir nil "\\`[^.].+\\.el\\'" t 1))) + ;; We won't use `dir', since dir is an absolute path and we + ;; don't want `lisp-dir' to depend on the current location of + ;; the package installation, ie. to break if moved around the + ;; file system or between installations. + (throw 'done (setq lisp-dir name))))) + + (when lisp-dir + (push (cons :lisp-dir lisp-dir) + (package-desc-extras pkg-desc))) + (package-vc--unpack-1 pkg-desc pkg-dir))) + +(defun package-vc--read-package-name (prompt &optional allow-url installed) + "Query the user for a VC package and return a name with PROMPT. +If the optional argument ALLOW-URL is non-nil, the user is also +allowed to specify a non-package name. If the optional argument +INSTALLED is non-nil, the selection will be filtered down to +VC packages that have already been installed." + (package-vc--archives-initialize) + (completing-read prompt (if installed package-alist package-archive-contents) + (if installed + (lambda (pkg) (package-vc-p (cadr pkg))) + (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))))))) + (not allow-url))) + +(defun package-vc--read-package-desc (prompt &optional installed) + "Query the user for a VC package and return a description with PROMPT. +If the optional argument INSTALLED is non-nil, the selection will +be filtered down to VC packages that have already been +installed, and the package description will be that of an +installed package." + (cadr (assoc (package-vc--read-package-name prompt nil installed) + (if installed package-alist package-archive-contents) + #'string=))) + +;;;###autoload +(defun package-vc-update-all () + "Attempt to update all installed VC packages." + (interactive) + (dolist (package package-alist) + (dolist (pkg-desc (cdr package)) + (when (package-vc-p pkg-desc) + (package-vc-update pkg-desc)))) + (message "Done updating packages.")) + +;;;###autoload +(defun package-vc-update (pkg-desc) + "Attempt to update the package PKG-DESC." + (interactive (list (package-vc--read-package-desc "Update VC package: " t))) + ;; HACK: To run `package-vc--unpack-1' after checking out the new + ;; revision, we insert a hook into `vc-post-command-functions', and + ;; remove it right after it ran. To avoid running the hook multiple + ;; times or even for the wrong repository (as `vc-pull' is often + ;; asynchronous), we extract the relevant arguments using a pseudo + ;; filter for `vc-filter-command-function', executed only for the + ;; side effect, and store them in the lexical scope. When the hook + ;; is run, we check if the arguments are the same (`eq') as the ones + ;; previously extracted, and only in that case will be call + ;; `package-vc--unpack-1'. Ugh... + ;; + ;; If there is a better way to do this, it should be done. + (cl-assert (package-vc-p pkg-desc)) + (letrec ((pkg-dir (package-desc-dir pkg-desc)) + (vc-flags) + (vc-filter-command-function + (lambda (command file-or-list flags) + (setq vc-flags flags) + (list command file-or-list flags))) + (post-upgrade + (lambda (_command _file-or-list flags) + (when (and (file-equal-p pkg-dir default-directory) + (eq flags vc-flags)) + (unwind-protect + (with-demoted-errors "Failed to activate: %S" + (package-vc--unpack-1 pkg-desc pkg-dir)) + (remove-hook 'vc-post-command-functions post-upgrade)))))) + (add-hook 'vc-post-command-functions post-upgrade) + (with-demoted-errors "Failed to fetch: %S" + (let ((default-directory pkg-dir)) + (vc-pull))))) + +(defun package-vc--archives-initialize () + "Initialize 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) + "Return 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 (package &optional rev backend name) + "Fetch a PACKAGE and set it up for using with Emacs. + +If PACKAGE is a string containing an URL, download the package +from the repository at that URL; the function will try to guess +the name of the package from the URL. This can be overridden by +passing the optional argument NAME. If PACKAGE is a cons-cell, +it should have the form (NAME . SPEC), where NAME is a symbol +indicating the package name and SPEC is a plist as described in +`package-vc-selected-packages'. Otherwise PACKAGE should be a +symbol whose name is the package name, and the URL for the +package will be taken from the package's metadata. + +By default, this function installs the last version of the package +available from its repository, but if REV is given and non-nil, it +specifies the revision to install. If REV has the special value +`:last-release' (interactively, the prefix argument), that stands +for the last released version of the package. + +Optional argument BACKEND specifies the VC backend to use for cloning +the package's repository; this is only possible if NAME-OR-URL is a URL, +a string. If BACKEND is omitted or nil, the function +uses `package-vc-heuristic-alist' to guess the backend. +Note that by default, a VC package will be prioritized over a +regular package, but it will not remove a VC package. + +\(fn PACKAGE &optional REV BACKEND)" + (interactive + (progn + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (package-vc--archives-initialize) + (let* ((name-or-url (package-vc--read-package-name + "Fetch and install package: " t)) + (name (file-name-base (directory-file-name name-or-url)))) + (when (string-empty-p name) + (user-error "Empty package name")) + (list name-or-url + (and current-prefix-arg :last-release) + nil + (intern (string-remove-prefix "emacs-" name)))))) + (package-vc--archives-initialize) + (cond + ((null package) + (signal 'wrong-type-argument nil)) + ((consp package) + (package-vc--unpack + (package-desc-create :name (car package) + :kind 'vc) + (cdr package) + rev)) + ((and-let* (((stringp package)) + (backend (or backend (package-vc--guess-backend package)))) + (package-vc--unpack + (package-desc-create + :name (or name (intern (file-name-base package))) + :kind 'vc) + (list :vc-backend backend :url package) + rev))) + ((and-let* ((desc (assoc package 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 `%s' has no VC data" package)) + rev))) + ((user-error "Unknown package to fetch: %s" package)))) + +;;;###autoload +(defun package-vc-checkout (pkg-desc directory &optional rev) + "Clone the sources for PKG-DESC into DIRECTORY and visit that directory. +Unlike `package-vc-install', this does not yet set up the package +for use with Emacs; use `package-vc-install-from-checkout' for +setting the package up after this function finishes. Optional +argument REV means to clone a specific version of the package; it +defaults to the last version available from the package's +repository. If REV has the special value +`:last-release' (interactively, the prefix argument), that stands +for the last released version of the package." + (interactive + (let* ((name (package-vc--read-package-name "Fetch package source: "))) + (list (cadr (assoc name package-archive-contents #'string=)) + (read-file-name "Clone into new or empty directory: " nil nil t nil + (lambda (dir) (or (not (file-exists-p dir)) + (directory-empty-p dir)))) + (and current-prefix-arg :last-release)))) + (package-vc--archives-initialize) + (let ((pkg-spec (or (package-vc--desc->spec pkg-desc) + (and-let* ((extras (package-desc-extras pkg-desc)) + (url (alist-get :url extras)) + (backend (package-vc--guess-backend url))) + (list :vc-backend backend :url url)) + (user-error "Package `%s' has no VC data" + (package-desc-name pkg-desc))))) + (package-vc--clone pkg-desc pkg-spec directory rev) + (find-file directory))) + +;;;###autoload +(defun package-vc-install-from-checkout (dir name) + "Set up the package NAME in DIR by linking it into the ELPA directory. +Interactively, prompt the user for DIR, which should be a directory +under version control, typically one created by `package-vc-checkout'. +If invoked interactively with a prefix argument, prompt the user +for the NAME of the package to set up. Otherwise infer the package +name 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))) + (when (file-exists-p pkg-dir) + (if (yes-or-no-p (format "Overwrite previous checkout for package `%s'?" name)) + (package--delete-directory pkg-dir) + (error "There already exists a checkout for %s" name))) + (make-symbolic-link (expand-file-name dir) pkg-dir) + (package-vc--unpack-1 + (package-desc-create + :name (intern name) + :dir pkg-dir + :kind 'vc) + (file-name-as-directory pkg-dir)))) + +;;;###autoload +(defun package-vc-rebuild (pkg-desc) + "Rebuild the installation for package given by PKG-DESC. +Rebuilding an installation means scraping for new autoload +cookies, re-compiling Emacs Lisp files, building and installing +any documentation, downloading any missing dependencies. This +command does not fetch new revisions from a remote server. That +is the responsibility of `package-vc-update'. Interactively, +prompt for the name of the package to rebuild." + (interactive (list (package-vc--read-package-desc "Rebuild package: " t))) + (package-vc--unpack-1 pkg-desc (package-desc-dir pkg-desc))) + +;;;###autoload +(defun package-vc-prepare-patch (pkg-desc subject revisions) + "Send patch for REVISIONS to maintainer of the package PKG using SUBJECT. +The function uses `vc-prepare-patch', passing SUBJECT and +REVISIONS directly. PKG-DESC must be a package description. +Interactively, prompt for PKG-DESC, SUBJECT, and REVISIONS. When +invoked with a numerical prefix argument, use the last N +revisions. When invoked interactively in a Log View buffer with +marked revisions, use those." + (interactive + (list (package-vc--read-package-desc "Package to prepare a patch for: " t) + (and (not vc-prepare-patches-separately) + (read-string "Subject: " "[PATCH] " nil nil t)) + (vc-prepare-patch-prompt-revisions))) + (let ((default-directory (package-desc-dir pkg-desc))) + (vc-prepare-patch (package-maintainers pkg-desc t) + subject revisions))) + +(provide 'package-vc) +;;; package-vc.el ends here |