my package-update package: package-get-interactive.el

I hacked this up a couple weeks ago, figured some of you might like it. The advantage for me is that it leads me thru the whole process, inspiring confidence that everything is working right. Still needs a bunch of work but it is definitely very usable as is. greg ;;; package-get-interactive.el --- simple interactive package update interface ;;; Author: Greg Klanderman <greg.klanderman(a)alum.mit.edu&gt; ;;; Version: 0.0 ;;; Created: July 22, 1998 ;;; Keywords: emacs package ;;; Commentary: ;;; ;;; This package provides a simple interactive interface for updating XEmacs ;;; packages. It leads the user through all the decisions being made, ;;; hopefully inspiring confidence that it is doing the right thing. ;;; Two interactive functions are provided: ;;; ;;; * M-x package-get-update-all-interactive, which offers to fetch and ;;; install the latest versions of all currently installed packages. ;;; * M-x package-get-all-interactive, which offers to fetch and install ;;; the latest versions of all known packages. ;;; ;;; These functions take an optional universal argument, see their documentation ;;; strings for details. ;;; ;;; Both functions work in much the same way. First, the user is prompted for ;;; the location of the current package-get-base.el file to be used. This file ;;; typically resides on ftp.xemacs.org and contains information about current ;;; versions of all available packages. Next, the user is prompted for the ;;; directory in which packages should be installed. Then, the user is presented ;;; with a buffer listing all package updates appropriate for the command being ;;; run, and is asked how to act for each with a y-or-n-p question. Pressing the ;;; `?' key at this point pops up a buffer containing more details on the package ;;; under consideration. Once all packages have been considered, the ones which ;;; were scheduled for update are fetched and installed. ;;; History: ;;; ;;; Created July 22, 1998 ;; TODO: ;; ;; * actually compute requires ;; * handle removes ;; * actually remove lisp/oldpkg before updating ;; * way to go back and modify choices. ;; * handle mult (version) entries for a pkg in package-get-base ;; * need to somehow keep track of packages that the user has decided ;; not to get and don't prompt again ;;; Code: (require 'package-get) ;;; ------------------------- user variables -------------------------- (defvar package-get-base-directory "/ftp.xemacs.org:/pub/xemacs/beta/xemacs-21.0/packages/binary-packages") (defvar package-get-base-filename "package-get-base.el") ;;; ------------------------- user functions -------------------------- (defun package-get-update-all-interactive (arg) "Offer to fetch and install the latest versions of all currently installed packages. With ARG, compute package dependencies, and offer to install any packages required by the packages being updated." (interactive "P") (package-get-interactive-load-base) (package-get-interactive (mapcar (lambda (pkg) (car pkg)) packages-package-list) arg)) (defun package-get-all-interactive (arg) "Offer to fetch and install the latest versions of all known packages. With ARG, offer to update all packages regardless of whether you already have the current version." (interactive "P") (package-get-interactive-load-base) (let ((packages-package-list (if arg nil packages-package-list))) (package-get-interactive (mapcar (lambda (pkg) (car pkg)) package-get-base)))) ;;; ---------------------------- internals ---------------------------- (defun package-get-interactive-load-base () (let ((pgb-file (read-file-name "Package get base file: " (file-name-as-directory package-get-base-directory) (expand-file-name package-get-base-filename package-get-base-directory) t package-get-base-filename))) (load-file pgb-file))) (defun canonicalize-package-version (v) (and v (format "%.2f" (if (stringp v) (string-to-number v) v)))) (defun package-get-interactive (pkgs &optional dorequires) (when (or (not (listp late-packages)) (not late-packages)) (error "No package path")) (let ((packages-to-get nil) (packages-need-up nil) (have-pkgs (mapcar (lambda (pkg) (car pkg)) packages-package-list)) (pkg-dir (car (last late-packages)))) (setq pkg-dir (read-directory-name "Install packages in: " (directory-file-name pkg-dir) (directory-file-name pkg-dir) t)) (while pkgs (if (not (assq (car pkgs) packages-need-up)) (let ((have-vers (nth 2 (assq (car pkgs) packages-package-list))) (curr-vers (package-get-info-prop (package-get-info-version (package-get-info-find-package package-get-base (car pkgs)) nil) 'version))) (when (not (equal (canonicalize-package-version have-vers) (canonicalize-package-version curr-vers))) (setq packages-need-up (cons (list (car pkgs) have-vers curr-vers nil) packages-need-up)) (when dorequires ;; #### need to fill this in... (message "don't handle requires yet") (ding) (sit-for 3))))) (setq pkgs (cdr pkgs))) (setq packages-need-up (sort packages-need-up (lambda (a b) (let ((asort (+ (if (nth 1 a) 0 2) (if (nth 2 a) 0 1))) (bsort (+ (if (nth 1 b) 0 2) (if (nth 2 b) 0 1)))) (if (= asort bsort) (string-lessp (symbol-name (car a)) (symbol-name (car b))) (< asort bsort)))))) (switch-to-buffer (get-buffer-create "*package-update*")) (erase-buffer) (setq buffer-read-only nil) (let ((standard-output (current-buffer))) (princ "Interactive package update\n\n") (mapc (lambda (pkg) (let ((name (nth 0 pkg)) (have (canonicalize-package-version (nth 1 pkg))) (curr (canonicalize-package-version (nth 2 pkg))) (reqr (nth 3 pkg))) (cond ((null curr) ;; no current version of pkg (princ (format " %15s : remove version %s\n" name have))) ((null have) ;; don't currently have it (princ (format " %15s : get version %s%s\n" name curr (if reqr (format " (required by %s)" (mapconcat 'symbol-name reqr " ")) "")))) (t (princ (format " %15s : update from %s to %s%s\n" name have curr (if (> (string-to-number have) (string-to-number curr)) " *** you seem to have a newer version ***" ""))))))) packages-need-up) (princ "\n\n")) (goto-char (point-min)) (setq packages-to-get nil) (while packages-need-up (let ((pkg (car packages-need-up))) (let ((name (nth 0 pkg)) (have (canonicalize-package-version (nth 1 pkg))) (curr (canonicalize-package-version (nth 2 pkg))) (reqr (nth 3 pkg))) (let ((prompt (cond ((null curr) ;; no current version of pkg (format "Remove `%s' version %s: " name have)) ((null have) ;; don't currently have it (format "Get `%s' version %s%s: " name curr (if reqr (format " (required by %s)" (mapconcat 'symbol-name reqr " ")) ""))) (t (format "%s `%s' from %s to %s: " (if (> (string-to-number have) (string-to-number curr)) "*** Downgrade ***" "Update") name have curr)))) (pkgup-help-package-name name)) ;; for query-y-or-n-p (let ((doit (query-y-or-n-p prompt pkgup-y-or-n-p-map))) (if doit (setq packages-to-get (cons pkg packages-to-get))) (save-excursion (save-window-excursion (goto-char (point-min)) (when (search-forward-regexp (format "^[ ]*%s :" name)) (beginning-of-line) (delete-char 1) (insert (if doit "Y" "N"))))))))) (setq packages-need-up (cdr packages-need-up))) (mapc (lambda (pkg) (if (nth 2 pkg) (package-get (car pkg) (nth 2 pkg) nil pkg-dir) (message "Don't know how to remove package %s, do it manually" (car pkg)) (ding) (sit-for 4))) packages-to-get) (message "done"))) ;;; ------------------------- better y-or-n-p ------------------------- (defvar query-y-or-n-p-map nil "Keymap to use for query-y-or-n-p.") (if query-y-or-n-p-map nil (let ((map (make-sparse-keymap 'query-y-or-n-p-map))) (suppress-keymap map t) (set-keymap-parents map (list minibuffer-local-map)) (define-key map " " 'query-y-or-n-p-yes) (define-key map "\d" 'query-y-or-n-p-no) (define-key map [delete] 'query-y-or-n-p-no) (define-key map [backspace] 'query-y-or-n-p-no) (define-key map "y" 'query-y-or-n-p-yes) (define-key map "n" 'query-y-or-n-p-no) (define-key map "Y" 'query-y-or-n-p-yes) (define-key map "N" 'query-y-or-n-p-no) (setq query-y-or-n-p-map map))) (defun query-y-or-n-p-yes () (interactive) (insert "y") (throw 'exit nil)) (defun query-y-or-n-p-no () (interactive) (insert "n") (throw 'exit nil)) (defun query-y-or-n-p (prompt &optional keymap) "Ask user a \"y or n\" question. Return t if answer is \"y\". Takes one argument, which is the string to display to ask the question. It should end in a space; `y-or-n-p' adds `(y or n) ' to it. No confirmation of the answer is requested; a single character is enough. Also accepts Space to mean yes, or Delete to mean no." (save-excursion (let ((keymap (or keymap query-y-or-n-p-map)) (prompt (concat (gettext prompt) (gettext "(y or n) "))) (ans "")) (while (stringp ans) (setq ans (downcase (read-from-minibuffer prompt nil keymap nil nil nil))) ;no history (cond ((string-equal ans (gettext "y")) (setq ans 't)) ((string-equal ans (gettext "n")) (setq ans 'nil)) (t (ding nil 'y-or-n-p) (discard-input) (message "Please answer y or n.") (sleep-for 2)))) (message "%s%s" prompt (if ans "Yes" "No")) ans))) ;;; --------------- keymap for package update y-or-n-p ---------------- (defvar pkgup-y-or-n-p-map nil "Keymap to use for package-get-interactive y-or-n-p queries.") (if pkgup-y-or-n-p-map nil (let ((map (make-sparse-keymap 'pkgup-y-or-n-p-map))) (set-keymap-parents map (list query-y-or-n-p-map)) (define-key map "?" 'pkgup-help-show-details) (setq pkgup-y-or-n-p-map map))) (defun pkgup-help-show-details () (interactive) (let ((info (package-get-info-version (package-get-info-find-package package-get-base pkgup-help-package-name) nil))) (when info (with-output-to-temp-buffer "*package-update-help*" (princ (format "%20s: %s\n" "package-name" pkgup-help-package-name)) (while info (princ (format "%20s: %s\n" (nth 0 info) (nth 1 info))) (setq info (cdr (cdr info)))))))) ;; hack this to do the requires above ;; (defun package-get-all (package version &optional fetched-packages) ;; "Fetch PACKAGE with VERSION and all other required packages. ;; Uses `package-get-base' to determine just what is required and what ;; package provides that functionality. If VERSION is nil, retrieves ;; latest version. Optional argument FETCHED-PACKAGES is used to keep ;; track of packages already fetched." ;; (interactive "sPackage: \nsVersion: ") ;; (let* ((the-package (package-get-info-find-package package-get-base ;; package)) ;; (this-package (package-get-info-version ;; the-package version)) ;; (this-requires (package-get-info-prop this-package 'requires)) ;; ) ;; (setq version (package-get-info-prop this-package 'version)) ;; (unless (package-get-installedp package version) ;; (package-get package version)) ;; (setq fetched-packages ;; (append (list package) ;; (package-get-info-prop this-package 'provides) ;; fetched-packages)) ;; ;; grab everything that this package requires plus recursively ;; ;; grab everything that the requires require. Keep track ;; ;; in `fetched-packages' the list of things provided -- this ;; ;; keeps us from going into a loop ;; (while this-requires ;; (if (not (member (car this-requires) fetched-packages)) ;; (let* ((reqd-package (package-get-package-provider ;; (car this-requires))) ;; (reqd-version (cadr reqd-package)) ;; (reqd-name (car reqd-package))) ;; (if (null reqd-name) ;; (error "Unable to find a provider for %s" (car this-requires))) ;; (setq fetched-packages ;; (package-get-all reqd-name reqd-version fetched-packages))) ;; ) ;; (setq this-requires (cdr this-requires))) ;; fetched-packages ;; )) ;; (provide 'package-get-interactive) ;;; package-get-interactive.el ends here