Commit 187d3296 authored by Chong Yidong's avatar Chong Yidong
Browse files

Fix several Package Menu and Finder bugs.

* finder.el: Load finder-inf using `require'.
(finder-list-matches): Sorting by status is now the default.
(finder-compile-keywords): Simpify printing.

* emacs-lisp/package.el (package--read-archive-file): Just use
`read', to avoid copying an additional string.
(package-menu-mode): Set header-line-format here.
(package-menu-refresh, package-menu-revert): Signal an error if
not in the Package Menu.
(package-menu-package-list): New var.
(package--generate-package-list): Operate on the current buffer;
don't assume that it is *Packages*, since the user may rename it.
Allow persistent package listings and sort keys using
package-menu-package-list and package-menu-package-sort-key.
(package-menu--version-predicate): Fix version calculation.
(package-menu-sort-by-column): Don't select the window.
(package--list-packages): Create the *Packages* buffer.  Set
package-menu-package-list-key.
(list-packages): Sorting by status is now the default.
(package-buffer-info): Use match-string-no-properties.
(define-package): Add a &rest argument for future proofing, but
don't use it yet.
(package-install-from-buffer, package-install-buffer-internal):
Merged into a single function, package-install-from-buffer.
(package-install-file): Caller changed.

Also, fix headers for hfy-cmap.el and ps-print.el.
parent 14721afc
2010-08-31 Chong Yidong <cyd@stupidchicken.com>
* emacs-lisp/package.el (package--read-archive-file): Just use
`read', to avoid copying an additional string.
(package-menu-mode): Set header-line-format here.
(package-menu-refresh, package-menu-revert): Signal an error if
not in the Package Menu.
(package-menu-package-list): New var.
(package--generate-package-list): Operate on the current buffer;
don't assume that it is *Packages*, since the user may rename it.
Allow persistent package listings and sort keys using
package-menu-package-list and package-menu-package-sort-key.
(package-menu--version-predicate): Fix version calculation.
(package-menu-sort-by-column): Don't select the window.
(package--list-packages): Create the *Packages* buffer. Set
package-menu-package-list-key.
(list-packages): Sorting by status is now the default.
(package-buffer-info): Use match-string-no-properties.
(define-package): Add a &rest argument for future proofing, but
don't use it yet.
(package-install-from-buffer, package-install-buffer-internal):
Merged into a single function, package-install-from-buffer.
(package-install-file): Caller changed.
* finder.el: Load finder-inf using `require'.
(finder-list-matches): Sorting by status is now the default.
(finder-compile-keywords): Simpify printing.
2010-08-30 Stefan Monnier <monnier@iro.umontreal.ca>
* progmodes/octave-mod.el (octave-font-lock-keywords): Use regexp-opt.
......
......@@ -754,7 +754,7 @@ surrounded by (block NAME ...).
;;;;;; find nsubstitute-if-not nsubstitute-if nsubstitute substitute-if-not
;;;;;; substitute-if substitute delete-duplicates remove-duplicates
;;;;;; delete-if-not delete-if delete* remove-if-not remove-if remove*
;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "8f4ba525c894365101b9a53905db94ba")
;;;;;; replace fill reduce) "cl-seq" "cl-seq.el" "7b7531276ddf8457abecdd487d3cf0b7")
;;; Generated autoloads from cl-seq.el
(autoload 'reduce "cl-seq" "\
......
......@@ -471,17 +471,18 @@ Return nil if the package could not be activated."
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))
......@@ -717,13 +718,13 @@ but version %s required"
"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))))
......@@ -733,16 +734,14 @@ Signal an error if the entire string was not used."
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', if it exists.
......@@ -751,18 +750,17 @@ If successful, set `package-archive-contents'."
(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.
......@@ -833,61 +831,60 @@ Otherwise return nil."
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.
......@@ -898,20 +895,19 @@ The return result is a vector like `package-buffer-info'."
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))
......@@ -919,18 +915,27 @@ The return result is a vector like `package-buffer-info'."
(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)))
......@@ -949,15 +954,6 @@ The return result is a vector like `package-buffer-info'."
;; 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.
......@@ -966,9 +962,10 @@ The file can either be a tar file or an Emacs Lisp 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)
......@@ -1012,7 +1009,7 @@ download."
(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))
......@@ -1275,10 +1272,32 @@ Letters do not insert themselves; instead, they are commands.
(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 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.
......@@ -1287,12 +1306,16 @@ the Emacs Lisp Package Archive, and then refreshes the
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--generate-package-list))
(defun package-menu-revert ()
"Update the list of packages."
(interactive)
(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 ()
......@@ -1438,96 +1461,99 @@ Emacs."
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--generate-package-list (&optional packages)
(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)
(setq name (car elt))
(when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
(or (null packages)
(memq name packages)))
(setq desc (cdr elt)
hold (cadr (assq name package-load-list))
builtin (cdr (assq name package--builtins)))
(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 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 packages)
(memq name packages))
(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 "Version")
'package-menu--version-predicate)
((string= package-menu-sort-key "Status")
'package-menu--status-predicate)
((string= package-menu-sort-key "Description")
'package-menu--description-predicate)
(t ; Sort by package name by default
'package-menu--name-predicate))))
(dolist (elt info-list)
(package-print-package (car (car elt))
(cdr (car elt))
(car (cdr elt))
(car (cdr (cdr elt))))))
;; 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
(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 (cdr (car left)))
(vright (cdr (car right))))
(if (version-list-= vleft 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-< left right))))
(version-list-< vleft vright))))
(defun package-menu--status-predicate (left right)
(let ((sleft (cadr left))
......@@ -1558,53 +1584,28 @@ Emacs."
(symbol-name (caar right))))
(defun package-menu-sort-by-column (&optional e)
"Sort the package menu by the last column clicked on."
"Sort the package menu by the column of the mouse click E."
(interactive "e")
(if e (mouse-select-window 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)))
(inhibit-read-only t))
(setq package-menu-sort-key col)
(package--generate-package-list)))
(obj (posn-object pos))
(col (if obj
(get-text-property (cdr obj) 'column-name (car obj))
(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)
"Display the properties of PACKAGES.
PACKAGES should be a list of package names (symbols).
If PACKAGES is nil, display all packages in `package-alist'."
(with-current-buffer (package--generate-package-list 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