;;; package.el --- Simple package system for Emacs -*- lexical-binding:t -*-
-;; Copyright (C) 2007-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2014 Free Software Foundation, Inc.
;; Author: Tom Tromey <tromey@redhat.com>
;; Daniel Hackney <dan@haxney.org>
(defvar Info-directory-list)
(declare-function info-initialize "info" ())
(declare-function url-http-parse-response "url-http" ())
+(declare-function url-http-file-exists-p "url-http" (url))
(declare-function lm-header "lisp-mnt" (header))
(declare-function lm-commentary "lisp-mnt" (&optional file))
(defvar url-http-end-of-headers)
:group 'package
:version "24.1")
+(defcustom package-check-signature 'allow-unsigned
+ "Whether to check package signatures when installing."
+ :type '(choice (const nil :tag "Never")
+ (const allow-unsigned :tag "Allow unsigned")
+ (const t :tag "Check always"))
+ :risky t
+ :group 'package
+ :version "24.1")
+
+(defcustom package-unsigned-archives nil
+ "A list of archives which do not use package signature."
+ :type '(repeat (string :tag "Archive name"))
+ :risky t
+ :group 'package
+ :version "24.1")
+
(defvar package--default-summary "No description available.")
(cl-defstruct (package-desc
(:constructor
package-desc-from-define
(name-string version-string &optional summary requirements
- &key kind archive
+ &rest rest-plist
&aux
(name (intern name-string))
(version (version-to-list version-string))
(version-to-list (cadr elt))))
(if (eq 'quote (car requirements))
(nth 1 requirements)
- requirements))))))
+ requirements)))
+ (kind (plist-get rest-plist :kind))
+ (archive (plist-get rest-plist :archive))
+ (extras (let (alist)
+ (while rest-plist
+ (unless (memq (car rest-plist) '(:kind :archive))
+ (let ((value (cadr rest-plist)))
+ (when value
+ (push (cons (car rest-plist) value)
+ alist))))
+ (setq rest-plist (cddr rest-plist)))
+ alist)))))
"Structure containing information about an individual package.
Slots:
package came.
`dir' The directory where the package is installed (if installed),
- `builtin' if it is built-in, or nil otherwise."
+ `builtin' if it is built-in, or nil otherwise.
+
+`extras' Optional alist of additional keyword-value pairs.
+
+`signed' Flag to indicate that the package is signed by provider."
name
version
(summary package--default-summary)
reqs
kind
archive
- dir)
+ dir
+ extras
+ signed)
;; Pseudo fields.
(defun package-desc-full-name (pkg-desc)
((>= num 0)
(push (int-to-string num) str-list)
(push "." str-list))
- ((< num -3)
+ ((< num -4)
(error "Invalid version list `%s'" vlist))
(t
;; pre, or beta, or alpha
(error "Invalid version list `%s'" vlist)))
(push (cond ((= num -1) "pre")
((= num -2) "beta")
- ((= num -3) "alpha"))
+ ((= num -3) "alpha")
+ ((= num -4) "snapshot"))
str-list))))
(if (equal "." (car str-list))
(pop str-list))
(defun package-load-descriptor (pkg-dir)
"Load the description file in directory PKG-DIR."
(let ((pkg-file (expand-file-name (package--description-file pkg-dir)
- pkg-dir)))
+ pkg-dir))
+ (signed-file (concat pkg-dir ".signed")))
(when (file-exists-p pkg-file)
(with-temp-buffer
(insert-file-contents pkg-file)
(let ((pkg-desc (package-process-define-package
(read (current-buffer)) pkg-file)))
(setf (package-desc-dir pkg-desc) pkg-dir)
+ (if (file-exists-p signed-file)
+ (setf (package-desc-signed pkg-desc) t))
pkg-desc)))))
(defun package-load-all-descriptors ()
(defun package-activate-1 (pkg-desc)
(let* ((name (package-desc-name pkg-desc))
- (pkg-dir (package-desc-dir pkg-desc)))
+ (pkg-dir (package-desc-dir pkg-desc))
+ (pkg-dir-dir (file-name-as-directory pkg-dir)))
(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))
+ (with-demoted-errors
+ (load (expand-file-name (format "%s-autoloads" name) pkg-dir) 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)))
;; Add info node.
(when (file-exists-p (expand-file-name "dir" pkg-dir))
;; FIXME: not the friendliest, but simple.
(require 'info)
(info-initialize)
(push pkg-dir Info-directory-list))
- ;; Add to load path, add autoloads, and activate the package.
- (push pkg-dir load-path)
- (load (expand-file-name (format "%s-autoloads" name) pkg-dir) nil t)
(push name package-activated-list)
;; Don't return nil.
t))
"Return true if PACKAGE is built-in to Emacs.
Optional arg MIN-VERSION, if non-nil, should be a version list
specifying the minimum acceptable version."
- (let ((bi (assq package package--builtin-versions)))
- (cond
- (bi (version-list-<= min-version (cdr bi)))
- (min-version nil)
- (t
- (require 'finder-inf nil t) ; For `package--builtins'.
- (assq package package--builtins)))))
+ (if (package-desc-p package) ;; was built-in and then was converted
+ (eq 'builtin (package-desc-dir package))
+ (let ((bi (assq package package--builtin-versions)))
+ (cond
+ (bi (version-list-<= min-version (cdr bi)))
+ (min-version nil)
+ (t
+ (require 'finder-inf nil t) ; For `package--builtins'.
+ (assq package package--builtins))))))
(defun package--from-builtin (bi-desc)
(package-desc-create :name (pop bi-desc)
(defvar version-control)
(defun package-generate-autoloads (name pkg-dir)
- (require 'autoload) ;Load before we let-bind generated-autoload-file!
(let* ((auto-name (format "%s-autoloads.el" name))
;;(ignore-name (concat name "-pkg.el"))
(generated-autoload-file (expand-file-name auto-name pkg-dir))
(write-region
(concat
(prin1-to-string
- (list 'define-package
- (symbol-name name)
- (package-version-join (package-desc-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)))))
+ (nconc
+ (list 'define-package
+ (symbol-name name)
+ (package-version-join (package-desc-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
+ (package-desc-extras pkg-desc))))
"\n")
nil
pkg-file))))
+(defun package--alist-to-plist (alist)
+ (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist)))
+
(defun package-unpack (pkg-desc)
"Install the contents of the current buffer as a package."
(let* ((name (package-desc-name pkg-desc))
(error "Error during download request:%s"
(buffer-substring-no-properties (point) (line-end-position))))))
+(defun package--archive-file-exists-p (location file)
+ (let ((http (string-match "\\`https?:" location)))
+ (if http
+ (progn
+ (require 'url-http)
+ (url-http-file-exists-p (concat location file)))
+ (file-exists-p (expand-file-name file location)))))
+
+(declare-function epg-make-context "epg"
+ (&optional protocol armor textmode include-certs
+ cipher-algorithm
+ digest-algorithm
+ compress-algorithm))
+(declare-function epg-context-set-home-directory "epg" (context directory))
+(declare-function epg-verify-string "epg" (context signature
+ &optional signed-text))
+(declare-function epg-context-result-for "epg" (context name))
+(declare-function epg-signature-status "epg" (signature))
+(declare-function epg-signature-to-string "epg" (signature))
+
+(defun package--check-signature (location file)
+ "Check signature of the current buffer.
+GnuPG keyring is located under \"gnupg\" in `package-user-dir'."
+ (let ((context (epg-make-context 'OpenPGP))
+ (homedir (expand-file-name "gnupg" package-user-dir))
+ (sig-file (concat file ".sig"))
+ sig-content
+ good-signatures)
+ (condition-case-unless-debug error
+ (setq sig-content (package--with-work-buffer location sig-file
+ (buffer-string)))
+ (error "Failed to download %s: %S" sig-file (cdr error)))
+ (epg-context-set-home-directory context homedir)
+ (epg-verify-string context sig-content (buffer-string))
+ ;; The .sig file may contain multiple signatures. Success if one
+ ;; of the signatures is good.
+ (setq good-signatures
+ (delq nil (mapcar (lambda (sig)
+ (if (eq (epg-signature-status sig) 'good)
+ sig))
+ (epg-context-result-for context 'verify))))
+ (if (null good-signatures)
+ (error "Failed to verify signature %s: %S"
+ sig-file
+ (mapcar #'epg-signature-to-string
+ (epg-context-result-for context 'verify)))
+ good-signatures)))
+
(defun package-install-from-archive (pkg-desc)
"Download and install a tar package."
- (let ((location (package-archive-base pkg-desc))
- (file (concat (package-desc-full-name pkg-desc)
- (package-desc-suffix pkg-desc))))
+ (let* ((location (package-archive-base pkg-desc))
+ (file (concat (package-desc-full-name pkg-desc)
+ (package-desc-suffix pkg-desc)))
+ (sig-file (concat file ".sig"))
+ good-signatures pkg-descs)
(package--with-work-buffer location file
- (package-unpack pkg-desc))))
+ (if (and package-check-signature
+ (not (member (package-desc-archive pkg-desc)
+ package-unsigned-archives)))
+ (if (package--archive-file-exists-p location sig-file)
+ (setq good-signatures (package--check-signature location file))
+ (unless (eq package-check-signature 'allow-unsigned)
+ (error "Unsigned package: `%s'"
+ (package-desc-name pkg-desc)))))
+ (package-unpack pkg-desc))
+ ;; Here the package has been installed successfully, mark it as
+ ;; signed if appropriate.
+ (when good-signatures
+ ;; Write out good signatures into NAME-VERSION.signed file.
+ (write-region (mapconcat #'epg-signature-to-string good-signatures "\n")
+ nil
+ (expand-file-name
+ (concat (package-desc-full-name pkg-desc)
+ ".signed")
+ package-user-dir))
+ ;; Update the old pkg-desc which will be shown on the description buffer.
+ (setf (package-desc-signed pkg-desc) t)
+ ;; Update the new (activated) pkg-desc as well.
+ (setq pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist)))
+ (if pkg-descs
+ (setf (package-desc-signed (car pkg-descs)) t)))))
(defvar package--initialized nil)
;; Changing this defstruct implies changing the format of the
;; "archive-contents" files.
(cl-defstruct (package--ac-desc
- (:constructor package-make-ac-desc (version reqs summary kind))
+ (:constructor package-make-ac-desc (version reqs summary kind extras))
(:copier nil)
(:type vector))
- version reqs summary kind)
+ version reqs summary kind extras)
(defun package--add-to-archive-contents (package archive)
"Add the PACKAGE from the given ARCHIVE if necessary.
:reqs (package--ac-desc-reqs (cdr package))
:summary (package--ac-desc-summary (cdr package))
:kind (package--ac-desc-kind (cdr package))
- :archive archive))
+ :archive archive
+ :extras (and (> (length (cdr package)) 4)
+ ;; Older archive-contents files have only 4
+ ;; elements here.
+ (package--ac-desc-extras (cdr package)))))
(existing-packages (assq name package-archive-contents))
(pinned-to-archive (assoc name package-pinned-packages)))
(cond
str)
(error nil))))
+(declare-function lm-homepage "lisp-mnt" (&optional file))
+
+(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))
+ (t dep)))
+ deps))))
+
(defun package-buffer-info ()
"Return a `package-desc' describing the package in the current buffer.
boundaries."
(goto-char (point-min))
(unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t)
- (error "Packages lacks a file header"))
+ (error "Package lacks a file header"))
(let ((file-name (match-string-no-properties 1))
(desc (match-string-no-properties 2))
(start (line-beginning-position)))
;; probably wants us to use it. Otherwise try Version.
(pkg-version
(or (package-strip-rcs-id (lm-header "package-version"))
- (package-strip-rcs-id (lm-header "version")))))
+ (package-strip-rcs-id (lm-header "version"))))
+ (homepage (lm-homepage)))
(unless pkg-version
(error
"Package lacks a \"Version\" or \"Package-Version\" header"))
(package-desc-from-define
file-name pkg-version desc
- (if requires-str (package-read-from-string requires-str))
- :kind 'single))))
+ (if requires-str
+ (package--prepare-dependencies
+ (package-read-from-string requires-str)))
+ :kind 'single
+ :url homepage))))
(declare-function tar-get-file-descriptor "tar-mode" (file))
(declare-function tar--extract "tar-mode" (descriptor))
(error "Package `%s' is a system package, not deleting"
(package-desc-full-name pkg-desc))
(delete-directory dir t t)
+ ;; Remove NAME-VERSION.signed file.
+ (let ((signed-file (concat dir ".signed")))
+ (if (file-exists-p signed-file)
+ (delete-file signed-file)))
;; Update package-alist.
(let* ((name (package-desc-name pkg-desc)))
(delete pkg-desc (assq name package-alist)))
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/archive-contents\" in `package-user-dir'."
- (let* ((dir (expand-file-name (format "archives/%s" (car archive))
- package-user-dir)))
+ (let ((dir (expand-file-name (format "archives/%s" (car archive))
+ package-user-dir))
+ (sig-file (concat file ".sig"))
+ good-signatures)
(package--with-work-buffer (cdr archive) file
+ ;; Check signature of archive-contents, if desired.
+ (if (and package-check-signature
+ (not (member archive package-unsigned-archives)))
+ (if (package--archive-file-exists-p (cdr archive) sig-file)
+ (setq good-signatures (package--check-signature (cdr archive)
+ file))
+ (unless (eq package-check-signature 'allow-unsigned)
+ (error "Unsigned archive `%s'"
+ (car archive)))))
;; Read the retrieved buffer to make sure it is valid (e.g. it
;; may fetch a URL redirect page).
(when (listp (read buffer))
(make-directory dir t)
(setq buffer-file-name (expand-file-name file dir))
- (let ((version-control 'never))
- (save-buffer))))))
+ (let ((version-control 'never)
+ (require-final-newline nil))
+ (save-buffer))))
+ (when good-signatures
+ ;; Write out good signatures into archive-contents.signed file.
+ (write-region (mapconcat #'epg-signature-to-string good-signatures "\n")
+ nil
+ (expand-file-name (concat file ".signed") dir)))))
+
+(declare-function epg-check-configuration "epg-config"
+ (config &optional minimum-version))
+(declare-function epg-configuration "epg-config" ())
+(declare-function epg-import-keys-from-file "epg" (context keys))
+
+;;;###autoload
+(defun package-import-keyring (&optional file)
+ "Import keys from FILE."
+ (interactive "fFile: ")
+ (setq file (expand-file-name file))
+ (let ((context (epg-make-context 'OpenPGP))
+ (homedir (expand-file-name "gnupg" package-user-dir)))
+ (make-directory homedir t)
+ (epg-context-set-home-directory context homedir)
+ (message "Importing %s..." (file-name-nondirectory file))
+ (epg-import-keys-from-file context file)
+ (message "Importing %s...done" (file-name-nondirectory file))))
;;;###autoload
(defun package-refresh-contents ()
;; FIXME: Do it asynchronously.
(unless (file-exists-p package-user-dir)
(make-directory package-user-dir t))
+ (let ((default-keyring (expand-file-name "package-keyring.gpg"
+ data-directory)))
+ (if (file-exists-p default-keyring)
+ (condition-case-unless-debug error
+ (progn
+ (epg-check-configuration (epg-configuration))
+ (package-import-keyring default-keyring))
+ (error (message "Cannot import default keyring: %S" (cdr error))))))
(dolist (archive package-archives)
(condition-case-unless-debug nil
(package--download-one-archive archive "archive-contents")
(reqs (if desc (package-desc-reqs desc)))
(version (if desc (package-desc-version desc)))
(archive (if desc (package-desc-archive desc)))
+ (extras (and desc (package-desc-extras desc)))
+ (homepage (cdr (assoc :url extras)))
+ (keywords (cdr (assoc :keywords extras)))
(built-in (eq pkg-dir 'builtin))
(installable (and archive (not built-in)))
- (status (if desc (package-desc-status desc) "orphan")))
+ (status (if desc (package-desc-status desc) "orphan"))
+ (signed (if desc (package-desc-signed desc))))
(prin1 name)
(princ " is ")
(princ (if (memq (aref status 0) '(?a ?e ?i ?o ?u)) "an " "a "))
'font-lock-face 'font-lock-builtin-face)
"."))
(pkg-dir
- (insert (propertize (capitalize status) ;FIXME: Why comment-face?
+ (insert (propertize (if (equal status "unsigned")
+ "Installed"
+ (capitalize status)) ;FIXME: Why comment-face?
'font-lock-face 'font-lock-comment-face))
(insert " in `")
;; Todo: Add button for uninstalling.
(not (package-built-in-p name version)))
(insert "',\n shadowing a "
(propertize "built-in package"
- 'font-lock-face 'font-lock-builtin-face)
- ".")
- (insert "'.")))
+ 'font-lock-face 'font-lock-builtin-face))
+ (insert "'"))
+ (if signed
+ (insert ".")
+ (insert " (unsigned).")))
(installable
(insert (capitalize status))
(insert " from " (format "%s" archive))
(insert " -- ")
- (let ((button-text (if (display-graphic-p) "Install" "[Install]"))
- (button-face (if (display-graphic-p)
- '(:box (:line-width 2 :color "dark grey")
- :background "light grey"
- :foreground "black")
- 'link)))
- (insert-text-button button-text 'face button-face 'follow-link t
- 'package-desc desc
- 'action 'package-install-button-action)))
+ (package-make-button
+ "Install"
+ 'action 'package-install-button-action
+ 'package-desc desc))
(t (insert (capitalize status) ".")))
(insert "\n")
+ (insert " " (propertize "Archive" 'font-lock-face 'bold)
+ ": " (or archive "n/a") "\n")
(and version
(insert " "
(propertize "Version" 'font-lock-face 'bold) ": "
(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) ": ")
+ (help-insert-xref-button homepage 'help-url homepage)
+ (insert "\n"))
+ (when keywords
+ (insert " " (propertize "Keywords" 'font-lock-face 'bold) ": ")
+ (dolist (k keywords)
+ (package-make-button
+ k
+ 'package-keyword k
+ 'action 'package-keyword-button-action)
+ (insert " "))
+ (insert "\n"))
(let* ((all-pkgs (append (cdr (assq name package-alist))
(cdr (assq name package-archive-contents))
(let ((bi (assq name package--builtins)))
;; For elpa packages, try downloading the commentary. If that
;; fails, try an existing readme file in `package-user-dir'.
(cond ((condition-case nil
- (package--with-work-buffer
- (package-archive-base desc)
- (format "%s-readme.txt" name)
- (setq buffer-file-name
- (expand-file-name readme package-user-dir))
- (let ((version-control 'never))
- (save-buffer))
- (setq readme-string (buffer-string))
- t)
+ (save-excursion
+ (package--with-work-buffer
+ (package-archive-base desc)
+ (format "%s-readme.txt" name)
+ (setq buffer-file-name
+ (expand-file-name readme package-user-dir))
+ (let ((version-control 'never)
+ (require-final-newline t))
+ (save-buffer))
+ (setq readme-string (buffer-string))
+ t))
(error nil))
(insert readme-string))
((file-readable-p readme)
(revert-buffer nil t)
(goto-char (point-min)))))
+(defun package-keyword-button-action (button)
+ (let ((pkg-keyword (button-get button 'package-keyword)))
+ (package-show-package-list t (list pkg-keyword))))
+
+(defun package-make-button (text &rest props)
+ (let ((button-text (if (display-graphic-p) text (concat "[" text "]")))
+ (button-face (if (display-graphic-p)
+ '(:box (:line-width 2 :color "dark grey")
+ :background "light grey"
+ :foreground "black")
+ 'link)))
+ (apply 'insert-text-button button-text 'face button-face 'follow-link t
+ props)))
+
\f
;;;; Package menu mode.
(define-key map "i" 'package-menu-mark-install)
(define-key map "U" 'package-menu-mark-upgrades)
(define-key map "r" 'package-menu-refresh)
+ (define-key map "f" 'package-menu-filter-interactive)
(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 menu-map [mq]
'(menu-item "Quit" quit-window
:help "Quit package selection"))
+ (define-key menu-map [mf]
+ '(menu-item "Filter" package-menu-filter-interactive
+ :help "Filter package selection (q to go back)"))
(define-key menu-map [s1] '("--"))
(define-key menu-map [mn]
'(menu-item "Next" next-line
(setq tabulated-list-format [("Package" 18 package-menu--name-predicate)
("Version" 12 nil)
("Status" 10 package-menu--status-predicate)
+ ("Archive" 10 package-menu--archive-predicate)
("Description" 0 nil)])
(setq tabulated-list-padding 2)
(setq tabulated-list-sort-key (cons "Status" nil))
(dir (package-desc-dir pkg-desc))
(lle (assq name package-load-list))
(held (cadr lle))
- (version (package-desc-version pkg-desc)))
+ (version (package-desc-version pkg-desc))
+ (signed (package-desc-signed pkg-desc)))
(cond
((eq dir 'builtin) "built-in")
((and lle (null held)) "disabled")
(dir ;One of the installed packages.
(cond
((not (file-exists-p (package-desc-dir pkg-desc))) "deleted")
- ((eq pkg-desc (cadr (assq name package-alist))) "installed")
+ ((eq pkg-desc (cadr (assq name package-alist))) (if signed
+ "installed"
+ "unsigned"))
(t "obsolete")))
(t
(let* ((ins (cadr (assq name package-alist)))
(if (memq name package-menu--new-package-list)
"new" "available"))
((version-list-< version ins-v) "obsolete")
- ((version-list-= version ins-v) "installed")))))))
+ ((version-list-= version ins-v) (if signed
+ "installed"
+ "unsigned"))))))))
-(defun package-menu--refresh (&optional packages)
+(defun package-menu--refresh (&optional packages keywords)
"Re-populate the `tabulated-list-entries'.
-PACKAGES should be nil or t, which means to display all known packages."
+PACKAGES should be nil or t, which means to display all known packages.
+KEYWORDS should be nil or a list of keywords."
;; Construct list of (PKG-DESC . STATUS).
(unless packages (setq packages t))
(let (info-list name)
(setq name (car elt))
(when (or (eq packages t) (memq name packages))
(dolist (pkg (cdr elt))
- (package--push pkg (package-desc-status pkg) info-list))))
+ (when (package--has-keyword-p pkg keywords)
+ (package--push pkg (package-desc-status pkg) info-list)))))
;; Built-in packages:
(dolist (elt package--builtins)
(setq name (car elt))
(when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
+ (package--has-keyword-p (package--from-builtin elt) keywords)
(or package-list-unversioned
(package--bi-desc-version (cdr elt)))
(or (eq packages t) (memq name packages)))
(when (or (eq packages t) (memq name packages))
(dolist (pkg (cdr elt))
;; Hide obsolete packages.
- (unless (package-installed-p (package-desc-name pkg)
- (package-desc-version pkg))
+ (when (and (not (package-installed-p (package-desc-name pkg)
+ (package-desc-version pkg)))
+ (package--has-keyword-p pkg keywords))
(package--push pkg (package-desc-status pkg) info-list)))))
;; Print the result.
(setq tabulated-list-entries
(mapcar #'package-menu--print-info info-list))))
-(defun package-menu--generate (remember-pos packages)
+(defun package-all-keywords ()
+ "Collect all package keywords"
+ (let (keywords)
+ (package--mapc (lambda (desc)
+ (let* ((extras (and desc (package-desc-extras desc)))
+ (desc-keywords (cdr (assoc :keywords extras))))
+ (setq keywords (append keywords desc-keywords)))))
+ keywords))
+
+(defun package--mapc (function &optional packages)
+ "Call FUNCTION for all known PACKAGES.
+PACKAGES can be nil or t, which means to display all known
+packages, or a list of packages.
+
+Built-in packages are converted with `package--from-builtin'."
+ (unless packages (setq packages t))
+ (let (name)
+ ;; Installed packages:
+ (dolist (elt package-alist)
+ (setq name (car elt))
+ (when (or (eq packages t) (memq name packages))
+ (mapc function (cdr elt))))
+
+ ;; Built-in packages:
+ (dolist (elt package--builtins)
+ (setq name (car elt))
+ (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
+ (or package-list-unversioned
+ (package--bi-desc-version (cdr elt)))
+ (or (eq packages t) (memq name packages)))
+ (funcall function (package--from-builtin elt))))
+
+ ;; Available and disabled packages:
+ (dolist (elt package-archive-contents)
+ (setq name (car elt))
+ (when (or (eq packages t) (memq name packages))
+ (dolist (pkg (cdr elt))
+ ;; Hide obsolete packages.
+ (unless (package-installed-p (package-desc-name pkg)
+ (package-desc-version pkg))
+ (funcall function pkg)))))))
+
+(defun package--has-keyword-p (desc &optional keywords)
+ "Test if package DESC has any of the given KEYWORDS.
+When none are given, the package matches."
+ (if keywords
+ (let* ((extras (and desc (package-desc-extras desc)))
+ (desc-keywords (cdr (assoc :keywords extras)))
+ found)
+ (dolist (k keywords)
+ (when (and (not found)
+ (member k desc-keywords))
+ (setq found t)))
+ found)
+ t))
+
+(defun package-menu--generate (remember-pos packages &optional keywords)
"Populate the Package Menu.
If REMEMBER-POS is non-nil, keep point on the same entry.
PACKAGES should be t, which means to display all known packages,
-or a list of package names (symbols) to display."
- (package-menu--refresh packages)
+or a list of package names (symbols) to display.
+
+With KEYWORDS given, only packages with those keywords are
+shown."
+ (package-menu--refresh packages keywords)
+ (setf (car (aref tabulated-list-format 0))
+ (if keywords
+ (let ((filters (mapconcat 'identity keywords ",")))
+ (concat "Package[" filters "]"))
+ "Package"))
+ (if keywords
+ (define-key package-menu-mode-map "q" 'package-show-package-list)
+ (define-key package-menu-mode-map "q" 'quit-window))
+ (tabulated-list-init-header)
(tabulated-list-print remember-pos))
(defun package-menu--print-info (pkg)
(`"held" 'font-lock-constant-face)
(`"disabled" 'font-lock-warning-face)
(`"installed" 'font-lock-comment-face)
+ (`"unsigned" 'font-lock-warning-face)
(_ 'font-lock-warning-face)))) ; obsolete.
(list pkg-desc
(vector (list (symbol-name (package-desc-name pkg-desc))
(package-desc-version pkg-desc))
'font-lock-face face)
(propertize status 'font-lock-face face)
+ (propertize (or (package-desc-archive pkg-desc) "")
+ 'font-lock-face face)
(propertize (package-desc-summary pkg-desc)
'font-lock-face face)))))
`package-archives', and then refreshes the package menu."
(interactive)
(unless (derived-mode-p 'package-menu-mode)
- (error "The current buffer is not a Package Menu"))
+ (user-error "The current buffer is not a Package Menu"))
(package-refresh-contents)
(package-menu--generate t t))
(tabulated-list-get-id))))
(if pkg-desc
(describe-package pkg-desc)
- (error "No package here"))))
+ (user-error "No package here"))))
;; fixme numeric argument
(defun package-menu-mark-delete (&optional _num)
"Mark a package for deletion and move to the next line."
(interactive "p")
- (if (member (package-menu-get-status) '("installed" "obsolete"))
+ (if (member (package-menu-get-status) '("installed" "obsolete" "unsigned"))
(tabulated-list-put-tag "D" t)
(forward-line)))
;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC])
(let ((pkg-desc (car entry))
(status (aref (cadr entry) 2)))
- (cond ((equal status "installed")
+ (cond ((member status '("installed" "unsigned"))
(push pkg-desc installed))
((member status '("available" "new"))
(push (cons (package-desc-name pkg-desc) pkg-desc)
((string= sB "available") nil)
((string= sA "installed") t)
((string= sB "installed") nil)
+ ((string= sA "unsigned") t)
+ ((string= sB "unsigned") nil)
((string= sA "held") t)
((string= sB "held") nil)
((string= sA "built-in") t)
(string< (symbol-name (package-desc-name (car A)))
(symbol-name (package-desc-name (car B)))))
+(defun package-menu--archive-predicate (A B)
+ (string< (or (package-desc-archive (car A)) "")
+ (or (package-desc-archive (car B)) "")))
+
;;;###autoload
(defun list-packages (&optional no-fetch)
"Display a list of packages.
(defalias 'package-list-packages 'list-packages)
;; Used in finder.el
-(defun package-show-package-list (packages)
+(defun package-show-package-list (&optional packages keywords)
"Display PACKAGES in a *Packages* buffer.
This is similar to `list-packages', but it does not fetch the
updated list of packages, and it only displays packages with
-names in PACKAGES (which should be a list of symbols)."
+names in PACKAGES (which should be a list of symbols).
+
+When KEYWORDS are given, only packages with those KEYWORDS are
+shown."
+ (interactive)
(require 'finder-inf nil t)
(let ((buf (get-buffer-create "*Packages*")))
(with-current-buffer buf
(package-menu-mode)
- (package-menu--generate nil packages))
+ (package-menu--generate nil packages keywords))
(switch-to-buffer buf)))
+(defun package-menu-filter-interactive (keyword)
+ "Filter the *Packages* buffer."
+ (interactive (list (completing-read "Keyword: " (package-all-keywords))))
+ (package-show-package-list t (list keyword)))
+
(defun package-list-packages-no-fetch ()
"Display a list of packages.
Does not fetch the updated list of packages before displaying.