Mercurial > hg > xemacs-beta
annotate lisp/package-ui.el @ 5324:d0bb90d90736
Provide #'device-x-display, as documented in Lispref; thanks, Jeff Mincy.
lisp/ChangeLog addition:
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* x-misc.el (device-x-display):
Provide this function, documented in the Lispref for years, but
not existing previously. Thank you Julian Bradfield, thank you
Jeff Mincy.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 30 Dec 2010 13:46:50 +0000 |
| parents | 668c73e222fd |
| children | 311f6817efc2 308d34e9f07d |
| 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 | |
|
5267
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
411 (mapcan |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
412 (lambda (pkg) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
413 (let ((installed |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
414 (package-get-key pkg :version)) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
415 (current |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
416 (package-get-info-prop |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
417 (package-get-info-version |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
418 (package-get-info-find-package |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
419 package-get-base pkg) nil) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
420 'version))) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
421 (if (or (null installed) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
422 (< (if (stringp installed) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
423 (string-to-number installed) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
424 installed) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
425 (if (stringp current) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
426 (string-to-number current) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
427 current))) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
428 (list pkg)))) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
5182
diff
changeset
|
429 (package-get-dependencies pui-selected-packages)))) |
| 428 | 430 ;; Don't change window config when asking the user if he really |
| 431 ;; wants to add the packages. We do this to avoid messing up | |
| 432 ;; the window configuration if errors occur (we don't want to | |
| 433 ;; display random buffers in addition to the error buffer, if | |
| 434 ;; errors occur, which would normally be caused by display-buffer). | |
| 435 (save-window-excursion | |
| 436 (with-output-to-temp-buffer tmpbuf | |
| 437 (display-completion-list (sort | |
| 438 (mapcar #'(lambda (pkg) | |
| 439 (symbol-name pkg)) | |
| 440 dependencies) | |
| 441 'string<) | |
| 442 :activate-callback nil | |
| 443 :help-string "Required packages:\n" | |
| 444 :completion-string t)) | |
| 445 (setq tmpbuf (get-buffer-create tmpbuf)) | |
| 446 (display-buffer tmpbuf) | |
| 447 (setq do-select (y-or-n-p "Select these packages? ")) | |
| 448 (kill-buffer tmpbuf)) | |
| 449 (if do-select | |
| 450 (progn | |
| 451 (setq pui-selected-packages | |
| 452 (union pui-selected-packages dependencies)) | |
| 453 (map-extents #'(lambda (extent maparg) | |
| 454 (pui-update-package-display extent)) | |
| 455 nil nil nil nil nil 'pui) | |
| 456 (message "added dependencies")) | |
| 457 (clear-message))) | |
| 1410 | 458 (error 'invalid-operation |
| 459 "No packages have been selected!")))) | |
| 428 | 460 |
| 461 (defun pui-help-echo (extent &optional force-update) | |
| 462 "Display additional package info in the modeline. | |
| 463 EXTENT determines the package to display (the package information is | |
| 464 attached to the extent as properties)." | |
| 1742 | 465 (let (pkg-sym info inst-ver inst-auth-ver auth-ver date maintainer balloon req) |
| 428 | 466 (if (or force-update (not (current-message)) |
| 1365 | 467 (string-match ".*: .*: " (current-message))) |
| 428 | 468 (progn |
| 469 (setq pkg-sym (extent-property extent 'pui-package) | |
| 470 info (extent-property extent 'pui-info) | |
| 471 inst-ver (package-get-key pkg-sym :version) | |
| 1742 | 472 inst-auth-ver (package-get-key pkg-sym :author-version) |
| 428 | 473 auth-ver (package-get-info-prop info 'author-version) |
| 474 date (package-get-info-prop info 'date) | |
| 852 | 475 maintainer (package-get-info-prop info 'maintainer) |
| 476 req (package-get-info-prop info 'requires)) | |
| 428 | 477 (if (not inst-ver) |
| 852 | 478 (setq inst-ver 0)) |
| 479 (if (featurep 'balloon-help) | |
| 480 (progn | |
| 481 (setq balloon (format " | |
| 2146 | 482 Package Information: [For package: \"%s\"]\n================ |
| 1742 | 483 Installed Upstream Ver: %s Available Upstream Ver: %s |
| 852 | 484 Maintainer : %s |
| 485 Released : %s | |
| 486 Required Packages : %s\n\n" | |
| 1742 | 487 pkg-sym inst-auth-ver auth-ver maintainer |
| 852 | 488 date req)) |
| 489 (set-extent-property extent 'balloon-help balloon))) | |
| 1742 | 490 (format |
| 491 "Installed upstream ver: %s Available upstream ver: %s" | |
| 492 inst-auth-ver auth-ver))))) | |
| 428 | 493 |
| 494 (defun pui-display-info (&optional no-error event) | |
| 495 "Display additional package info in the modeline. | |
| 496 Designed to be called interactively (from a keypress)." | |
| 497 (interactive) | |
| 498 (let (extent) | |
| 499 (save-excursion | |
| 500 (beginning-of-line) | |
| 501 (if (setq extent (extent-at (point) (current-buffer) 'pui)) | |
| 502 (message (pui-help-echo extent t)) | |
| 503 (if no-error | |
| 504 (clear-message nil) | |
| 1410 | 505 (error 'invalid-operation |
| 506 "No package under cursor!")))))) | |
| 428 | 507 |
| 1742 | 508 (defun pui-display-maintainer (&optional no-error event) |
| 509 "Display a package's maintainer in the minibuffer." | |
| 510 (interactive) | |
| 2367 | 511 (let (extent ;pkg-sym |
| 512 info maintainer) | |
| 1742 | 513 (save-excursion |
| 514 (beginning-of-line) | |
| 515 (if (setq extent (extent-at (point) (current-buffer) 'pui)) | |
| 516 (progn | |
| 2367 | 517 (setq ;pkg-sym (extent-property extent 'pui-package) |
| 518 info (extent-property extent 'pui-info) | |
| 519 maintainer (package-get-info-prop info 'maintainer)) | |
| 1742 | 520 (message (format "Maintainer: %s" maintainer))) |
| 521 (if no-error | |
| 522 (clear-message nil) | |
| 523 (error 'invalid-operation | |
| 524 "No package under cursor!")))))) | |
| 525 | |
| 428 | 526 (defvar pui-menu |
| 527 '("Packages" | |
| 528 ["Toggle install " pui-toggle-package-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))] | |
| 529 ["Toggle delete " pui-toggle-package-delete-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))] | |
| 530 ["Info on" pui-display-info :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))] | |
| 531 "---" | |
| 532 ["Add Required" pui-add-required-packages t] | |
| 533 ["Install/Remove Selected" pui-install-selected-packages t] | |
| 534 "---" | |
| 535 ["Verbose" pui-toggle-verbosity-redisplay | |
| 536 :active t :style toggle :selected pui-list-verbose] | |
| 537 ["Refresh" pui-list-packages t] | |
| 538 ["Help" pui-help t] | |
| 539 ["Quit" pui-quit t])) | |
| 540 | |
| 442 | 541 ;;; "Why is there no standard function to do this?" |
| 542 (defun pui-popup-context-sensitive (event) | |
| 543 (interactive "e") | |
| 544 (save-excursion | |
| 545 (set-buffer (event-buffer event)) | |
| 546 (goto-char (event-point event)) | |
| 547 (popup-menu pui-menu event) | |
| 548 ;; I agree with dired.el - this is seriously bogus. | |
| 549 (while (popup-up-p) | |
| 550 (dispatch-event (next-event))))) | |
| 428 | 551 |
| 552 (defun list-packages-mode () | |
| 553 "Symbols in the leftmost column: | |
| 554 | |
| 555 + The package is marked for installation. | |
| 556 - The package has not been installed. | |
| 557 D The package has been marked for deletion. | |
| 558 * The currently installed package is old, and a newer version is | |
| 559 available. | |
| 560 | |
| 561 Useful keys: | |
| 562 | |
| 563 `\\[pui-toggle-package-key]' to select/unselect the current package for installation. | |
| 564 `\\[pui-toggle-package-delete-key]' to select/unselect the current package for removal. | |
| 565 `\\[pui-add-required-packages]' to add any packages required by those selected. | |
| 566 `\\[pui-install-selected-packages]' to install/delete selected packages. | |
| 1742 | 567 `\\[pui-display-info]' to display additional information about the package in the minibuffer. |
| 568 `\\[pui-display-maintainer]' to display the package's maintainer in the minibuffer | |
| 428 | 569 `\\[pui-list-packages]' to refresh the package list. |
| 570 `\\[pui-toggle-verbosity-redisplay]' to toggle between a verbose and non-verbose display. | |
| 571 `\\[pui-quit]' to kill this buffer. | |
| 572 " | |
| 1410 | 573 (error 'invalid-operation |
| 574 "You cannot enter this mode directly. Use `pui-list-packages'")) | |
| 428 | 575 |
| 576 (put 'list-packages-mode 'mode-class 'special) | |
| 577 | |
| 578 ;;;###autoload | |
| 579 (defun pui-list-packages () | |
| 580 "List all packages and package information. | |
| 581 The package name, version, and description are displayed. From the displayed | |
| 582 buffer, the user can see which packages are installed, which are not, and | |
| 583 which are out-of-date (a newer version is available). The user can then | |
| 584 select packages for installation via the keyboard or mouse." | |
| 585 (interactive) | |
| 586 (package-get-require-base t) | |
| 1365 | 587 (let ((outbuf (get-buffer-create pui-info-buffer)) |
| 588 (sep-string "===============================================================================\n") | |
| 589 start) | |
| 428 | 590 (message "Creating package list ...") (sit-for 0) |
| 591 (set-buffer outbuf) | |
| 592 (setq buffer-read-only nil) | |
| 593 (buffer-disable-undo outbuf) | |
| 594 (erase-buffer outbuf) | |
| 595 (kill-all-local-variables) | |
| 596 (use-local-map pui-display-keymap) | |
| 597 (setq major-mode 'list-packages-mode) | |
| 598 (setq mode-name "Packages") | |
| 599 (setq truncate-lines t) | |
| 600 | |
| 601 (unless package-get-remote | |
| 602 (insert " | |
| 603 Warning: No download sites specified. Package index may be out of date. | |
| 604 If you intend to install packages, specify download sites first. | |
| 605 | |
| 606 ")) | |
| 607 | |
| 608 (if pui-list-verbose | |
| 2598 | 609 (insert " Latest Installed |
| 610 Package name Vers. Vers. Description | |
| 428 | 611 ") |
| 2598 | 612 (insert " Latest |
| 613 Package name Vers. Description | |
| 428 | 614 ")) |
| 615 (insert sep-string) | |
| 616 (setq start (point)) | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2598
diff
changeset
|
617 (mapc |
| 442 | 618 #'(lambda (pkg) |
| 619 (let (pkg-sym info version desc | |
| 620 b e extent current-vers disp) | |
| 621 (setq pkg-sym (car pkg) | |
| 622 info (package-get-info-version (cdr pkg) nil)) | |
| 623 (setq version (package-get-info-prop info 'version) | |
| 624 desc (package-get-info-prop info 'description)) | |
| 428 | 625 |
| 442 | 626 (setq disp (pui-package-symbol-char pkg-sym |
| 627 version)) | |
| 628 (setq b (point)) | |
| 629 (if pui-list-verbose | |
| 630 (progn | |
| 631 (setq current-vers (package-get-key pkg-sym :version)) | |
| 632 (cond | |
| 1365 | 633 ((not current-vers) |
| 634 (setq current-vers "-----")) | |
| 635 ((stringp current-vers) | |
| 636 (setq current-vers | |
| 637 (format "%.2f" | |
| 638 (string-to-number current-vers)))) | |
| 639 ((numberp current-vers) | |
| 640 (setq current-vers (format "%.2f" current-vers)))) | |
| 442 | 641 (insert |
| 2598 | 642 (format "%s %-20s %-5.2f %-5s %s\n" |
| 442 | 643 (car disp) pkg-sym |
| 644 (if (stringp version) | |
| 645 (string-to-number version) | |
| 646 version) | |
| 1365 | 647 current-vers desc))) |
| 2598 | 648 (insert (format "%s %-20s %-5s %s\n" |
| 442 | 649 (car disp) |
| 650 pkg-sym version desc))) | |
| 651 (save-excursion | |
| 652 (setq e (progn | |
| 653 (forward-line -1) | |
| 654 (end-of-line) | |
| 655 (point)))) | |
| 656 (setq extent (make-extent b e)) | |
| 657 (if (car (cdr disp)) | |
| 658 (set-extent-face extent (get-face (car (cdr disp)))) | |
| 659 (set-extent-face extent (get-face 'default))) | |
| 660 (set-extent-property extent 'highlight t) | |
| 661 (set-extent-property extent 'pui t) | |
| 662 (set-extent-property extent 'pui-package pkg-sym) | |
| 663 (set-extent-property extent 'pui-info info) | |
| 664 (set-extent-property extent 'help-echo 'pui-help-echo) | |
| 1365 | 665 (set-extent-property extent 'keymap pui-package-keymap))) |
|
5182
2e528066e2fc
Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4783
diff
changeset
|
666 (sort* (copy-sequence package-get-base) #'string< :key #'car)) |
| 428 | 667 (insert sep-string) |
| 668 (insert (documentation 'list-packages-mode)) | |
| 669 (set-buffer-modified-p nil) | |
| 670 (setq buffer-read-only t) | |
| 671 (pop-to-buffer outbuf) | |
| 672 (delete-other-windows) | |
| 673 (goto-char start) | |
| 674 (setq pui-selected-packages nil) ; Reset list | |
| 675 (setq pui-deleted-packages nil) ; Reset list | |
| 676 (when (featurep 'menubar) | |
| 677 (set-buffer-menubar current-menubar) | |
| 678 (add-submenu '() pui-menu) | |
| 679 (setq mode-popup-menu pui-menu)) | |
| 1365 | 680 (clear-message))) |
| 428 | 681 |
| 682 ;;;###autoload | |
| 683 (defalias 'list-packages 'pui-list-packages) | |
| 684 | |
| 685 (provide 'package-ui) | |
| 686 | |
| 687 ;;; package-ui.el ends here |