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