Mercurial > emacs
changeset 110017:10e66ac64b61
Merge Finder and package-menu functionality.
* lisp/finder.el: Require `package'.
(finder-known-keywords): Tweak descriptions. Retire `oop' keyword.
(finder-package-info): Var deleted.
(finder-keywords-hash, finder--builtins-alist): New vars.
(finder-compile-keywords): Compute package--builtins and
finder-keywords-hash instead of finder-keywords-hash, respecting
the "Package" header.
(finder-unknown-keywords, finder-list-matches): Use
finder-keywords-hash and package--list-packages.
(finder-mode): Don't set font-lock-defaults.
(finder-exit): We don't use "*Finder-package*" and "*Finder
Category*" buffers anymore.
* lisp/info.el (Info-finder-find-node): Search package-alist instead of
finder-package-info.
* lisp/emacs-lisp/package.el (package--builtins-base): Var deleted.
(package--builtins): Set default value to nil.
(package-initialize): Load precomputed value of package--builtins
from finder-inf.el.
(package-alist, package-compute-transaction)
(package-download-transaction): Improve docstring.
(package-read-all-archive-contents): Do not change
package--builtins here.
(list-packages): Make package-list-packages an alias for this.
Sort by status by default.
(package--list-packages): Add optional PACKAGES arg.
(describe-package-1): Use font-lock-face property. For built-in
packages, insert file commentary.
(package--generate-package-list): Rename from
package-list-packages-internal; all callers changed. Add optional
PACKAGES arg. Add alphabetical sort fallbacks.
(package-menu--version-predicate, package-menu--status-predicate)
(package-menu--description-predicate)
(package-menu--name-predicate): New functions.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Sun, 29 Aug 2010 18:15:09 -0400 |
parents | a3e1f7134e6e |
children | aa172fa85851 c1792addf7ea 1b626601d32d |
files | lisp/ChangeLog lisp/emacs-lisp/package.el lisp/finder.el lisp/ibuffer.el lisp/info.el |
diffstat | 5 files changed, 433 insertions(+), 322 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sun Aug 29 16:10:43 2010 -0400 +++ b/lisp/ChangeLog Sun Aug 29 18:15:09 2010 -0400 @@ -1,3 +1,41 @@ +2010-08-29 Chong Yidong <cyd@stupidchicken.com> + + * finder.el: Require `package'. + (finder-known-keywords): Tweak descriptions. Retire `oop' keyword. + (finder-package-info): Var deleted. + (finder-keywords-hash, finder--builtins-alist): New vars. + (finder-compile-keywords): Compute package--builtins and + finder-keywords-hash instead of finder-keywords-hash, respecting + the "Package" header. + (finder-unknown-keywords, finder-list-matches): Use + finder-keywords-hash and package--list-packages. + (finder-mode): Don't set font-lock-defaults. + (finder-exit): We don't use "*Finder-package*" and "*Finder + Category*" buffers anymore. + + * emacs-lisp/package.el (package--builtins-base): Var deleted. + (package--builtins): Set default value to nil. + (package-initialize): Load precomputed value of package--builtins + from finder-inf.el. + (package-alist, package-compute-transaction) + (package-download-transaction): Improve docstring. + (package-read-all-archive-contents): Do not change + package--builtins here. + (list-packages): Make package-list-packages an alias for this. + Sort by status by default. + (package--list-packages): Add optional PACKAGES arg. + (describe-package-1): Use font-lock-face property. For built-in + packages, insert file commentary. + (package--generate-package-list): Rename from + package-list-packages-internal; all callers changed. Add optional + PACKAGES arg. Add alphabetical sort fallbacks. + (package-menu--version-predicate, package-menu--status-predicate) + (package-menu--description-predicate) + (package-menu--name-predicate): New functions. + + * info.el (Info-finder-find-node): Search package-alist instead of + finder-package-info. + 2010-08-29 Chong Yidong <cyd@stupidchicken.com> * subr.el (version-regexp-alist): Don't use "a" and "b" for
--- a/lisp/emacs-lisp/package.el Sun Aug 29 16:10:43 2010 -0400 +++ b/lisp/emacs-lisp/package.el Sun Aug 29 18:15:09 2010 -0400 @@ -273,46 +273,35 @@ :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.") +;; 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. -(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 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) @@ -673,7 +662,19 @@ (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))) @@ -704,13 +705,13 @@ (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. @@ -744,22 +745,10 @@ (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. @@ -787,9 +776,13 @@ (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. @@ -1028,6 +1021,9 @@ "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) @@ -1066,6 +1062,7 @@ (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) @@ -1088,9 +1085,10 @@ 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) @@ -1112,14 +1110,17 @@ '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) @@ -1134,38 +1135,46 @@ (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))) @@ -1195,6 +1204,8 @@ (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 @@ -1246,6 +1257,7 @@ (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.") @@ -1276,12 +1288,12 @@ available for download." (interactive) (package-refresh-contents) - (package-list-packages-internal)) + (package--generate-package-list)) (defun package-menu-revert () "Update the list of packages." (interactive) - (package-list-packages-internal)) + (package--generate-package-list)) (defun package-menu-describe-package () "Describe the package in the current line." @@ -1429,7 +1441,7 @@ ;; This decides how we should sort; nil means by package name. (defvar package-menu-sort-key nil) -(defun package-list-packages-internal () +(defun package--generate-package-list (&optional packages) (package-initialize) ; FIXME: do this here? (with-current-buffer (get-buffer-create "*Packages*") (setq buffer-read-only nil) @@ -1439,34 +1451,35 @@ 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 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 (cadr hold)) - "held") - ((and (setq builtin (assq name package--builtins)) + (cond ((stringp hold) "held") + ((and builtin (version-list-= - (package-desc-vers (cdr builtin)) + (package-desc-vers builtin) (package-desc-vers desc))) "built-in") (t "installed")) (package-desc-doc desc) info-list)))) - ;; List available packages + + ;; List available and disabled 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)))) + (when (or (null packages) + (memq name packages)) (setq info-list (package-list-maybe-add name (package-desc-vers desc) @@ -1488,47 +1501,80 @@ 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)))))))) - (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)) + + (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)))))) (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) + (package-menu--name-predicate left right) + (version-list-< left right)))) + +(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)) + (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)))) - (setq package-menu-sort-key col)) - (package-list-packages-internal)) + (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))) -(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) +(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) (package-menu-mode) ;; Set up the header line. (setq header-line-format @@ -1560,22 +1606,22 @@ "")) ;; 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*'." (interactive) (package-refresh-contents) + (setq package-menu-sort-key "Status") (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.
--- a/lisp/finder.el Sun Aug 29 16:10:43 2010 -0400 +++ b/lisp/finder.el Sun Aug 29 18:15:09 2010 -0400 @@ -30,6 +30,7 @@ ;;; Code: +(require 'package) (require 'lisp-mnt) (require 'find-func) ;for find-library(-suffixes) ;; Use `load' rather than `require' so that it doesn't get loaded @@ -39,46 +40,42 @@ ;; These are supposed to correspond to top-level customization groups, ;; says rms. (defvar finder-known-keywords - '( - (abbrev . "abbreviation handling, typing shortcuts, macros") - ;; Too specific: - (bib . "code related to the `bib' bibliography processor") - (c . "support for the C language and related languages") - (calendar . "calendar and time management support") - (comm . "communications, networking, remote access to files") + '((abbrev . "abbreviation handling, typing shortcuts, and macros") + (bib . "bibliography processors") + (c . "C and related programming languages") + (calendar . "calendar and time management tools") + (comm . "communications, networking, and remote file access") (convenience . "convenience features for faster editing") - (data . "support for editing files of data") - (docs . "support for Emacs documentation") + (data . "editing data (non-text) files") + (docs . "Emacs documentation facilities") (emulations . "emulations of other editors") (extensions . "Emacs Lisp language extensions") - (faces . "support for multiple fonts") - (files . "support for editing and manipulating files") - (frames . "support for Emacs frames and window systems") + (faces . "fonts and colors for text") + (files . "file editing and manipulation") + (frames . "Emacs frames and window systems") (games . "games, jokes and amusements") - (hardware . "support for interfacing with exotic hardware") - (help . "support for on-line help systems") - (hypermedia . "support for links between text or other media types") - (i18n . "internationalization and alternate character-set support") + (hardware . "interfacing with system hardware") + (help . "on-line help systems") + (hypermedia . "links between text or other media types") + (i18n . "internationalization and character-set support") (internal . "code for Emacs internals, build process, defaults") (languages . "specialized modes for editing programming languages") (lisp . "Lisp support, including Emacs Lisp") (local . "code local to your site") - (maint . "maintenance aids for the Emacs development group") - (mail . "modes for electronic-mail handling") - (matching . "various sorts of searching and matching") + (maint . "Emacs development tools and aids") + (mail . "email reading and posting") + (matching . "searching, matching, and sorting") (mouse . "mouse support") - (multimedia . "images and sound support") - (news . "support for netnews reading and posting") - (oop . "support for object-oriented programming") - (outlines . "support for hierarchical outlining") - (processes . "process, subshell, compilation, and job control support") - (terminals . "support for terminal types") - (tex . "supporting code for the TeX formatter") + (multimedia . "images and sound") + (news . "USENET news reading and posting") + (outlines . "hierarchical outlining and note taking") + (processes . "processes, subshells, and compilation") + (terminals . "text terminals (ttys)") + (tex . "the TeX document formatter") (tools . "programming tools") - (unix . "front-ends/assistants for, or emulators of, UNIX-like features") + (unix . "UNIX feature interfaces and emulators") (vc . "version control") - (wp . "word processing") - )) + (wp . "word processing"))) (defvar finder-mode-map (let ((map (make-sparse-keymap)) @@ -125,8 +122,9 @@ ;;; Code for regenerating the keyword list. -(defvar finder-package-info nil - "Assoc list mapping file names to description & keyword lists.") +(defvar finder-keywords-hash nil + "Hash table mapping keywords to lists of package names. +Keywords and package names both should be symbols.") (defvar generated-finder-keywords-file "finder-inf.el" "The function `finder-compile-keywords' writes keywords into this file.") @@ -142,10 +140,91 @@ (autoload 'autoload-rubric "autoload") +(defvar finder--builtins-alist + '(("calc" . calc) + ("ede" . ede) + ("erc" . erc) + ("eshell" . eshell) + ("gnus" . gnus) + ("international" . emacs) + ("language" . emacs) + ("mh-e" . mh-e) + ("semantic" . semantic) + ("analyze" . semantic) + ("bovine" . semantic) + ("decorate" . semantic) + ("symref" . semantic) + ("wisent" . semantic) + ("nxml" . nxml) + ("org" . org) + ("srecode" . srecode) + ("term" . emacs) + ("url" . url)) + "Alist of built-in package directories. +Each element should have the form (DIR . PACKAGE), where DIR is a +directory name and PACKAGE is the name of a package (a symbol). +When generating `package--builtins', Emacs assumes any file in +DIR is part of the package PACKAGE.") + (defun finder-compile-keywords (&rest dirs) - "Regenerate the keywords association list into `generated-finder-keywords-file'. -Optional arguments DIRS are a list of Emacs Lisp directories to compile from; -no arguments compiles from `load-path'." + "Regenerate list of built-in Emacs packages. +This recomputes `package--builtins' and `finder-keywords-hash', +and prints them into the file `generated-finder-keywords-file'. + +Optional DIRS is a list of Emacs Lisp directories to compile +from; the default is `load-path'." + ;; Allow compressed files also. + (setq package--builtins nil) + (setq finder-keywords-hash (make-hash-table :test 'eq)) + (let ((el-file-regexp "^\\([^=].*\\)\\.el\\(\\.\\(gz\\|Z\\)\\)?$") + package-override files base-name processed + summary keywords package version entry desc) + (dolist (d (or dirs load-path)) + (when (file-exists-p (directory-file-name d)) + (message "Directory %s" d) + (setq package-override + (intern-soft + (cdr-safe + (assoc (file-name-nondirectory (directory-file-name d)) + finder--builtins-alist)))) + (setq files (directory-files d nil el-file-regexp)) + (dolist (f files) + (unless (or (string-match finder-no-scan-regexp f) + (null (setq base-name + (and (string-match el-file-regexp f) + (intern (match-string 1 f))))) + (memq base-name processed)) + (push base-name processed) + (with-temp-buffer + (insert-file-contents (expand-file-name f d)) + (setq summary (lm-synopsis) + keywords (mapcar 'intern (lm-keywords-list)) + package (or package-override + (intern-soft (lm-header "package")) + base-name) + version (lm-header "version"))) + (when summary + (setq version (ignore-errors (version-to-list version))) + (setq entry (assq package package--builtins)) + (cond ((null entry) + (push (cons package (vector version nil summary)) + package--builtins)) + ((eq base-name package) + (setq desc (cdr entry)) + (aset desc 0 version) + (aset desc 2 summary))) + (dolist (kw keywords) + (puthash kw + (cons package + (delq package + (gethash kw finder-keywords-hash))) + finder-keywords-hash)))))))) + + (setq package--builtins + (sort package--builtins + (lambda (a b) (string< (symbol-name (car a)) + (symbol-name (car b)))))) + (save-excursion (find-file generated-finder-keywords-file) (setq buffer-undo-list t) @@ -153,40 +232,23 @@ (insert (autoload-rubric generated-finder-keywords-file "keyword-to-package mapping" t)) (search-backward "") - (insert "(setq finder-package-info '(\n") - (let (processed summary keywords) - (mapc - (lambda (d) - (when (file-exists-p (directory-file-name d)) - (message "Directory %s" d) - (mapc - (lambda (f) - ;; FIXME should this not be using (expand-file-name f d)? - (unless (or (member f processed) - (string-match finder-no-scan-regexp f)) - (setq processed (cons f processed)) - (with-temp-buffer - (insert-file-contents (expand-file-name f d)) - (setq summary (lm-synopsis) - keywords (lm-keywords-list))) - (insert - (format " (\"%s\"\n " - (if (string-match "\\.\\(gz\\|Z\\)$" f) - (file-name-sans-extension f) - f))) - (prin1 summary (current-buffer)) - (insert "\n ") - (prin1 (mapcar 'intern keywords) (current-buffer)) - (insert ")\n"))) - (directory-files d nil - ;; Allow compressed files also. FIXME: - ;; generalize this, especially for - ;; MS-DOG-type filenames. - "^[^=].*\\.el\\(\\.\\(gz\\|Z\\)\\)?$" - )))) - (or dirs load-path))) - (insert " ))\n") - (eval-buffer) ; so we get the new keyword list immediately + (insert "(setq package--builtins '(\n") + (dolist (package package--builtins) + (insert " (") + (prin1 (car package) (current-buffer)) + (insert " .\n [") + (let ((desc (cdr package))) + (prin1 (aref desc 0) (current-buffer)) + (insert " ") + (prin1 (aref desc 1) (current-buffer)) + (insert " ") + (prin1 (aref desc 2) (current-buffer))) + (insert "])\n")) + (insert " ))\n\n") + ;; Insert hash table. + (insert "(setq finder-keywords-hash\n ") + (prin1 finder-keywords-hash (current-buffer)) + (insert ")\n") (basic-save-buffer))) (defun finder-compile-keywords-make-dist () @@ -226,26 +288,14 @@ (defun finder-unknown-keywords () "Return an alist of unknown keywords and number of their occurences. -Unknown are keywords that are present in `finder-package-info' -but absent in `finder-known-keywords'." - (let ((unknown-keywords-hash (make-hash-table))) - ;; Prepare a hash where key is a keyword - ;; and value is the number of keyword occurences. - (mapc (lambda (package) - (mapc (lambda (keyword) - (unless (assq keyword finder-known-keywords) - (puthash keyword - (1+ (gethash keyword unknown-keywords-hash 0)) - unknown-keywords-hash))) - (nth 2 package))) - finder-package-info) - ;; Make an alist from the hash and sort by the keyword name. - (sort (let (unknown-keywords-list) - (maphash (lambda (key value) - (push (cons key value) unknown-keywords-list)) - unknown-keywords-hash) - unknown-keywords-list) - (lambda (a b) (string< (car a) (car b)))))) +Unknown keywords are those present in `finder-keywords-hash' but +not `finder-known-keywords'." + (let (alist) + (maphash (lambda (kw packages) + (unless (assq kw finder-known-keywords) + (push (cons kw (length packages)) alist))) + finder-keywords-hash) + (sort alist (lambda (a b) (string< (car a) (car b)))))) ;;;###autoload (defun finder-list-keywords () @@ -255,46 +305,28 @@ (pop-to-buffer "*Finder*") (pop-to-buffer (get-buffer-create "*Finder*")) (finder-mode) - (setq buffer-read-only nil - buffer-undo-list t) - (erase-buffer) - (mapc - (lambda (assoc) - (let ((keyword (car assoc))) - (insert (symbol-name keyword)) - (finder-insert-at-column 14 (concat (cdr assoc) "\n")) - (finder-mouse-face-on-line))) - finder-known-keywords) - (goto-char (point-min)) - (setq finder-headmark (point) - buffer-read-only t) - (set-buffer-modified-p nil) - (balance-windows) - (finder-summary))) + (let ((inhibit-read-only t)) + (erase-buffer) + (dolist (assoc finder-known-keywords) + (let ((keyword (car assoc))) + (insert (propertize (symbol-name keyword) + 'font-lock-face 'font-lock-constant-face)) + (finder-insert-at-column 14 (concat (cdr assoc) "\n")) + (finder-mouse-face-on-line))) + (goto-char (point-min)) + (setq finder-headmark (point) + buffer-read-only t) + (set-buffer-modified-p nil) + (balance-windows) + (finder-summary)))) (defun finder-list-matches (key) - (pop-to-buffer (set-buffer (get-buffer-create "*Finder Category*"))) - (finder-mode) - (setq buffer-read-only nil - buffer-undo-list t) - (erase-buffer) - (let ((id (intern key))) - (insert - "The following packages match the keyword `" key "':\n\n") - (setq finder-headmark (point)) - (mapc - (lambda (x) - (when (memq id (cadr (cdr x))) - (insert (car x)) - (finder-insert-at-column 16 (concat (cadr x) "\n")) - (finder-mouse-face-on-line))) - finder-package-info) - (goto-char (point-min)) - (forward-line) - (setq buffer-read-only t) - (set-buffer-modified-p nil) - (shrink-window-if-larger-than-buffer) - (finder-summary))) + (let* ((id (intern key)) + (packages (gethash id finder-keywords-hash))) + (unless packages + (error "No packages matching key `%s'" key)) + (setq package-menu-sort-key nil) + (package--list-packages packages))) (define-button-type 'finder-xref 'action #'finder-goto-xref) @@ -381,8 +413,8 @@ \\[finder-select] more help for the item on the current line \\[finder-exit] exit Finder mode and kill the Finder buffer." :syntax-table finder-mode-syntax-table - (setq font-lock-defaults '(finder-font-lock-keywords nil nil - (("+-*/.<>=!?$%_&~^:@" . "w")) nil)) + (setq buffer-read-only t + buffer-undo-list t) (set (make-local-variable 'finder-headmark) nil)) (defun finder-summary () @@ -399,8 +431,8 @@ Delete the window and kill all Finder-related buffers." (interactive) (ignore-errors (delete-window)) - (dolist (buff '("*Finder*" "*Finder-package*" "*Finder Category*")) - (and (get-buffer buff) (kill-buffer buff)))) + (let ((buf "*Finder*")) + (and (get-buffer buf) (kill-buffer buf)))) (provide 'finder)
--- a/lisp/ibuffer.el Sun Aug 29 16:10:43 2010 -0400 +++ b/lisp/ibuffer.el Sun Aug 29 18:15:09 2010 -0400 @@ -2641,7 +2641,7 @@ ;;;;;; ibuffer-backward-filter-group ibuffer-forward-filter-group ;;;;;; ibuffer-toggle-filter-group ibuffer-mouse-toggle-filter-group ;;;;;; ibuffer-interactive-filter-by-mode ibuffer-mouse-filter-by-mode -;;;;;; ibuffer-auto-mode) "ibuf-ext" "ibuf-ext.el" "e1272bfdc7c3b6e926b2a68155217303") +;;;;;; ibuffer-auto-mode) "ibuf-ext" "ibuf-ext.el" "fa9822b5ef905f06d8a03dc9ce3a2894") ;;; Generated autoloads from ibuf-ext.el (autoload 'ibuffer-auto-mode "ibuf-ext" "\
--- a/lisp/info.el Sun Aug 29 16:10:43 2010 -0400 +++ b/lisp/info.el Sun Aug 29 18:15:09 2010 -0400 @@ -3372,7 +3372,6 @@ filename) (defvar finder-known-keywords) -(defvar finder-package-info) (declare-function find-library-name "find-func" (library)) (declare-function finder-unknown-keywords "finder" ()) (declare-function lm-commentary "lisp-mnt" (&optional file)) @@ -3388,15 +3387,14 @@ (insert "Finder Keywords\n") (insert "***************\n\n") (insert "* Menu:\n\n") - (mapc - (lambda (assoc) - (let ((keyword (car assoc))) - (insert (format "* %-14s %s.\n" - (concat (symbol-name keyword) "::") - (cdr assoc))))) - (append '((all . "All package info") - (unknown . "unknown keywords")) - finder-known-keywords))) + (dolist (assoc (append '((all . "All package info") + (unknown . "unknown keywords")) + finder-known-keywords)) + (let ((keyword (car assoc))) + (insert (format "* %s %s.\n" + (concat (symbol-name keyword) ": " + "kw:" (symbol-name keyword) ".") + (cdr assoc)))))) ((equal nodename "unknown") ;; Display unknown keywords (insert (format "\n\^_\nFile: %s, Node: %s, Up: Top\n\n" @@ -3416,17 +3414,36 @@ Info-finder-file nodename)) (insert "Finder Package Info\n") (insert "*******************\n\n") - (mapc (lambda (package) - (insert (format "%s - %s\n" - (format "*Note %s::" (nth 0 package)) - (nth 1 package))) - (insert "Keywords: " - (mapconcat (lambda (keyword) - (format "*Note %s::" (symbol-name keyword))) - (nth 2 package) ", ") - "\n\n")) - finder-package-info)) - ((string-match-p "\\.el\\'" nodename) + (dolist (package package-alist) + (insert (format "%s - %s\n" + (format "*Note %s::" (nth 0 package)) + (nth 1 package))))) + ((string-match "\\`kw:" nodename) + (setq nodename (substring nodename (match-end 0))) + ;; Display packages that match the keyword + ;; or the list of keywords separated by comma. + (insert (format "\n\^_\nFile: %s, Node: kw:%s, Up: Top\n\n" + Info-finder-file nodename)) + (insert "Finder Packages\n") + (insert "***************\n\n") + (insert + "The following packages match the keyword `" nodename "':\n\n") + (insert "* Menu:\n\n") + (let ((keywords + (mapcar 'intern (if (string-match-p "," nodename) + (split-string nodename ",[ \t\n]*" t) + (list nodename)))) + hits desc) + (dolist (kw keywords) + (push (copy-tree (gethash kw finder-keywords-hash)) hits)) + (setq hits (delete-dups (apply 'append hits))) + (dolist (package hits) + (setq desc (cdr-safe (assq package package-alist))) + (when (vectorp desc) + (insert (format "* %-16s %s.\n" + (concat (symbol-name package) "::") + (aref desc 2))))))) + (t ;; Display commentary section (insert (format "\n\^_\nFile: %s, Node: %s, Up: Top\n\n" Info-finder-file nodename)) @@ -3447,29 +3464,7 @@ (goto-char (point-min)) (while (re-search-forward "^;+ ?" nil t) (replace-match "" nil nil)) - (buffer-string)))))) - (t - ;; Display packages that match the keyword - ;; or the list of keywords separated by comma. - (insert (format "\n\^_\nFile: %s, Node: %s, Up: Top\n\n" - Info-finder-file nodename)) - (insert "Finder Packages\n") - (insert "***************\n\n") - (insert - "The following packages match the keyword `" nodename "':\n\n") - (insert "* Menu:\n\n") - (let ((keywords - (mapcar 'intern (if (string-match-p "," nodename) - (split-string nodename ",[ \t\n]*" t) - (list nodename))))) - (mapc - (lambda (package) - (unless (memq nil (mapcar (lambda (k) (memq k (nth 2 package))) - keywords)) - (insert (format "* %-16s %s.\n" - (concat (nth 0 package) "::") - (nth 1 package))))) - finder-package-info))))) + (buffer-string)))))))) ;;;###autoload (defun info-finder (&optional keywords)