:group 'package
:version "24.1")
-(defconst package--builtins-base
- ;; We use package-version split here to make sure to pick up the
- ;; minor version.
- `((emacs . [,(version-to-list emacs-version) nil
- "GNU Emacs"])
- (package . [,(version-to-list package-el-version)
- nil "Simple package system for GNU Emacs"]))
- "Packages which are always built-in.")
-
-(defvar package--builtins
- (delq nil
- (append
- package--builtins-base
- (if (>= emacs-major-version 22)
- ;; FIXME: emacs 22 includes tramp, rcirc, maybe
- ;; other things...
- '((erc . [(5 2) nil "Internet Relay Chat client"])
- ;; The external URL is version 1.15, so make sure the
- ;; built-in one looks newer.
- (url . [(1 16) nil "URL handling libary"])))
- (if (>= emacs-major-version 23)
- '(;; Strangely, nxml-version is missing in Emacs 23.
- ;; We pick the merge date as the version.
- (nxml . [(20071123) nil "Major mode for XML documents"])
- (bubbles . [(0 5) nil "A puzzle game"])))))
- "Alist of all built-in packages.
-Maps the package name to a vector [VERSION REQS DOCSTRING].")
+;; The value is precomputed in finder-inf.el, but don't load that
+;; until it's needed (i.e. when `package-intialize' is called).
+(defvar package--builtins nil
+ "Alist of built-in packages.
+Each element has the form (PKG . DESC), where PKG is a package
+name (a symbol) and DESC is a vector that describes the package.
+
+The vector DESC has the form [VERSION REQS DOCSTRING].
+ VERSION is a version list.
+ REQS is a list of packages (symbols) required by the package.
+ DOCSTRING is a brief description of the package.")
(put 'package--builtins 'risky-local-variable t)
-(defvar package-alist package--builtins
+(defvar package-alist nil
"Alist of all packages available for activation.
-This maps the package name to a vector [VERSION REQS DOCSTRING].
+Each element has the form (PKG . DESC), where PKG is a package
+name (a symbol) and DESC is a vector that describes the package.
-The value is generated by `package-load-descriptor', usually
-called via `package-initialize'. For user customizations of
-which packages to load/activate, see `package-load-list'.")
+The vector DESC has the form [VERSION REQS DOCSTRING].
+ VERSION is a version list.
+ REQS is a list of packages (symbols) required by the package.
+ DOCSTRING is a brief description of the package.
+
+This variable is set automatically by `package-load-descriptor',
+called via `package-initialize'. To change which packages are
+loaded and/or activated, customize `package-load-list'.")
(put 'package-archive-contents 'risky-local-variable t)
-(defvar package-activated-list
- (mapcar #'car package-alist)
+(defvar package-activated-list nil
"List of the names of currently activated packages.")
(put 'package-activated-list 'risky-local-variable t)
pkg-vec)))
package-obsolete-alist)))))
-;; (define-package "emacs" "21.4.1" "GNU Emacs core package.")
-;; (define-package "erc" "5.1" "ERC - irc client" '((emacs "21.0")))
(defun define-package (name-str version-string
- &optional docstring requirements)
+ &optional docstring requirements
+ &rest extra-properties)
"Define a new package.
NAME is the name of the package, a string.
VERSION-STRING is the version of the package, a dotted sequence
of integers.
DOCSTRING is the optional description.
REQUIREMENTS is a list of requirements on other packages.
-Each requirement is of the form (OTHER-PACKAGE \"VERSION\")."
+Each requirement is of the form (OTHER-PACKAGE \"VERSION\").
+
+EXTRA-PROPERTIES is currently unused."
(let* ((name (intern name-str))
(pkg-desc (assq name package-alist))
(new-version (version-to-list version-string))
(version-list-<= min-version
(package-desc-vers (cdr pkg-desc))))))
-(defun package-compute-transaction (result requirements)
+(defun package-compute-transaction (package-list requirements)
+ "Return a list of packages to be installed, including PACKAGE-LIST.
+PACKAGE-LIST should be a list of package names (symbols).
+
+REQUIREMENTS should be a list of additional requirements; each
+element in this list should have the form (PACKAGE VERSION),
+where PACKAGE is a package name and VERSION is the required
+version of that package (as a list).
+
+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."
(dolist (elt requirements)
(let* ((next-pkg (car elt))
(next-version (cadr elt)))
(symbol-name next-pkg) (package-version-join next-version)
(package-version-join (package-desc-vers (cdr pkg-desc)))))
;; Only add to the transaction if we don't already have it.
- (unless (memq next-pkg result)
- (setq result (cons next-pkg result)))
- (setq result
- (package-compute-transaction result
+ (unless (memq next-pkg package-list)
+ (setq package-list (cons next-pkg package-list)))
+ (setq package-list
+ (package-compute-transaction package-list
(package-desc-reqs
(cdr pkg-desc))))))))
- result)
+ package-list)
(defun package-read-from-string (str)
"Read a Lisp expression from STR.
Signal an error if the entire string was not used."
(let* ((read-data (read-from-string str))
- (more-left
- (condition-case nil
- ;; The call to `ignore' suppresses a compiler warning.
- (progn (ignore (read-from-string
- (substring str (cdr read-data))))
- t)
- (end-of-file nil))))
+ (more-left
+ (condition-case nil
+ ;; The call to `ignore' suppresses a compiler warning.
+ (progn (ignore (read-from-string
+ (substring str (cdr read-data))))
+ t)
+ (end-of-file nil))))
(if more-left
(error "Can't read whole string")
(car read-data))))
Will return the data from the file, or nil if the file does not exist.
Will throw an error if the archive version is too new."
(let ((filename (expand-file-name file package-user-dir)))
- (if (file-exists-p filename)
- (with-temp-buffer
- (insert-file-contents-literally filename)
- (let ((contents (package-read-from-string
- (buffer-substring-no-properties (point-min)
- (point-max)))))
- (if (> (car contents) package-archive-version)
- (error "Package archive version %d is greater than %d - upgrade package.el"
- (car contents) package-archive-version))
- (cdr contents))))))
+ (when (file-exists-p filename)
+ (with-temp-buffer
+ (insert-file-contents-literally filename)
+ (let ((contents (read (current-buffer))))
+ (if (> (car contents) package-archive-version)
+ (error "Package archive version %d is higher than %d"
+ (car contents) package-archive-version))
+ (cdr contents))))))
(defun package-read-all-archive-contents ()
- "Re-read `archive-contents' and `builtin-packages', if they exist.
-Set `package-archive-contents' and `package--builtins' if successful.
-Throw an error if the archive version is too new."
+ "Re-read `archive-contents', if it exists.
+If successful, set `package-archive-contents'."
(dolist (archive package-archives)
- (package-read-archive-contents (car archive)))
- (let ((builtins (package--read-archive-file "builtin-packages")))
- (if builtins
- ;; Version 1 of 'builtin-packages' is a list where the car is
- ;; a split emacs version and the cdr is an alist suitable for
- ;; package--builtins.
- (let ((our-version (version-to-list emacs-version))
- (result package--builtins-base))
- (setq package--builtins
- (dolist (elt builtins result)
- (if (version-list-<= (car elt) our-version)
- (setq result (append (cdr elt) result)))))))))
+ (package-read-archive-contents (car archive))))
(defun package-read-archive-contents (archive)
- "Re-read `archive-contents' and `builtin-packages' for ARCHIVE.
-If successful, set `package-archive-contents' and `package--builtins'.
+ "Re-read archive contents for ARCHIVE.
+If successful, set the variable `package-archive-contents'.
If the archive version is too new, signal an error."
- (let ((archive-contents (package--read-archive-file
- (concat "archives/" archive
- "/archive-contents"))))
- (if archive-contents
- ;; Version 1 of 'archive-contents' is identical to our
- ;; internal representation.
- ;; TODO: merge archive lists
- (dolist (package archive-contents)
- (package--add-to-archive-contents package archive)))))
+ ;; Version 1 of 'archive-contents' is identical to our internal
+ ;; representation.
+ (let* ((dir (concat "archives/" archive))
+ (contents-file (concat dir "/archive-contents"))
+ contents)
+ (when (setq contents (package--read-archive-file contents-file))
+ (dolist (package contents)
+ (package--add-to-archive-contents package archive)))))
(defun package--add-to-archive-contents (package archive)
"Add the PACKAGE from the given ARCHIVE if necessary.
(version-list-< (aref existing-package 0) version))
(add-to-list 'package-archive-contents entry))))
-(defun package-download-transaction (transaction)
- "Download and install all the packages in the given transaction."
- (dolist (elt transaction)
+(defun package-download-transaction (package-list)
+ "Download and install all the packages in PACKAGE-LIST.
+PACKAGE-LIST should be a list of package names (symbols).
+This function assumes that all package requirements in
+PACKAGE-LIST are satisfied, i.e. that PACKAGE-LIST is computed
+using `package-compute-transaction'."
+ (dolist (elt package-list)
(let* ((desc (cdr (assq elt package-archive-contents)))
;; As an exception, if package is "held" in
;; `package-load-list', download the held version.
v-str))))
(defun package-buffer-info ()
- "Return a vector of information about the package in the current buffer.
-The vector looks like [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY]
-FILENAME is the file name, a string. It does not have the \".el\" extension.
+ "Return a vector describing the package in the current buffer.
+The vector has the form
+
+ [FILENAME REQUIRES DESCRIPTION VERSION COMMENTARY]
+
+FILENAME is the file name, a string, sans the \".el\" extension.
REQUIRES is a requires list, or nil.
-DESCRIPTION is the package description (a string).
+DESCRIPTION is the package description, a string.
VERSION is the version, a string.
COMMENTARY is the commentary section, a string, or nil if none.
-Throws an exception if the buffer does not contain a conforming package.
-If there is a package, narrows the buffer to the file's boundaries.
-May narrow buffer or move point even on failure."
+
+If the buffer does not contain a conforming package, signal an
+error. If there is a package, narrow the buffer to the file's
+boundaries."
(goto-char (point-min))
- (if (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t)
- (let ((file-name (match-string 1))
- (desc (match-string 2))
- (start (progn (beginning-of-line) (point))))
- (if (search-forward (concat ";;; " file-name ".el ends here"))
- (progn
- ;; Try to include a trailing newline.
- (forward-line)
- (narrow-to-region start (point))
- (require 'lisp-mnt)
- ;; Use some headers we've invented to drive the process.
- (let* ((requires-str (lm-header "package-requires"))
- (requires (if requires-str
- (package-read-from-string requires-str)))
- ;; Prefer Package-Version, because if it is
- ;; defined the package author 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"))))
- (commentary (lm-commentary)))
- (unless pkg-version
- (error
- "Package does not define a usable \"Version\" or \"Package-Version\" header"))
- ;; Turn string version numbers into list form.
- (setq requires
- (mapcar
- (lambda (elt)
- (list (car elt)
- (version-to-list (car (cdr elt)))))
- requires))
- (set-text-properties 0 (length file-name) nil file-name)
- (set-text-properties 0 (length pkg-version) nil pkg-version)
- (set-text-properties 0 (length desc) nil desc)
- (vector file-name requires desc pkg-version commentary)))
- (error "Package missing a terminating comment")))
- (error "No starting comment for package")))
+ (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el --- \\(.*\\)$" nil t)
+ (error "Packages lacks a file header"))
+ (let ((file-name (match-string-no-properties 1))
+ (desc (match-string-no-properties 2))
+ (start (line-beginning-position)))
+ (unless (search-forward (concat ";;; " file-name ".el ends here"))
+ (error "Package lacks a terminating comment"))
+ ;; Try to include a trailing newline.
+ (forward-line)
+ (narrow-to-region start (point))
+ (require 'lisp-mnt)
+ ;; Use some headers we've invented to drive the process.
+ (let* ((requires-str (lm-header "package-requires"))
+ (requires (if requires-str
+ (package-read-from-string requires-str)))
+ ;; Prefer Package-Version; if defined, the package author
+ ;; 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"))))
+ (commentary (lm-commentary)))
+ (unless pkg-version
+ (error
+ "Package lacks a \"Version\" or \"Package-Version\" header"))
+ ;; Turn string version numbers into list form.
+ (setq requires
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (version-to-list (car (cdr elt)))))
+ requires))
+ (vector file-name requires desc pkg-version commentary))))
(defun package-tar-file-info (file)
"Find package information for a tar file.
FILE is the name of the tar file to examine.
The return result is a vector like `package-buffer-info'."
(unless (string-match "^\\(.+\\)-\\([0-9.]+\\)\\.tar$" file)
- (error "`%s' doesn't have a package-ish name" file))
+ (error "Invalid package name `%s'" file))
(let* ((pkg-name (file-name-nondirectory (match-string-no-properties 1 file)))
(pkg-version (match-string-no-properties 2 file))
;; Extract the package descriptor.
pkg-name "-pkg.el")))
(pkg-def-parsed (package-read-from-string pkg-def-contents)))
(unless (eq (car pkg-def-parsed) 'define-package)
- (error "%s-pkg.el doesn't contain `define-package' sexp" pkg-name))
- (let ((name-str (nth 1 pkg-def-parsed))
+ (error "No `define-package' sexp is present in `%s-pkg.el'" pkg-name))
+ (let ((name-str (nth 1 pkg-def-parsed))
(version-string (nth 2 pkg-def-parsed))
- (docstring (nth 3 pkg-def-parsed))
- (requires (nth 4 pkg-def-parsed))
-
+ (docstring (nth 3 pkg-def-parsed))
+ (requires (nth 4 pkg-def-parsed))
(readme (shell-command-to-string
;; Requires GNU tar.
(concat "tar -xOf " file " "
pkg-name "-" pkg-version "/README"))))
(unless (equal pkg-version version-string)
- (error "Inconsistent versions!"))
+ (error "Package has inconsistent versions"))
(unless (equal pkg-name name-str)
- (error "Inconsistent names!"))
+ (error "Package has inconsistent names"))
;; Kind of a hack.
(if (string-match ": Not found in archive" readme)
(setq readme nil))
(if (eq (car requires) 'quote)
(setq requires (car (cdr requires))))
(setq requires
- (mapcar
- (lambda (elt)
- (list (car elt)
- (version-to-list (car (cdr elt)))))
- requires))
+ (mapcar (lambda (elt)
+ (list (car elt)
+ (version-to-list (cadr elt))))
+ requires))
(vector pkg-name requires docstring version-string readme))))
-(defun package-install-buffer-internal (pkg-info type)
+;;;###autoload
+(defun package-install-from-buffer (pkg-info type)
+ "Install a package from the current buffer.
+When called interactively, the current buffer is assumed to be a
+single .el file that follows the packaging guidelines; see info
+node `(elisp)Packaging'.
+
+When called from Lisp, PKG-INFO is a vector describing the
+information, of the type returned by `package-buffer-info'; and
+TYPE is the package type (either `single' or `tar')."
+ (interactive (list (package-buffer-info) 'single))
(save-excursion
(save-restriction
(let* ((file-name (aref pkg-info 0))
- (requires (aref pkg-info 1))
+ (requires (aref pkg-info 1))
(desc (if (string= (aref pkg-info 2) "")
"No description available."
(aref pkg-info 2)))
;; Try to activate it.
(package-initialize)))))
-;;;###autoload
-(defun package-install-from-buffer ()
- "Install a package from the current buffer.
-The package is assumed to be a single .el file which
-follows the elisp comment guidelines; see
-info node `(elisp)Library Headers'."
- (interactive)
- (package-install-buffer-internal (package-buffer-info) 'single))
-
;;;###autoload
(defun package-install-file (file)
"Install a package from a file.
(with-temp-buffer
(insert-file-contents-literally file)
(cond
- ((string-match "\\.el$" file) (package-install-from-buffer))
+ ((string-match "\\.el$" file)
+ (package-install-from-buffer (package-buffer-info) 'single))
((string-match "\\.tar$" file)
- (package-install-buffer-internal (package-tar-file-info file) 'tar))
+ (package-install-from-buffer (package-tar-file-info file) 'tar))
(t (error "Unrecognized extension `%s'" (file-name-extension file))))))
(defun package-delete (name version)
(dolist (archive package-archives)
(condition-case nil
(package--download-one-archive archive "archive-contents")
- (error (message "Failed to download archive `%s'."
+ (error (message "Failed to download `%s' archive."
(car archive)))))
(package-read-all-archive-contents))
"Load Emacs Lisp packages, and activate them.
The variable `package-load-list' controls which packages to load."
(interactive)
+ (require 'finder-inf nil t)
+ (setq package-alist package--builtins)
+ (setq package-activated-list (mapcar #'car package-alist))
(setq package-obsolete-alist nil)
(package-load-all-descriptors)
(package-read-all-archive-contents)
(describe-package-1 package)))))
(defun describe-package-1 (package)
+ (require 'lisp-mnt)
(let ((package-name (symbol-name package))
(built-in (assq package package--builtins))
desc pkg-dir reqs version installable)
installable t)
(insert "an uninstalled package.\n\n"))
- (insert " " (propertize "Status" 'face 'bold) ": ")
+ (insert " " (propertize "Status" 'font-lock-face 'bold) ": ")
(cond (pkg-dir
- (insert (propertize "Installed" 'face 'font-lock-comment-face))
+ (insert (propertize "Installed"
+ 'font-lock-face 'font-lock-comment-face))
(insert " in `")
;; Todo: Add button for uninstalling.
(help-insert-xref-button (file-name-as-directory pkg-dir)
'package-symbol package
'action 'package-install-button-action)))
(built-in
- (insert (propertize "Built-in" 'face 'font-lock-builtin-face) "."))
+ (insert (propertize "Built-in"
+ 'font-lock-face 'font-lock-builtin-face) "."))
(t (insert "Deleted.")))
(insert "\n")
- (when version
- (insert " " (propertize "Version" 'face 'bold) ": " version "\n"))
+ (and version
+ (> (length version) 0)
+ (insert " "
+ (propertize "Version" 'font-lock-face 'bold) ": " version "\n"))
(setq reqs (package-desc-reqs desc))
(when reqs
- (insert " " (propertize "Requires" 'face 'bold) ": ")
+ (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ")
(let ((first t)
name vers text)
(dolist (req reqs)
(t (insert ", ")))
(help-insert-xref-button text 'help-package name))
(insert "\n")))
- (insert " " (propertize "Summary" 'face 'bold)
+ (insert " " (propertize "Summary" 'font-lock-face 'bold)
": " (package-desc-doc desc) "\n\n")
- ;; Insert the package commentary.
- ;; FIXME: We should try to be smarter about when to download.
- (let ((readme (expand-file-name (concat package-name "-readme.txt")
- package-user-dir)))
- ;; Try downloading the commentary. If that fails, try an
- ;; existing readme file in `package-user-dir'.
- (cond ((let ((buffer
- (condition-case nil
- (url-retrieve-synchronously
- (concat (package-archive-url package)
- package-name "-readme.txt"))
- (error nil)))
- response)
- (when buffer
- (with-current-buffer buffer
- (setq response (url-http-parse-response))
- (if (or (< response 200) (>= response 300))
- (setq response nil)
- (setq buffer-file-name
- (expand-file-name readme package-user-dir))
- (delete-region (point-min) (1+ url-http-end-of-headers))
- (save-buffer)))
- (when response
- (insert-buffer-substring buffer)
- (kill-buffer buffer)
- t))))
- ((file-readable-p readme)
- (insert-file-contents readme)
- (goto-char (point-max)))))))
+ (if (assq package package--builtins)
+ ;; For built-in packages, insert the commentary.
+ (let ((fn (locate-file (concat package-name ".el") load-path
+ load-file-rep-suffixes))
+ (opoint (point)))
+ (insert (or (lm-commentary fn) ""))
+ (save-excursion
+ (goto-char opoint)
+ (when (re-search-forward "^;;; Commentary:\n" nil t)
+ (replace-match ""))
+ (while (re-search-forward "^\\(;+ ?\\)" nil t)
+ (replace-match ""))))
+ (let ((readme (expand-file-name (concat package-name "-readme.txt")
+ package-user-dir)))
+ ;; For elpa packages, try downloading the commentary. If that
+ ;; fails, try an existing readme file in `package-user-dir'.
+ (cond ((let ((buffer (ignore-errors
+ (url-retrieve-synchronously
+ (concat (package-archive-url package)
+ package-name "-readme.txt"))))
+ response)
+ (when buffer
+ (with-current-buffer buffer
+ (setq response (url-http-parse-response))
+ (if (or (< response 200) (>= response 300))
+ (setq response nil)
+ (setq buffer-file-name
+ (expand-file-name readme package-user-dir))
+ (delete-region (point-min) (1+ url-http-end-of-headers))
+ (save-buffer)))
+ (when response
+ (insert-buffer-substring buffer)
+ (kill-buffer buffer)
+ t))))
+ ((file-readable-p readme)
+ (insert-file-contents readme)
+ (goto-char (point-max))))))))
(defun package-install-button-action (button)
(let ((package (button-get button 'package-symbol)))
(define-key map "\177" 'package-menu-backup-unmark)
(define-key map "d" 'package-menu-mark-delete)
(define-key map "i" 'package-menu-mark-install)
- (define-key map "g" 'package-menu-revert)
+ (define-key map "g" 'revert-buffer)
(define-key map "r" 'package-menu-refresh)
(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 "?" 'package-menu-describe-package)
+ (define-key map [follow-link] 'mouse-face)
+ (define-key map [mouse-2] 'mouse-select-window)
(define-key map [menu-bar package-menu] (cons "Package" menu-map))
(define-key menu-map [mq]
'(menu-item "Quit" quit-window
:help "Mark a package for installation and move to the next line"))
(define-key menu-map [s3] '("--"))
(define-key menu-map [mg]
- '(menu-item "Update package list" package-menu-revert
+ '(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
(defvar package-menu-sort-button-map
(let ((map (make-sparse-keymap)))
(define-key map [header-line mouse-1] 'package-menu-sort-by-column)
+ (define-key map [header-line mouse-2] 'package-menu-sort-by-column)
(define-key map [follow-link] 'mouse-face)
map)
"Local keymap for package menu sort buttons.")
(setq mode-name "Package Menu")
(setq truncate-lines t)
(setq buffer-read-only t)
- ;; Support Emacs 21.
- (if (fboundp 'run-mode-hooks)
- (run-mode-hooks 'package-menu-mode-hook)
- (run-hooks 'package-menu-mode-hook)))
+ (setq revert-buffer-function 'package-menu-revert)
+ (setq header-line-format
+ (mapconcat
+ (lambda (pair)
+ (let ((column (car pair))
+ (name (cdr pair)))
+ (concat
+ ;; Insert a space that aligns the button properly.
+ (propertize " " 'display (list 'space :align-to column)
+ 'face 'fixed-pitch)
+ ;; Set up the column button.
+ (propertize name
+ 'column-name name
+ 'help-echo "mouse-1: sort by column"
+ 'mouse-face 'highlight
+ 'keymap package-menu-sort-button-map))))
+ ;; We take a trick from buff-menu and have a dummy leading
+ ;; space to align the header line with the beginning of the
+ ;; text. This doesn't really work properly on Emacs 21, but
+ ;; it is close enough.
+ '((0 . "")
+ (2 . "Package")
+ (20 . "Version")
+ (32 . "Status")
+ (43 . "Description"))
+ ""))
+ (run-mode-hooks 'package-menu-mode-hook))
(defun package-menu-refresh ()
"Download the ELPA archive.
package menu. This lets you see what new packages are
available for download."
(interactive)
+ (unless (eq major-mode 'package-menu-mode)
+ (error "The current buffer is not a Package Menu"))
(package-refresh-contents)
- (package-list-packages-internal))
+ (package--generate-package-list))
-(defun package-menu-revert ()
- "Update the list of packages."
+(defun package-menu-revert (&optional arg noconfirm)
+ "Update the list of packages.
+This function is the `revert-buffer-function' for Package Menu
+buffers. The arguments are ignored."
(interactive)
- (package-list-packages-internal))
+ (unless (eq major-mode 'package-menu-mode)
+ (error "The current buffer is not a Package Menu"))
+ (package--generate-package-list))
(defun package-menu-describe-package ()
"Describe the package in the current line."
result)))
result)
-;; This decides how we should sort; nil means by package name.
-(defvar package-menu-sort-key nil)
+(defvar package-menu-package-list nil
+ "List of packages to display in the Package Menu buffer.
+A value of nil means to display all packages.")
-(defun package-list-packages-internal ()
- (package-initialize) ; FIXME: do this here?
- (with-current-buffer (get-buffer-create "*Packages*")
+(defvar package-menu-sort-key nil
+ "Sort key for the current Package Menu buffer.")
+
+(defun package--generate-package-list ()
+ "Populate the current Package Menu buffer."
+ (package-initialize)
+ (let ((inhibit-read-only t)
+ info-list name desc hold builtin)
(setq buffer-read-only nil)
(erase-buffer)
- (let ((info-list)
- name desc hold
- builtin)
- ;; List installed packages
- (dolist (elt package-alist)
- ;; Ignore the Emacs package.
- (setq name (car elt)
- desc (cdr elt)
- hold (assq name package-load-list))
- (unless (memq name '(emacs package))
- (setq info-list
- (package-list-maybe-add
- name (package-desc-vers desc)
- ;; FIXME: it turns out to be tricky to see if this
- ;; package is presently activated.
- (cond ((stringp (cadr hold))
- "held")
- ((and (setq builtin (assq name package--builtins))
- (version-list-=
- (package-desc-vers (cdr builtin))
- (package-desc-vers desc)))
- "built-in")
- (t "installed"))
- (package-desc-doc desc)
- info-list))))
- ;; List available packages
- (dolist (elt package-archive-contents)
- (setq name (car elt)
- desc (cdr elt)
- hold (assq name package-load-list))
- (unless (and hold (stringp (cadr hold))
- (package-installed-p
- name (version-to-list (cadr hold))))
- (setq info-list
- (package-list-maybe-add name
- (package-desc-vers desc)
- (if (and hold (null (cadr hold)))
- "disabled"
- "available")
- (package-desc-doc (cdr elt))
- info-list))))
- ;; List obsolete packages
- (mapc (lambda (elt)
- (mapc (lambda (inner-elt)
- (setq info-list
- (package-list-maybe-add (car elt)
- (package-desc-vers
- (cdr inner-elt))
- "obsolete"
- (package-desc-doc
- (cdr inner-elt))
- info-list)))
- (cdr elt)))
- package-obsolete-alist)
- (let ((selector (cond
- ((string= package-menu-sort-key "Version")
- ;; FIXME this doesn't work.
- #'(lambda (e) (cdr (car e))))
- ((string= package-menu-sort-key "Status")
- #'(lambda (e) (car (cdr e))))
- ((string= package-menu-sort-key "Description")
- #'(lambda (e) (car (cdr (cdr e)))))
- (t ; "Package" is default.
- #'(lambda (e) (symbol-name (car (car e))))))))
+ ;; List installed packages
+ (dolist (elt package-alist)
+ (setq name (car elt))
+ (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
+ (or (null package-menu-package-list)
+ (memq name package-menu-package-list)))
+ (setq desc (cdr elt)
+ hold (cadr (assq name package-load-list))
+ builtin (cdr (assq name package--builtins)))
(setq info-list
- (sort info-list
- (lambda (left right)
- (let ((vleft (funcall selector left))
- (vright (funcall selector right)))
- (string< vleft vright))))))
- (mapc (lambda (elt)
- (package-print-package (car (car elt))
- (cdr (car elt))
- (car (cdr elt))
- (car (cdr (cdr elt)))))
- info-list))
+ (package-list-maybe-add
+ name (package-desc-vers desc)
+ ;; FIXME: it turns out to be tricky to see if this
+ ;; package is presently activated.
+ (cond ((stringp hold) "held")
+ ((and builtin
+ (version-list-=
+ (package-desc-vers builtin)
+ (package-desc-vers desc)))
+ "built-in")
+ (t "installed"))
+ (package-desc-doc desc)
+ info-list))))
+
+ ;; List available and disabled packages
+ (dolist (elt package-archive-contents)
+ (setq name (car elt)
+ desc (cdr elt)
+ hold (assq name package-load-list))
+ (when (or (null package-menu-package-list)
+ (memq name package-menu-package-list))
+ (setq info-list
+ (package-list-maybe-add name
+ (package-desc-vers desc)
+ (if (and hold (null (cadr hold)))
+ "disabled"
+ "available")
+ (package-desc-doc (cdr elt))
+ info-list))))
+ ;; List obsolete packages
+ (mapc (lambda (elt)
+ (mapc (lambda (inner-elt)
+ (setq info-list
+ (package-list-maybe-add (car elt)
+ (package-desc-vers
+ (cdr inner-elt))
+ "obsolete"
+ (package-desc-doc
+ (cdr inner-elt))
+ info-list)))
+ (cdr elt)))
+ package-obsolete-alist)
+
+ (setq info-list
+ (sort info-list
+ (cond ((string= package-menu-sort-key "Package")
+ 'package-menu--name-predicate)
+ ((string= package-menu-sort-key "Version")
+ 'package-menu--version-predicate)
+ ((string= package-menu-sort-key "Description")
+ 'package-menu--description-predicate)
+ (t ; By default, sort by package status
+ 'package-menu--status-predicate))))
+
+ (dolist (elt info-list)
+ (package-print-package (car (car elt))
+ (cdr (car elt))
+ (car (cdr elt))
+ (car (cdr (cdr elt)))))
(goto-char (point-min))
+ (set-buffer-modified-p nil)
(current-buffer)))
+(defun package-menu--version-predicate (left right)
+ (let ((vleft (or (cdr (car left)) '(0)))
+ (vright (or (cdr (car right)) '(0))))
+ (if (version-list-= vleft vright)
+ (package-menu--name-predicate left right)
+ (version-list-< vleft vright))))
+
+(defun package-menu--status-predicate (left right)
+ (let ((sleft (cadr left))
+ (sright (cadr right)))
+ (cond ((string= sleft sright)
+ (package-menu--name-predicate left right))
+ ((string= sleft "available") t)
+ ((string= sright "available") nil)
+ ((string= sleft "installed") t)
+ ((string= sright "installed") nil)
+ ((string= sleft "held") t)
+ ((string= sright "held") nil)
+ ((string= sleft "built-in") t)
+ ((string= sright "built-in") nil)
+ ((string= sleft "obsolete") t)
+ ((string= sright "obsolete") nil)
+ (t (string< sleft sright)))))
+
+(defun package-menu--description-predicate (left right)
+ (let ((sleft (car (cddr left)))
+ (sright (car (cddr right))))
+ (if (string= sleft sright)
+ (package-menu--name-predicate left right)
+ (string< sleft sright))))
+
+(defun package-menu--name-predicate (left right)
+ (string< (symbol-name (caar left))
+ (symbol-name (caar right))))
+
(defun package-menu-sort-by-column (&optional e)
- "Sort the package menu by the last column clicked on."
- (interactive (list last-input-event))
- (if e (mouse-select-window e))
+ "Sort the package menu by the column of the mouse click E."
+ (interactive "e")
(let* ((pos (event-start e))
(obj (posn-object pos))
(col (if obj
(get-text-property (cdr obj) 'column-name (car obj))
- (get-text-property (posn-point pos) 'column-name))))
- (setq package-menu-sort-key col))
- (package-list-packages-internal))
-
-(defun package--list-packages ()
- "Display a list of packages.
-Helper function that does all the work for the user-facing functions."
- (with-current-buffer (package-list-packages-internal)
+ (get-text-property (posn-point pos) 'column-name)))
+ (buf (window-buffer (posn-window (event-start e)))))
+ (with-current-buffer buf
+ (when (eq major-mode 'package-menu-mode)
+ (setq package-menu-sort-key col)
+ (package--generate-package-list)))))
+
+(defun package--list-packages (&optional packages)
+ "Generate and pop to the *Packages* buffer.
+Optional PACKAGES is a list of names of packages (symbols) to
+list; the default is to display everything in `package-alist'."
+ (with-current-buffer (get-buffer-create "*Packages*")
(package-menu-mode)
- ;; Set up the header line.
- (setq header-line-format
- (mapconcat
- (lambda (pair)
- (let ((column (car pair))
- (name (cdr pair)))
- (concat
- ;; Insert a space that aligns the button properly.
- (propertize " " 'display (list 'space :align-to column)
- 'face 'fixed-pitch)
- ;; Set up the column button.
- (if (string= name "Version")
- name
- (propertize name
- 'column-name name
- 'help-echo "mouse-1: sort by column"
- 'mouse-face 'highlight
- 'keymap package-menu-sort-button-map)))))
- ;; We take a trick from buff-menu and have a dummy leading
- ;; space to align the header line with the beginning of the
- ;; text. This doesn't really work properly on Emacs 21,
- ;; but it is close enough.
- '((0 . "")
- (2 . "Package")
- (20 . "Version")
- (32 . "Status")
- (43 . "Description"))
- ""))
-
+ (set (make-local-variable 'package-menu-package-list) packages)
+ (set (make-local-variable 'package-menu-sort-key) nil)
+ (package--generate-package-list)
;; It's okay to use pop-to-buffer here. The package menu buffer
- ;; has keybindings, and the user just typed 'M-x
- ;; package-list-packages', suggesting that they might want to use
- ;; them.
+ ;; has keybindings, and the user just typed `M-x list-packages',
+ ;; suggesting that they might want to use them.
(pop-to-buffer (current-buffer))))
;;;###autoload
-(defun package-list-packages ()
+(defun list-packages ()
"Display a list of packages.
Fetches the updated list of packages before displaying.
The list is displayed in a buffer named `*Packages*'."
(package--list-packages))
;;;###autoload
-(defalias 'list-packages 'package-list-packages)
+(defalias 'package-list-packages 'list-packages)
(defun package-list-packages-no-fetch ()
"Display a list of packages.
HCoop / bpt / emacs.git / blobdiff