This variable has three possible values:
nil: no packages are hidden;
- archive: only criteria (a) is used;
+ `archive': only criteria (a) is used;
t: both criteria are used.
This variable has no effect if `package-menu--hide-packages' is
(require 'finder-inf nil t) ; For `package--builtins'.
(assq package package--builtins))))))
+(defun package--autoloads-file-name (pkg-desc)
+ "Return the absolute name of the autoloads file, sans extension.
+PKG-DESC is a `package-desc' object."
+ (expand-file-name
+ (format "%s-autoloads" (package-desc-name pkg-desc))
+ (package-desc-dir pkg-desc)))
+
+(defun package--activate-autoloads-and-load-path (pkg-desc)
+ "Load the autoloads file and add package dir to `load-path'.
+PKG-DESC is a `package-desc' object."
+ (let* ((old-lp load-path)
+ (pkg-dir (package-desc-dir pkg-desc))
+ (pkg-dir-dir (file-name-as-directory pkg-dir)))
+ (with-demoted-errors "Error loading autoloads: %s"
+ (load (package--autoloads-file-name pkg-desc) nil t))
+ (when (and (eq old-lp load-path)
+ (not (or (member pkg-dir load-path)
+ (member pkg-dir-dir load-path))))
+ ;; Old packages don't add themselves to the `load-path', so we have to
+ ;; do it ourselves.
+ (push pkg-dir load-path))))
+
(defvar Info-directory-list)
(declare-function info-initialize "info" ())
correspond to previously loaded files (those returned by
`package--list-loaded-files')."
(let* ((name (package-desc-name pkg-desc))
- (pkg-dir (package-desc-dir pkg-desc))
- (pkg-dir-dir (file-name-as-directory pkg-dir)))
+ (pkg-dir (package-desc-dir pkg-desc)))
(unless pkg-dir
(error "Internal error: unable to find directory for `%s'"
(package-desc-full-name pkg-desc)))
- ;; Add to load path, add autoloads, and activate the package.
- (let* ((old-lp load-path)
- (autoloads-file (expand-file-name
- (format "%s-autoloads" name) pkg-dir))
- (loaded-files-list (and reload (package--list-loaded-files pkg-dir))))
- (with-demoted-errors "Error in package-activate-1: %s"
- (load autoloads-file nil t))
- (when (and (eq old-lp load-path)
- (not (or (member pkg-dir load-path)
- (member pkg-dir-dir load-path))))
- ;; Old packages don't add themselves to the `load-path', so we have to
- ;; do it ourselves.
- (push pkg-dir load-path))
+ (let* ((loaded-files-list (when reload
+ (package--list-loaded-files pkg-dir))))
+ ;; Add to load path, add autoloads, and activate the package.
+ (package--activate-autoloads-and-load-path pkg-desc)
;; Call `load' on all files in `pkg-dir' already present in
;; `load-history'. This is done so that macros in these files are updated
;; to their new definitions. If another package is being installed which
(with-demoted-errors "Error in package-activate-1: %s"
(mapc (lambda (feature) (load feature nil t))
;; Skip autoloads file since we already evaluated it above.
- (remove (file-truename autoloads-file) loaded-files-list))))
+ (remove (file-truename (package--autoloads-file-name pkg-desc))
+ loaded-files-list))))
;; Add info node.
(when (file-exists-p (expand-file-name "dir" pkg-dir))
;; FIXME: not the friendliest, but simple.
" --- automatically extracted autoloads\n"
";;\n"
";;; Code:\n"
- "(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))\n"
+ ;; `load-path' should contain only directory names
+ "(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))\n"
"\f\n;; Local Variables:\n"
";; version-control: never\n"
";; no-byte-compile: t\n"
(defun package--compile (pkg-desc)
"Byte-compile installed package PKG-DESC."
(let ((warning-minimum-level :error)
- (save-silently inhibit-message))
- (package-activate-1 pkg-desc)
+ (save-silently inhibit-message)
+ (load-path load-path))
+ (package--activate-autoloads-and-load-path pkg-desc)
(byte-recompile-directory (package-desc-dir pkg-desc) 0 t)))
;;;; Inferring package from current buffer
(declare-function lm-header "lisp-mnt" (header))
(declare-function lm-homepage "lisp-mnt" (&optional file))
+(declare-function lm-maintainer "lisp-mnt" (&optional file))
+(declare-function lm-authors "lisp-mnt" (&optional file))
(defun package-buffer-info ()
"Return a `package-desc' describing the package in the current buffer.
(package--prepare-dependencies
(package-read-from-string requires-str)))
:kind 'single
- :url homepage))))
+ :url homepage
+ :maintainer (lm-maintainer)
+ :authors (lm-authors)))))
(defun package--read-pkg-desc (kind)
"Read a `define-package' form in current buffer.
This macro retrieves FILE from LOCATION into a temporary buffer,
and evaluates BODY while that buffer is current. This work
buffer is killed afterwards. Return the last value in BODY."
- (declare (indent 2) (debug t))
+ (declare (indent 2) (debug t)
+ (obsolete package--with-response-buffer "25.1"))
`(with-temp-buffer
(if (string-match-p "\\`https?:" ,location)
(url-insert-file-contents (concat ,location ,file))
(insert-file-contents (expand-file-name ,file ,location)))
,@body))
-(defmacro package--with-work-buffer-async (location file async &rest body)
- "Run BODY in a buffer containing the contents of FILE at LOCATION.
-If ASYNC is non-nil, and if it is possible, run BODY
-asynchronously. If an error is encountered and ASYNC is a
-function, call it with no arguments (instead of executing BODY).
-If it returns non-nil, or if it wasn't a function, propagate the
-error.
-
-For a description of the other arguments see
-`package--with-work-buffer'."
- (declare (indent 3) (debug t))
- (macroexp-let2* macroexp-copyable-p
- ((async-1 async)
- (file-1 file)
- (location-1 location))
- `(if (or (not ,async-1)
- (not (string-match-p "\\`https?:" ,location-1)))
- (package--with-work-buffer ,location-1 ,file-1 ,@body)
- ;; This `condition-case' is to catch connection errors.
- (condition-case error-signal
- (url-retrieve (concat ,location-1 ,file-1)
- (lambda (status)
- (if-let ((er (plist-get status :error)))
- (when (if (functionp ,async-1)
- (funcall ,async-1)
- t)
- (message "Error contacting: %s" (concat ,location-1 ,file-1))
- (signal (car er) (cdr er)))
- (goto-char (point-min))
- (unless (search-forward "\n\n" nil 'noerror)
- (error "Invalid url response in buffer %s"
- (current-buffer)))
- (delete-region (point-min) (point))
- ,@body)
- (kill-buffer (current-buffer)))
- nil
- 'silent)
- (error (when (functionp ,async-1)
- (funcall ,async-1))
- (message "Error contacting: %s" (concat ,location-1 ,file-1))
- (signal (car error-signal) (cdr error-signal)))))))
+(cl-defmacro package--with-response-buffer (url &rest body &key async file error-form noerror &allow-other-keys)
+ "Access URL and run BODY in a buffer containing the response.
+Point is after the headers when BODY runs.
+FILE, if provided, is added to URL.
+URL can be a local file name, which must be absolute.
+ASYNC, if non-nil, runs the request asynchronously.
+ERROR-FORM is run only if an error occurs. If NOERROR is
+non-nil, don't propagate errors caused by the connection or by
+BODY (does not apply to errors signaled by ERROR-FORM).
+
+\(fn URL &key ASYNC FILE ERROR-FORM NOERROR &rest BODY)"
+ (declare (indent defun) (debug t))
+ (while (keywordp (car body))
+ (setq body (cdr (cdr body))))
+ (macroexp-let2* nil ((url-1 url))
+ `(cl-macrolet ((wrap-errors (&rest bodyforms)
+ (let ((err (make-symbol "err")))
+ `(condition-case ,err
+ ,(macroexp-progn bodyforms)
+ ,(list 'error ',error-form
+ (list 'unless ',noerror
+ `(signal (car ,err) (cdr ,err))))))))
+ (if (string-match-p "\\`https?:" ,url-1)
+ (let* ((url (concat ,url-1 ,file))
+ (callback (lambda (status)
+ (let ((b (current-buffer)))
+ (require 'url-handlers)
+ (unwind-protect (wrap-errors
+ (when-let ((er (plist-get status :error)))
+ (error "Error retrieving: %s %S" url er))
+ (unless (search-forward-regexp "^\r?\n\r?" nil 'noerror)
+ (error "Error retrieving: %s %S" url "incomprehensible buffer"))
+ (with-temp-buffer
+ (url-insert-buffer-contents b url)
+ (kill-buffer b)
+ (goto-char (point-min))
+ ,@body)))))))
+ (if ,async
+ (wrap-errors (url-retrieve url callback nil 'silent))
+ (with-current-buffer (wrap-errors (url-retrieve-synchronously url 'silent))
+ (funcall callback nil))))
+ (wrap-errors (with-temp-buffer
+ (let ((url (expand-file-name ,file ,url-1)))
+ (unless (file-name-absolute-p url)
+ (error "Location %s is not a url nor an absolute file name" url))
+ (insert-file-contents url))
+ ,@body))))))
(defun package--check-signature-content (content string &optional sig-file)
"Check signature CONTENT against STRING.
CALLBACK is called with no arguments."
(let ((sig-file (concat file ".sig"))
(string (or string (buffer-string))))
- (condition-case nil
- (package--with-work-buffer-async
- location sig-file (when async (or callback t))
- (let ((sig (package--check-signature-content
- (buffer-string) string sig-file)))
- (when callback (funcall callback sig))
- sig))
- (file-error (funcall callback)))))
-
+ (package--with-response-buffer location :file sig-file
+ :async async :noerror t
+ :error-form (when callback (funcall callback nil))
+ (let ((sig (package--check-signature-content (buffer-substring (point) (point-max)) string sig-file)))
+ (when callback (funcall callback sig))
+ sig))))
\f
;;; Packages on Archives
;; The following variables store information about packages available
(dolist (package contents)
(package--add-to-archive-contents package archive)))))
+(defvar package--old-archive-priorities nil
+ "Store currently used `package-archive-priorities'.
+This is the value of `package-archive-priorities' last time
+`package-read-all-archive-contents' was called. It can be used
+by arbitrary functions to decide whether it is necessary to call
+it again.")
+
(defun package-read-all-archive-contents ()
"Re-read `archive-contents', if it exists.
If successful, set `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))))
The variable `package-load-list' controls which packages to load.
If optional arg NO-ACTIVATE is non-nil, don't activate packages.
If `user-init-file' does not mention `(package-initialize)', add
-it to the file."
+it to the file.
+If called as part of loading `user-init-file', set
+`package-enable-at-startup' to nil, to prevent accidentally
+loading packages twice."
(interactive)
(setq package-alist nil)
(if (equal user-init-file load-file-name)
;; If `package-initialize' is being called as part of loading
;; the init file, it's obvious we don't need to ensure-init.
- (setq package--init-file-ensured t)
+ (setq package--init-file-ensured t
+ ;; And likely we don't need to run it again after init.
+ package-enable-at-startup nil)
(package--ensure-init-file))
(package-load-all-descriptors)
(package-read-all-archive-contents)
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'."
- (package--with-work-buffer-async (cdr archive) file async
+ (package--with-response-buffer (cdr archive) :file file
+ :async async
+ :error-form (package--update-downloads-in-progress archive)
(let* ((location (cdr archive))
(name (car archive))
(content (buffer-string))
;; remove it from the in-progress list.
(package--update-downloads-in-progress archive)
(error "Unsigned archive `%s'" name))
+ ;; Either everything worked or we don't mind not signing.
;; Write out the archives file.
(write-region content nil local-file nil 'silent)
;; Write out good signatures into archive-contents.signed file.
(when good-sigs
(write-region (mapconcat #'epg-signature-to-string good-sigs "\n")
nil (concat local-file ".signed") nil 'silent))
- (package--update-downloads-in-progress archive)
- ;; If we got this far, either everything worked or we don't mind
- ;; not signing, so tell `package--with-work-buffer-async' to not
- ;; propagate errors.
- nil)))))))
+ (package--update-downloads-in-progress archive))))))))
(defun package--download-and-read-archives (&optional async)
"Download descriptions of all `package-archives' and read them.
:test #'equal))
(dolist (archive package-archives)
(condition-case-unless-debug nil
- (package--download-one-archive
- archive "archive-contents"
- ;; Called if the async download fails
- (when async
- ;; The t at the end means to propagate connection errors.
- (lambda () (package--update-downloads-in-progress archive) t)))
+ (package--download-one-archive archive "archive-contents" async)
(error (message "Failed to download `%s' archive."
(car archive))))))
;; blocked via `package-load-list'.
(let ((pkg-descs (cdr (assq next-pkg package-archive-contents)))
(found nil)
+ (found-something nil)
(problem nil))
(while (and pkg-descs (not found))
(let* ((pkg-desc (pop pkg-descs))
(disabled (package-disabled-p next-pkg version)))
(cond
((version-list-< version next-version)
- (error
- "Need package `%s-%s', but only %s is available"
- next-pkg (package-version-join next-version)
- (package-version-join version)))
+ ;; pkg-descs is sorted by priority, not version, so
+ ;; don't error just yet.
+ (unless found-something
+ (setq found-something (package-version-join version))))
(disabled
(unless problem
(setq problem
(if (stringp disabled)
- (format "Package `%s' held at version %s, \
-but version %s required"
- next-pkg disabled
- (package-version-join next-version))
- (format "Required package '%s' is disabled"
- next-pkg)))))
+ (format-message
+ "Package `%s' held at version %s, but version %s required"
+ next-pkg disabled
+ (package-version-join next-version))
+ (format-message "Required package `%s' is disabled"
+ next-pkg)))))
(t (setq found pkg-desc)))))
(unless found
- (if problem
- (error "%s" problem)
- (error "Package `%s-%s' is unavailable"
- next-pkg (package-version-join next-version))))
+ (cond
+ (problem (error "%s" problem))
+ (found-something
+ (error "Need package `%s-%s', but only %s is available"
+ next-pkg (package-version-join next-version)
+ found-something))
+ (t (error "Package `%s-%s' is unavailable"
+ next-pkg (package-version-join next-version)))))
(setq packages
(package-compute-transaction (cons found packages)
(package-desc-reqs found)
unless (memq name dep-list)
collect name)))
-(defun package--save-selected-packages (value)
+(defun package--save-selected-packages (&optional value)
"Set and save `package-selected-packages' to VALUE."
- (let ((save-silently inhibit-message))
- (customize-save-variable
- 'package-selected-packages
- (setq package-selected-packages value))))
+ (when value
+ (setq package-selected-packages value))
+ (if after-init-time
+ (let ((save-silently inhibit-message))
+ (customize-save-variable 'package-selected-packages package-selected-packages))
+ (add-hook 'after-init-hook #'package--save-selected-packages)))
(defun package--user-selected-p (pkg)
"Return non-nil if PKG is a package was installed by the user.
(let* ((location (package-archive-base pkg-desc))
(file (concat (package-desc-full-name pkg-desc)
(package-desc-suffix pkg-desc))))
- (package--with-work-buffer location file
+ (package--with-response-buffer location :file file
(if (or (not package-check-signature)
(member (package-desc-archive pkg-desc)
package-unsigned-archives))
(save-restriction
(widen)
(goto-char (point-min))
- (search-forward "(package-initialize)" nil 'noerror))))
+ (re-search-forward "(package-initialize\\_>" nil 'noerror))))
;; Don't visit the file if we don't have to.
(with-temp-buffer
(insert-file-contents user-init-file)
(goto-char (point-min))
- (search-forward "(package-initialize)" nil 'noerror)))))
+ (re-search-forward "(package-initialize\\_>" nil 'noerror)))))
(unless contains-init
(with-current-buffer (or buffer
(let ((delay-mode-hooks t))
;;;###autoload
(defun package-install (pkg &optional dont-select)
"Install the package PKG.
-PKG can be a package-desc or the package name of one the available packages
+PKG can be a package-desc or a symbol naming one of the available packages
in an archive in `package-archives'. Interactively, prompt for its name.
If called interactively or if DONT-SELECT nil, add PKG to
pkg)))
(unless (or dont-select (package--user-selected-p name))
(package--save-selected-packages
- (cons name package-selected-packages))))
- (if-let ((transaction
- (if (package-desc-p pkg)
- (unless (package-installed-p pkg)
- (package-compute-transaction (list pkg)
- (package-desc-reqs pkg)))
- (package-compute-transaction () (list (list pkg))))))
- (package-download-transaction transaction)
- (message "`%s' is already installed" (package-desc-full-name pkg))))
+ (cons name package-selected-packages)))
+ (if-let ((transaction
+ (if (package-desc-p pkg)
+ (unless (package-installed-p pkg)
+ (package-compute-transaction (list pkg)
+ (package-desc-reqs pkg)))
+ (package-compute-transaction () (list (list pkg))))))
+ (package-download-transaction transaction)
+ (message "`%s' is already installed" name))))
(defun package-strip-rcs-id (str)
"Strip RCS version ID from the version string STR.
;;;###autoload
(defun package-install-file (file)
"Install a package from a file.
-The file can either be a tar file or an Emacs Lisp file."
+The file can either be a tar file, an Emacs Lisp file, or a
+directory."
(interactive "fPackage file name: ")
(with-temp-buffer
(if (file-directory-p file)
;; do absolutely nothing.
(when (or package-selected-packages
(yes-or-no-p
- "`package-selected-packages' is empty! Really remove ALL packages? "))
+ (format-message
+ "`package-selected-packages' is empty! Really remove ALL packages? ")))
(let ((removable (package--removable-packages)))
(if removable
(when (y-or-n-p
(defun describe-package (package)
"Display the full documentation of PACKAGE (a symbol)."
(interactive
- (let* ((guess (function-called-at-point)))
+ (let* ((guess (or (function-called-at-point)
+ (symbol-at-point))))
(require 'finder-inf nil t)
;; Load the package list if necessary (but don't activate them).
(unless package--initialized
(format "Describe package (default %s): "
guess)
"Describe package: ")
- packages nil t nil nil guess)))
+ packages nil t nil nil (when guess
+ (symbol-name guess)))))
(list (intern val))))))
(if (not (or (package-desc-p package) (and package (symbolp package))))
(message "No package specified")
(with-current-buffer standard-output
(describe-package-1 package)))))
+(defface package-help-section-name
+ '((t :inherit (bold font-lock-function-name-face)))
+ "Face used on section names in package description buffers."
+ :version "25.1")
+
+(defun package--print-help-section (name &rest strings)
+ "Print \"NAME: \", right aligned to the 13th column.
+If more STRINGS are provided, insert them followed by a newline.
+Otherwise no newline is inserted."
+ (declare (indent 1))
+ (insert (make-string (max 0 (- 11 (string-width name))) ?\s)
+ (propertize (concat name ": ") 'font-lock-face 'package-help-section-name))
+ (when strings
+ (apply #'insert strings)
+ (insert "\n")))
+
(declare-function lm-commentary "lisp-mnt" (&optional file))
(defun describe-package-1 (pkg)
(status (if desc (package-desc-status desc) "orphan"))
(incompatible-reason (package--incompatible-p desc))
(signed (if desc (package-desc-signed desc))))
+ (when (string= status "avail-obso")
+ (setq status "available obsolete"))
(when incompatible-reason
(setq status "incompatible"))
(prin1 name)
(princ status)
(princ " package.\n\n")
- (insert " " (propertize "Status" 'font-lock-face 'bold) ": ")
+ (package--print-help-section "Status")
(cond (built-in
(insert (propertize (capitalize status)
- 'font-lock-face 'font-lock-builtin-face)
+ 'font-lock-face 'package-status-builtin-face)
"."))
(pkg-dir
(insert (propertize (if (member status '("unsigned" "dependency"))
"Installed"
- (capitalize status)) ;FIXME: Why comment-face?
- 'font-lock-face 'font-lock-comment-face))
- (insert (substitute-command-keys " in ‘"))
- ;; Todo: Add button for uninstalling.
- (help-insert-xref-button (abbreviate-file-name
- (file-name-as-directory pkg-dir))
- 'help-package-def pkg-dir)
+ (capitalize status))
+ 'font-lock-face 'package-status-builtin-face))
+ (insert (substitute-command-keys " in `"))
+ (let ((dir (abbreviate-file-name
+ (file-name-as-directory
+ (if (file-in-directory-p pkg-dir package-user-dir)
+ (file-relative-name pkg-dir package-user-dir)
+ pkg-dir)))))
+ (help-insert-xref-button dir 'help-package-def pkg-dir))
(if (and (package-built-in-p name)
(not (package-built-in-p name version)))
(insert (substitute-command-keys
- "’,\n shadowing a ")
+ "',\n shadowing a ")
(propertize "built-in package"
- 'font-lock-face 'font-lock-builtin-face))
- (insert (substitute-command-keys "’")))
+ 'font-lock-face 'package-status-builtin-face))
+ (insert (substitute-command-keys "'")))
(if signed
(insert ".")
(insert " (unsigned)."))
(when (and (package-desc-p desc)
(not required-by)
- (package-installed-p desc))
+ (member status '("unsigned" "installed")))
(insert " ")
(package-make-button "Delete"
'action #'package-delete-button-action
'package-desc desc)))
(incompatible-reason
- (insert (propertize "Incompatible" 'face font-lock-warning-face)
+ (insert (propertize "Incompatible" 'font-lock-face font-lock-warning-face)
" because it depends on ")
(if (stringp incompatible-reason)
(insert "Emacs " incompatible-reason ".")
'package-desc desc))
(t (insert (capitalize status) ".")))
(insert "\n")
- (insert " " (propertize "Archive" 'font-lock-face 'bold)
- ": " (or archive "n/a") "\n")
+ (unless (and pkg-dir (not archive)) ; Installed pkgs don't have archive.
+ (package--print-help-section "Archive"
+ (or archive "n/a") "\n"))
(and version
- (insert " "
- (propertize "Version" 'font-lock-face 'bold) ": "
- (package-version-join version) "\n"))
+ (package--print-help-section "Version"
+ (package-version-join version)))
+ (when desc
+ (package--print-help-section "Summary"
+ (package-desc-summary desc)))
(setq reqs (if desc (package-desc-reqs desc)))
(when reqs
- (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ")
+ (package--print-help-section "Requires")
(let ((first t))
(dolist (req reqs)
(let* ((name (car req))
(insert reason)))
(insert "\n")))
(when required-by
- (insert (propertize "Required by" 'font-lock-face 'bold) ": ")
+ (package--print-help-section "Required by")
(let ((first t))
(dolist (pkg required-by)
(let ((text (package-desc-full-name pkg)))
(help-insert-xref-button text 'help-package
(package-desc-name pkg))))
(insert "\n")))
- (insert " " (propertize "Summary" 'font-lock-face 'bold)
- ": " (if desc (package-desc-summary desc)) "\n")
(when homepage
- (insert " " (propertize "Homepage" 'font-lock-face 'bold) ": ")
+ (package--print-help-section "Homepage")
(help-insert-xref-button homepage 'help-url homepage)
(insert "\n"))
(when keywords
- (insert " " (propertize "Keywords" 'font-lock-face 'bold) ": ")
+ (package--print-help-section "Keywords")
(dolist (k keywords)
(package-make-button
k
(if bi (list (package--from-builtin bi))))))
(other-pkgs (delete desc all-pkgs)))
(when other-pkgs
- (insert " " (propertize "Other versions" 'font-lock-face 'bold) ": "
- (mapconcat
- (lambda (opkg)
- (let* ((ov (package-desc-version opkg))
- (dir (package-desc-dir opkg))
- (from (or (package-desc-archive opkg)
- (if (stringp dir) "installed" dir))))
- (if (not ov) (format "%s" from)
- (format "%s (%s)"
- (make-text-button (package-version-join ov) nil
- 'face 'link
- 'follow-link t
- 'action
- (lambda (_button)
- (describe-package opkg)))
- from))))
- other-pkgs ", ")
- ".\n")))
+ (package--print-help-section "Other versions"
+ (mapconcat (lambda (opkg)
+ (let* ((ov (package-desc-version opkg))
+ (dir (package-desc-dir opkg))
+ (from (or (package-desc-archive opkg)
+ (if (stringp dir) "installed" dir))))
+ (if (not ov) (format "%s" from)
+ (format "%s (%s)"
+ (make-text-button (package-version-join ov) nil
+ 'font-lock-face 'link
+ 'follow-link t
+ 'action
+ (lambda (_button)
+ (describe-package opkg)))
+ from))))
+ other-pkgs ", ")
+ ".")))
(insert "\n")
(replace-match ""))
(while (re-search-forward "^\\(;+ ?\\)" nil t)
(replace-match ""))))
- (let ((readme (expand-file-name (format "%s-readme.txt" name)
- package-user-dir))
- readme-string)
+ (let* ((basename (format "%s-readme.txt" name))
+ (readme (expand-file-name basename package-user-dir))
+ readme-string)
;; For elpa packages, try downloading the commentary. If that
;; fails, try an existing readme file in `package-user-dir'.
- (cond ((condition-case nil
- (save-excursion
- (package--with-work-buffer
- (package-archive-base desc)
- (format "%s-readme.txt" name)
- (save-excursion
- (goto-char (point-max))
- (unless (bolp)
- (insert ?\n)))
- (write-region nil nil
- (expand-file-name readme package-user-dir)
- nil 'silent)
- (setq readme-string (buffer-string))
- t))
- (error nil))
+ (cond ((and (package-desc-archive desc)
+ (package--with-response-buffer (package-archive-base desc)
+ :file basename :noerror t
+ (save-excursion
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert ?\n)))
+ (write-region nil nil
+ (expand-file-name readme package-user-dir)
+ nil 'silent)
+ (setq readme-string (buffer-string))
+ t))
(insert readme-string))
((file-readable-p readme)
(insert-file-contents readme)
(defun package-install-button-action (button)
(let ((pkg-desc (button-get button 'package-desc)))
- (when (y-or-n-p (format "Install package `%s'? "
- (package-desc-full-name pkg-desc)))
+ (when (y-or-n-p (format-message "Install package `%s'? "
+ (package-desc-full-name pkg-desc)))
(package-install pkg-desc nil)
(revert-buffer nil t)
(goto-char (point-min)))))
(defun package-delete-button-action (button)
(let ((pkg-desc (button-get button 'package-desc)))
- (when (y-or-n-p (format "Delete package `%s'? "
- (package-desc-full-name pkg-desc)))
+ (when (y-or-n-p (format-message "Delete package `%s'? "
+ (package-desc-full-name pkg-desc)))
(package-delete pkg-desc)
(revert-buffer nil t)
(goto-char (point-min)))))
;;;; Package menu mode.
(defvar package-menu-mode-map
- (let ((map (make-sparse-keymap))
- (menu-map (make-sparse-keymap "Package")))
+ (let ((map (make-sparse-keymap)))
(set-keymap-parent map tabulated-list-mode-map)
(define-key map "\C-m" 'package-menu-describe-package)
(define-key map "u" 'package-menu-mark-unmark)
(define-key map "~" 'package-menu-mark-obsolete-for-deletion)
(define-key map "x" 'package-menu-execute)
(define-key map "h" 'package-menu-quick-help)
+ (define-key map "H" #'package-menu-hide-package)
(define-key map "?" 'package-menu-describe-package)
(define-key map "(" #'package-menu-toggle-hiding)
- (define-key map [menu-bar package-menu] (cons "Package" menu-map))
- (define-key menu-map [mq]
- '(menu-item "Quit" quit-window
- :help "Quit package selection"))
- (define-key menu-map [s1] '("--"))
- (define-key menu-map [mn]
- '(menu-item "Next" next-line
- :help "Next Line"))
- (define-key menu-map [mp]
- '(menu-item "Previous" previous-line
- :help "Previous Line"))
- (define-key menu-map [s2] '("--"))
- (define-key menu-map [mu]
- '(menu-item "Unmark" package-menu-mark-unmark
- :help "Clear any marks on a package and move to the next line"))
- (define-key menu-map [munm]
- '(menu-item "Unmark Backwards" package-menu-backup-unmark
- :help "Back up one line and clear any marks on that package"))
- (define-key menu-map [md]
- '(menu-item "Mark for Deletion" package-menu-mark-delete
- :help "Mark a package for deletion and move to the next line"))
- (define-key menu-map [mi]
- '(menu-item "Mark for Install" package-menu-mark-install
- :help "Mark a package for installation and move to the next line"))
- (define-key menu-map [mupgrades]
- '(menu-item "Mark Upgradable Packages" package-menu-mark-upgrades
- :help "Mark packages that have a newer version for upgrading"))
- (define-key menu-map [s3] '("--"))
- (define-key menu-map [mf]
- '(menu-item "Filter Package List..." package-menu-filter
- :help "Filter package selection (q to go back)"))
- (define-key menu-map [mg]
- '(menu-item "Update Package List" revert-buffer
- :help "Update the list of packages"))
- (define-key menu-map [mr]
- '(menu-item "Refresh Package List" package-menu-refresh
- :help "Download the ELPA archive"))
- (define-key menu-map [s4] '("--"))
- (define-key menu-map [mt]
- '(menu-item "Mark Obsolete Packages" package-menu-mark-obsolete-for-deletion
- :help "Mark all obsolete packages for deletion"))
- (define-key menu-map [mx]
- '(menu-item "Execute Actions" package-menu-execute
- :help "Perform all the marked actions"))
- (define-key menu-map [s5] '("--"))
- (define-key menu-map [mh]
- '(menu-item "Help" package-menu-quick-help
- :help "Show short key binding help for package-menu-mode"))
- (define-key menu-map [mc]
- '(menu-item "Describe Package" package-menu-describe-package
- :help "Display information about this package"))
map)
"Local keymap for `package-menu-mode' buffers.")
+(easy-menu-define package-menu-mode-menu package-menu-mode-map
+ "Menu for `package-menu-mode'."
+ `("Package"
+ ["Describe Package" package-menu-describe-package :help "Display information about this package"]
+ ["Help" package-menu-quick-help :help "Show short key binding help for package-menu-mode"]
+ "--"
+ ["Refresh Package List" package-menu-refresh
+ :help "Redownload the ELPA archive"
+ :active (not package--downloads-in-progress)]
+ ["Redisplay buffer" revert-buffer :help "Update the buffer with current list of packages"]
+ ["Execute Marked Actions" package-menu-execute :help "Perform all the marked actions"]
+
+ "--"
+ ["Mark All Available Upgrades" package-menu-mark-upgrades
+ :help "Mark packages that have a newer version for upgrading"
+ :active (not package--downloads-in-progress)]
+ ["Mark All Obsolete for Deletion" package-menu-mark-obsolete-for-deletion :help "Mark all obsolete packages for deletion"]
+ ["Mark for Install" package-menu-mark-install :help "Mark a package for installation and move to the next line"]
+ ["Mark for Deletion" package-menu-mark-delete :help "Mark a package for deletion and move to the next line"]
+ ["Unmark" package-menu-mark-unmark :help "Clear any marks on a package and move to the next line"]
+
+ "--"
+ ["Filter Package List" package-menu-filter :help "Filter package selection (q to go back)"]
+ ["Hide by Regexp" package-menu-hide-package :help "Permanently hide all packages matching a regexp"]
+ ["Display Older Versions" package-menu-toggle-hiding
+ :style toggle :selected (not package-menu--hide-packages)
+ :help "Display package even if a newer version is already installed"]
+
+ "--"
+ ["Quit" quit-window :help "Quit package selection"]
+ ["Customize" (customize-group 'package)]))
+
(defvar package-menu--new-package-list nil
"List of newly-available packages since `list-packages' was last called.")
(out))
(while pkg-list
(let ((p (pop pkg-list)))
- (if (>= (package-desc-priority p) max-priority)
+ (let ((priority (package-desc-priority p)))
+ (if (< priority max-priority)
+ (setq pkg-list nil)
(push p out)
- (setq pkg-list nil))))
+ (setq max-priority priority)))))
(nreverse out)))
(pkg-list
(list (car pkg-list))))))
(defcustom package-hidden-regexps nil
"List of regexps matching the name of packages to hide.
If the name of a package matches any of these regexps it is
-omited from the package menu. To toggle this, type \\[package-menu-toggle-hiding].
+omitted from the package menu. To toggle this, type \\[package-menu-toggle-hiding].
Values can be interactively added to this list by typing
\\[package-menu-hide-package] on a package"
(push pkg info-list)))))
;; Available and disabled packages:
+ (unless (equal package--old-archive-priorities package-archive-priorities)
+ (package-read-all-archive-contents))
(dolist (elt package-archive-contents)
(let ((name (car elt)))
;; To be displayed it must be in PACKAGES;
(make-obsolete 'package-menu--print-info
'package-menu--print-info-simple "25.1")
+\f
+;;; Package menu faces
+(defface package-name
+ '((t :inherit link))
+ "Face used on package names in the package menu."
+ :version "25.1")
+
+(defface package-description
+ '((t :inherit default))
+ "Face used on package description summaries in the package menu."
+ :version "25.1")
+
+(defface package-status-built-in
+ '((t :inherit font-lock-builtin-face))
+ "Face used on the status and version of built-in packages."
+ :version "25.1")
+
+(defface package-status-external
+ '((t :inherit package-status-builtin-face))
+ "Face used on the status and version of external packages."
+ :version "25.1")
+
+(defface package-status-available
+ '((t :inherit default))
+ "Face used on the status and version of available packages."
+ :version "25.1")
+
+(defface package-status-new
+ '((t :inherit (bold package-status-available)))
+ "Face used on the status and version of new packages."
+ :version "25.1")
+
+(defface package-status-held
+ '((t :inherit font-lock-constant-face))
+ "Face used on the status and version of held packages."
+ :version "25.1")
+
+(defface package-status-disabled
+ '((t :inherit font-lock-warning-face))
+ "Face used on the status and version of disabled packages."
+ :version "25.1")
+
+(defface package-status-installed
+ '((t :inherit font-lock-comment-face))
+ "Face used on the status and version of installed packages."
+ :version "25.1")
+
+(defface package-status-dependency
+ '((t :inherit package-status-installed))
+ "Face used on the status and version of dependency packages."
+ :version "25.1")
+
+(defface package-status-unsigned
+ '((t :inherit font-lock-warning-face))
+ "Face used on the status and version of unsigned packages."
+ :version "25.1")
+
+(defface package-status-incompat
+ '((t :inherit font-lock-comment-face))
+ "Face used on the status and version of incompat packages."
+ :version "25.1")
+
+(defface package-status-avail-obso
+ '((t :inherit package-status-incompat))
+ "Face used on the status and version of avail-obso packages."
+ :version "25.1")
+
+\f
+;;; Package menu printing
(defun package-menu--print-info-simple (pkg)
"Return a package entry suitable for `tabulated-list-entries'.
PKG is a package-desc object.
Return (PKG-DESC [NAME VERSION STATUS DOC])."
(let* ((status (package-desc-status pkg))
(face (pcase status
- (`"built-in" 'font-lock-builtin-face)
- (`"external" 'font-lock-builtin-face)
- (`"available" 'default)
- (`"avail-obso" 'font-lock-comment-face)
- (`"new" 'bold)
- (`"held" 'font-lock-constant-face)
- (`"disabled" 'font-lock-warning-face)
- (`"installed" 'font-lock-comment-face)
- (`"dependency" 'font-lock-comment-face)
- (`"unsigned" 'font-lock-warning-face)
- (`"incompat" 'font-lock-comment-face)
+ (`"built-in" 'package-status-built-in)
+ (`"external" 'package-status-external)
+ (`"available" 'package-status-available)
+ (`"avail-obso" 'package-status-avail-obso)
+ (`"new" 'package-status-new)
+ (`"held" 'package-status-held)
+ (`"disabled" 'package-status-disabled)
+ (`"installed" 'package-status-installed)
+ (`"dependency" 'package-status-dependency)
+ (`"unsigned" 'package-status-unsigned)
+ (`"incompat" 'package-status-incompat)
(_ 'font-lock-warning-face)))) ; obsolete.
(list pkg
`[(,(symbol-name (package-desc-name pkg))
- face link
+ face package-name
+ font-lock-face package-name
follow-link t
package-desc ,pkg
action package-menu-describe-package)
,@(if (cdr package-archives)
(list (propertize (or (package-desc-archive pkg) "")
'font-lock-face face)))
- ,(package-desc-summary pkg)])))
+ ,(propertize (package-desc-summary pkg)
+ 'font-lock-face 'package-description)])))
(defvar package-menu--old-archive-contents nil
"`package-archive-contents' before the latest refresh.")
(defvar package--quick-help-keys
'(("install," "delete," "unmark," ("execute" . 1))
("next," "previous")
- ("refresh-contents," "g-redisplay," "filter," "(-toggle-obsolete" "help")))
+ ("Hide-package," "(-toggle-hidden")
+ ("refresh-contents," "g-redisplay," "filter," "help")))
(defun package--prettify-quick-help-key (desc)
"Prettify DESC to be displayed as a help menu."
(mapconcat #'package--prettify-quick-help-key desc " ")
(let ((place (cdr desc))
(out (car desc)))
- ;; (setq out (propertize out 'face 'paradox-comment-face))
(add-text-properties place (1+ place)
- '(face (bold font-lock-function-name-face))
+ '(face (bold font-lock-warning-face))
out)
out))
(package--prettify-quick-help-key (cons desc 0))))
(length packages)
(mapconcat #'package-desc-full-name packages ", ")))
;; Exactly 1
- (t (format "package `%s'"
- (package-desc-full-name (car packages))))))
+ (t (format-message "package `%s'"
+ (package-desc-full-name (car packages))))))
(defun package-menu--prompt-transaction-p (delete install upgrade)
"Prompt the user about DELETE, INSTALL, and UPGRADE.
(if-let ((removable (package--removable-packages)))
(message "Package menu: Operation finished. %d packages %s"
(length removable)
- "are no longer needed, type `M-x package-autoremove' to remove them")
+ (substitute-command-keys
+ "are no longer needed, type `\\[package-autoremove]' to remove them"))
(message (replace-regexp-in-string "__" "ed" message-template)
"finished"))))))))