;;; 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)
(defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/"))
"An alist of archives from which to fetch.
(unless (memq (car rest-plist) '(:kind :archive))
(let ((value (cadr rest-plist)))
(when value
- (push (cons (car rest-plist) value)
+ (push (cons (car rest-plist)
+ (if (eq (car-safe value) 'quote)
+ (cadr value)
+ value))
alist))))
(setq rest-plist (cddr rest-plist)))
alist)))))
(`tar ".tar")
(kind (error "Unknown package kind: %s" kind))))
+(defun package-desc--keywords (pkg-desc)
+ (let ((keywords (cdr (assoc :keywords (package-desc-extras pkg-desc)))))
+ (if (eq (car-safe keywords) 'quote)
+ (nth 1 keywords)
+ keywords)))
+
;; Package descriptor format used in finder-inf.el and package--builtins.
(cl-defstruct (package--bi-desc
(:constructor package-make-builtin (version summary))
"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)))
+ ((remove 0 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)
";; End:\n"
";;; " (file-name-nondirectory file)
" ends here\n")
- nil file))
+ nil file nil 'silent))
file)
(defvar generated-autoload-file)
(package--alist-to-plist
(package-desc-extras pkg-desc))))
"\n")
- nil
- pkg-file))))
+ nil pkg-file nil 'silent))))
(defun package--alist-to-plist (alist)
(apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist)))
(defun package--write-file-no-coding (file-name)
(let ((buffer-file-coding-system 'no-conversion))
- (write-region (point-min) (point-max) file-name)))
+ (write-region (point-min) (point-max) file-name nil 'silent)))
(defmacro package--with-work-buffer (location file &rest body)
"Run BODY in a buffer containing the contents of FILE at LOCATION.
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))
- `(let* ((http (string-match "\\`https?:" ,location))
- (buffer
- (if http
- (url-retrieve-synchronously (concat ,location ,file))
- (generate-new-buffer "*package work buffer*"))))
- (prog1
- (with-current-buffer buffer
- (if http
- (progn (package-handle-response)
- (re-search-forward "^$" nil 'move)
- (forward-char)
- (delete-region (point-min) (point)))
- (unless (file-name-absolute-p ,location)
- (error "Archive location %s is not an absolute file name"
- ,location))
- (insert-file-contents (expand-file-name ,file ,location)))
- ,@body)
- (kill-buffer buffer))))
-
-(defun package-handle-response ()
- "Handle the response from a `url-retrieve-synchronously' call.
-Parse the HTTP response and throw if an error occurred.
-The url package seems to require extra processing for this.
-This should be called in a `save-excursion', in the download buffer.
-It will move point to somewhere in the headers."
- ;; We assume HTTP here.
- (require 'url-http)
- (let ((response (url-http-parse-response)))
- (when (or (< response 200) (>= response 300))
- (error "Error during download request:%s"
- (buffer-substring-no-properties (point) (line-end-position))))))
+ `(with-temp-buffer
+ (if (string-match-p "\\`https?:" ,location)
+ (url-insert-file-contents (concat ,location ,file))
+ (unless (file-name-absolute-p ,location)
+ (error "Archive location %s is not an absolute file name"
+ ,location))
+ (insert-file-contents (expand-file-name ,file ,location)))
+ ,@body))
(defun package--archive-file-exists-p (location file)
(let ((http (string-match "\\`https?:" location)))
(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)))
+ (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.
- (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)))
+ (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."
(expand-file-name
(concat (package-desc-full-name pkg-desc)
".signed")
- package-user-dir))
+ package-user-dir)
+ nil 'silent)
;; 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.
"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)))
-
-(defun package-compute-transaction (packages requirements)
+ (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 &optional seen)
"Return a list of packages to be installed, including PACKAGES.
PACKAGES should be a list of `package-desc'.
This function recursively computes the requirements of the
packages in REQUIREMENTS, and returns a list of all the packages
that must be installed. Packages that are already installed are
-not included in this list."
+not included in this list.
+
+SEEN is used internally to detect infinite recursion."
;; FIXME: We really should use backtracking to explore the whole
;; search space (e.g. if foo require bar-1.3, and bar-1.4 requires toto-1.1
;; whereas bar-1.3 requires toto-1.0 and the user has put a hold on toto-1.0:
(dolist (pkg packages)
(if (eq next-pkg (package-desc-name pkg))
(setq already pkg)))
- (cond
- (already
- (if (version-list-< next-version (package-desc-version already))
- ;; Move to front, so it gets installed early enough (bug#14082).
- (setq packages (cons already (delq already packages)))
- (error "Need package `%s-%s', but only %s is available"
+ (when already
+ (if (version-list-<= next-version (package-desc-version already))
+ ;; `next-pkg' is already in `packages', but its position there
+ ;; means it might be installed too late: remove it from there, so
+ ;; we re-add it (along with its dependencies) at an earlier place
+ ;; below (bug#16994).
+ (if (memq already seen) ;Avoid inf-loop on dependency cycles.
+ (message "Dependency cycle going through %S"
+ (package-desc-full-name already))
+ (setq packages (delq already packages))
+ (setq already nil))
+ (error "Need package `%s-%s', but only %s is being installed"
next-pkg (package-version-join next-version)
(package-version-join (package-desc-version already)))))
-
+ (cond
+ (already nil)
((package-installed-p next-pkg next-version) nil)
(t
(t (setq found pkg-desc)))))
(unless found
(if problem
- (error problem)
+ (error "%s" problem)
(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))))))))
+ (package-desc-reqs found)
+ (cons found seen))))))))
packages)
(defun package-read-from-string (str)
(existing-packages (assq name package-archive-contents))
(pinned-to-archive (assoc name package-pinned-packages)))
(cond
- ;; Skip entirely if pinned to another archive or already installed.
- ((or (and pinned-to-archive
- (not (equal (cdr pinned-to-archive) archive)))
- (let ((bi (assq name package--builtin-versions)))
- (and bi (version-list-= version (cdr bi))))
- (let ((ins (cdr (assq name package-alist))))
- (and ins (version-list-= version
- (package-desc-version (car ins))))))
+ ;; Skip entirely if pinned to another archive.
+ ((and pinned-to-archive
+ (not (equal (cdr pinned-to-archive) archive)))
nil)
((not existing-packages)
(push (list name pkg-desc) package-archive-contents))
(package-refresh-contents))
(list (intern (completing-read
"Install package: "
- (mapcar (lambda (elt) (symbol-name (car elt)))
- package-archive-contents)
+ (delq nil
+ (mapcar (lambda (elt)
+ (unless (package-installed-p (car elt))
+ (symbol-name (car elt))))
+ package-archive-contents))
nil t)))))
(package-download-transaction
(if (package-desc-p pkg)
(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))
+ ((and (listp dep) (null (cdr dep)))
+ (list (car dep) "0"))
+ (t dep)))
+ deps))))
+
(defun package-buffer-info ()
"Return a `package-desc' describing the package in the current buffer.
"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))
+ (if requires-str
+ (package--prepare-dependencies
+ (package-read-from-string requires-str)))
:kind 'single
:url homepage))))
(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)
(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))
+ (when (listp (read (current-buffer)))
(make-directory dir t)
(setq buffer-file-name (expand-file-name file dir))
(let ((version-control 'never)
;; 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)))))
+ (expand-file-name (concat file ".signed") dir)
+ nil 'silent))))
(declare-function epg-check-configuration "epg-config"
(config &optional minimum-version))
(archive (if desc (package-desc-archive desc)))
(extras (and desc (package-desc-extras desc)))
(homepage (cdr (assoc :url extras)))
- (keywords (cdr (assoc :keywords extras)))
+ (keywords (if desc (package-desc--keywords desc)))
(built-in (eq pkg-dir 'builtin))
(installable (and archive (not built-in)))
(status (if desc (package-desc-status desc) "orphan"))
(revert-buffer nil t)
(goto-char (point-min)))))
-(autoload 'finder-list-matches "finder")
(defun package-keyword-button-action (button)
(let ((pkg-keyword (button-get button 'package-keyword)))
- (finder-list-matches pkg-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 "]")))
(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)
(define-key map "~" 'package-menu-mark-obsolete-for-deletion)
(define-key map "x" 'package-menu-execute)
(define-key map "h" 'package-menu-quick-help)
'(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"))
'(menu-item "Help" package-menu-quick-help
:help "Show short key binding help for package-menu-mode"))
(define-key menu-map [mc]
- '(menu-item "View Commentary" package-menu-view-commentary
+ '(menu-item "Describe Package" package-menu-describe-package
:help "Display information about this package"))
map)
"Local keymap for `package-menu-mode' buffers.")
Letters do not insert themselves; instead, they are commands.
\\<package-menu-mode-map>
\\{package-menu-mode-map}"
- (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-format
+ `[("Package" 18 package-menu--name-predicate)
+ ("Version" 12 nil)
+ ("Status" 10 package-menu--status-predicate)
+ ,@(if (cdr package-archives)
+ '(("Archive" 10 package-menu--archive-predicate)))
+ ("Description" 0 nil)])
(setq tabulated-list-padding 2)
(setq tabulated-list-sort-key (cons "Status" nil))
(add-hook 'tabulated-list-revert-hook 'package-menu--refresh nil t)
"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* ((desc-keywords (and desc (package-desc--keywords desc))))
+ (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* ((desc-keywords (and desc (package-desc--keywords desc)))
+ 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)
(let* ((pkg-desc (car pkg))
(status (cdr pkg))
(face (pcase status
- (`"built-in" 'font-lock-builtin-face)
- (`"available" 'default)
- (`"new" 'bold)
- (`"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.
+ (`"built-in" 'font-lock-builtin-face)
+ (`"available" 'default)
+ (`"new" 'bold)
+ (`"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))
- 'face 'link
- 'follow-link t
- 'package-desc pkg-desc
- 'action 'package-menu-describe-package)
- (propertize (package-version-join
- (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)))))
+ `[,(list (symbol-name (package-desc-name pkg-desc))
+ 'face 'link
+ 'follow-link t
+ 'package-desc pkg-desc
+ 'action 'package-menu-describe-package)
+ ,(propertize (package-version-join
+ (package-desc-version pkg-desc))
+ 'font-lock-face face)
+ ,(propertize status 'font-lock-face face)
+ ,@(if (cdr package-archives)
+ (list (propertize (or (package-desc-archive pkg-desc) "")
+ 'font-lock-face face)))
+ ,(propertize (package-desc-summary pkg-desc)
+ 'font-lock-face face)])))
(defun package-menu-refresh ()
"Download the Emacs Lisp package archive.
(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*")))
+ (let* ((buf (get-buffer-create "*Packages*"))
+ (win (get-buffer-window buf)))
(with-current-buffer buf
(package-menu-mode)
- (package-menu--generate nil packages))
- (switch-to-buffer buf)))
+ (package-menu--generate nil packages keywords))
+ (if win
+ (select-window win)
+ (switch-to-buffer buf))))
+
+;; package-menu--generate rebinds "q" on the fly, so we have to
+;; hard-code the binding in the doc-string here.
+(defun package-menu-filter (keyword)
+ "Filter the *Packages* buffer.
+Show only those items that relate to the specified KEYWORD.
+To restore the full package list, type `q'."
+ (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.
HCoop / bpt / emacs.git / blobdiff