[Emacs-diffs] /srv/bzr/emacs/trunk r101191: Improvements to describe-package buffer.

[Chong Yidong]

------------------------------------------------------------
revno: 101191
committer: Chong Yidong <address@hidden>
branch nick: trunk
timestamp: Wed 2010-08-25 23:31:34 -0400
message:
  Improvements to describe-package buffer.
  
  * lisp/help.el (help-map): Bind `C-h P' to describe-package.
  
  * lisp/menu-bar.el (menu-bar-describe-menu): Add describe-package.
  
  * lisp/emacs-lisp/package.el (package-refresh-contents): Catch errors
  when downloading archives.
  (describe-package-1): Add package commentary.
  (package-install-button-action): New function.
  (package-menu-mode-map): Bind ? to package-menu-describe-package.
  (package-menu-view-commentary): Function removed.
  (package-list-packages-internal): Hide the `package' package too.
modified:
  etc/NEWS
  lisp/ChangeLog
  lisp/emacs-lisp/package.el
  lisp/help.el
  lisp/menu-bar.el

=== modified file 'etc/NEWS'
--- a/etc/NEWS  2010-08-23 13:57:55 +0000
+++ b/etc/NEWS  2010-08-26 03:31:34 +0000
@@ -176,8 +176,12 @@
 
 ** An Emacs Lisp package manager is now included.
 This is a convenient way to download and install additional packages,
-from elpa.gnu.org.  `M-x package-list-packages' shows a list of
-packages, which can be selected for installation.
+from elpa.gnu.org.
+
+*** `M-x list-packages' shows a list of packages, which can be
+selected for installation.
+
+*** New command `describe-package', bound to `C-h P'.
 
 *** By default, all installed packages are loaded and activated
 automatically when Emacs starts up.  To disable this, set

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2010-08-25 08:15:45 +0000
+++ b/lisp/ChangeLog    2010-08-26 03:31:34 +0000
@@ -1,3 +1,17 @@
+2010-08-26  Chong Yidong  <address@hidden>
+
+       * help.el (help-map): Bind `C-h P' to describe-package.
+
+       * menu-bar.el (menu-bar-describe-menu): Add describe-package.
+
+       * emacs-lisp/package.el (package-refresh-contents): Catch errors
+       when downloading archives.
+       (describe-package-1): Add package commentary.
+       (package-install-button-action): New function.
+       (package-menu-mode-map): Bind ? to package-menu-describe-package.
+       (package-menu-view-commentary): Function removed.
+       (package-list-packages-internal): Hide the `package' package too.
+
 2010-08-25  Kenichi Handa  <address@hidden>
 
        * language/misc-lang.el ("Arabic"): New language environment.

=== modified file 'lisp/emacs-lisp/package.el'
--- a/lisp/emacs-lisp/package.el        2010-08-24 21:36:33 +0000
+++ b/lisp/emacs-lisp/package.el        2010-08-26 03:31:34 +0000
@@ -216,6 +216,7 @@
 (declare-function lm-header "lisp-mnt" (header))
 (declare-function lm-commentary "lisp-mnt" (&optional file))
 (declare-function dired-delete-file "dired" (file &optional recursive trash))
+(defvar url-http-end-of-headers)
 
 (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/";))
   "An alist of archives from which to fetch.
@@ -1016,7 +1017,10 @@
   (unless (file-exists-p package-user-dir)
     (make-directory package-user-dir t))
   (dolist (archive package-archives)
-    (package--download-one-archive archive "archive-contents"))
+    (condition-case nil
+       (package--download-one-archive archive "archive-contents")
+      (error (message "Failed to download archive `%s'."
+                     (car archive)))))
   (package-read-all-archive-contents))
 
 ;;;###autoload
@@ -1052,9 +1056,7 @@
                                        guess)
                              "Describe package: ")
                            packages nil t nil nil guess))
-     (list (if (equal val "")
-              guess
-            (intern val)))))
+     (list (if (equal val "") guess (intern val)))))
   (if (or (null package) (null (symbolp package)))
       (message "You did not specify a package")
     (help-setup-xref (list #'describe-package package)
@@ -1064,38 +1066,60 @@
        (describe-package-1 package)))))
 
 (defun describe-package-1 (package)
-  (let ((desc (cdr (assq package package-alist)))
-       reqs version installable)
+  (let ((package-name (symbol-name package))
+       (built-in (assq package package--builtins))
+       desc pkg-dir reqs version installable)
     (prin1 package)
     (princ " is ")
-    (cond
-     (desc
-      ;; This package is loaded (i.e. in `package-alist').
-      (let (pkg-dir)
-       (setq version (package-version-join (package-desc-vers desc)))
-       (if (assq package package--builtins)
-           (princ "a built-in package.\n\n")
-         (setq pkg-dir (package--dir (symbol-name package) version))
-         (if pkg-dir
-             (progn
-               (insert "a package installed in `")
-               (help-insert-xref-button (file-name-as-directory pkg-dir)
-                                        'help-package-def pkg-dir)
-               (insert "'.\n\n"))
-           ;; This normally does not happen.
-           (insert "a deleted package.\n\n")
-           (setq version nil)))))
-     (t
-      ;; An uninstalled package.
-      (setq desc (cdr (assq package package-archive-contents))
+    (if (setq desc (cdr (assq package package-alist)))
+       ;; This package is loaded (i.e. in `package-alist').
+       (progn
+         (setq version (package-version-join (package-desc-vers desc)))
+         (cond (built-in
+                (princ "a built-in package.\n\n"))
+               ((setq pkg-dir (package--dir package-name version))
+                (insert "an installed package.\n\n"))
+               (t ;; This normally does not happen.
+                (insert "a deleted package.\n\n")
+                (setq version nil))))
+      ;; This package is not installed.
+      (setq desc    (cdr (assq package package-archive-contents))
            version (package-version-join (package-desc-vers desc))
            installable t)
-      (insert "an installable package.\n\n")))
-    (if version
-       (insert "      Version: " version "\n"))
+      (insert "an uninstalled package.\n\n"))
+
+    (insert "     " (propertize "Status" 'face 'bold) ": ")
+    (cond (pkg-dir
+          (insert (propertize "Installed" 'face 'font-lock-comment-face))
+          (insert " in `")
+          ;; Todo: Add button for uninstalling.
+          (help-insert-xref-button (file-name-as-directory pkg-dir)
+                                   'help-package-def pkg-dir)
+          (insert "'."))
+         (installable
+          (insert "Available -- ")
+          (let ((button-text (if (display-graphic-p)
+                                 "Install"
+                               "[Install]"))
+                (button-face (if (display-graphic-p)
+                                 '(:box (:line-width 2 :color "dark grey")
+                                        :background "light grey"
+                                        :foreground "black")
+                               'link)))
+            (insert-text-button button-text
+                                'face button-face
+                                'follow-link t
+                                'package-symbol package
+                                'action 'package-install-button-action)))
+         (built-in
+          (insert (propertize "Built-in" 'face 'font-lock-builtin-face) "."))
+         (t (insert "Deleted.")))
+    (insert "\n")
+    (when version
+      (insert "    " (propertize "Version" 'face 'bold) ": " version "\n"))
     (setq reqs (package-desc-reqs desc))
     (when reqs
-      (insert "     Requires: ")
+      (insert "   " (propertize "Requires" 'face 'bold) ": ")
       (let ((first t)
            name vers text)
        (dolist (req reqs)
@@ -1110,28 +1134,45 @@
                (t (insert ", ")))
          (help-insert-xref-button text 'help-package name))
        (insert "\n")))
-    (insert "  Description: " (package-desc-doc desc) "\n")
-    ;; Todo: button for uninstalling a package.
-    (when installable
-      (let ((button-text (if (display-graphic-p)
-                            "Install"
-                          "[Install]"))
-           (button-face (if (display-graphic-p)
-                            '(:box (:line-width 2 :color "dark grey")
-                                   :background "light grey"
-                                   :foreground "black")
-                          'link)))
-       (insert "\n")
-       (insert-text-button button-text
-                           'face button-face
-                           'follow-link t
-                           'package-symbol package
-                           'action (lambda (button)
-                                     (package-install
-                                      (button-get button 'package-symbol))
-                                     (revert-buffer nil t)
-                                     (goto-char (point-min))))
-       (insert "\n")))))
+    (insert "    " (propertize "Summary" '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)))))))
+
+(defun package-install-button-action (button)
+  (let ((package (button-get button 'package-symbol)))
+    (when (y-or-n-p (format "Install package `%s'? " package))
+      (package-install package)
+      (revert-buffer nil t)
+      (goto-char (point-min)))))
 
 
 ;;;; Package menu mode.
@@ -1153,7 +1194,7 @@
     (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-view-commentary)
+    (define-key map "?" 'package-menu-describe-package)
     (define-key map [menu-bar package-menu] (cons "Package" menu-map))
     (define-key menu-map [mq]
       '(menu-item "Quit" quit-window
@@ -1297,32 +1338,8 @@
   (interactive)
   (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp"))
 
-(defun package-menu-view-commentary ()
-  "Display information about this package.
-For single-file packages, shows the commentary section from the header.
-For larger packages, shows the README file."
-  (interactive)
-  (let* ((pkg-name (package-menu-get-package))
-        (buffer (url-retrieve-synchronously
-                 (concat (package-archive-url pkg-name)
-                         pkg-name
-                         "-readme.txt")))
-        start-point ok)
-    (with-current-buffer buffer
-      ;; FIXME: it would be nice to work with any URL type.
-      (setq start-point url-http-end-of-headers)
-      (setq ok (eq (url-http-parse-response) 200)))
-    (let ((new-buffer (get-buffer-create "*Package Info*")))
-      (with-current-buffer new-buffer
-       (let ((buffer-read-only nil))
-         (erase-buffer)
-         (insert "Package information for " pkg-name "\n\n")
-         (if ok
-             (insert-buffer-substring buffer start-point)
-           (insert "This package lacks a README file or commentary.\n"))
-         (goto-char (point-min))
-         (view-mode)))
-      (display-buffer new-buffer t))))
+(define-obsolete-function-alias
+  'package-menu-view-commentary 'package-menu-describe-package "24.1")
 
 ;; Return the name of the package on the current line.
 (defun package-menu-get-package ()
@@ -1426,7 +1443,7 @@
        (setq name (car elt)
              desc (cdr elt)
              hold (assq name package-load-list))
-       (unless (eq name 'emacs)
+       (unless (memq name '(emacs package))
          (setq info-list
                (package-list-maybe-add
                 name (package-desc-vers desc)

=== modified file 'lisp/help.el'
--- a/lisp/help.el      2010-07-10 18:52:53 +0000
+++ b/lisp/help.el      2010-08-26 03:31:34 +0000
@@ -103,6 +103,7 @@
     (define-key map "m" 'describe-mode)
     (define-key map "n" 'view-emacs-news)
     (define-key map "p" 'finder-by-keyword)
+    (define-key map "P" 'describe-package)
     (define-key map "r" 'info-emacs-manual)
     (define-key map "s" 'describe-syntax)
     (define-key map "t" 'help-with-tutorial)

=== modified file 'lisp/menu-bar.el'
--- a/lisp/menu-bar.el  2010-08-25 06:53:55 +0000
+++ b/lisp/menu-bar.el  2010-08-26 03:31:34 +0000
@@ -1485,6 +1485,9 @@
 (define-key menu-bar-describe-menu [describe-current-display-table]
   `(menu-item ,(purecopy "Describe Display Table") 
describe-current-display-table
              :help ,(purecopy "Describe the current display table")))
+(define-key menu-bar-describe-menu [describe-package]
+  `(menu-item ,(purecopy "Describe Package...") describe-package
+              :help ,(purecopy "Display documentation of a Lisp package")))
 (define-key menu-bar-describe-menu [describe-face]
   `(menu-item ,(purecopy "Describe Face...") describe-face
               :help ,(purecopy "Display the properties of a face")))
@@ -1616,11 +1619,11 @@
 (define-key menu-bar-help-menu [sep2]
   menu-bar-separator)
 (define-key menu-bar-help-menu [external-packages]
-  `(menu-item ,(purecopy "External Packages") menu-bar-help-extra-packages
+  `(menu-item ,(purecopy "Finding Extra Packages") menu-bar-help-extra-packages
              :help ,(purecopy "Lisp packages distributed separately for use in 
Emacs")))
 (define-key menu-bar-help-menu [find-emacs-packages]
-  `(menu-item ,(purecopy "Find Emacs Packages") finder-by-keyword
-             :help ,(purecopy "Find packages and features by keyword")))
+  `(menu-item ,(purecopy "Search Built-in Packages") finder-by-keyword
+             :help ,(purecopy "Find built-in packages and features by 
keyword")))
 (define-key menu-bar-help-menu [more-manuals]
   `(menu-item ,(purecopy "More Manuals") ,menu-bar-manuals-menu))
 (define-key menu-bar-help-menu [emacs-manual]