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