[Emacs-diffs] /srv/bzr/emacs/trunk r105776: Add an "mark upgradable packages" command to Package Menu mode.

[Chong Yidong]

------------------------------------------------------------
revno: 105776
committer: Chong Yidong <address@hidden>
branch nick: trunk
timestamp: Wed 2011-09-14 21:57:54 -0400
message:
  Add an "mark upgradable packages" command to Package Menu mode.
  
  * lisp/emacs-lisp/package.el (package-alist): Fix risky-local-variable
  declaration.
  (package--add-to-archive-contents): If there is a duplicate entry
  with an older version, remove it.
  (package-menu-mark-delete, package-menu-mark-install)
  (package-menu-mark-unmark): Make unused args optional.
  (package-menu-mark-obsolete-for-deletion): Use
  package-menu-get-status instead of a regexp search.
  (package-menu-get-status): Use tabulated-list-entry.
  (package-menu-mark-upgrades): New command.
  (package-menu-mode-map): Bind it to U.
  (package-menu-execute): Do installation before deletion.
  (package-menu-refresh, package-menu-execute): Use derived-mode-p
  instead of checking major-mode.
  (package-menu--find-upgrades): New function.
modified:
  lisp/ChangeLog
  lisp/emacs-lisp/package.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2011-09-14 22:57:57 +0000
+++ b/lisp/ChangeLog    2011-09-15 01:57:54 +0000
@@ -1,3 +1,21 @@
+2011-09-15  Chong Yidong  <address@hidden>
+
+       * emacs-lisp/package.el (package-alist): Fix risky-local-variable
+       declaration.
+       (package--add-to-archive-contents): If there is a duplicate entry
+       with an older version, remove it.
+       (package-menu-mark-delete, package-menu-mark-install)
+       (package-menu-mark-unmark): Make unused args optional.
+       (package-menu-mark-obsolete-for-deletion): Use
+       package-menu-get-status instead of a regexp search.
+       (package-menu-get-status): Use tabulated-list-entry.
+       (package-menu-mark-upgrades): New command.
+       (package-menu-mode-map): Bind it to U.
+       (package-menu-execute): Do installation before deletion.
+       (package-menu-refresh, package-menu-execute): Use derived-mode-p
+       instead of checking major-mode.
+       (package-menu--find-upgrades): New function.
+
 2011-09-14  Lars Magne Ingebrigtsen  <address@hidden>
 
        * mail/smtpmail.el (smtpmail-send-command): Don't include AUTH

=== modified file 'lisp/emacs-lisp/package.el'
--- a/lisp/emacs-lisp/package.el        2011-08-28 21:32:50 +0000
+++ b/lisp/emacs-lisp/package.el        2011-09-15 01:57:54 +0000
@@ -309,7 +309,7 @@
 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)
+(put 'package-alist 'risky-local-variable t)
 
 (defvar package-activated-list nil
   "List of the names of currently activated packages.")
@@ -820,13 +820,19 @@
   "Add the PACKAGE from the given ARCHIVE if necessary.
 Also, add the originating archive to the end of the package vector."
   (let* ((name    (car package))
-         (version (aref (cdr package) 0))
-         (entry   (cons (car package)
+         (version (package-desc-vers (cdr package)))
+         (entry   (cons name
                        (vconcat (cdr package) (vector archive))))
-         (existing-package (cdr (assq name package-archive-contents))))
-    (when (or (not existing-package)
-              (version-list-< (aref existing-package 0) version))
-      (add-to-list 'package-archive-contents entry))))
+         (existing-package (assq name package-archive-contents)))
+    (cond ((not existing-package)
+          (add-to-list 'package-archive-contents entry))
+         ((version-list-< (package-desc-vers (cdr existing-package))
+                          version)
+          ;; Replace the entry with this one.
+          (setq package-archive-contents
+                (cons entry
+                      (delq existing-package
+                            package-archive-contents)))))))
 
 (defun package-download-transaction (package-list)
   "Download and install all the packages in PACKAGE-LIST.
@@ -1269,6 +1275,7 @@
     (define-key map "\177" 'package-menu-backup-unmark)
     (define-key map "d" 'package-menu-mark-delete)
     (define-key map "i" 'package-menu-mark-install)
+    (define-key map "U" 'package-menu-mark-upgrades)
     (define-key map "r" 'package-menu-refresh)
     (define-key map "~" 'package-menu-mark-obsolete-for-deletion)
     (define-key map "x" 'package-menu-execute)
@@ -1422,7 +1429,7 @@
 This fetches the contents of each archive specified in
 `package-archives', and then refreshes the package menu."
   (interactive)
-  (unless (eq major-mode 'package-menu-mode)
+  (unless (derived-mode-p 'package-menu-mode)
     (error "The current buffer is not a Package Menu"))
   (package-refresh-contents)
   (package-menu--generate t t))
@@ -1437,21 +1444,21 @@
        (describe-package package))))
 
 ;; fixme numeric argument
-(defun package-menu-mark-delete (num)
+(defun package-menu-mark-delete (&optional num)
   "Mark a package for deletion and move to the next line."
   (interactive "p")
   (if (member (package-menu-get-status) '("installed" "obsolete"))
       (tabulated-list-put-tag "D" t)
     (forward-line)))
 
-(defun package-menu-mark-install (num)
+(defun package-menu-mark-install (&optional num)
   "Mark a package for installation and move to the next line."
   (interactive "p")
   (if (string-equal (package-menu-get-status) "available")
       (tabulated-list-put-tag "I" t)
     (forward-line)))
 
-(defun package-menu-mark-unmark (num)
+(defun package-menu-mark-unmark (&optional num)
   "Clear any marks on a package and move to the next line."
   (interactive "p")
   (tabulated-list-put-tag " " t))
@@ -1467,9 +1474,8 @@
   (interactive)
   (save-excursion
     (goto-char (point-min))
-    (forward-line 2)
     (while (not (eobp))
-      (if (looking-at ".*\\s obsolete\\s ")
+      (if (equal (package-menu-get-status) "obsolete")
          (tabulated-list-put-tag "D" t)
        (forward-line 1)))))
 
@@ -1482,17 +1488,66 @@
   'package-menu-view-commentary 'package-menu-describe-package "24.1")
 
 (defun package-menu-get-status ()
-  (save-excursion
-    (if (looking-at ". [^ \t]*[ \t]*[^ \t]*[ \t]*\\([^ \t]*\\)")
-       (match-string 1)
+  (let* ((pkg (tabulated-list-get-id))
+        (entry (and pkg (assq pkg tabulated-list-entries))))
+    (if entry
+       (aref (cadr entry) 2)
       "")))
 
+(defun package-menu--find-upgrades ()
+  (let (installed available upgrades)
+    ;; Build list of installed/available packages in this buffer.
+    (dolist (entry tabulated-list-entries)
+      ;; ENTRY is ((NAME . VERSION) [NAME VERSION STATUS DOC])
+      (let ((pkg (car entry))
+           (status (aref (cadr entry) 2))
+           old)
+       (cond ((equal status "installed")
+              (push pkg installed))
+             ((equal status "available")
+              (push pkg available)))))
+    ;; Loop through list of installed packages, finding upgrades
+    (dolist (pkg installed)
+      (let ((avail-pkg (assq (car pkg) available)))
+       (and avail-pkg
+            (version-list-< (cdr pkg) (cdr avail-pkg))
+            (push avail-pkg upgrades))))
+    upgrades))
+
+(defun package-menu-mark-upgrades ()
+  "Mark all upgradable packages in the Package Menu.
+For each installed package with a newer version available, place
+an (I)nstall flag on the available version and a (D)elete flag on
+the installed version.  A subsequent \\[package-menu-execute]
+call will upgrade the package."
+  (interactive)
+  (unless (derived-mode-p 'package-menu-mode)
+    (error "The current buffer is not a Package Menu"))
+  (let ((upgrades (package-menu--find-upgrades)))
+    (if (null upgrades)
+       (message "No packages to upgrade.")
+      (widen)
+      (save-excursion
+       (goto-char (point-min))
+       (while (not (eobp))
+         (let* ((pkg (tabulated-list-get-id))
+                (upgrade (assq (car pkg) upgrades)))
+           (cond ((null upgrade)
+                  (forward-line 1))
+                 ((equal pkg upgrade)
+                  (package-menu-mark-install))
+                 (t
+                  (package-menu-mark-delete))))))
+      (message "%d package%s marked for upgrading."
+              (length upgrades)
+              (if (= (length upgrades) 1) "" "s")))))
+
 (defun package-menu-execute ()
   "Perform marked Package Menu actions.
 Packages marked for installation are downloaded and installed;
 packages marked for deletion are removed."
   (interactive)
-  (unless (eq major-mode 'package-menu-mode)
+  (unless (derived-mode-p 'package-menu-mode)
     (error "The current buffer is not in Package Menu mode"))
   (let (install-list delete-list cmd id)
     (save-excursion
@@ -1509,6 +1564,14 @@
                ((eq cmd ?I)
                 (push (car id) install-list))))
        (forward-line)))
+    (when install-list
+      (if (yes-or-no-p
+          (if (= (length install-list) 1)
+              (format "Install package `%s'? " (car install-list))
+            (format "Install these %d packages (%s)? "
+                    (length install-list)
+                    (mapconcat 'symbol-name install-list ", "))))
+         (mapc 'package-install install-list)))
     ;; Delete packages, prompting if necessary.
     (when delete-list
       (if (yes-or-no-p
@@ -1527,14 +1590,6 @@
                (package-delete (car elt) (cdr elt))
              (error (message (cadr err)))))
        (error "Aborted")))
-    (when install-list
-      (if (yes-or-no-p
-          (if (= (length install-list) 1)
-              (format "Install package `%s'? " (car install-list))
-            (format "Install these %d packages (%s)? "
-                    (length install-list)
-                    (mapconcat 'symbol-name install-list ", "))))
-         (mapc 'package-install install-list)))
     ;; If we deleted anything, regenerate `package-alist'.  This is done
     ;; automatically if we installed a package.
     (and delete-list (null install-list)
@@ -1597,7 +1652,13 @@
       (package-menu--generate nil t))
     ;; The package menu buffer has keybindings.  If the user types
     ;; `M-x list-packages', that suggests it should become current.
-    (switch-to-buffer buf)))
+    (switch-to-buffer buf))
+  (let ((upgrades (package-menu--find-upgrades)))
+    (if upgrades
+       (message "%d package%s can be upgraded; type `%s' to mark them for 
upgrading."
+                (length upgrades)
+                (if (= (length upgrades) 1) "" "s")
+                (substitute-command-keys "\\[package-menu-mark-upgrades]")))))
 
 ;;;###autoload
 (defalias 'package-list-packages 'list-packages)