diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 16 | ||||
| -rw-r--r-- | lisp/emacs-lisp/package-vc.el | 476 | ||||
| -rw-r--r-- | lisp/emacs-lisp/package.el | 267 |
3 files changed, 701 insertions, 58 deletions
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index f0265682172..45ff1f4a8ec 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 00000000000..83038418529 --- /dev/null +++ b/lisp/emacs-lisp/package-vc.el @@ -0,0 +1,476 @@ +;;; package-vc.el --- Manage packages from VC checkouts -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Philip Kaludercic <philipk@posteo.net> +;; Keywords: tools + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; While packages managed by package.el use tarballs for distributing +;; the source code, this extension allows for packages to be fetched +;; and updated directly from a version control system. + +;;; TODO: + +;; - Allow for automatic updating TODO +;; * Detect merge conflicts TODO +;; * Check if there are upstream changes TODO +;; - Allow finding revisions that bump the version tag TODO +;; * Allow for `package-vc-install' to use the version +;; of the package if already installed. +;; - Allow for ELPA specifications to be respected without TODO +;; endangering the user with arbitrary code execution + +;;; Code: + +(eval-when-compile (require 'rx)) +(require 'package) +(require 'lisp-mnt) +(require 'vc) +(require 'seq) +(require 'map) +(require 'xdg) + +(defgroup package-vc nil + "Manage packages from VC checkouts." + :group 'package + :version "29.1") + +(defcustom package-vc-heusitic-alist + `((,(rx bos "http" (? "s") "://" + (or (: (? "www.") "github.com" + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "codeberg.org" + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: (? "www.") "gitlab" (+ "." (+ alnum)) + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "git.sr.ht" + "/~" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/" + (or "r" "git") "/" + (+ (or alnum "-" "." "_")) (? "/"))) + (or (? "/") ".git") eos) + . Git) + (,(rx bos "http" (? "s") "://" + (or (: "hg.sr.ht" + "/~" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/" + (+ (or alnum "-" "." "_")) (? "/"))) + eos) + . Hg) + (,(rx bos "http" (? "s") "://" + (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/" + (+ (or alnum "-" "." "_")) (? "/"))) + eos) + . Bzr)) + "Heuristic mapping URL regular expressions to VC backends." + :type `(alist :key-type (regexp :tag "Regular expression matching URLs") + :value-type (choice :tag "VC Backend" + ,@(mapcar (lambda (b) `(const ,b)) + vc-handled-backends))) + :version "29.1") + +(defcustom package-vc-repository-store + (expand-file-name "emacs/vc-packages" (xdg-data-home)) + "Directory used by `package-vc-unpack' to store repositories." + :type 'directory + :version "29.1") + +(defcustom package-vc-default-backend 'Git + "VC backend to use as a fallback." + :type `(choice + ,@(mapcar (lambda (b) (list 'const b)) + vc-handled-backends)) + :version "29.1") + +(defvar package-vc-archive-spec-alist nil + "List of package specifications for each archive. +The list maps package names as string to plist. Valid keys +include + + `:url' (string) + +The URL of the repository used to fetch the package source. + + `:branch' (string) + +If given, the branch to check out after cloning the directory. + + `:lisp-dir' (string) + +The repository-relative directory to use for loading the Lisp +sources. If not given, the value defaults to the root directory +of the repository. + + `:main-file' (string) + +The main file of the project, relevant to gather package +metadata. If not given, the assumed default is the package named +with \".el\" concatenated to the end. + +All other values are ignored.") + +(defun pacakge-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." + (let ((spec (alist-get + (or name (package-desc-name pkg-desc)) + (alist-get (intern (package-desc-archive pkg-desc)) + package-vc-archive-spec-alist) + nil nil #'string=))) + spec)) + +(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" 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)) + (setf (alist-get (intern archive) package-vc-archive-spec-alist) + (read (current-buffer))))))) + +(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" async) + (error (message "Failed to download `%s' archive." (car archive)))))) + +(add-hook 'package-read-archive-hook #'package-vc--read-archive-data 20) +(add-hook 'package-refresh-contents-hook #'package-vc--download-and-read-archives 20) + +(defun package-vc-commit (pkg) + "Extract the commit of a development package PKG." + (cl-assert (package-vc-p pkg)) + ;; FIXME: vc should be extended to allow querying the commit of a + ;; directory (as is possible when dealing with git repositores). + ;; This should be a fallback option. + (cl-loop with dir = (package-desc-dir pkg) + for file in (directory-files dir t "\\.el\\'" t) + when (vc-working-revision file) return it + finally return "unknown")) + +(defun package-vc-version (pkg) + "Extract the commit of a development package PKG." + (cl-assert (package-vc-p pkg)) + (cl-loop with dir = (package-desc-dir pkg) ;FIXME: dir is nil + for file in (sort (directory-files dir t "\\.el\\'") + (lambda (s1 s2) + (< (length s1) (length s2)))) + when (with-temp-buffer + (insert-file-contents file) + (package-strip-rcs-id + (or (lm-header "package-version") + (lm-header "version")))) + return it + finally return "0")) + +(defun package-vc-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) + (or (package-desc-summary pkg-desc) + (and-let* ((pkg (cadr (assq name package-archive-contents)))) + (package-desc-summary pkg)) + (and-let* ((pkg-spec (pacakge-vc-desc->spec pkg-desc)) + (main-file (plist-get pkg-spec :main-file))) + (lm-summary main-file)) + (and-let* ((main-file (expand-file-name + (format "%s.el" name) + (package-desc-dir pkg-desc))) + ((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)))) + +(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 (executable-find "install-info") + ;; Only proceed if we can find an unambiguous TeXinfo file + (let ((texi-files (directory-files pkg-dir t "\\.texi\\'")) + (dir-file (expand-file-name "dir" pkg-dir))) + (when (length= texi-files 1) + (call-process "install-info" nil nil nil + (concat "--dir=" dir-file) + (car texi-files)))))) + + ;; Update package-alist. + (let ((new-desc (package-load-descriptor pkg-dir))) + ;; Activation has to be done before compilation, so that if we're + ;; upgrading and macros have changed we load the new definitions + ;; before compiling. + (when (package-activate-1 new-desc :reload :deps) + ;; FIXME: Compilation should be done as a separate, optional, step. + ;; E.g. for multi-package installs, we should first install all packages + ;; and then compile them. + (package--compile new-desc) + (when package-native-compile + (package--native-compile-async new-desc)) + ;; After compilation, load again any files loaded by + ;; `activate-1', so that we use the byte-compiled definitions. + (package--reload-previously-loaded new-desc))) + + ;; Mark package as selected + (package--save-selected-packages + (cons (package-desc-name pkg-desc) + package-selected-packages))) + +(defun package-vc-unpack (pkg-desc pkg-spec &optional rev) + "Install the package described by PKG-DESC. +PKG-SPEC is a package specification is a property list describing +how to fetch and build the package PKG-DESC. See +`package-vc-archive-spec-alist' for details. The optional argument +REV specifies a specific revision to checkout. This overrides +the `:brach' attribute in PKG-SPEC." + (let* ((name (package-desc-name pkg-desc)) + (dirname (package-desc-full-name pkg-desc)) + (pkg-dir (expand-file-name dirname package-user-dir))) + (setf (package-desc-dir pkg-desc) pkg-dir) + (when (file-exists-p pkg-dir) + (if (yes-or-no-p "Overwrite previous checkout?") + (package--delete-directory pkg-dir pkg-desc) + (error "There already exists a checkout for %s" name))) + (pcase-let* ((extras (package-desc-extras pkg-desc)) + ((map :url :branch :lisp-dir) pkg-spec) + (repo-dir + (if (null lisp-dir) + pkg-dir + (unless (file-exists-p package-vc-repository-store) + (make-directory package-vc-repository-store t)) + (file-name-concat + package-vc-repository-store + ;; FIXME: We aren't sure this directory + ;; will be unique, but we can try other + ;; names to avoid an unnecessary error. + (file-name-base url))))) + + ;; Clone the repository into `repo-dir' if necessary + (unless (file-exists-p repo-dir) + (make-directory (file-name-directory repo-dir) t) + (unless (vc-clone (or (alist-get :vc-backend extras) + package-vc-default-backend) + url repo-dir) + (error "Failed to clone %s from %s" name url))) + + (unless (eq pkg-dir repo-dir) + ;; Link from the right position in `repo-dir' to the package + ;; directory in the ELPA store. + (make-symbolic-link (file-name-concat repo-dir lisp-dir) pkg-dir)) + (when-let* ((default-directory repo-dir) (rev (or rev branch))) + (vc-retrieve-tag pkg-dir rev))) + + (package-vc-unpack-1 pkg-desc pkg-dir))) + +(defun package-vc-sourced-packages-list () + "Generate a list of packages with VC data." + (seq-filter + (lambda (pkg) + (or (pacakge-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)) + (backend (alist-get url package-vc-heusitic-alist + nil nil #'string-match-p)))))) + package-archive-contents)) + +(defun package-vc-update (pkg-desc) + "Attempt to update the packager PKG-DESC." + (let* ((default-directory (package-desc-dir pkg-desc)) + (ret (with-demoted-errors "Error during package update: %S" + (vc-pull))) + (buf (cond + ((processp ret) (process-buffer ret)) + ((bufferp ret) ret)))) + (if buf + (with-current-buffer buf + (vc-run-delayed + (package-vc-unpack-1 pkg-desc default-directory))) + (package-vc-unpack-1 pkg-desc default-directory)))) + +;;;###autoload +(defun package-vc-install (name-or-url &optional name rev) + "Fetch the source of NAME-OR-URL. +If NAME-OR-URL is a URL, then the package will be downloaded from +the repository indicated by the URL. The function will try to +guess the name of the package using `file-name-base'. This can +be overridden by manually passing the optional NAME. Otherwise +NAME-OR-URL is taken to be a package name, and the package +metadata will be consulted for the URL. An explicit revision can +be requested using REV." + (interactive + (progn + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (package--archives-initialize) + (let* ((packages (package-vc-sourced-packages-list)) + (input (completing-read + "Fetch package source (name or URL): " packages)) + (name (file-name-base input))) + (list input (intern (string-remove-prefix "emacs-" name)))))) + (package--archives-initialize) + (cond + ((and-let* ((stringp name-or-url) + (backend (alist-get name-or-url + package-vc-heusitic-alist + nil nil #'string-match-p))) + (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 (pacakge-vc-desc->spec (cadr desc)) + (user-error "Package has no VC data")) + rev))) + ((user-error "Unknown package to fetch: %s" name-or-url)))) + +;;;###autoload +(defalias 'package-checkout #'package-vc-install) + +(defun package-vc-link-directory (dir name) + "Install the package NAME in DIR by linking it into the ELPA directory. +If invoked interactively with a prefix argument, the user will be +prompted for the package NAME. Otherwise it will be inferred +from the base name of DIR." + (interactive (let ((dir (read-directory-name "Directory: "))) + (list dir + (if current-prefix-arg + (read-string "Package name: ") + (file-name-base (directory-file-name dir)))))) + (unless (vc-responsible-backend dir) + (user-error "Directory %S is not under version control" dir)) + (package--archives-initialize) + (let* ((name (file-name-base (directory-file-name dir))) + (pkg-dir (expand-file-name name package-user-dir))) + (make-symbolic-link dir pkg-dir) + (package-vc-unpack-1 (package-desc-create + :name (intern name) + :kind 'vc) + pkg-dir))) + +(defun package-vc-refresh (pkg-desc) + "Refresh the installation for PKG-DESC." + (interactive (package-vc-read-pkg "Refresh package: ")) + (package-vc-unpack-1 pkg-desc (package-desc-dir pkg-desc))) + +(defun package-vc-read-pkg (prompt) + "Query for a source package description with PROMPT." + (cadr (assoc (completing-read + prompt + package-alist + (lambda (pkg) (package-vc-p (cadr pkg))) + t) + package-alist + #'string=))) + +;;;###autoload +(defun package-vc-prepare-patch (pkg subject revisions) + "Send a patch to the maintainer of a package PKG. +SUBJECT and REVISIONS are used passed on to `vc-prepare-patch'. +PKG must be a package description." + (interactive + (list (package-vc-read-pkg "Package to prepare a patch for: ") + (and (not vc-prepare-patches-separately) + (read-string "Subject: " "[PATCH] " nil nil t)) + (or (log-view-get-marked) + (vc-read-multiple-revisions "Revisions: ")))) + (vc-prepare-patch (package-maintainers pkg t) + subject revisions)) + +(provide 'package-vc) +;;; package-vc.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index d619142d64c..425abfeea5c 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 @@ -691,6 +726,10 @@ return it." (read (current-buffer))) (error "Can't find define-package in %s" pkg-file)))) (setf (package-desc-dir pkg-desc) pkg-dir) + (when (package-vc-p pkg-desc) + (require 'package-vc) + (push (cons :commit (package-vc-commit pkg-desc)) + (package-desc-extras pkg-desc))) (if (file-exists-p signed-file) (setf (package-desc-signed pkg-desc) t)) pkg-desc))))) @@ -706,11 +745,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." @@ -874,14 +911,22 @@ correspond to previously loaded files (those returned by (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))) @@ -959,7 +1004,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))) @@ -1022,6 +1067,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)) @@ -1069,11 +1115,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))) @@ -1602,13 +1650,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 @@ -1784,6 +1838,11 @@ asynchronously." (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. @@ -1802,7 +1861,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 @@ -2036,9 +2095,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) @@ -2176,17 +2235,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 @@ -2196,12 +2260,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 @@ -2358,15 +2423,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. @@ -2420,7 +2498,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 @@ -2631,7 +2709,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 @@ -2830,6 +2911,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) @@ -2920,6 +3009,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 @@ -3078,6 +3168,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) @@ -3166,8 +3257,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 @@ -3369,6 +3461,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." @@ -3406,6 +3503,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) @@ -3417,9 +3515,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) "") @@ -3494,7 +3597,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))) @@ -3850,6 +3953,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) @@ -4143,6 +4248,7 @@ packages." "held" "incompat" "installed" + "source" "new" "unsigned"))) package-menu-mode) @@ -4214,22 +4320,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." @@ -4411,11 +4517,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 @@ -4424,9 +4541,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) |