X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/6ccb9cab43613632ece4f62d9ee28d694bc1d666..0116ee837aed1f34fe406febc991db00c22ee073:/lisp/emacs-lisp/package.el diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 68d2880d33..f22221f3de 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1,6 +1,6 @@ ;;; 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 ;; Daniel Hackney @@ -206,9 +206,12 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")." (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) +(declare-function url-recreate-url "url" (urlobj)) +(defvar url-http-target-url) (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) "An alist of archives from which to fetch. @@ -285,6 +288,22 @@ contrast, `package-user-dir' contains packages for personal use." :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 @@ -296,7 +315,7 @@ contrast, `package-user-dir' contains packages for personal use." (: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)) @@ -305,7 +324,18 @@ contrast, `package-user-dir' contains packages for personal use." (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: @@ -327,14 +357,20 @@ 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) @@ -395,7 +431,7 @@ This is, approximately, the inverse of `version-to-list'. ((>= 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 @@ -405,7 +441,8 @@ This is, approximately, the inverse of `version-to-list'. (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)) @@ -414,7 +451,8 @@ This is, approximately, the inverse of `version-to-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) @@ -422,6 +460,8 @@ This is, approximately, the inverse of `version-to-list'. (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 () @@ -457,19 +497,27 @@ Return the max version (as a string) if the package is held at a lower version." (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)) @@ -478,13 +526,15 @@ Return the max version (as a string) if the package is held at a lower version." "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) @@ -589,7 +639,6 @@ EXTRA-PROPERTIES is currently unused." (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)) @@ -635,22 +684,28 @@ untar into a directory named DIR; otherwise, signal an error." (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)) @@ -736,16 +791,87 @@ It will move point to somewhere in the headers." (require 'url-http) (let ((response (url-http-parse-response))) (when (or (< response 200) (>= response 300)) - (error "Error during download request:%s" + (error "Error downloading %s:%s" + (url-recreate-url url-http-target-url) (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 (package--with-work-buffer location sig-file + (buffer-string)))) + (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. + (let ((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) @@ -753,13 +879,13 @@ It will move point to somewhere in the headers." "Return true if PACKAGE, of MIN-VERSION or newer, is installed. MIN-VERSION should be a version list." (unless package--initialized (error "package.el is not yet initialized!")) - (or - (let ((pkg-descs (cdr (assq package package-alist)))) - (and pkg-descs - (version-list-<= min-version - (package-desc-version (car pkg-descs))))) - ;; Also check built-in packages. - (package-built-in-p package min-version))) + (or + (let ((pkg-descs (cdr (assq package package-alist)))) + (and pkg-descs + (version-list-<= min-version + (package-desc-version (car pkg-descs))))) + ;; Also check built-in packages. + (package-built-in-p package min-version))) (defun package-compute-transaction (packages requirements) "Return a list of packages to be installed, including PACKAGES. @@ -886,10 +1012,10 @@ If the archive version is too new, signal an error." ;; 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. @@ -904,7 +1030,11 @@ Also, add the originating archive to the `package-desc' structure." :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 @@ -973,6 +1103,25 @@ Otherwise return nil." 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. @@ -981,7 +1130,7 @@ error. If there is a package, narrow the buffer to the file's 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))) @@ -997,14 +1146,18 @@ boundaries." ;; 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)) @@ -1071,9 +1224,16 @@ The file can either be a tar file or an Emacs Lisp file." (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))) + (let* ((name (package-desc-name pkg-desc)) + (pkgs (assq name package-alist))) + (delete pkg-desc pkgs) + (unless (cdr pkgs) + (setq package-alist (delq pkgs package-alist)))) (message "Package `%s' deleted." (package-desc-full-name pkg-desc))))) (defun package-archive-base (desc) @@ -1085,16 +1245,51 @@ The file can either be a tar file or an Emacs Lisp file." 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 () @@ -1105,6 +1300,14 @@ makes them available for download." ;; 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") @@ -1173,9 +1376,13 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (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 ")) @@ -1188,7 +1395,9 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." '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. @@ -1199,24 +1408,23 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (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) ": " @@ -1241,7 +1449,19 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (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))) @@ -1287,15 +1507,17 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." ;; 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) @@ -1310,6 +1532,20 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (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))) + ;;;; Package menu mode. @@ -1324,6 +1560,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (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) @@ -1332,6 +1569,9 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (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 @@ -1390,6 +1630,7 @@ Letters do not insert themselves; instead, they are commands. (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)) @@ -1412,7 +1653,8 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." (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") @@ -1426,7 +1668,9 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." (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))) @@ -1436,11 +1680,14 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." (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) @@ -1449,12 +1696,14 @@ PACKAGES should be nil or t, which means to display all known packages." (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))) @@ -1466,20 +1715,89 @@ PACKAGES should be nil or t, which means to display all known 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) @@ -1495,6 +1813,7 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (`"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)) @@ -1506,6 +1825,8 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (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))))) @@ -1515,7 +1836,7 @@ This fetches the contents of each archive specified in `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)) @@ -1527,13 +1848,13 @@ If optional arg BUTTON is non-nil, describe its associated package." (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))) @@ -1587,7 +1908,7 @@ If optional arg BUTTON is non-nil, describe its associated package." ;; 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) @@ -1701,6 +2022,8 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." ((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) @@ -1720,6 +2043,10 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (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. @@ -1766,18 +2093,27 @@ The list is displayed in a buffer named `*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.