Mercurial > hg > xemacs-beta

comparison lisp/package-ui.el @ 384:bbff43aa5eb7 r21-2-7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-7
author cvs
date Mon, 13 Aug 2007 11:08:24 +0200
parents d883f39b8495
children 7d59cb494b73
comparison
equal deleted inserted replaced
383:6a50c6a581a5 384:bbff43aa5eb7
60 "*The face to use for selected packages. 60 "*The face to use for selected packages.
61 Set this to `nil' to use the `default' face." 61 Set this to `nil' to use the `default' face."
62 :group 'pui 62 :group 'pui
63 :type 'face) 63 :type 'face)
64 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
65 (defcustom pui-outdated-package-face 'red 71 (defcustom pui-outdated-package-face 'red
66 "*The face to use for outdated packages. 72 "*The face to use for outdated packages.
67 Set this to `nil' to use the `default' face." 73 Set this to `nil' to use the `default' face."
68 :group 'pui 74 :group 'pui
69 :type 'face) 75 :type 'face)
85 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 91 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
86 92
87 (defvar pui-selected-packages nil 93 (defvar pui-selected-packages nil
88 "The list of user-selected packages to install.") 94 "The list of user-selected packages to install.")
89 95
96 (defvar pui-deleted-packages nil
97 "The list of user-selected packages to remove.")
98
99 (defvar pui-actual-package "")
100
90 (defvar pui-display-keymap 101 (defvar pui-display-keymap
91 (let ((m (make-keymap))) 102 (let ((m (make-keymap)))
92 (suppress-keymap m) 103 (suppress-keymap m)
93 (set-keymap-name m 'pui-display-keymap) 104 (set-keymap-name m 'pui-display-keymap)
94 (define-key m "q" 'pui-quit) 105 (define-key m "q" 'pui-quit)
95 (define-key m "g" 'pui-list-packages) 106 (define-key m "g" 'pui-list-packages)
96 (define-key m " " 'pui-display-info) 107 (define-key m "i" 'pui-display-info)
97 (define-key m "?" 'pui-help) 108 (define-key m "?" 'describe-mode)
98 (define-key m "v" 'pui-toggle-verbosity-redisplay) 109 (define-key m "v" 'pui-toggle-verbosity-redisplay)
99 (define-key m "d" 'pui-toggle-verbosity-redisplay) 110 (define-key m "d" 'pui-toggle-package-delete-key)
111 (define-key m "D" 'pui-toggle-package-delete-key)
100 (define-key m [return] 'pui-toggle-package-key) 112 (define-key m [return] 'pui-toggle-package-key)
101 (define-key m "x" 'pui-install-selected-packages) 113 (define-key m "x" 'pui-install-selected-packages)
102 (define-key m "I" 'pui-install-selected-packages) 114 (define-key m "I" 'pui-install-selected-packages)
103 (define-key m "r" 'pui-add-required-packages) 115 (define-key m "r" 'pui-add-required-packages)
104 (define-key m "n" 'next-line) 116 (define-key m "n" 'next-line)
105 (define-key m "+" 'next-line) 117 (define-key m "+" 'pui-toggle-package-key)
106 (define-key m "p" 'previous-line) 118 (define-key m "p" 'previous-line)
107 (define-key m "-" 'previous-line) 119 (define-key m " " 'scroll-up-command)
120 (define-key m [delete] 'scroll-down-command)
108 m) 121 m)
109 "Keymap to use in the `pui-info-buffer' buffer") 122 "Keymap to use in the `pui-info-buffer' buffer")
110 123
111 (defvar pui-package-keymap 124 (defvar pui-package-keymap
112 (let ((m (make-sparse-keymap))) 125 (let ((m (make-sparse-keymap)))
113 (set-keymap-name m 'pui-package-keymap) 126 (set-keymap-name m 'pui-package-keymap)
114 (define-key m 'button2 'pui-toggle-package-event) 127 (define-key m 'button2 'pui-toggle-package-event)
115 ;; We use a popup menu 128 ;; We use a popup menu
116 ;; (define-key m 'button3 'pui-toggle-package-event) 129 (define-key m 'button3 'pui-popup-context-sensitive)
117 m) 130 m)
118 "Keymap to use over package names/descriptions.") 131 "Keymap to use over package names/descriptions.")
119 132
120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 133 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
121 ;; End of variables 134 ;; End of variables
156 (setq paths (cdr paths)) 169 (setq paths (cdr paths))
157 ) 170 )
158 (insert "\nThese are the places that will be searched for package binaries.\n") 171 (insert "\nThese are the places that will be searched for package binaries.\n")
159 (goto-char (point-min)) 172 (goto-char (point-min))
160 )) 173 ))
174
175 ;;;###autoload
176 (defun package-ui-add-site (site)
177 "Add site to package-get-remote and possibly offer to update package list."
178 (let ((had-none (null package-get-remote)))
179 (push site package-get-remote)
180 (when (and had-none package-get-was-current
181 (y-or-n-p "Update Package list?"))
182 (setq package-get-was-current nil)
183 (package-get-require-base t)
184 (if (get-buffer pui-info-buffer)
185 (save-window-excursion
186 (pui-list-packages))))
187 (set-menubar-dirty-flag)))
188
161 189
162 ;;;###autoload 190 ;;;###autoload
163 (defun pui-add-install-directory (dir) 191 (defun pui-add-install-directory (dir)
164 "Add a new package binary directory to the head of `package-get-remote'. 192 "Add a new package binary directory to the head of `package-get-remote'.
165 Note that no provision is made for saving any changes made by this function. 193 Note that no provision is made for saving any changes made by this function.
196 224
197 (defun pui-quit () 225 (defun pui-quit ()
198 (interactive) 226 (interactive)
199 (kill-buffer nil)) 227 (kill-buffer nil))
200 228
201 (defun pui-help ()
202 (interactive)
203 (let ( (help-buffer (get-buffer-create "*Help*")) )
204 (display-buffer help-buffer t)
205 (save-window-excursion
206 (set-buffer help-buffer)
207 (buffer-disable-undo help-buffer)
208 (erase-buffer help-buffer)
209 (insert (pui-help-string))
210 )
211 ))
212
213 (defun pui-package-symbol-char (pkg-sym version) 229 (defun pui-package-symbol-char (pkg-sym version)
214 (progn 230 (progn
215 (if (package-get-info-find-package packages-package-list pkg-sym) 231 (if (package-get-info-find-package packages-package-list pkg-sym)
216 (let ((installed (package-get-key pkg-sym :version))) 232 (let ((installed (package-get-key pkg-sym :version)))
217 (if (>= (if (stringp installed) 233 (if (>= (if (stringp installed)
234 (if (not pkg-sym) 250 (if (not pkg-sym)
235 (setq pkg-sym (extent-property extent 'pui-package))) 251 (setq pkg-sym (extent-property extent 'pui-package)))
236 (if (not version) 252 (if (not version)
237 (setq version (package-get-info-prop (extent-property extent 'pui-info) 253 (setq version (package-get-info-prop (extent-property extent 'pui-info)
238 'version))) 254 'version)))
239 (if (member pkg-sym pui-selected-packages) 255 (cond ((member pkg-sym pui-selected-packages)
240 (progn 256 (if pui-selected-package-face
241 (if pui-selected-package-face 257 (set-extent-face extent (get-face pui-selected-package-face))
242 (set-extent-face extent (get-face pui-selected-package-face)) 258 (set-extent-face extent (get-face 'default)))
243 (set-extent-face extent (get-face 'default))) 259 (setq sym-char "+"))
244 (setq sym-char "+") 260 ((member pkg-sym pui-deleted-packages)
245 ) 261 (if pui-deleted-package-face
246 (progn 262 (set-extent-face extent (get-face pui-deleted-package-face))
247 (setq disp (pui-package-symbol-char pkg-sym version)) 263 (set-extent-face extent (get-face 'default)))
248 (setq sym-char (car disp)) 264 (setq sym-char "D"))
249 (if (car (cdr disp)) 265 (t
250 (set-extent-face extent (get-face (car (cdr disp)))) 266 (setq disp (pui-package-symbol-char pkg-sym version))
251 (set-extent-face extent (get-face 'default))) 267 (setq sym-char (car disp))
252 )) 268 (if (car (cdr disp))
269 (set-extent-face extent (get-face (car (cdr disp))))
270 (set-extent-face extent (get-face 'default)))))
253 (save-excursion 271 (save-excursion
254 (goto-char (extent-start-position extent)) 272 (goto-char (extent-start-position extent))
255 (delete-char 1) 273 (delete-char 1)
256 (insert sym-char) 274 (insert sym-char)
257 (set-buffer-modified-p nil) 275 (set-buffer-modified-p nil)
263 (setq pkg-sym (extent-property extent 'pui-package)) 281 (setq pkg-sym (extent-property extent 'pui-package))
264 (if (member pkg-sym pui-selected-packages) 282 (if (member pkg-sym pui-selected-packages)
265 (setq pui-selected-packages 283 (setq pui-selected-packages
266 (delete pkg-sym pui-selected-packages)) 284 (delete pkg-sym pui-selected-packages))
267 (setq pui-selected-packages 285 (setq pui-selected-packages
268 (cons pkg-sym pui-selected-packages))) 286 (cons pkg-sym pui-selected-packages))
287 (setq pui-deleted-packages
288 (delete pkg-sym pui-deleted-packages)))
269 (pui-update-package-display extent pkg-sym) 289 (pui-update-package-display extent pkg-sym)
270 )) 290 ))
271 291
272 (defun pui-toggle-package-key () 292 (defun pui-toggle-package-key ()
273 "Select/unselect package for installation, using the keyboard." 293 "Select/unselect package for installation, using the keyboard."
279 (forward-line 1) 299 (forward-line 1)
280 ) 300 )
281 (error "No package under cursor!")) 301 (error "No package under cursor!"))
282 )) 302 ))
283 303
304 (defun pui-toggle-package-delete (extent)
305 (let (pkg-sym)
306 (setq pkg-sym (extent-property extent 'pui-package))
307 (if (member pkg-sym pui-deleted-packages)
308 (setq pui-deleted-packages
309 (delete pkg-sym pui-deleted-packages))
310 (setq pui-deleted-packages
311 (cons pkg-sym pui-deleted-packages))
312 (setq pui-seleted-packages
313 (delete pkg-sym pui-selected-packages)))
314 (pui-update-package-display extent pkg-sym)
315 ))
316
317
318 (defun pui-toggle-package-delete-key ()
319 "Select/unselect package for removal, using the keyboard."
320 (interactive)
321 (let (extent)
322 (if (setq extent (extent-at (point) (current-buffer) 'pui))
323 (progn
324 (pui-toggle-package-delete extent)
325 (forward-line 1)
326 )
327 (error "No package under cursor!"))
328 ))
329
330 (defun pui-current-package ()
331 (let ((extent (extent-at (point) (current-buffer) 'pui)))
332 (if extent
333 (extent-property extent 'pui-package))))
334
284 (defun pui-toggle-package-event (event) 335 (defun pui-toggle-package-event (event)
285 "Select/unselect package for installation, using the mouse." 336 "Select/unselect package for installation, using the mouse."
286 (interactive "e") 337 (interactive "e")
287 (let* ( (ep (event-point event)) 338 (let* ( (ep (event-point event))
288 (buffer (window-buffer (event-window event))) 339 (buffer (window-buffer (event-window event)))
300 )) 351 ))
301 352
302 (defun pui-install-selected-packages () 353 (defun pui-install-selected-packages ()
303 "Install selected packages." 354 "Install selected packages."
304 (interactive) 355 (interactive)
356 (let ( (tmpbuf "*Packages-To-Remove*") do-delete)
357 (when pui-deleted-packages
358 (save-window-excursion
359 (with-output-to-temp-buffer tmpbuf
360 (display-completion-list (sort
361 (mapcar '(lambda (pkg)
362 (symbol-name pkg)
363 )
364 pui-deleted-packages)
365 'string<)
366 :activate-callback nil
367 :help-string "Packages selected for removal:\n"
368 :completion-string t
369 ))
370 (setq tmpbuf (get-buffer-create tmpbuf))
371 (display-buffer tmpbuf)
372 (setq do-delete (yes-or-no-p "Remove these packages? "))
373 (kill-buffer tmpbuf))
374 (when do-delete
375 (message "Deleting selected packages ...") (sit-for 0)
376 (when (catch 'done
377 (mapcar (lambda (pkg)
378 (if (not
379 (package-admin-delete-binary-package
380 pkg (package-admin-get-install-dir pkg nil)))
381 (throw 'done nil)))
382 pui-deleted-packages)
383 t)
384 (message "Packages deleted")
385 ))))
386
305 (let ( (tmpbuf "*Packages-To-Install*") do-install) 387 (let ( (tmpbuf "*Packages-To-Install*") do-install)
306 (if pui-selected-packages 388 (if pui-selected-packages
307 (progn 389 (progn
308 ;; Don't change window config when asking the user if he really 390 ;; Don't change window config when asking the user if he really
309 ;; wants to install the packages. We do this to avoid messing up 391 ;; wants to install the packages. We do this to avoid messing up
349 )) 431 ))
350 ) 432 )
351 (clear-message) 433 (clear-message)
352 ) 434 )
353 ) 435 )
354 (error "No packages have been selected!")) 436 (if pui-deleted-packages
437 (pui-list-packages)
438 (error "No packages have been selected!")))
355 )) 439 ))
356 440
357 (defun pui-add-required-packages () 441 (defun pui-add-required-packages ()
358 "Select packages required by those already selected for installation." 442 "Select packages required by those already selected for installation."
359 (interactive) 443 (interactive)
432 (format "%-6s: %-8s %11s: %s" 516 (format "%-6s: %-8s %11s: %s"
433 inst-ver auth-ver date maintainer)) 517 inst-ver auth-ver date maintainer))
434 )) 518 ))
435 )) 519 ))
436 520
437 (defun pui-display-info (&optional no-error) 521 (defun pui-display-info (&optional no-error event)
438 "Display additional package info in the modeline. 522 "Display additional package info in the modeline.
439 Designed to be called interactively (from a keypress)." 523 Designed to be called interactively (from a keypress)."
440 (interactive) 524 (interactive)
441 (let (extent) 525 (let (extent)
442 (save-excursion 526 (save-excursion
443 (beginning-of-line) 527 (beginning-of-line)
444 (if (setq extent (extent-at (point) (current-buffer) 'pui)) 528 (if (setq extent (extent-at (point) (current-buffer) 'pui))
445 (message (pui-help-echo extent t)) 529 (message (pui-help-echo extent t))
446 (if no-error 530 (if no-error
447 (clear-message nil) 531 (clear-message nil)
448 (error "No package under cursor!"))) 532 (error "No package under cursor!")))
449 ))) 533 )))
450 534
451 (defun pui-help-string () 535 ;;; "Why is there no standard function to do this?"
452 "Return the help string for the package-info buffer. 536 (defun pui-popup-context-sensitive (event)
453 This is not a defconst because of the call to substitute-command-keys." 537 (interactive "e")
454 (save-excursion 538 (save-excursion
455 (set-buffer (get-buffer pui-info-buffer)) 539 (set-buffer (event-buffer event))
456 (substitute-command-keys 540 (goto-char (event-point event))
457 "Symbols in the leftmost column: 541 (popup-menu pui-menu event)
458 542 ;; I agreee with dired.el this is seriously bogus.
459 + The package is marked for installation. 543 (while (popup-menu-up-p)
460 - The package has not been installed. 544 (dispatch-event (next-event)))))
461 * The currently installed package is old, and a newer version is
462 available.
463
464 Useful keys:
465
466 `\\[pui-toggle-package-key]' to select/unselect the current package for installation.
467 `\\[pui-add-required-packages]' to add any packages required by those selected.
468 `\\[pui-install-selected-packages]' to install selected packages.
469 `\\[pui-display-info]' to display additional information about the package in the modeline.
470 `\\[pui-list-packages]' to refresh the package list.
471 `\\[pui-toggle-verbosity-redisplay]' to toggle between a verbose and non-verbose display.
472 `\\[pui-quit]' to kill this buffer.
473 ")
474 ))
475 545
476 (defvar pui-menu 546 (defvar pui-menu
477 '("Packages" 547 '("Packages"
478 ["Select" pui-toggle-package-key t] 548 ["Toggle install " pui-toggle-package-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))]
479 ["Info" pui-display-info t] 549 ["Toggle delete " pui-toggle-package-delete-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))]
550 ["Info on" pui-display-info :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))]
480 "---" 551 "---"
481 ["Add Required" pui-add-required-packages t] 552 ["Add Required" pui-add-required-packages t]
482 ["Install Selected" pui-install-selected-packages t] 553 ["Install/Remove Selected" pui-install-selected-packages t]
483 "---" 554 "---"
484 ["Verbose" pui-toggle-verbosity-redisplay 555 ["Verbose" pui-toggle-verbosity-redisplay
485 :active t :style toggle :selected pui-list-verbose] 556 :active t :style toggle :selected pui-list-verbose]
486 ["Refresh" pui-list-packages t] 557 ["Refresh" pui-list-packages t]
487 ["Help" pui-help t] 558 ["Help" pui-help t]
488 ["Quit" pui-quit t])) 559 ["Quit" pui-quit t]))
489 560
561
562 (defun list-packages-mode ()
563 "Symbols in the leftmost column:
564
565 + The package is marked for installation.
566 - The package has not been installed.
567 D The package has been marked for deletion.
568 * The currently installed package is old, and a newer version is
569 available.
570
571 Useful keys:
572
573 `\\[pui-toggle-package-key]' to select/unselect the current package for installation.
574 `\\[pui-toggle-package-delete-key]' to select/unselect the current package for removal.
575 `\\[pui-add-required-packages]' to add any packages required by those selected.
576 `\\[pui-install-selected-packages]' to install/delete selected packages.
577 `\\[pui-display-info]' to display additional information about the package in the modeline.
578 `\\[pui-list-packages]' to refresh the package list.
579 `\\[pui-toggle-verbosity-redisplay]' to toggle between a verbose and non-verbose display.
580 `\\[pui-quit]' to kill this buffer.
581 "
582 (error "You cannot enter this mode directly. Use `pui-list-packages'"))
583
584 (put 'list-packages-mode 'mode-class 'special)
490 585
491 ;;;###autoload 586 ;;;###autoload
492 (defun pui-list-packages () 587 (defun pui-list-packages ()
493 "List all packages and package information. 588 "List all packages and package information.
494 The package name, version, and description are displayed. From the displayed 589 The package name, version, and description are displayed. From the displayed
503 (message "Creating package list ...") (sit-for 0) 598 (message "Creating package list ...") (sit-for 0)
504 (set-buffer outbuf) 599 (set-buffer outbuf)
505 (setq buffer-read-only nil) 600 (setq buffer-read-only nil)
506 (buffer-disable-undo outbuf) 601 (buffer-disable-undo outbuf)
507 (erase-buffer outbuf) 602 (erase-buffer outbuf)
603 (kill-all-local-variables)
508 (use-local-map pui-display-keymap) 604 (use-local-map pui-display-keymap)
605 (setq major-mode 'list-packages-mode)
606 (setq mode-name "Packages")
607 (setq truncate-lines t)
608
609 (unless package-get-remote
610 (insert "
611 Warning: No download sites specified. Package index may be out of date.
612 If you intend to install packages, specify download sites first.
613
614 "))
615
509 (if pui-list-verbose 616 (if pui-list-verbose
510 (insert " Latest Installed 617 (insert " Latest Installed
511 Package name Vers. Vers. Description 618 Package name Vers. Vers. Description
512 ") 619 ")
513 (insert " Latest 620 (insert " Latest
575 '(lambda (a b) 682 '(lambda (a b)
576 (string< (symbol-name (car a)) 683 (string< (symbol-name (car a))
577 (symbol-name (car b))) 684 (symbol-name (car b)))
578 ))) 685 )))
579 (insert sep-string) 686 (insert sep-string)
580 (insert (pui-help-string)) 687 (insert (documentation 'list-packages-mode))
581 (set-buffer-modified-p nil) 688 (set-buffer-modified-p nil)
582 (setq buffer-read-only t) 689 (setq buffer-read-only t)
583 (pop-to-buffer outbuf) 690 (pop-to-buffer outbuf)
584 (delete-other-windows) 691 (delete-other-windows)
585 (goto-char start) 692 (goto-char start)
586 (setq pui-selected-packages nil) ; Reset list 693 (setq pui-selected-packages nil) ; Reset list
694 (setq pui-deleted-packages nil) ; Reset list
587 (when (featurep 'menubar) 695 (when (featurep 'menubar)
588 (set-buffer-menubar current-menubar) 696 (set-buffer-menubar current-menubar)
589 (add-submenu '() pui-menu) 697 (add-submenu '() pui-menu)
590 (setq mode-popup-menu pui-menu)) 698 (setq mode-popup-menu pui-menu))
591 (clear-message) 699 (clear-message)
592 ; (message (substitute-command-keys "Press `\\[pui-help]' for help.")) 700 ; (message (substitute-command-keys "Press `\\[pui-help]' for help."))
593 )) 701 ))
594 702
703 ;;;###autoload
704 (defalias 'list-packages 'pui-list-packages)
595 705
596 (provide 'package-ui) 706 (provide 'package-ui)
597 707
598 ;;; package-ui.el ends here 708 ;;; package-ui.el ends here