procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'feature/package+vc'

Browse source
This commit is contained in:
Philip Kaludercic 2022-11-04 18:57:45 +01:00
commit 5fa2f11679
11 changed files with 1146 additions and 78 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

71
doc/emacs/package.texi
View file

@ -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.

38
etc/NEWS
View file

@ -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:

16
lisp/emacs-lisp/bytecomp.el
View file

@ -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)

721
lisp/emacs-lisp/package-vc.el Normal file
View file

@ -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

285
lisp/emacs-lisp/package.el
View file

@ -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)

6
lisp/vc/vc-bzr.el
View file

@ -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.

19
lisp/vc/vc-git.el
View file

@ -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"

6
lisp/vc/vc-hg.el
View file

@ -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)

7
lisp/vc/vc-svn.el
View file

@ -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

51
lisp/vc/vc.el
View file

@ -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

4
src/keyboard.c
View file

@ -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);
}