diff lisp/emacs-lisp/package.el @ 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.

--- 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.