diff options
Diffstat (limited to 'lisp/emacs-lisp/package.el')
| -rw-r--r-- | lisp/emacs-lisp/package.el | 339 |
1 files changed, 207 insertions, 132 deletions
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 608306c8254..ab1731aeb54 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -378,10 +378,8 @@ If so, and variable `package-check-signature' is `allow-unsigned', return `allow-unsigned', otherwise return the value of variable `package-check-signature'." (if (eq package-check-signature 'allow-unsigned) - (progn - (require 'epg-config) - (and (epg-find-configuration 'OpenPGP) - 'allow-unsigned)) + (and (epg-find-configuration 'OpenPGP) + 'allow-unsigned) package-check-signature)) (defcustom package-unsigned-archives nil @@ -611,7 +609,7 @@ package." (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." + "Return a list of regular expressions 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) @@ -903,13 +901,7 @@ correspond to previously loaded files." (when reload (package--reload-previously-loaded pkg-desc)) (with-demoted-errors "Error loading autoloads: %s" - (load (package--autoloads-file-name pkg-desc) nil t)) - ;; FIXME: Since 2013 (commit 4fac34cee97a), the autoload files take - ;; care of changing the `load-path', so maybe it's time to - ;; remove this fallback code? - (unless (or (member (file-name-as-directory pkg-dir) load-path) - (member (directory-file-name pkg-dir) load-path)) - (add-to-list 'load-path pkg-dir))) + (load (package--autoloads-file-name pkg-desc) nil t))) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. @@ -970,7 +962,6 @@ Newer versions are always activated, regardless of FORCE." "Untar the current buffer. This uses `tar-untar-buffer' from Tar mode. All files should untar into a directory named DIR; otherwise, signal an error." - (require 'tar-mode) (tar-mode) ;; Make sure everything extracts into DIR. (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/")) @@ -1158,27 +1149,8 @@ Signal an error if the entire string was not used." (error "Can't read whole string")) (end-of-file expr)))) -(defun package--prepare-dependencies (deps) - "Turn DEPS into an acceptable list of dependencies. - -Any parts missing a version string get a default version string -of \"0\" (meaning any version) and an appropriate level of lists -is wrapped around any parts requiring it." - (cond - ((not (listp deps)) - (error "Invalid requirement specifier: %S" deps)) - (t (mapcar (lambda (dep) - (cond - ((symbolp dep) `(,dep "0")) - ((stringp dep) - (error "Invalid requirement specifier: %S" dep)) - ((and (listp dep) (null (cdr dep))) - (list (car dep) "0")) - (t dep))) - deps)))) - (declare-function lm-header "lisp-mnt" (header)) -(declare-function lm-header-multiline "lisp-mnt" (header)) +(declare-function lm-package-requires "lisp-mnt" (&optional file)) (declare-function lm-website "lisp-mnt" (&optional file)) (declare-function lm-keywords-list "lisp-mnt" (&optional file)) (declare-function lm-maintainers "lisp-mnt" (&optional file)) @@ -1200,9 +1172,15 @@ boundaries." ;; the earliest in version 31.1. The idea is to phase out the ;; requirement for a "footer line" without unduly impacting users ;; on earlier Emacs versions. See Bug#26490 for more details. - (unless (search-forward (concat ";;; " file-name ".el ends here")) - (lwarn '(package package-format) :warning - "Package lacks a terminating comment")) + (unless (search-forward (concat ";;; " file-name ".el ends here") nil 'move) + ;; Starting in Emacs 30.1, avoid warning if the minimum Emacs + ;; version is specified as 30.1 or later. + (let ((min-emacs (cadar (seq-filter (lambda (x) (eq (car x) 'emacs)) + (lm-package-requires))))) + (when (or (null min-emacs) + (version< min-emacs "30.1")) + (lwarn '(package package-format) :warning + "Package lacks a terminating comment")))) ;; Try to include a trailing newline. (forward-line) (narrow-to-region start (point)) @@ -1221,15 +1199,13 @@ boundaries." (error "Package lacks a \"Version\" or \"Package-Version\" header"))) (package-desc-from-define file-name pkg-version desc - (and-let* ((require-lines (lm-header-multiline "package-requires"))) - (package--prepare-dependencies - (package-read-from-string (mapconcat #'identity require-lines " ")))) + (lm-package-requires) :kind 'single :url website :keywords keywords :maintainer - ;; For backward compatibility, use a single string if there's only - ;; one maintainer (the most common case). + ;; For backward compatibility, use a single cons-cell if + ;; there's only one maintainer (the most common case). (let ((maints (lm-maintainers))) (if (cdr maints) maints (car maints))) :authors (lm-authors))))) @@ -1237,15 +1213,14 @@ boundaries." "Read a `define-package' form in current buffer. Return the pkg-desc, with desc-kind set to KIND." (goto-char (point-min)) - (unwind-protect - (let* ((pkg-def-parsed (read (current-buffer))) - (pkg-desc - (when (eq (car pkg-def-parsed) 'define-package) - (apply #'package-desc-from-define - (append (cdr pkg-def-parsed)))))) - (when pkg-desc - (setf (package-desc-kind pkg-desc) kind) - pkg-desc)))) + (let* ((pkg-def-parsed (read (current-buffer))) + (pkg-desc + (when (eq (car pkg-def-parsed) 'define-package) + (apply #'package-desc-from-define + (append (cdr pkg-def-parsed)))))) + (when pkg-desc + (setf (package-desc-kind pkg-desc) kind) + pkg-desc))) (declare-function tar-get-file-descriptor "tar-mode" (file)) (declare-function tar--extract "tar-mode" (descriptor)) @@ -1730,18 +1705,26 @@ The variable `package-load-list' controls which packages to load." package-quickstart-file)))) ;; The quickstart file presumes that it has a blank slate, ;; so don't use it if we already activated some packages. - (if (and qs (not (bound-and-true-p package-activated-list))) - ;; Skip load-source-file-function which would slow us down by a factor - ;; 2 when loading the .el file (this assumes we were careful to - ;; save this file so it doesn't need any decoding). - (let ((load-source-file-function nil)) - (unless (boundp 'package-activated-list) - (setq package-activated-list nil)) - (load qs nil 'nomessage)) - (require 'package) - (package--activate-all))))) + (or (and qs (not (bound-and-true-p package-activated-list)) + ;; Skip `load-source-file-function' which would slow us down by + ;; a factor 2 when loading the .el file (this assumes we were + ;; careful to save this file so it doesn't need any decoding). + (with-demoted-errors "Error during quickstart: %S" + (let ((load-source-file-function nil)) + (unless (boundp 'package-activated-list) + (setq package-activated-list nil)) + (load qs nil 'nomessage) + t))) + (progn + (require 'package) + ;; Silence the "unknown function" warning when this is compiled + ;; inside `loaddefs.el'. + ;; FIXME: We use `with-no-warnings' because the effect of + ;; `declare-function' is currently not scoped, so if we use + ;; it here, we end up with a redefinition warning instead :-) + (with-no-warnings + (package--activate-all))))))) -;;;###autoload (defun package--activate-all () (dolist (elt (package--alist)) (condition-case err @@ -1992,8 +1975,11 @@ Used to populate `package-selected-packages'." (defun package--save-selected-packages (&optional value) "Set and save `package-selected-packages' to VALUE." - (when value - (setq package-selected-packages value)) + (when (or value after-init-time) + ;; It is valid to set it to nil, for example when the last package + ;; is uninstalled. But it shouldn't be done at init time, to + ;; avoid overwriting configurations that haven't yet been loaded. + (setq package-selected-packages (sort value #'string<))) (if after-init-time (customize-save-variable 'package-selected-packages package-selected-packages) (add-hook 'after-init-hook #'package--save-selected-packages))) @@ -2268,25 +2254,26 @@ had been enabled." ;;;###autoload (defun package-upgrade (name) - "Upgrade package NAME if a newer version exists. - -Currently, packages which are part of the Emacs distribution -cannot be upgraded that way. To enable upgrades of such a -package using this command, first upgrade the package to a -newer version from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'." + "Upgrade package NAME if a newer version exists." (interactive (list (completing-read - "Upgrade package: " (package--upgradeable-packages) nil t))) + "Upgrade package: " (package--upgradeable-packages t) nil t))) (let* ((package (if (symbolp name) name (intern name))) - (pkg-desc (cadr (assq package package-alist)))) - (if (package-vc-p pkg-desc) + (pkg-desc (cadr (assq package package-alist))) + (package-install-upgrade-built-in (not pkg-desc))) + ;; `pkg-desc' will be nil when the package is an "active built-in". + (if (and pkg-desc (package-vc-p pkg-desc)) (package-vc-upgrade pkg-desc) - (package-delete pkg-desc 'force 'dont-unselect) - (package-install package 'dont-select)))) - -(defun package--upgradeable-packages () + (when pkg-desc + (package-delete pkg-desc 'force 'dont-unselect)) + (package-install package + ;; An active built-in has never been "selected" + ;; before. Mark it as installed explicitly. + (and pkg-desc 'dont-select))))) + +(defun package--upgradeable-packages (&optional include-builtins) ;; Initialize the package system to get the list of package ;; symbols for completion. (package--archives-initialize) @@ -2297,11 +2284,21 @@ newer version from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark- (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))) + (or (and + include-builtins + (not (package-desc-version (cadr elt)))) + (version-list-< + (package-desc-version (cadr elt)) + (package-desc-version (cadr available)))))) + (package-vc-p (cadr elt)))) + (if include-builtins + (append package-alist + (mapcan + (lambda (elt) + (when (not (assq (car elt) package-alist)) + (list (list (car elt) (package--from-builtin elt))))) + package--builtins)) + package-alist)))) ;;;###autoload (defun package-upgrade-all (&optional query) @@ -2311,8 +2308,9 @@ interactively, QUERY is always true. Currently, packages which are part of the Emacs distribution are not upgraded by this command. To enable upgrading such a package -using this command, first upgrade the package to a newer version -from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'." +using this command, first upgrade the package to a newer version +from ELPA by either using `\\[package-upgrade]' or +`\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'." (interactive (list (not noninteractive))) (package-refresh-contents) (let ((upgradeable (package--upgradeable-packages))) @@ -2328,12 +2326,25 @@ from ELPA by using `\\<package-menu-mode-map>\\[package-menu-mark-install]' afte (mapc #'package-upgrade upgradeable)))) (defun package--dependencies (pkg) - "Return a list of all dependencies PKG has. -This is done recursively." - ;; Can we have circular dependencies? Assume "nope". - (when-let* ((desc (cadr (assq pkg package-archive-contents))) - (deps (mapcar #'car (package-desc-reqs desc)))) - (delete-dups (apply #'nconc deps (mapcar #'package--dependencies deps))))) + "Return a list of all transitive dependencies of PKG. +If PKG is a package descriptor, the return value is a list of +package descriptors. If PKG is a symbol designating a package, +the return value is a list of symbols designating packages." + (when-let* ((desc (if (package-desc-p pkg) pkg + (cadr (assq pkg package-archive-contents))))) + ;; Can we have circular dependencies? Assume "nope". + (let ((all (named-let more ((pkg-desc desc)) + (let (deps) + (dolist (req (package-desc-reqs pkg-desc)) + (setq deps (nconc + (catch 'found + (dolist (p (apply #'append (mapcar #'cdr (package--alist)))) + (when (and (string= (car req) (package-desc-name p)) + (version-list-<= (cadr req) (package-desc-version p))) + (throw 'found (more p))))) + deps))) + (delete-dups (cons pkg-desc deps)))))) + (remq pkg (mapcar (if (package-desc-p pkg) #'identity #'package-desc-name) all))))) (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. @@ -2469,7 +2480,9 @@ 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\\'") + for file in (directory-files-recursively dir + ;; Exclude lockfiles + (rx bos (or (and "." (not "#")) (not ".")) (* nonl) ".el" eos)) do (comp-clean-up-stale-eln (comp-el-to-eln-filename file)))) (if (file-symlink-p (directory-file-name dir)) (delete-file (directory-file-name dir)) @@ -2501,8 +2514,12 @@ If NOSAVE is non-nil, the package is not removed from nil t))) (list (cdr (assoc package-name package-table)) current-prefix-arg nil)))) - (let ((dir (package-desc-dir pkg-desc)) - (name (package-desc-name pkg-desc)) + (let* ((dir (package-desc-dir pkg-desc)) + (name (package-desc-name pkg-desc)) + (new-package-alist (let ((pkgs (assq name package-alist))) + (if (null (remove pkg-desc (cdr pkgs))) + (remq pkgs package-alist) + package-alist))) pkg-used-elsewhere-by) ;; If the user is trying to delete this package, they definitely ;; don't want it marked as selected, so we remove it from @@ -2521,7 +2538,8 @@ If NOSAVE is non-nil, the package is not removed from (package-desc-full-name pkg-desc))) ((and (null force) (setq pkg-used-elsewhere-by - (package--used-elsewhere-p pkg-desc))) + (let ((package-alist new-package-alist)) + (package--used-elsewhere-p pkg-desc)))) ;See bug#65475 ;; Don't delete packages used as dependency elsewhere. (error "Package `%s' is used by `%s' as dependency, not deleting" (package-desc-full-name pkg-desc) @@ -2542,10 +2560,7 @@ If NOSAVE is non-nil, the package is not removed from (when (file-exists-p file) (delete-file file)))) ;; Update package-alist. - (let ((pkgs (assq name package-alist))) - (delete pkg-desc pkgs) - (unless (cdr pkgs) - (setq package-alist (delq pkgs package-alist)))) + (setq package-alist new-package-alist) (package--quickstart-maybe-refresh) (message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))) @@ -2595,7 +2610,8 @@ This is meant to be used only in the case the byte-compiled files are invalid due to changed byte-code, macros or the like." (interactive) (pcase-dolist (`(_ ,pkg-desc) package-alist) - (package-recompile pkg-desc))) + (with-demoted-errors "Error while recompiling: %S" + (package-recompile pkg-desc)))) ;;;###autoload (defun package-autoremove () @@ -2623,6 +2639,57 @@ will be deleted." removable)) (message "Nothing to autoremove"))))) +(defun package-isolate (packages &optional temp-init) + "Start an uncustomised Emacs and only load a set of PACKAGES. +If TEMP-INIT is non-nil, or when invoked with a prefix argument, +the Emacs user directory is set to a temporary directory." + (interactive + (cl-loop for p in (cl-loop for p in (package--alist) append (cdr p)) + unless (package-built-in-p p) + collect (cons (package-desc-full-name p) p) into table + finally return + (list (cl-loop for c in (completing-read-multiple + "Isolate packages: " table + nil t) + collect (alist-get c table nil nil #'string=)) + current-prefix-arg))) + (let* ((name (concat "package-isolate-" + (mapconcat #'package-desc-full-name packages ","))) + (all-packages (delete-consecutive-dups + (sort (append packages (mapcan #'package--dependencies packages)) + (lambda (p0 p1) + (string< (package-desc-name p0) (package-desc-name p1)))))) + initial-scratch-message package-load-list) + (with-temp-buffer + (insert ";; This is an isolated testing environment, with these packages enabled:\n\n") + (dolist (package all-packages) + (push (list (package-desc-name package) + (package-version-join (package-desc-version package))) + package-load-list) + (insert ";; - " (package-desc-full-name package)) + (unless (memq package packages) + (insert " (dependency)")) + (insert "\n")) + (insert "\n") + (setq initial-scratch-message (buffer-string))) + (apply #'start-process (concat "*" name "*") nil + (list (expand-file-name invocation-name invocation-directory) + "--quick" "--debug-init" + "--init-directory" (if temp-init + (make-temp-file name t) + user-emacs-directory) + (format "--eval=%S" + `(progn + (setq initial-scratch-message ,initial-scratch-message) + + (require 'package) + ,@(mapcar + (lambda (dir) + `(add-to-list 'package-directory-list ,dir)) + (cons package-user-dir package-directory-list)) + (setq package-load-list ',package-load-list) + (package-initialize))))))) + ;;;; Package description buffer. @@ -2738,7 +2805,7 @@ Helper function for `describe-package'." (status (if desc (package-desc-status desc) "orphan")) (incompatible-reason (package--incompatible-p desc)) (signed (if desc (package-desc-signed desc))) - (maintainer (cdr (assoc :maintainer extras))) + (maintainers (cdr (assoc :maintainer extras))) (authors (cdr (assoc :authors extras))) (news (and-let* (pkg-dir ((not built-in)) @@ -2873,19 +2940,21 @@ Helper function for `describe-package'." 'action 'package-keyword-button-action) (insert " ")) (insert "\n")) - (when maintainer - (package--print-help-section "Maintainer") - (package--print-email-button maintainer)) - (when authors + (when maintainers + (when (stringp (car maintainers)) + (setq maintainers (list maintainers))) (package--print-help-section - (if (= (length authors) 1) - "Author" - "Authors")) - (package--print-email-button (pop authors)) - ;; If there's more than one author, indent the rest correctly. - (dolist (name authors) - (insert (make-string 13 ?\s)) - (package--print-email-button name))) + (if (cdr maintainers) "Maintainers" "Maintainer")) + (dolist (maintainer maintainers) + (when (bolp) + (insert (make-string 13 ?\s))) + (package--print-email-button maintainer))) + (when authors + (package--print-help-section (if (cdr authors) "Authors" "Author")) + (dolist (author authors) + (when (bolp) + (insert (make-string 13 ?\s))) + (package--print-email-button author))) (let* ((all-pkgs (append (cdr (assq name package-alist)) (cdr (assq name package-archive-contents)) (let ((bi (assq name package--builtins))) @@ -3146,8 +3215,7 @@ The most useful commands here are: `[("Package" ,package-name-column-width package-menu--name-predicate) ("Version" ,package-version-column-width package-menu--version-predicate) ("Status" ,package-status-column-width package-menu--status-predicate) - ,@(if (cdr package-archives) - `(("Archive" ,package-archive-column-width package-menu--archive-predicate))) + ("Archive" ,package-archive-column-width package-menu--archive-predicate) ("Description" 0 package-menu--description-predicate)]) (setq tabulated-list-padding 2) (setq tabulated-list-sort-key (cons "Status" nil)) @@ -3587,9 +3655,8 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (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) "") - 'font-lock-face face))) + ,(propertize (or (package-desc-archive pkg) "") + 'font-lock-face face) ,(propertize (package-desc-summary pkg) 'font-lock-face 'package-description)]))) @@ -4538,8 +4605,8 @@ activations need to be changed, such as when `package-load-list' is modified." (let ((load-suffixes '(".el" ".elc"))) (locate-library (package--autoloads-file-name pkg)))) (pfile (prin1-to-string file))) - (insert "(let ((load-true-file-name " pfile ")\ -\(load-file-name " pfile "))\n") + (insert "(let* ((load-file-name " pfile ")\ +\(load-true-file-name load-file-name))\n") (insert-file-contents file) ;; Fixup the special #$ reader form and throw away comments. (while (re-search-forward "#\\$\\|^;\\(.*\n\\)" nil 'move) @@ -4632,19 +4699,25 @@ will be signaled in that case." (let* ((name (package-desc-name pkg-desc)) (extras (package-desc-extras pkg-desc)) (maint (alist-get :maintainer extras))) + (unless (listp (cdr maint)) + (setq maint (list maint))) (cond ((and (null maint) (null no-error)) (user-error "Package `%s' has no explicit maintainer" name)) ((and (not (progn (require 'ietf-drums) - (ietf-drums-parse-address (cdr maint)))) + (ietf-drums-parse-address (cdar maint)))) (null no-error)) (user-error "Package `%s' has no maintainer address" name)) - ((not (null maint)) + (t (with-temp-buffer - (package--print-email-button maint) - (string-trim (substring-no-properties (buffer-string)))))))) + (mapc #'package--print-email-button maint) + (replace-regexp-in-string + "\n" ", " (string-trim + (buffer-substring-no-properties + (point-min) (point-max))))))))) +;;;###autoload (defun package-report-bug (desc) "Prepare a message to send to the maintainers of a package. DESC must be a `package-desc' object." @@ -4652,17 +4725,19 @@ DESC must be a `package-desc' object." package-menu-mode) (let ((maint (package-maintainers desc)) (name (symbol-name (package-desc-name desc))) + (pkgdir (package-desc-dir desc)) vars) - (dolist-with-progress-reporter (group custom-current-group-alist) - "Scanning for modified user options..." - (when (and (car group) - (file-in-directory-p (car group) (package-desc-dir desc))) - (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))))) - (push (car ent) vars))))) + (when pkgdir + (dolist-with-progress-reporter (group custom-current-group-alist) + "Scanning for modified user options..." + (when (and (car group) + (file-in-directory-p (car group) pkgdir)) + (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))))) + (push (car ent) vars)))))) (dlet ((reporter-prompt-for-summary-p t)) (reporter-submit-bug-report maint name vars)))) |