[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master 5fa2f11679: Merge branch 'feature/package+vc'
|
From: |
Philip Kaludercic |
|
Subject: |
master 5fa2f11679: Merge branch 'feature/package+vc' |
|
Date: |
Fri, 4 Nov 2022 13:58:51 -0400 (EDT) |
branch: master
commit 5fa2f116799b8a7c17ff6eedd6e1b1af077c116b
Merge: 616aa23d8a f762c5bb2c
Author: Philip Kaludercic <philipk@posteo.net>
Commit: Philip Kaludercic <philipk@posteo.net>
Merge branch 'feature/package+vc'
---
doc/emacs/package.texi | 71 +++++
etc/NEWS | 38 ++-
lisp/emacs-lisp/bytecomp.el | 16 +-
lisp/emacs-lisp/package-vc.el | 721 ++++++++++++++++++++++++++++++++++++++++++
lisp/emacs-lisp/package.el | 285 +++++++++++++----
lisp/vc/vc-bzr.el | 6 +
lisp/vc/vc-git.el | 19 ++
lisp/vc/vc-hg.el | 6 +
lisp/vc/vc-svn.el | 7 +
lisp/vc/vc.el | 51 +++
src/keyboard.c | 4 +-
11 files changed, 1146 insertions(+), 78 deletions(-)
diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi
index 420da09097..bd11648e57 100644
--- a/doc/emacs/package.texi
+++ b/doc/emacs/package.texi
@@ -49,6 +49,7 @@ Manual}.
* Package Statuses:: Which statuses a package can have.
* Package Installation:: Options for package installation.
* Package Files:: Where packages are installed.
+* Fetching Package Sources:: Managing packages directly from source.
@end menu
@node Package Menu
@@ -530,3 +531,73 @@ are laid out in the same way as in @code{package-user-dir}.
corresponding package subdirectory. This only works for packages
installed in @code{package-user-dir}; if told to act on a package in a
system-wide package directory, the deletion command signals an error.
+
+@node Fetching Package Sources
+@section Fetching Package Sources
+@cindex package development source
+@cindex upstream source, for packages
+@cindex git source of package @c "git" is not technically correct
+
+ By default @code{package-install} downloads a Tarball from a package
+archive and installs its files. This might be inadequate if you wish
+to hack on the package sources and share your changes with others. In
+that case, you may prefer to directly fetch and work on the upstream
+source. This often makes it easier to develop patches and report
+bugs.
+
+@findex package-vc-install
+@findex package-vc-checkout
+ One way to do this is to use @code{package-vc-install}, to fetch the
+source code for a package directly from source. The command will also
+automatically ensure that all files are byte-compiled and auto-loaded,
+just like with a regular package. Packages installed this way behave
+just like any other package. You can update them using
+@code{package-update} or @code{package-update-all} and delete them
+again using @code{package-delete}. They are even displayed in the
+regular package listing. If you just wish to clone the source of a
+package, without adding it to the package list, use
+@code{package-vc-checkout}.
+
+@vindex package-vc-selected-packages
+@findex package-vc-ensure-packages
+ An alternative way to use @code{package-vc-install} is via the
+@code{package-vc-selected-packages} user option. This is an alist of
+packages to install, where each key is a package name and the value is
+@code{nil}, indicating that any revision is to install, a string,
+indicating a specific revision or a package specification plist. The
+side effect of setting the user option is to install the package, but
+the process can also be manually triggered using the function
+@code{package-vc-ensure-packages}. Here is an example of how the user
+option:
+
+@example
+@group
+(setopt package-vc-selected-packages
+ '((modus-themes . "0f39eb3fd9") ;specific revision
+ (auctex . nil) ;any revision
+ (foo ;a package specification
+ :url "https://git.sv.gnu.org/r/foo-mode.git";
+ :branch "trunk")))
+@end group
+@end example
+
+@findex package-report-bug
+@findex package-vc-prepare-patch
+ With the source checkout, you might want to reproduce a bug against
+the current development head or implement a new feature to scratch an
+itch. If the package metadata indicates how to contact the
+maintainer, you can use the command @code{package-report-bug} to
+report a bug via Email. This report will include all the user options
+that you have customised. If you have made a change you wish to share
+with the maintainers, first commit your changes then use the command
+@code{package-vc-prepare-patch} to share it. @xref{Preparing Patches}.
+
+@findex package-vc-link-directory
+@findex package-vc-refresh
+ If you maintain your own packages you might want to use a local
+checkout instead of cloning a remote repository. You can do this by
+using @code{package-vc-link-directory}, which creates a symbolic link
+from the package directory (@pxref{Package Files}) to your checkout
+and initialises the code. Note that you might have to use
+@code{package-vc-refresh} to repeat the initialisation and update the
+autoloads.
diff --git a/etc/NEWS b/etc/NEWS
index f3a58366fe..edeb8fc3d0 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1553,6 +1553,36 @@ These commands can be useful if the ".elc" files are out
of date
If no packages are marked, 'x' will install the package under point if
it isn't already, and remove it if it is installed.
++++
+*** New command 'package-vc-install'
+Packages can now be installed directly from source by cloning from a
+repository.
+
++++
+*** New command 'package-vc-link-directory'
+An existing checkout can now be loaded via package.el, by creating a
+symbolic link from the usual package directory to the checkout.
+
++++
+*** New command 'package-vc-checkout'
+Used to fetch the source of a package by cloning a repository without
+activating the package.
+
++++
+*** New command 'package-vc-prepare-patch'
+This command allows you to send patches to package maintainers, for
+packages checked out using 'package-vc-install'.
+
++++
+*** New command 'package-report-bug'
+This command helps you compose an email for sending bug reports to
+package maintainers.
+
++++
+*** New user option 'package-vc-selected-packages'
+By customising this user option you can specify specific packages to
+install.
+
** Emacs Sessions (Desktop)
+++
@@ -4251,11 +4281,3 @@ 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/>.
-
-
-Local variables:
-coding: utf-8
-mode: outline
-mode: emacs-news
-paragraph-separate: "[ ]*$"
-end:
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 9f29ffbb8e..4d258dab96 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1882,6 +1882,9 @@ Files in subdirectories of DIRECTORY are processed also."
(interactive "DByte force recompile (directory): ")
(byte-recompile-directory directory nil t))
+(defvar byte-compile-ignore-files nil
+ "List of regexps for files to ignore during byte compilation.")
+
;;;###autoload
(defun byte-recompile-directory (directory &optional arg force follow-symlinks)
"Recompile every `.el' file in DIRECTORY that needs recompilation.
@@ -1938,14 +1941,23 @@ also be compiled."
;; This file is a subdirectory. Handle them differently.
(or (null arg) (eq 0 arg)
(y-or-n-p (concat "Check " source "? ")))
- (setq directories (nconc directories (list source))))
+ (setq directories (nconc directories (list source)))
+ ;; Directory is requested to be ignored
+ (string-match-p
+ (regexp-opt byte-compile-ignore-files)
+ source)
+ (setq directories (nconc directories (list source))))
;; It is an ordinary file. Decide whether to compile it.
(if (and (string-match emacs-lisp-file-regexp source)
;; The next 2 tests avoid compiling lock files
(file-readable-p source)
(not (string-match "\\`\\.#" file))
(not (auto-save-file-name-p source))
- (not (member source (dir-locals--all-files
directory))))
+ (not (member source (dir-locals--all-files directory)))
+ ;; File is requested to be ignored
+ (string-match-p
+ (regexp-opt byte-compile-ignore-files)
+ source))
(progn (cl-incf
(pcase (byte-recompile-file source force arg)
('no-byte-compile skip-count)
diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el
new file mode 100644
index 0000000000..a19bbb1988
--- /dev/null
+++ b/lisp/emacs-lisp/package-vc.el
@@ -0,0 +1,721 @@
+;;; 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.
+;;
+;; 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-link-directory' 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.
+
+;;; 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
+ :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-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")
+
+(defun package-vc-ensure-packages ()
+ "Ensure source packages specified in `package-vc-selected-packages'."
+ (pcase-dolist (`(,(and (pred symbolp) name) . ,spec)
+ package-vc-selected-packages)
+ (let ((pkg-desc (cadr (assoc name package-alist #'string=))))
+ (unless (and name (package-installed-p name)
+ (package-vc-p pkg-desc))
+ (cond
+ ((null spec)
+ (package-vc-install name))
+ ((stringp spec)
+ (package-vc-install name nil spec))
+ ((listp spec)
+ (package-vc--archives-initialize)
+ (package-vc--unpack pkg-desc spec)))))))
+
+;;;###autoload
+(defcustom package-vc-selected-packages '()
+ "List of packages to ensure being installed.
+Each entry of the list is of the form (NAME . SPEC), where NAME
+is a symbol designating the package and SPEC is one of:
+
+- the value nil, if any package version is to be installed,
+- a string, if a specific revision, as designating by the string
+ is to be installed,
+- a property list of the form described in
+ `package-vc-archive-spec-alist', giving a package
+ specification.
+
+This user option differs from `package-selected-packages' in that
+it is meant to be specified manually. You can also use the
+function `package-vc-selected-packages' to apply the changes."
+ :type '(alist :tag "List of ensured packages"
+ :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)))))
+ :set (lambda (sym val)
+ (custom-set-default sym val)
+ (package-vc-ensure-packages))
+ :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))
+ (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"))
+
+(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--clone (pkg-desc pkg-spec dir rev)
+ "Clone the source of a package into a directory DIR.
+The package is described by a package descriptions PKG-DESC and a
+package specification 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...")))))
+
+(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."
+ (pcase-let* (((map :url :lisp-dir) pkg-spec)
+ (name (package-desc-name pkg-desc))
+ (dirname (package-desc-full-name pkg-desc))
+ (pkg-dir (expand-file-name dirname package-user-dir))
+ (real-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)))))
+ (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)))
+ (package-vc--clone pkg-desc pkg-spec real-dir rev)
+ (unless (eq pkg-dir real-dir)
+ ;; Link from the right position in `repo-dir' to the package
+ ;; directory in the ELPA store.
+ (make-symbolic-link (file-name-concat real-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."
+ ;; 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.
+ (letrec ((pkg-dir (package-desc-dir pkg-desc))
+ (empty (make-symbol empty))
+ (args (list empty empty empty))
+ (vc-filter-command-function
+ (lambda (command file-or-list flags)
+ (setf (nth 0 args) command
+ (nth 1 args) file-or-list
+ (nth 2 args) flags)
+ (list command file-or-list flags)))
+ (post-upgrade
+ (lambda (command file-or-list flags)
+ (when (and (memq (nth 0 args) (list command empty))
+ (memq (nth 1 args) (list file-or-list empty))
+ (memq (nth 2 args) (list flags empty)))
+ (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"
+ (vc-pull))))
+
+(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))))
+
+;;;###autoload
+(defun package-vc-checkout (pkg-desc directory &optional rev)
+ "Clone the sources for PKG-DESC into DIRECTORY and open it.
+An explicit revision can be requested by passing a string to the
+optional argument 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."
+ (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)))
+ (list (cadr (assoc input 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 has no VC data"))))
+ (package-vc--clone pkg-desc pkg-spec directory rev)
+ (find-file directory)))
+
+;;;###autoload
+(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)))
+
+;;;###autoload
+(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
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index f3077cbbdb..27324f2b9b 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -146,6 +146,7 @@
(require 'cl-lib)
(eval-when-compile (require 'subr-x))
(eval-when-compile (require 'epg)) ;For setf accessors.
+(eval-when-compile (require 'inline)) ;For `define-inline'
(require 'seq)
(require 'tabulated-list)
@@ -456,6 +457,11 @@ synchronously."
(defvar package--default-summary "No description available.")
+(define-inline package-vc-p (pkg-desc)
+ "Return non-nil if PKG-DESC is a source package."
+ (inline-letevals (pkg-desc)
+ (inline-quote (eq (package-desc-kind ,pkg-desc) 'vc))))
+
(cl-defstruct (package-desc
;; Rename the default constructor from `make-package-desc'.
(:constructor package-desc-create)
@@ -468,14 +474,18 @@ synchronously."
&rest rest-plist
&aux
(name (intern name-string))
- (version (version-to-list version-string))
+ (version (if (eq (car-safe version-string) 'vc)
+ (version-to-list (cdr version-string))
+ (version-to-list version-string)))
(reqs (mapcar (lambda (elt)
(list (car elt)
(version-to-list (cadr elt))))
(if (eq 'quote (car requirements))
(nth 1 requirements)
requirements)))
- (kind (plist-get rest-plist :kind))
+ (kind (if (eq (car-safe version-string) 'vc)
+ 'vc
+ (plist-get rest-plist :kind)))
(archive (plist-get rest-plist :archive))
(extras (let (alist)
(while rest-plist
@@ -567,9 +577,11 @@ This is, approximately, the inverse of `version-to-list'.
(defun package-desc-full-name (pkg-desc)
"Return full name of package-desc object PKG-DESC.
This is the name of the package with its version appended."
- (format "%s-%s"
- (package-desc-name pkg-desc)
- (package-version-join (package-desc-version pkg-desc))))
+ (if (package-vc-p pkg-desc)
+ (symbol-name (package-desc-name pkg-desc))
+ (format "%s-%s"
+ (package-desc-name pkg-desc)
+ (package-version-join (package-desc-version pkg-desc)))))
(defun package-desc-suffix (pkg-desc)
"Return file-name extension of package-desc object PKG-DESC.
@@ -600,6 +612,25 @@ package."
"Return the priority of the archive of package-desc object PKG-DESC."
(package-archive-priority (package-desc-archive pkg-desc)))
+(defun package--parse-elpaignore (pkg-desc)
+ "Return the of regular expression to match files ignored by PKG-DESC."
+ (let* ((pkg-dir (file-name-as-directory (package-desc-dir pkg-desc)))
+ (ignore (expand-file-name ".elpaignore" pkg-dir))
+ files)
+ (when (file-exists-p ignore)
+ (with-temp-buffer
+ (insert-file-contents ignore)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (push (wildcard-to-regexp
+ (let ((line (buffer-substring
+ (line-beginning-position)
+ (line-end-position))))
+ (file-name-concat pkg-dir (string-trim-left line "/"))))
+ files)
+ (forward-line)))
+ files)))
+
(cl-defstruct (package--bi-desc
(:constructor package-make-builtin (version summary))
(:type vector))
@@ -648,6 +679,8 @@ loaded and/or activated, customize `package-load-list'.")
;; `package-load-all-descriptors', which ultimately populates the
;; `package-alist' variable.
+(declare-function package-vc-version "package-vc" (pkg))
+
(defun package-process-define-package (exp)
"Process define-package expression EXP and push it to `package-alist'.
EXP should be a form read from a foo-pkg.el file.
@@ -676,6 +709,8 @@ are sorted with the highest version first."
nil)))
new-pkg-desc)))
+(declare-function package-vc-commit "package-vc" (pkg))
+
(defun package-load-descriptor (pkg-dir)
"Load the package description file in directory PKG-DIR.
Create a new `package-desc' object, add it to `package-alist' and
@@ -706,11 +741,9 @@ description file containing a call to `define-package',
which
updates `package-alist'."
(dolist (dir (cons package-user-dir package-directory-list))
(when (file-directory-p dir)
- (dolist (subdir (directory-files dir))
- (unless (equal subdir "..")
- (let ((pkg-dir (expand-file-name subdir dir)))
- (when (file-directory-p pkg-dir)
- (package-load-descriptor pkg-dir))))))))
+ (dolist (pkg-dir (directory-files dir t "^[^.]" t))
+ (when (file-directory-p pkg-dir)
+ (package-load-descriptor pkg-dir))))))
(defun package--alist ()
"Return `package-alist', after computing it if needed."
@@ -873,14 +906,22 @@ correspond to previously loaded files."
(defun package--get-activatable-pkg (pkg-name)
;; Is "activatable" a word?
- (let ((pkg-descs (cdr (assq pkg-name package-alist))))
+ (let ((pkg-descs (sort (cdr (assq pkg-name package-alist))
+ (lambda (p1 p2)
+ (let ((v1 (package-desc-version p1))
+ (v2 (package-desc-version p2)))
+ (or
+ ;; Prefer source packages.
+ (package-vc-p p1)
+ (package-vc-p p2)
+ ;; Prefer builtin packages.
+ (package-disabled-p p1 v1)
+ (not (package-disabled-p p2 v2))))))))
;; Check if PACKAGE is available in `package-alist'.
(while
(when pkg-descs
(let ((available-version (package-desc-version (car pkg-descs))))
- (or (package-disabled-p pkg-name available-version)
- ;; Prefer a builtin package.
- (package-built-in-p pkg-name available-version))))
+ (package-disabled-p pkg-name available-version)))
(setq pkg-descs (cdr pkg-descs)))
(car pkg-descs)))
@@ -958,7 +999,7 @@ untar into a directory named DIR; otherwise, signal an
error."
;; indistinguishable from a `tar' or a `single'. Let's make
;; things simple by ensuring we're one of them.
(setf (package-desc-kind pkg-desc)
- (if (> (length file-list) 1) 'tar 'single))))
+ (if (length> file-list 1) 'tar 'single))))
('tar
(make-directory package-user-dir t)
(let* ((default-directory (file-name-as-directory package-user-dir)))
@@ -1021,6 +1062,7 @@ untar into a directory named DIR; otherwise, signal an
error."
"\n")
nil pkg-file nil 'silent))))
+
;;;; Autoload
(declare-function autoload-rubric "autoload" (file &optional type feature))
@@ -1068,11 +1110,13 @@ untar into a directory named DIR; otherwise, signal an
error."
;;;; Compilation
(defvar warning-minimum-level)
+(defvar byte-compile-ignore-files)
(defun package--compile (pkg-desc)
"Byte-compile installed package PKG-DESC.
This assumes that `pkg-desc' has already been activated with
`package-activate-1'."
- (let ((warning-minimum-level :error)
+ (let ((byte-compile-ignore-files (package--parse-elpaignore pkg-desc))
+ (warning-minimum-level :error)
(load-path load-path))
(byte-recompile-directory (package-desc-dir pkg-desc) 0 t)))
@@ -1601,13 +1645,19 @@ This is the value of `package-archive-priorities' last
time
by arbitrary functions to decide whether it is necessary to call
it again.")
+(defvar package-read-archive-hook (list #'package-read-archive-contents)
+ "List of functions to call to read the archive contents.
+Each function must take an optional argument, a symbol indicating
+what archive to read in. The symbol ought to be a key in
+`package-archives'.")
+
(defun package-read-all-archive-contents ()
"Read cached archive file for all archives in `package-archives'.
If successful, set or update `package-archive-contents'."
(setq package-archive-contents nil)
(setq package--old-archive-priorities package-archive-priorities)
(dolist (archive package-archives)
- (package-read-archive-contents (car archive))))
+ (run-hook-with-args 'package-read-archive-hook (car archive))))
;;;; Package Initialize
@@ -1733,9 +1783,14 @@ Once it's empty, run
`package--post-download-archives-hook'."
ARCHIVE should be a cons cell of the form (NAME . LOCATION),
similar to an entry in `package-alist'. Save the cached copy to
\"archives/NAME/FILE\" in `package-user-dir'."
+ ;; The downloaded archive contents will be read as part of
+ ;; `package--update-downloads-in-progress'.
+ (dolist (archive package-archives)
+ (cl-pushnew (cons archive file) package--downloads-in-progress
+ :test #'equal))
(package--with-response-buffer (cdr archive) :file file
:async async
- :error-form (package--update-downloads-in-progress archive)
+ :error-form (package--update-downloads-in-progress (cons archive file))
(let* ((location (cdr archive))
(name (car archive))
(content (buffer-string))
@@ -1748,10 +1803,10 @@ similar to an entry in `package-alist'. Save the
cached copy to
;; If we don't care about the signature, save the file and
;; we're done.
(progn
- (cl-assert (not enable-multibyte-characters))
- (let ((coding-system-for-write 'binary))
- (write-region content nil local-file nil 'silent))
- (package--update-downloads-in-progress archive))
+ (cl-assert (not enable-multibyte-characters))
+ (let ((coding-system-for-write 'binary))
+ (write-region content nil local-file nil 'silent))
+ (package--update-downloads-in-progress (cons archive file)))
;; If we care, check it (perhaps async) and *then* write the file.
(package--check-signature
location file content async
@@ -1764,7 +1819,7 @@ similar to an entry in `package-alist'. Save the cached
copy to
(when good-sigs
(write-region (mapconcat #'epg-signature-to-string good-sigs
"\n")
nil (concat local-file ".signed") nil 'silent)))
- (lambda () (package--update-downloads-in-progress archive))))))))
+ (lambda () (package--update-downloads-in-progress (cons archive
file)))))))))
(defun package--download-and-read-archives (&optional async)
"Download descriptions of all `package-archives' and read them.
@@ -1772,17 +1827,17 @@ Populate `package-archive-contents' with the result.
If optional argument ASYNC is non-nil, perform the downloads
asynchronously."
- ;; The downloaded archive contents will be read as part of
- ;; `package--update-downloads-in-progress'.
- (dolist (archive package-archives)
- (cl-pushnew archive package--downloads-in-progress
- :test #'equal))
(dolist (archive package-archives)
(condition-case-unless-debug nil
(package--download-one-archive archive "archive-contents" async)
(error (message "Failed to download `%s' archive."
(car archive))))))
+(defvar package-refresh-contents-hook (list
#'package--download-and-read-archives)
+ "List of functions to call to refresh the package archive.
+Each function may take an optional argument indicating that the
+operation ought to be executed asynchronously.")
+
;;;###autoload
(defun package-refresh-contents (&optional async)
"Download descriptions of all configured ELPA packages.
@@ -1801,7 +1856,7 @@ downloads in the background."
(condition-case-unless-debug error
(package-import-keyring default-keyring)
(error (message "Cannot import default keyring: %S" (cdr error))))))
- (package--download-and-read-archives async))
+ (run-hook-with-args 'package-refresh-contents-hook async))
;;; Dependency Management
@@ -2035,9 +2090,9 @@ if all the in-between dependencies are also in
PACKAGE-LIST."
(cdr (assoc (package-desc-archive desc) package-archives)))
(defun package-install-from-archive (pkg-desc)
- "Download and install a tar package defined by PKG-DESC."
+ "Download and install a package defined by PKG-DESC."
;; This won't happen, unless the archive is doing something wrong.
- (when (eq (package-desc-kind pkg-desc) 'dir)
+ (when (package-vc-p pkg-desc)
(error "Can't install directory package from archive"))
(let* ((location (package-archive-base pkg-desc))
(file (concat (package-desc-full-name pkg-desc)
@@ -2175,17 +2230,22 @@ to install it but still mark it as selected."
(message "Package `%s' installed." name))
(message "`%s' is already installed" name))))
+(declare-function package-vc-update "package-vc" (pkg))
+
;;;###autoload
(defun package-update (name)
"Update package NAME if a newer version exists."
(interactive
(list (completing-read
"Update package: " (package--updateable-packages) nil t)))
- (let ((package (if (symbolp name)
- name
- (intern name))))
- (package-delete (cadr (assq package package-alist)) 'force)
- (package-install package 'dont-select)))
+ (let* ((package (if (symbolp name)
+ name
+ (intern name)))
+ (pkg-desc (cadr (assq package package-alist))))
+ (if (package-vc-p pkg-desc)
+ (package-vc-update pkg-desc)
+ (package-delete pkg-desc 'force)
+ (package-install package 'dont-select))))
(defun package--updateable-packages ()
;; Initialize the package system to get the list of package
@@ -2195,12 +2255,13 @@ to install it but still mark it as selected."
#'car
(seq-filter
(lambda (elt)
- (let ((available
- (assq (car elt) package-archive-contents)))
- (and available
- (version-list-<
- (package-desc-version (cadr elt))
- (package-desc-version (cadr available))))))
+ (or (let ((available
+ (assq (car elt) package-archive-contents)))
+ (and available
+ (version-list-<
+ (package-desc-version (cadr elt))
+ (package-desc-version (cadr available)))))
+ (package-vc-p (cadr (assq (car elt) package-alist)))))
package-alist)))
;;;###autoload
@@ -2357,15 +2418,28 @@ installed), maybe you need to
\\[package-refresh-contents]")
pkg))
(declare-function comp-el-to-eln-filename "comp.c")
-(defun package--delete-directory (dir)
- "Delete DIR recursively.
+(defvar package-vc-repository-store)
+(defun package--delete-directory (dir pkg-desc)
+ "Delete PKG-DESC directory DIR recursively.
Clean-up the corresponding .eln files if Emacs is native
compiled."
(when (featurep 'native-compile)
(cl-loop
for file in (directory-files-recursively dir "\\.el\\'")
do (comp-clean-up-stale-eln (comp-el-to-eln-filename file))))
- (delete-directory dir t))
+ (if (and (package-vc-p pkg-desc)
+ (require 'package-vc) ;load `package-vc-repository-store'
+ (file-in-directory-p dir package-vc-repository-store))
+ (progn
+ (delete-directory
+ (expand-file-name
+ (car (file-name-split
+ (file-relative-name dir package-vc-repository-store)))
+ package-vc-repository-store)
+ t)
+ (delete-file (directory-file-name dir)))
+ (delete-directory dir t)))
+
(defun package-delete (pkg-desc &optional force nosave)
"Delete package PKG-DESC.
@@ -2419,7 +2493,7 @@ If NOSAVE is non-nil, the package is not removed from
(package-desc-name pkg-used-elsewhere-by)))
(t
(add-hook 'post-command-hook #'package-menu--post-refresh)
- (package--delete-directory dir)
+ (package--delete-directory dir pkg-desc)
;; Remove NAME-VERSION.signed and NAME-readme.txt files.
;;
;; NAME-readme.txt files are no longer created, but they
@@ -2630,7 +2704,10 @@ Helper function for `describe-package'."
(incompatible-reason (package--incompatible-p desc))
(signed (if desc (package-desc-signed desc)))
(maintainer (cdr (assoc :maintainer extras)))
- (authors (cdr (assoc :authors extras))))
+ (authors (cdr (assoc :authors extras)))
+ (news (and-let* ((file (expand-file-name "news" pkg-dir))
+ ((file-readable-p file)))
+ file)))
(when (string= status "avail-obso")
(setq status "available obsolete"))
(when incompatible-reason
@@ -2829,6 +2906,14 @@ Helper function for `describe-package'."
t)
(insert (or readme-string
"This package does not provide a description.")))))
+
+ ;; Insert news if available.
+ (when news
+ (insert "\n" (make-separator-line) "\n"
+ (propertize "* News" 'face 'package-help-section-name)
+ "\n\n")
+ (insert-file-contents news))
+
;; Make library descriptions into links.
(goto-char start-of-description)
(package--describe-add-library-links)
@@ -2919,6 +3004,7 @@ either a full name or nil, and EMAIL is a valid email
address."
"r" #'revert-buffer
"~" #'package-menu-mark-obsolete-for-deletion
"w" #'package-browse-url
+ "b" #'package-report-bug
"x" #'package-menu-execute
"h" #'package-menu-quick-help
"H" #'package-menu-hide-package
@@ -3077,6 +3163,7 @@ of these dependencies, similar to the list returned by
(signed (or (not package-list-unsigned)
(package-desc-signed pkg-desc))))
(cond
+ ((package-vc-p pkg-desc) "source")
((eq dir 'builtin) "built-in")
((and lle (null held)) "disabled")
((stringp held)
@@ -3165,8 +3252,9 @@ to their archives."
(if (not installed)
filtered-by-priority
(let ((ins-version (package-desc-version installed)))
- (cl-remove-if (lambda (p) (version-list-= (package-desc-version
p)
- ins-version))
+ (cl-remove-if (lambda (p) (or (version-list-=
(package-desc-version p)
+ ins-version)
+ (package-vc-p installed)))
filtered-by-priority))))))))
(defcustom package-hidden-regexps nil
@@ -3368,6 +3456,11 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])."
"Face used on the status and version of installed packages."
:version "25.1")
+(defface package-status-from-source
+ '((t :inherit font-lock-negation-char-face))
+ "Face used on the status and version of installed packages."
+ :version "29.1")
+
(defface package-status-dependency
'((t :inherit package-status-installed))
"Face used on the status and version of dependency packages."
@@ -3405,6 +3498,7 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])."
("held" 'package-status-held)
("disabled" 'package-status-disabled)
("installed" 'package-status-installed)
+ ("source" 'package-status-from-source)
("dependency" 'package-status-dependency)
("unsigned" 'package-status-unsigned)
("incompat" 'package-status-incompat)
@@ -3416,9 +3510,14 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])."
follow-link t
package-desc ,pkg
action package-menu-describe-package)
- ,(propertize (package-version-join
- (package-desc-version pkg))
- 'font-lock-face face)
+ ,(propertize
+ (if (package-vc-p pkg)
+ (progn
+ (require 'package-vc)
+ (package-vc-commit pkg))
+ (package-version-join
+ (package-desc-version pkg)))
+ 'font-lock-face face)
,(propertize status 'font-lock-face face)
,@(if (cdr package-archives)
(list (propertize (or (package-desc-archive pkg) "")
@@ -3493,7 +3592,7 @@ If optional arg BUTTON is non-nil, describe its
associated package."
(interactive "p" package-menu-mode)
(package--ensure-package-menu-mode)
(if (member (package-menu-get-status)
- '("installed" "dependency" "obsolete" "unsigned"))
+ '("installed" "source" "dependency" "obsolete" "unsigned"))
(tabulated-list-put-tag "D" t)
(forward-line)))
@@ -3849,6 +3948,8 @@ This is used for `tabulated-list-format' in
`package-menu-mode'."
((string= sB "installed") nil)
((string= sA "dependency") t)
((string= sB "dependency") nil)
+ ((string= sA "source") t)
+ ((string= sB "source") nil)
((string= sA "unsigned") t)
((string= sB "unsigned") nil)
((string= sA "held") t)
@@ -4142,6 +4243,7 @@ packages."
"held"
"incompat"
"installed"
+ "source"
"new"
"unsigned")))
package-menu-mode)
@@ -4213,22 +4315,22 @@ Unlike other filters, this leaves the marks intact."
(while (not (eobp))
(setq mark (char-after))
(unless (eq mark ?\s)
- (setq pkg-id (tabulated-list-get-id))
+ (setq pkg-id (tabulated-list-get-id))
(setq entry (package-menu--print-info-simple pkg-id))
- (push entry found-entries)
- ;; remember the mark
- (push (cons pkg-id mark) marks))
+ (push entry found-entries)
+ ;; remember the mark
+ (push (cons pkg-id mark) marks))
(forward-line))
(if found-entries
(progn
(setq tabulated-list-entries found-entries)
(package-menu--display t nil)
- ;; redo the marks, but we must remember the marks!!
- (goto-char (point-min))
- (while (not (eobp))
- (setq mark (cdr (assq (tabulated-list-get-id) marks)))
- (tabulated-list-put-tag (char-to-string mark) t)))
- (user-error "No packages found")))))
+ ;; redo the marks, but we must remember the marks!!
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq mark (cdr (assq (tabulated-list-get-id) marks)))
+ (tabulated-list-put-tag (char-to-string mark) t)))
+ (user-error "No packages found")))))
(defun package-menu-filter-upgradable ()
"Filter \"*Packages*\" buffer to show only upgradable packages."
@@ -4410,11 +4512,22 @@ beginning of the line."
(package-version-join (package-desc-version package-desc))
(package-desc-summary package-desc))))
+(defun package--query-desc (&optional alist)
+ "Query the user for a package or return the package at point.
+The optional argument ALIST must consist of elements with the
+form (PKG-NAME PKG-DESC). If not specified, it will default to
+`package-alist'."
+ (or (tabulated-list-get-id)
+ (let ((alist (or alist package-alist)))
+ (cadr (assoc (completing-read "Package: " alist nil t)
+ alist #'string=)))))
+
(defun package-browse-url (desc &optional secondary)
"Open the website of the package under point in a browser.
-`browse-url' is used to determine the browser to be used.
-If SECONDARY (interactively, the prefix), use the secondary browser."
- (interactive (list (tabulated-list-get-id)
+`browse-url' is used to determine the browser to be used. If
+SECONDARY (interactively, the prefix), use the secondary browser.
+DESC must be a `package-desc' object."
+ (interactive (list (package--query-desc)
current-prefix-arg)
package-menu-mode)
(unless desc
@@ -4423,9 +4536,47 @@ If SECONDARY (interactively, the prefix), use the
secondary browser."
(unless url
(user-error "No website for %s" (package-desc-name desc)))
(if secondary
- (funcall browse-url-secondary-browser-function url)
+ (funcall browse-url-secondary-browser-function url)
(browse-url url))))
+(defun package-maintainers (pkg-desc &optional no-error)
+ "Return an email address for the maintainers of PKG-DESC.
+The email address may contain commas, if there are multiple
+maintainers. If no maintainers are found, an error will be
+signalled. If the optional argument NO-ERROR is non-nil no error
+will be signalled in that case."
+ (unless pkg-desc
+ (error "Invalid package description"))
+ (let* ((extras (package-desc-extras pkg-desc))
+ (maint (alist-get :maintainer extras)))
+ (cond
+ ((and (null maint) (null no-error))
+ (user-error "Package has no explicit maintainer"))
+ ((not (null maint))
+ (with-temp-buffer
+ (package--print-email-button maint)
+ (string-trim (substring-no-properties (buffer-string))))))))
+
+(defun package-report-bug (desc)
+ "Prepare a message to send to the maintainers of a package.
+DESC must be a `package-desc' object."
+ (interactive (list (package--query-desc package-alist))
+ package-menu-mode)
+ (let ((maint (package-maintainers desc))
+ (name (symbol-name (package-desc-name desc)))
+ vars)
+ (dolist-with-progress-reporter (group custom-current-group-alist)
+ "Scanning for modified user options..."
+ (dolist (ent (get (cdr group) 'custom-group))
+ (when (and (custom-variable-p (car ent))
+ (boundp (car ent))
+ (not (eq (custom--standard-value (car ent))
+ (default-toplevel-value (car ent))))
+ (file-in-directory-p (car group) (package-desc-dir desc)))
+ (push (car ent) vars))))
+ (dlet ((reporter-prompt-for-summary-p t))
+ (reporter-submit-bug-report maint name vars))))
+
;;;; Introspection
(defun package-get-descriptor (pkg-name)
diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el
index 6f77f99555..8f00441e81 100644
--- a/lisp/vc/vc-bzr.el
+++ b/lisp/vc/vc-bzr.el
@@ -532,6 +532,12 @@ in the branch repository (or whose status not be
determined)."
(add-hook 'after-save-hook #'vc-bzr-resolve-when-done nil t)
(vc-message-unresolved-conflicts buffer-file-name)))
+(defun vc-bzr-clone (remote directory rev)
+ (if rev
+ (vc-bzr-command nil 0 '() "branch" "-r" rev remote directory)
+ (vc-bzr-command nil 0 '() "branch" remote directory))
+ directory)
+
(defun vc-bzr-version-dirstate (dir)
"Try to return as a string the bzr revision ID of directory DIR.
This uses the dirstate file's parent revision entry.
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 3c6afec037..376892c720 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -1268,6 +1268,12 @@ This prompts for a branch to merge from."
(add-hook 'after-save-hook #'vc-git-resolve-when-done nil 'local))
(vc-message-unresolved-conflicts buffer-file-name)))
+(defun vc-git-clone (remote directory rev)
+ (if rev
+ (vc-git--out-ok "clone" "--branch" rev remote directory)
+ (vc-git--out-ok "clone" remote directory))
+ directory)
+
;;; HISTORY FUNCTIONS
(autoload 'vc-setup-buffer "vc-dispatcher")
@@ -1626,6 +1632,19 @@ This requires git 1.8.4 or later, for the \"-L\" option
of \"git log\"."
(expand-file-name fname (vc-git-root default-directory))))
revision)))))
+(defun vc-git-last-change (file line)
+ (vc-buffer-sync)
+ (let ((file (file-relative-name file (vc-git-root (buffer-file-name)))))
+ (with-temp-buffer
+ (when (vc-git--out-ok
+ "blame" "--porcelain"
+ (format "-L%d,+1" line)
+ file)
+ (goto-char (point-min))
+ (save-match-data
+ (when (looking-at "\\`\\([[:alnum:]]+\\)[[:space:]]+")
+ (match-string 1)))))))
+
;;; TAG/BRANCH SYSTEM
(declare-function vc-read-revision "vc"
diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el
index 1b1c1683dd..90903255e0 100644
--- a/lisp/vc/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -1266,6 +1266,12 @@ REV is the revision to check out into WORKFILE."
(add-hook 'after-save-hook #'vc-hg-resolve-when-done nil t)
(vc-message-unresolved-conflicts buffer-file-name)))
+(defun vc-hg-clone (remote directory rev)
+ (if rev
+ (vc-hg-command nil 0 '() "clone" "--rev" rev remote directory)
+ (vc-hg-command nil 0 '() "clone" remote directory))
+
+ directory)
;; Modeled after the similar function in vc-bzr.el
(defun vc-hg-revert (file &optional contents-done)
diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el
index b9ea8f1578..1b43ca5787 100644
--- a/lisp/vc/vc-svn.el
+++ b/lisp/vc/vc-svn.el
@@ -817,6 +817,13 @@ Set file properties accordingly. If FILENAME is non-nil,
return its status."
"info" "--show-item" "repos-root-url")
(buffer-substring-no-properties (point-min) (1- (point-max))))))
+(defun vc-svn-clone (remote directory rev)
+ (if rev
+ (vc-svn-command nil 0 '() "checkout" "--revision" rev remote directory)
+ (vc-svn-command nil 0 '() "checkout" remote directory))
+
+ (file-name-concat directory "trunk"))
+
(provide 'vc-svn)
;;; vc-svn.el ends here
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 3e78b8cfe9..513fbb23fe 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -448,6 +448,11 @@
;; - mergebase (rev1 &optional rev2)
;;
;; Return the common ancestor between REV1 and REV2 revisions.
+;;
+;; - last-change (file line)
+;;
+;; Return the most recent revision of FILE that made a change
+;; on LINE.
;; TAG/BRANCH SYSTEM
;;
@@ -584,6 +589,15 @@
;; buffer should be inserted into an inline patch. If the two last
;; properties are omitted, `point-min' and `point-max' will
;; respectively be used instead.
+;;
+;; - clone (remote directory rev)
+;;
+;; Attempt to clone a REMOTE repository, into a local DIRECTORY.
+;; Returns a string with the directory with the contents of the
+;; repository if successful, otherwise nil. With a non-nil value
+;; for REV the backend will attempt to check out a specific
+;; revision, if possible without first checking out the default
+;; branch.
;;; Changes from the pre-25.1 API:
;;
@@ -3551,6 +3565,43 @@ to provide the `find-revision' operation instead."
(interactive)
(vc-call-backend (vc-backend buffer-file-name) 'check-headers))
+(defun vc-clone (remote &optional backend directory rev)
+ "Use BACKEND to clone REMOTE into DIRECTORY.
+If successful, returns the a string with the directory of the
+checkout. If BACKEND is nil, iterate through every known backend
+in `vc-handled-backends' until one succeeds. If REV is non-nil,
+it indicates a specific revision to check out."
+ (unless directory
+ (setq directory default-directory))
+ (if backend
+ (progn
+ (unless (memq backend vc-handled-backends)
+ (error "Unknown VC backend %s" backend))
+ (vc-call-backend backend 'clone remote directory rev))
+ (catch 'ok
+ (dolist (backend vc-handled-backends)
+ (ignore-error vc-not-supported
+ (when-let ((res (vc-call-backend
+ backend 'clone
+ remote directory rev)))
+ (throw 'ok res)))))))
+
+(declare-function log-view-current-tag "log-view" (&optional pos))
+(defun vc-default-last-change (_backend file line)
+ "Default `last-change' implementation.
+It returns the last revision that changed LINE number in FILE."
+ (unless (file-exists-p file)
+ (signal 'file-error "File doesn't exist"))
+ (with-temp-buffer
+ (vc-call-backend (vc-backend file) 'annotate-command
+ file (current-buffer))
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (let ((rev (vc-call-backend
+ (vc-backend file)
+ 'annotate-extract-revision-at-line)))
+ (if (consp rev) (car rev) rev))))
+
;; These things should probably be generally available
diff --git a/src/keyboard.c b/src/keyboard.c
index a978d6f02b..069cf0627b 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -503,9 +503,11 @@ echo_add_key (Lisp_Object c)
if ((NILP (echo_string) || SCHARS (echo_string) == 0)
&& help_char_p (c))
{
- AUTO_STRING (str, " (Type ? for further options)");
+ AUTO_STRING (str, " (Type ? for further options, q for quick help)");
AUTO_LIST2 (props, Qface, Qhelp_key_binding);
Fadd_text_properties (make_fixnum (7), make_fixnum (8), props, str);
+ Fadd_text_properties (make_fixnum (30), make_fixnum (31), props,
+str);
new_string = concat2 (new_string, str);
}