Mercurial > hg > xemacs-beta
annotate lisp/package-ui.el @ 4834:b3ea9c582280
Use new cygwin_conv_path API with Cygwin 1.7 for converting names between Win32 and POSIX, UTF-8-aware, with attendant changes elsewhere
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Tue, 12 Jan 2010 01:38:04 -0600 |
| parents | e29fcfd8df5f |
| children | 2e528066e2fc |
| rev | line source |
|---|---|
| 428 | 1 ;;; package-ui.el --- |
| 2 | |
| 3 ;; Copyright (C) 1998 by Darryl Okahata | |
| 4 | |
| 5 ;; Author: Darryl Okahata <darrylo@sr.hp.com> | |
| 6 ;; Keywords: internal | |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
| 10 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 11 ;; under the terms of the GNU General Public License as published by | |
| 12 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 13 ;; any later version. | |
| 14 | |
| 15 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 18 ;; General Public License for more details. | |
| 19 | |
| 20 ;; You should have received a copy of the GNU General Public License | |
| 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 23 ;; 02111-1307, USA. | |
| 24 | |
| 25 ;;; Synched up with: Not in FSF | |
| 26 | |
| 27 (require 'package-get) ;; which, in turn, requires 'package-admin | |
| 28 | |
| 29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 30 ;; User-changeable variables: | |
| 31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 32 | |
| 33 (defgroup pui nil | |
| 442 | 34 "Convenient interface to the package system." |
| 428 | 35 :group 'package-tools |
| 36 :tag "Package User interface" | |
| 37 :prefix "pui-") | |
| 38 | |
| 39 (defcustom pui-package-install-dest-dir nil | |
| 40 "*If non-nil (Automatic) path to package tree to install packages in. | |
| 41 Otherwise, use old path for installed packages and make a guess for | |
| 42 new ones." | |
| 43 :group 'pui | |
| 44 :tag "Install Location" | |
| 45 :type '(choice (const :tag "Automatic" nil) | |
| 46 (directory))) | |
| 47 | |
| 48 (defcustom pui-list-verbose t | |
| 49 "*If non-nil, display verbose info in the package list buffer." | |
| 50 :group 'pui | |
| 51 :tag "Verbose Listing" | |
| 52 :type 'boolean) | |
| 53 | |
| 54 (defcustom pui-up-to-date-package-face nil | |
| 55 "*The face to use for packages that are up-to-date." | |
| 56 :group 'pui | |
| 57 :type 'face) | |
| 58 | |
| 59 (defcustom pui-selected-package-face 'bold | |
| 60 "*The face to use for selected packages. | |
| 61 Set this to `nil' to use the `default' face." | |
| 62 :group 'pui | |
| 63 :type 'face) | |
| 64 | |
| 65 (defcustom pui-deleted-package-face 'blue | |
| 66 "*The face to use for packages marked for removal. | |
| 67 Set this to `nil' to use the `default' face." | |
| 68 :group 'pui | |
| 69 :type 'face) | |
| 70 | |
| 71 (defcustom pui-outdated-package-face 'red | |
| 72 "*The face to use for outdated packages. | |
| 73 Set this to `nil' to use the `default' face." | |
| 74 :group 'pui | |
| 75 :type 'face) | |
| 76 | |
| 77 (defcustom pui-uninstalled-package-face 'italic | |
| 78 "*The face to use for uninstalled packages. | |
| 79 Set this to `nil' to use the `default' face." | |
| 80 :group 'pui | |
| 81 :type 'face) | |
| 82 | |
| 1365 | 83 (defcustom pui-info-buffer "*Packages*" |
| 84 "*Buffer to use for displaying package information." | |
| 85 :group 'pui | |
| 86 :type 'string) | |
| 428 | 87 |
| 88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 89 ;; End of user-changeable variables. | |
| 90 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 91 | |
| 92 (defvar pui-selected-packages nil | |
| 93 "The list of user-selected packages to install.") | |
| 94 | |
| 95 (defvar pui-deleted-packages nil | |
| 96 "The list of user-selected packages to remove.") | |
| 97 | |
| 98 (defvar pui-actual-package "") | |
| 99 | |
| 100 (defvar pui-display-keymap | |
| 101 (let ((m (make-keymap))) | |
| 102 (suppress-keymap m) | |
| 103 (set-keymap-name m 'pui-display-keymap) | |
| 104 (define-key m "q" 'pui-quit) | |
| 105 (define-key m "g" 'pui-list-packages) | |
| 106 (define-key m "i" 'pui-display-info) | |
| 1742 | 107 (define-key m "m" 'pui-display-maintainer) |
| 428 | 108 (define-key m "?" 'describe-mode) |
| 109 (define-key m "v" 'pui-toggle-verbosity-redisplay) | |
| 110 (define-key m "d" 'pui-toggle-package-delete-key) | |
| 111 (define-key m "D" 'pui-toggle-package-delete-key) | |
| 112 (define-key m [return] 'pui-toggle-package-key) | |
| 113 (define-key m "x" 'pui-install-selected-packages) | |
| 114 (define-key m "I" 'pui-install-selected-packages) | |
| 115 (define-key m "r" 'pui-add-required-packages) | |
| 116 (define-key m "n" 'next-line) | |
| 117 (define-key m "+" 'pui-toggle-package-key) | |
| 118 (define-key m "p" 'previous-line) | |
| 119 (define-key m " " 'scroll-up-command) | |
| 120 (define-key m [delete] 'scroll-down-command) | |
| 121 m) | |
| 122 "Keymap to use in the `pui-info-buffer' buffer") | |
| 123 | |
| 124 (defvar pui-package-keymap | |
| 125 (let ((m (make-sparse-keymap))) | |
| 126 (set-keymap-name m 'pui-package-keymap) | |
| 127 (define-key m 'button2 'pui-toggle-package-event) | |
| 128 ;; We use a popup menu | |
| 129 (define-key m 'button3 'pui-popup-context-sensitive) | |
| 130 m) | |
| 131 "Keymap to use over package names/descriptions.") | |
| 132 | |
| 133 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 134 ;; End of variables | |
| 135 | |
| 136 | |
| 137 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 138 ;; Configuration routines | |
| 139 | |
| 140 ;;;###autoload | |
| 141 (defun package-ui-add-site (site) | |
| 142 "Add site to package-get-remote and possibly offer to update package list." | |
| 143 (let ((had-none (null package-get-remote))) | |
| 1365 | 144 (setq package-get-remote site) |
| 428 | 145 (when (and had-none package-get-was-current |
| 146 (y-or-n-p "Update Package list?")) | |
| 147 (setq package-get-was-current nil) | |
| 148 (package-get-require-base t) | |
| 149 (if (get-buffer pui-info-buffer) | |
| 150 (save-window-excursion | |
| 151 (pui-list-packages)))) | |
| 152 (set-menubar-dirty-flag))) | |
| 1365 | 153 |
| 154 ;;;###autoload | |
| 155 (defun package-ui-download-menu () | |
| 156 "Build the `Add Download Site' menu." | |
| 157 (mapcar (lambda (site) | |
| 158 (vector (car site) | |
| 159 `(if (equal package-get-remote (quote ,(cdr site))) | |
| 160 (setq package-get-remote nil) | |
| 161 (package-ui-add-site (quote ,(cdr site)))) | |
| 162 ;; I've used radio buttons so that only a single | |
| 163 ;; site can be selected, but they are in fact | |
| 164 ;; toggles. SY. | |
| 165 :style 'radio | |
| 166 :selected `(equal package-get-remote (quote ,(cdr site))))) | |
| 167 package-get-download-sites)) | |
| 428 | 168 |
| 169 ;;;###autoload | |
| 1365 | 170 (defun package-ui-pre-release-download-menu () |
| 171 "Build the 'Pre-Release Download Sites' menu." | |
| 172 (mapcar (lambda (site) | |
| 173 (vector (car site) | |
| 174 `(if (equal package-get-remote (quote ,(cdr site))) | |
| 175 (setq package-get-remote nil) | |
| 176 (package-ui-add-site (quote ,(cdr site)))) | |
| 177 ;; I've used radio buttons so that only a single | |
| 178 ;; site can be selected, but they are in fact | |
| 179 ;; toggles. SY. | |
| 180 :style 'radio | |
| 181 :selected `(equal package-get-remote (quote ,(cdr site))))) | |
| 182 package-get-pre-release-download-sites)) | |
| 183 | |
| 184 ;;;###autoload | |
| 1374 | 185 (defun package-ui-site-release-download-menu () |
| 186 "Build the 'Site Release Download Sites' menu." | |
| 187 (mapcar (lambda (site) | |
| 188 (vector (car site) | |
| 189 `(if (equal package-get-remote (quote ,(cdr site))) | |
| 190 (setq package-get-remote nil) | |
| 191 (package-ui-add-site (quote ,(cdr site)))) | |
| 192 ;; I've used radio buttons so that only a single | |
| 193 ;; site can be selected, but they are in fact | |
| 194 ;; toggles. SY. | |
| 195 :style 'radio | |
| 196 :selected `(equal package-get-remote (quote ,(cdr site))))) | |
| 197 package-get-site-release-download-sites)) | |
| 198 | |
| 199 ;;;###autoload | |
| 1647 | 200 (defun pui-set-local-package-get-directory () |
| 1365 | 201 "Set a new package binary directory in `package-get-remote'. |
| 428 | 202 Note that no provision is made for saving any changes made by this function. |
| 203 It exists mainly as a convenience for one-time package installations from | |
| 204 disk." | |
| 1365 | 205 (interactive) |
| 206 (let ((dir (read-directory-name | |
| 207 "New package binary directory to add? " | |
| 208 nil nil t))) | |
| 209 (setq package-get-remote (list nil dir)) | |
| 210 (message "Package directory \"%s\" added." dir))) | |
| 428 | 211 |
| 212 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 213 ;; Package list/installer routines | |
| 214 | |
| 215 (defun pui-quit () | |
| 216 (interactive) | |
| 217 (kill-buffer nil)) | |
| 218 | |
| 219 (defun pui-package-symbol-char (pkg-sym version) | |
| 220 (progn | |
| 221 (if (package-get-info-find-package packages-package-list pkg-sym) | |
| 222 (let ((installed (package-get-key pkg-sym :version))) | |
| 223 (if (>= (if (stringp installed) | |
| 224 (string-to-number installed) | |
| 225 installed) | |
| 226 (if (stringp version) | |
| 227 (string-to-number version) | |
| 228 version)) | |
| 229 (list " " pui-up-to-date-package-face) | |
| 230 (list "*" pui-outdated-package-face))) | |
| 1365 | 231 (list "-" pui-uninstalled-package-face)))) |
| 428 | 232 |
| 233 (defun pui-update-package-display (extent &optional pkg-sym version) | |
| 234 "Update the package status for EXTENT. | |
| 235 If PKG-SYM or VERSION are not given, they are read from the extent. | |
| 236 These are used to determine whether or not the package is installed, | |
| 237 and whether or not it is up-to-date." | |
| 238 (let (buffer-read-only disp sym-char) | |
| 239 (if (not pkg-sym) | |
| 240 (setq pkg-sym (extent-property extent 'pui-package))) | |
| 241 (if (not version) | |
| 242 (setq version (package-get-info-prop (extent-property extent 'pui-info) | |
| 243 'version))) | |
| 244 (cond ((member pkg-sym pui-selected-packages) | |
| 245 (if pui-selected-package-face | |
| 246 (set-extent-face extent (get-face pui-selected-package-face)) | |
| 247 (set-extent-face extent (get-face 'default))) | |
| 248 (setq sym-char "+")) | |
| 249 ((member pkg-sym pui-deleted-packages) | |
| 250 (if pui-deleted-package-face | |
| 251 (set-extent-face extent (get-face pui-deleted-package-face)) | |
| 252 (set-extent-face extent (get-face 'default))) | |
| 253 (setq sym-char "D")) | |
| 254 (t | |
| 255 (setq disp (pui-package-symbol-char pkg-sym version)) | |
| 256 (setq sym-char (car disp)) | |
| 257 (if (car (cdr disp)) | |
| 258 (set-extent-face extent (get-face (car (cdr disp)))) | |
| 259 (set-extent-face extent (get-face 'default))))) | |
| 260 (save-excursion | |
| 261 (goto-char (extent-start-position extent)) | |
| 262 (delete-char 1) | |
| 263 (insert sym-char) | |
| 1365 | 264 (set-buffer-modified-p nil)))) |
| 428 | 265 |
| 266 (defun pui-toggle-package (extent) | |
| 267 (let (pkg-sym) | |
| 268 (setq pkg-sym (extent-property extent 'pui-package)) | |
| 269 (if (member pkg-sym pui-selected-packages) | |
| 270 (setq pui-selected-packages | |
| 271 (delete pkg-sym pui-selected-packages)) | |
| 272 (setq pui-selected-packages | |
| 273 (cons pkg-sym pui-selected-packages)) | |
| 274 (setq pui-deleted-packages | |
| 275 (delete pkg-sym pui-deleted-packages))) | |
| 1365 | 276 (pui-update-package-display extent pkg-sym))) |
| 428 | 277 |
| 278 (defun pui-toggle-package-key () | |
| 279 "Select/unselect package for installation, using the keyboard." | |
| 280 (interactive) | |
| 281 (let (extent) | |
| 282 (if (setq extent (extent-at (point) (current-buffer) 'pui)) | |
| 283 (progn | |
| 284 (pui-toggle-package extent) | |
| 1365 | 285 (forward-line 1)) |
| 1410 | 286 (error 'invalid-operation |
| 287 "No package under cursor!")))) | |
| 428 | 288 |
| 289 (defun pui-toggle-package-delete (extent) | |
| 290 (let (pkg-sym) | |
| 291 (setq pkg-sym (extent-property extent 'pui-package)) | |
| 292 (if (member pkg-sym pui-deleted-packages) | |
| 293 (setq pui-deleted-packages | |
| 294 (delete pkg-sym pui-deleted-packages)) | |
| 295 (setq pui-deleted-packages | |
| 296 (cons pkg-sym pui-deleted-packages)) | |
| 442 | 297 (setq pui-selected-packages |
| 428 | 298 (delete pkg-sym pui-selected-packages))) |
| 1365 | 299 (pui-update-package-display extent pkg-sym))) |
| 428 | 300 |
| 301 | |
| 302 (defun pui-toggle-package-delete-key () | |
| 303 "Select/unselect package for removal, using the keyboard." | |
| 304 (interactive) | |
| 305 (let (extent) | |
| 306 (if (setq extent (extent-at (point) (current-buffer) 'pui)) | |
| 307 (progn | |
| 308 (pui-toggle-package-delete extent) | |
| 1365 | 309 (forward-line 1)) |
| 1410 | 310 (error 'invalid-operation |
| 311 "No package under cursor!")))) | |
| 428 | 312 |
| 313 (defun pui-current-package () | |
| 314 (let ((extent (extent-at (point) (current-buffer) 'pui))) | |
| 315 (if extent | |
| 316 (extent-property extent 'pui-package)))) | |
| 317 | |
| 318 (defun pui-toggle-package-event (event) | |
| 319 "Select/unselect package for installation, using the mouse." | |
| 320 (interactive "e") | |
| 1365 | 321 (let* ((ep (event-point event)) |
| 322 (buffer (window-buffer (event-window event))) | |
| 323 (extent (extent-at ep buffer 'pui-package))) | |
| 324 (pui-toggle-package extent))) | |
| 428 | 325 |
| 326 (defun pui-toggle-verbosity-redisplay () | |
| 327 "Toggle verbose package info." | |
| 328 (interactive) | |
| 329 (progn | |
| 330 (setq pui-list-verbose (not pui-list-verbose)) | |
| 1365 | 331 (pui-list-packages))) |
| 428 | 332 |
| 333 (defun pui-install-selected-packages () | |
| 334 "Install selected packages." | |
| 335 (interactive) | |
| 1365 | 336 (let ((tmpbuf "*Packages-To-Remove*") |
| 337 do-delete) | |
| 428 | 338 (when pui-deleted-packages |
| 339 (save-window-excursion | |
| 340 (with-output-to-temp-buffer tmpbuf | |
| 341 (display-completion-list (sort | |
| 442 | 342 (mapcar #'symbol-name pui-deleted-packages) |
| 343 #'string<) | |
| 428 | 344 :activate-callback nil |
| 345 :help-string "Packages selected for removal:\n" | |
| 1365 | 346 :completion-string t)) |
| 428 | 347 (setq tmpbuf (get-buffer-create tmpbuf)) |
| 348 (display-buffer tmpbuf) | |
| 349 (setq do-delete (yes-or-no-p "Remove these packages? ")) | |
| 350 (kill-buffer tmpbuf)) | |
| 351 (when do-delete | |
| 352 (message "Deleting selected packages ...") (sit-for 0) | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2598
diff
changeset
|
353 (mapc (lambda (pkg) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2598
diff
changeset
|
354 (package-admin-delete-binary-package |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2598
diff
changeset
|
355 pkg (package-admin-get-install-dir pkg))) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2598
diff
changeset
|
356 (nreverse pui-deleted-packages)) |
| 428 | 357 (message "Packages deleted")))) |
| 358 | |
| 1365 | 359 (let ((tmpbuf "*Packages-To-Install*") |
| 360 do-install) | |
| 428 | 361 (if pui-selected-packages |
| 362 (progn | |
| 363 ;; Don't change window config when asking the user if he really | |
| 364 ;; wants to install the packages. We do this to avoid messing up | |
| 365 ;; the window configuration if errors occur (we don't want to | |
| 366 ;; display random buffers in addition to the error buffer, if | |
| 367 ;; errors occur, which would normally be caused by display-buffer). | |
| 368 (save-window-excursion | |
| 369 (with-output-to-temp-buffer tmpbuf | |
| 442 | 370 (display-completion-list |
| 371 (sort (mapcar #'symbol-name pui-selected-packages) #'string<) | |
| 372 :activate-callback nil | |
| 373 :help-string "Packages selected for installation:\n" | |
| 1365 | 374 :completion-string t)) |
| 428 | 375 (setq tmpbuf (get-buffer-create tmpbuf)) |
| 376 (display-buffer tmpbuf) | |
| 377 (setq do-install (y-or-n-p "Install these packages? ")) | |
| 1365 | 378 (kill-buffer tmpbuf)) |
| 428 | 379 (if do-install |
| 380 (progn | |
| 381 (save-excursion | |
| 382 ;; Clear old temp buffer history | |
| 383 (set-buffer (get-buffer-create package-admin-temp-buffer)) | |
| 384 (buffer-disable-undo package-admin-temp-buffer) | |
| 1365 | 385 (erase-buffer package-admin-temp-buffer)) |
| 428 | 386 (message "Installing selected packages ...") (sit-for 0) |
| 387 (if (catch 'done | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2598
diff
changeset
|
388 (mapc (lambda (pkg) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2598
diff
changeset
|
389 (if (not (package-get pkg nil nil |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2598
diff
changeset
|
390 pui-package-install-dest-dir)) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2598
diff
changeset
|
391 (throw 'done nil))) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2598
diff
changeset
|
392 (nreverse pui-selected-packages)) |
| 428 | 393 t) |
| 394 (progn | |
| 395 (pui-list-packages) | |
| 1365 | 396 (message "Packages installed")))) |
| 397 (clear-message))) | |
| 428 | 398 (if pui-deleted-packages |
| 399 (pui-list-packages) | |
| 1410 | 400 (error 'invalid-operation |
| 401 "No packages have been selected!"))) | |
| 454 | 402 ;; sync with windows type systems |
| 1365 | 403 (package-net-update-installed-db))) |
| 428 | 404 |
| 405 (defun pui-add-required-packages () | |
| 406 "Select packages required by those already selected for installation." | |
| 407 (interactive) | |
| 408 (let ((tmpbuf "*Required-Packages*") do-select) | |
| 409 (if pui-selected-packages | |
| 410 (let ((dependencies | |
| 411 (delq nil (mapcar | |
| 412 (lambda (pkg) | |
| 413 (let ((installed | |
| 414 (package-get-key pkg :version)) | |
| 415 (current | |
| 416 (package-get-info-prop | |
| 417 (package-get-info-version | |
| 418 (package-get-info-find-package | |
| 419 package-get-base pkg) nil) | |
| 420 'version))) | |
| 421 (if (or (null installed) | |
| 422 (< (if (stringp installed) | |
| 423 (string-to-number installed) | |
| 424 installed) | |
| 425 (if (stringp current) | |
| 426 (string-to-number current) | |
| 427 current))) | |
| 428 pkg | |
| 429 nil))) | |
| 430 (package-get-dependencies pui-selected-packages))))) | |
| 431 ;; Don't change window config when asking the user if he really | |
| 432 ;; wants to add the packages. We do this to avoid messing up | |
| 433 ;; the window configuration if errors occur (we don't want to | |
| 434 ;; display random buffers in addition to the error buffer, if | |
| 435 ;; errors occur, which would normally be caused by display-buffer). | |
| 436 (save-window-excursion | |
| 437 (with-output-to-temp-buffer tmpbuf | |
| 438 (display-completion-list (sort | |
| 439 (mapcar #'(lambda (pkg) | |
| 440 (symbol-name pkg)) | |
| 441 dependencies) | |
| 442 'string<) | |
| 443 :activate-callback nil | |
| 444 :help-string "Required packages:\n" | |
| 445 :completion-string t)) | |
| 446 (setq tmpbuf (get-buffer-create tmpbuf)) | |
| 447 (display-buffer tmpbuf) | |
| 448 (setq do-select (y-or-n-p "Select these packages? ")) | |
| 449 (kill-buffer tmpbuf)) | |
| 450 (if do-select | |
| 451 (progn | |
| 452 (setq pui-selected-packages | |
| 453 (union pui-selected-packages dependencies)) | |
| 454 (map-extents #'(lambda (extent maparg) | |
| 455 (pui-update-package-display extent)) | |
| 456 nil nil nil nil nil 'pui) | |
| 457 (message "added dependencies")) | |
| 458 (clear-message))) | |
| 1410 | 459 (error 'invalid-operation |
| 460 "No packages have been selected!")))) | |
| 428 | 461 |
| 462 (defun pui-help-echo (extent &optional force-update) | |
| 463 "Display additional package info in the modeline. | |
| 464 EXTENT determines the package to display (the package information is | |
| 465 attached to the extent as properties)." | |
| 1742 | 466 (let (pkg-sym info inst-ver inst-auth-ver auth-ver date maintainer balloon req) |
| 428 | 467 (if (or force-update (not (current-message)) |
| 1365 | 468 (string-match ".*: .*: " (current-message))) |
| 428 | 469 (progn |
| 470 (setq pkg-sym (extent-property extent 'pui-package) | |
| 471 info (extent-property extent 'pui-info) | |
| 472 inst-ver (package-get-key pkg-sym :version) | |
| 1742 | 473 inst-auth-ver (package-get-key pkg-sym :author-version) |
| 428 | 474 auth-ver (package-get-info-prop info 'author-version) |
| 475 date (package-get-info-prop info 'date) | |
| 852 | 476 maintainer (package-get-info-prop info 'maintainer) |
| 477 req (package-get-info-prop info 'requires)) | |
| 428 | 478 (if (not inst-ver) |
| 852 | 479 (setq inst-ver 0)) |
| 480 (if (featurep 'balloon-help) | |
| 481 (progn | |
| 482 (setq balloon (format " | |
| 2146 | 483 Package Information: [For package: \"%s\"]\n================ |
| 1742 | 484 Installed Upstream Ver: %s Available Upstream Ver: %s |
| 852 | 485 Maintainer : %s |
| 486 Released : %s | |
| 487 Required Packages : %s\n\n" | |
| 1742 | 488 pkg-sym inst-auth-ver auth-ver maintainer |
| 852 | 489 date req)) |
| 490 (set-extent-property extent 'balloon-help balloon))) | |
| 1742 | 491 (format |
| 492 "Installed upstream ver: %s Available upstream ver: %s" | |
| 493 inst-auth-ver auth-ver))))) | |
| 428 | 494 |
| 495 (defun pui-display-info (&optional no-error event) | |
| 496 "Display additional package info in the modeline. | |
| 497 Designed to be called interactively (from a keypress)." | |
| 498 (interactive) | |
| 499 (let (extent) | |
| 500 (save-excursion | |
| 501 (beginning-of-line) | |
| 502 (if (setq extent (extent-at (point) (current-buffer) 'pui)) | |
| 503 (message (pui-help-echo extent t)) | |
| 504 (if no-error | |
| 505 (clear-message nil) | |
| 1410 | 506 (error 'invalid-operation |
| 507 "No package under cursor!")))))) | |
| 428 | 508 |
| 1742 | 509 (defun pui-display-maintainer (&optional no-error event) |
| 510 "Display a package's maintainer in the minibuffer." | |
| 511 (interactive) | |
| 2367 | 512 (let (extent ;pkg-sym |
| 513 info maintainer) | |
| 1742 | 514 (save-excursion |
| 515 (beginning-of-line) | |
| 516 (if (setq extent (extent-at (point) (current-buffer) 'pui)) | |
| 517 (progn | |
| 2367 | 518 (setq ;pkg-sym (extent-property extent 'pui-package) |
| 519 info (extent-property extent 'pui-info) | |
| 520 maintainer (package-get-info-prop info 'maintainer)) | |
| 1742 | 521 (message (format "Maintainer: %s" maintainer))) |
| 522 (if no-error | |
| 523 (clear-message nil) | |
| 524 (error 'invalid-operation | |
| 525 "No package under cursor!")))))) | |
| 526 | |
| 428 | 527 (defvar pui-menu |
| 528 '("Packages" | |
| 529 ["Toggle install " pui-toggle-package-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))] | |
| 530 ["Toggle delete " pui-toggle-package-delete-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))] | |
| 531 ["Info on" pui-display-info :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))] | |
| 532 "---" | |
| 533 ["Add Required" pui-add-required-packages t] | |
| 534 ["Install/Remove Selected" pui-install-selected-packages t] | |
| 535 "---" | |
| 536 ["Verbose" pui-toggle-verbosity-redisplay | |
| 537 :active t :style toggle :selected pui-list-verbose] | |
| 538 ["Refresh" pui-list-packages t] | |
| 539 ["Help" pui-help t] | |
| 540 ["Quit" pui-quit t])) | |
| 541 | |
| 442 | 542 ;;; "Why is there no standard function to do this?" |
| 543 (defun pui-popup-context-sensitive (event) | |
| 544 (interactive "e") | |
| 545 (save-excursion | |
| 546 (set-buffer (event-buffer event)) | |
| 547 (goto-char (event-point event)) | |
| 548 (popup-menu pui-menu event) | |
| 549 ;; I agree with dired.el - this is seriously bogus. | |
| 550 (while (popup-up-p) | |
| 551 (dispatch-event (next-event))))) | |
| 428 | 552 |
| 553 (defun list-packages-mode () | |
| 554 "Symbols in the leftmost column: | |
| 555 | |
| 556 + The package is marked for installation. | |
| 557 - The package has not been installed. | |
| 558 D The package has been marked for deletion. | |
| 559 * The currently installed package is old, and a newer version is | |
| 560 available. | |
| 561 | |
| 562 Useful keys: | |
| 563 | |
| 564 `\\[pui-toggle-package-key]' to select/unselect the current package for installation. | |
| 565 `\\[pui-toggle-package-delete-key]' to select/unselect the current package for removal. | |
| 566 `\\[pui-add-required-packages]' to add any packages required by those selected. | |
| 567 `\\[pui-install-selected-packages]' to install/delete selected packages. | |
| 1742 | 568 `\\[pui-display-info]' to display additional information about the package in the minibuffer. |
| 569 `\\[pui-display-maintainer]' to display the package's maintainer in the minibuffer | |
| 428 | 570 `\\[pui-list-packages]' to refresh the package list. |
| 571 `\\[pui-toggle-verbosity-redisplay]' to toggle between a verbose and non-verbose display. | |
| 572 `\\[pui-quit]' to kill this buffer. | |
| 573 " | |
| 1410 | 574 (error 'invalid-operation |
| 575 "You cannot enter this mode directly. Use `pui-list-packages'")) | |
| 428 | 576 |
| 577 (put 'list-packages-mode 'mode-class 'special) | |
| 578 | |
| 579 ;;;###autoload | |
| 580 (defun pui-list-packages () | |
| 581 "List all packages and package information. | |
| 582 The package name, version, and description are displayed. From the displayed | |
| 583 buffer, the user can see which packages are installed, which are not, and | |
| 584 which are out-of-date (a newer version is available). The user can then | |
| 585 select packages for installation via the keyboard or mouse." | |
| 586 (interactive) | |
| 587 (package-get-require-base t) | |
| 1365 | 588 (let ((outbuf (get-buffer-create pui-info-buffer)) |
| 589 (sep-string "===============================================================================\n") | |
| 590 start) | |
| 428 | 591 (message "Creating package list ...") (sit-for 0) |
| 592 (set-buffer outbuf) | |
| 593 (setq buffer-read-only nil) | |
| 594 (buffer-disable-undo outbuf) | |
| 595 (erase-buffer outbuf) | |
| 596 (kill-all-local-variables) | |
| 597 (use-local-map pui-display-keymap) | |
| 598 (setq major-mode 'list-packages-mode) | |
| 599 (setq mode-name "Packages") | |
| 600 (setq truncate-lines t) | |
| 601 | |
| 602 (unless package-get-remote | |
| 603 (insert " | |
| 604 Warning: No download sites specified. Package index may be out of date. | |
| 605 If you intend to install packages, specify download sites first. | |
| 606 | |
| 607 ")) | |
| 608 | |
| 609 (if pui-list-verbose | |
| 2598 | 610 (insert " Latest Installed |
| 611 Package name Vers. Vers. Description | |
| 428 | 612 ") |
| 2598 | 613 (insert " Latest |
| 614 Package name Vers. Description | |
| 428 | 615 ")) |
| 616 (insert sep-string) | |
| 617 (setq start (point)) | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2598
diff
changeset
|
618 (mapc |
| 442 | 619 #'(lambda (pkg) |
| 620 (let (pkg-sym info version desc | |
| 621 b e extent current-vers disp) | |
| 622 (setq pkg-sym (car pkg) | |
| 623 info (package-get-info-version (cdr pkg) nil)) | |
| 624 (setq version (package-get-info-prop info 'version) | |
| 625 desc (package-get-info-prop info 'description)) | |
| 428 | 626 |
| 442 | 627 (setq disp (pui-package-symbol-char pkg-sym |
| 628 version)) | |
| 629 (setq b (point)) | |
| 630 (if pui-list-verbose | |
| 631 (progn | |
| 632 (setq current-vers (package-get-key pkg-sym :version)) | |
| 633 (cond | |
| 1365 | 634 ((not current-vers) |
| 635 (setq current-vers "-----")) | |
| 636 ((stringp current-vers) | |
| 637 (setq current-vers | |
| 638 (format "%.2f" | |
| 639 (string-to-number current-vers)))) | |
| 640 ((numberp current-vers) | |
| 641 (setq current-vers (format "%.2f" current-vers)))) | |
| 442 | 642 (insert |
| 2598 | 643 (format "%s %-20s %-5.2f %-5s %s\n" |
| 442 | 644 (car disp) pkg-sym |
| 645 (if (stringp version) | |
| 646 (string-to-number version) | |
| 647 version) | |
| 1365 | 648 current-vers desc))) |
| 2598 | 649 (insert (format "%s %-20s %-5s %s\n" |
| 442 | 650 (car disp) |
| 651 pkg-sym version desc))) | |
| 652 (save-excursion | |
| 653 (setq e (progn | |
| 654 (forward-line -1) | |
| 655 (end-of-line) | |
| 656 (point)))) | |
| 657 (setq extent (make-extent b e)) | |
| 658 (if (car (cdr disp)) | |
| 659 (set-extent-face extent (get-face (car (cdr disp)))) | |
| 660 (set-extent-face extent (get-face 'default))) | |
| 661 (set-extent-property extent 'highlight t) | |
| 662 (set-extent-property extent 'pui t) | |
| 663 (set-extent-property extent 'pui-package pkg-sym) | |
| 664 (set-extent-property extent 'pui-info info) | |
| 665 (set-extent-property extent 'help-echo 'pui-help-echo) | |
| 1365 | 666 (set-extent-property extent 'keymap pui-package-keymap))) |
| 442 | 667 (sort (copy-sequence package-get-base) |
| 668 #'(lambda (a b) | |
| 669 (string< (symbol-name (car a)) | |
| 670 (symbol-name (car b)))))) | |
| 428 | 671 (insert sep-string) |
| 672 (insert (documentation 'list-packages-mode)) | |
| 673 (set-buffer-modified-p nil) | |
| 674 (setq buffer-read-only t) | |
| 675 (pop-to-buffer outbuf) | |
| 676 (delete-other-windows) | |
| 677 (goto-char start) | |
| 678 (setq pui-selected-packages nil) ; Reset list | |
| 679 (setq pui-deleted-packages nil) ; Reset list | |
| 680 (when (featurep 'menubar) | |
| 681 (set-buffer-menubar current-menubar) | |
| 682 (add-submenu '() pui-menu) | |
| 683 (setq mode-popup-menu pui-menu)) | |
| 1365 | 684 (clear-message))) |
| 428 | 685 |
| 686 ;;;###autoload | |
| 687 (defalias 'list-packages 'pui-list-packages) | |
| 688 | |
| 689 (provide 'package-ui) | |
| 690 | |
| 691 ;;; package-ui.el ends here |