3 ;; Copyright (C) 1998 by Darryl Okahata
5 ;; Author: Darryl Okahata <darrylo@sr.hp.com>
8 ;; This file is part of XEmacs.
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)
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.
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
25 ;;; Synched up with: Not in FSF
27 (require 'package-get) ;; which, in turn, requires 'package-admin
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;; User-changeable variables:
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
34 "Convenient interface to the package system."
36 :tag "Package User interface"
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
44 :tag "Install Location"
45 :type '(choice (const :tag "Automatic" nil)
48 (defcustom pui-list-verbose t
49 "*If non-nil, display verbose info in the package list buffer."
51 :tag "Verbose Listing"
54 (defcustom pui-up-to-date-package-face nil
55 "*The face to use for packages that are up-to-date."
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."
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."
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."
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."
83 (defcustom pui-info-buffer "*Packages*"
84 "*Buffer to use for displaying package information."
88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
89 ;; End of user-changeable variables.
90 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
92 (defvar pui-selected-packages nil
93 "The list of user-selected packages to install.")
95 (defvar pui-deleted-packages nil
96 "The list of user-selected packages to remove.")
98 (defvar pui-actual-package "")
100 (defvar pui-display-keymap
101 (let ((m (make-keymap)))
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)
107 (define-key m "m" 'pui-display-maintainer)
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)
122 "Keymap to use in the `pui-info-buffer' buffer")
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)
131 "Keymap to use over package names/descriptions.")
133 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
137 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
138 ;; Configuration routines
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)))
144 (setq package-get-remote site)
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)))
155 (defun package-ui-download-menu ()
156 "Build the `Add Download Site' menu."
157 (mapcar (lambda (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
166 :selected `(equal package-get-remote (quote ,(cdr site)))))
167 package-get-download-sites))
170 (defun package-ui-pre-release-download-menu ()
171 "Build the 'Pre-Release Download Sites' menu."
172 (mapcar (lambda (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
181 :selected `(equal package-get-remote (quote ,(cdr site)))))
182 package-get-pre-release-download-sites))
185 (defun package-ui-site-release-download-menu ()
186 "Build the 'Site Release Download Sites' menu."
187 (mapcar (lambda (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
196 :selected `(equal package-get-remote (quote ,(cdr site)))))
197 package-get-site-release-download-sites))
200 (defun pui-set-local-package-get-directory ()
201 "Set a new package binary directory in `package-get-remote'.
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
206 (let ((dir (read-directory-name
207 "New package binary directory to add? "
209 (setq package-get-remote (list nil dir))
210 (message "Package directory \"%s\" added." dir)))
212 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
213 ;; Package list/installer routines
219 (defun pui-package-symbol-char (pkg-sym version)
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)
226 (if (stringp version)
227 (string-to-number version)
229 (list " " pui-up-to-date-package-face)
230 (list "*" pui-outdated-package-face)))
231 (list "-" pui-uninstalled-package-face))))
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)
240 (setq pkg-sym (extent-property extent 'pui-package)))
242 (setq version (package-get-info-prop (extent-property extent 'pui-info)
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)))
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)))
255 (setq disp (pui-package-symbol-char pkg-sym version))
256 (setq sym-char (car disp))
258 (set-extent-face extent (get-face (car (cdr disp))))
259 (set-extent-face extent (get-face 'default)))))
261 (goto-char (extent-start-position extent))
264 (set-buffer-modified-p nil))))
266 (defun pui-toggle-package (extent)
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)))
276 (pui-update-package-display extent pkg-sym)))
278 (defun pui-toggle-package-key ()
279 "Select/unselect package for installation, using the keyboard."
282 (if (setq extent (extent-at (point) (current-buffer) 'pui))
284 (pui-toggle-package extent)
286 (error 'invalid-operation
287 "No package under cursor!"))))
289 (defun pui-toggle-package-delete (extent)
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))
297 (setq pui-selected-packages
298 (delete pkg-sym pui-selected-packages)))
299 (pui-update-package-display extent pkg-sym)))
302 (defun pui-toggle-package-delete-key ()
303 "Select/unselect package for removal, using the keyboard."
306 (if (setq extent (extent-at (point) (current-buffer) 'pui))
308 (pui-toggle-package-delete extent)
310 (error 'invalid-operation
311 "No package under cursor!"))))
313 (defun pui-current-package ()
314 (let ((extent (extent-at (point) (current-buffer) 'pui)))
316 (extent-property extent 'pui-package))))
318 (defun pui-toggle-package-event (event)
319 "Select/unselect package for installation, using the mouse."
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)))
326 (defun pui-toggle-verbosity-redisplay ()
327 "Toggle verbose package info."
330 (setq pui-list-verbose (not pui-list-verbose))
331 (pui-list-packages)))
333 (defun pui-install-selected-packages ()
334 "Install selected packages."
336 (let ((tmpbuf "*Packages-To-Remove*")
338 (when pui-deleted-packages
339 (save-window-excursion
340 (with-output-to-temp-buffer tmpbuf
341 (display-completion-list (sort
342 (mapcar #'symbol-name pui-deleted-packages)
344 :activate-callback nil
345 :help-string "Packages selected for removal:\n"
346 :completion-string t))
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))
352 (message "Deleting selected packages ...") (sit-for 0)
353 (mapcar (lambda (pkg)
354 (package-admin-delete-binary-package
355 pkg (package-admin-get-install-dir pkg)))
356 (nreverse pui-deleted-packages))
357 (message "Packages deleted"))))
359 (let ((tmpbuf "*Packages-To-Install*")
361 (if pui-selected-packages
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
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"
374 :completion-string t))
375 (setq tmpbuf (get-buffer-create tmpbuf))
376 (display-buffer tmpbuf)
377 (setq do-install (y-or-n-p "Install these packages? "))
378 (kill-buffer tmpbuf))
382 ;; Clear old temp buffer history
383 (set-buffer (get-buffer-create package-admin-temp-buffer))
384 (buffer-disable-undo package-admin-temp-buffer)
385 (erase-buffer package-admin-temp-buffer))
386 (message "Installing selected packages ...") (sit-for 0)
388 (mapcar (lambda (pkg)
389 (if (not (package-get pkg nil nil
390 pui-package-install-dest-dir))
392 (nreverse pui-selected-packages))
396 (message "Packages installed"))))
398 (if pui-deleted-packages
400 (error 'invalid-operation
401 "No packages have been selected!")))
402 ;; sync with windows type systems
403 (package-net-update-installed-db)))
405 (defun pui-add-required-packages ()
406 "Select packages required by those already selected for installation."
408 (let ((tmpbuf "*Required-Packages*") do-select)
409 (if pui-selected-packages
414 (package-get-key pkg :version))
416 (package-get-info-prop
417 (package-get-info-version
418 (package-get-info-find-package
419 package-get-base pkg) nil)
421 (if (or (null installed)
422 (< (if (stringp installed)
423 (string-to-number installed)
425 (if (stringp current)
426 (string-to-number current)
430 (package-get-dependencies pui-selected-packages)))))
431 ;; Don't change window config when asking the user if he really
432 ;; wants to add the packages. We do this to avoid messing up
433 ;; the window configuration if errors occur (we don't want to
434 ;; display random buffers in addition to the error buffer, if
435 ;; errors occur, which would normally be caused by display-buffer).
436 (save-window-excursion
437 (with-output-to-temp-buffer tmpbuf
438 (display-completion-list (sort
439 (mapcar #'(lambda (pkg)
443 :activate-callback nil
444 :help-string "Required packages:\n"
445 :completion-string t))
446 (setq tmpbuf (get-buffer-create tmpbuf))
447 (display-buffer tmpbuf)
448 (setq do-select (y-or-n-p "Select these packages? "))
449 (kill-buffer tmpbuf))
452 (setq pui-selected-packages
453 (union pui-selected-packages dependencies))
454 (map-extents #'(lambda (extent maparg)
455 (pui-update-package-display extent))
456 nil nil nil nil nil 'pui)
457 (message "added dependencies"))
459 (error 'invalid-operation
460 "No packages have been selected!"))))
462 (defun pui-help-echo (extent &optional force-update)
463 "Display additional package info in the modeline.
464 EXTENT determines the package to display (the package information is
465 attached to the extent as properties)."
466 (let (pkg-sym info inst-ver inst-auth-ver auth-ver date maintainer balloon req)
467 (if (or force-update (not (current-message))
468 (string-match ".*: .*: " (current-message)))
470 (setq pkg-sym (extent-property extent 'pui-package)
471 info (extent-property extent 'pui-info)
472 inst-ver (package-get-key pkg-sym :version)
473 inst-auth-ver (package-get-key pkg-sym :author-version)
474 auth-ver (package-get-info-prop info 'author-version)
475 date (package-get-info-prop info 'date)
476 maintainer (package-get-info-prop info 'maintainer)
477 req (package-get-info-prop info 'requires))
480 (if (featurep 'balloon-help)
482 (setq balloon (format "
483 Package Information: [For package: \"%s\"]\n================
484 Installed Upstream Ver: %s Available Upstream Ver: %s
487 Required Packages : %s\n\n"
488 pkg-sym inst-auth-ver auth-ver maintainer
490 (set-extent-property extent 'balloon-help balloon)))
492 "Installed upstream ver: %s Available upstream ver: %s"
493 inst-auth-ver auth-ver)))))
495 (defun pui-display-info (&optional no-error event)
496 "Display additional package info in the modeline.
497 Designed to be called interactively (from a keypress)."
502 (if (setq extent (extent-at (point) (current-buffer) 'pui))
503 (message (pui-help-echo extent t))
506 (error 'invalid-operation
507 "No package under cursor!"))))))
509 (defun pui-display-maintainer (&optional no-error event)
510 "Display a package's maintainer in the minibuffer."
512 (let (extent ;pkg-sym
516 (if (setq extent (extent-at (point) (current-buffer) 'pui))
518 (setq ;pkg-sym (extent-property extent 'pui-package)
519 info (extent-property extent 'pui-info)
520 maintainer (package-get-info-prop info 'maintainer))
521 (message (format "Maintainer: %s" maintainer)))
524 (error 'invalid-operation
525 "No package under cursor!"))))))
529 ["Toggle install " pui-toggle-package-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))]
530 ["Toggle delete " pui-toggle-package-delete-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))]
531 ["Info on" pui-display-info :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))]
533 ["Add Required" pui-add-required-packages t]
534 ["Install/Remove Selected" pui-install-selected-packages t]
536 ["Verbose" pui-toggle-verbosity-redisplay
537 :active t :style toggle :selected pui-list-verbose]
538 ["Refresh" pui-list-packages t]
540 ["Quit" pui-quit t]))
542 ;;; "Why is there no standard function to do this?"
543 (defun pui-popup-context-sensitive (event)
546 (set-buffer (event-buffer event))
547 (goto-char (event-point event))
548 (popup-menu pui-menu event)
549 ;; I agree with dired.el - this is seriously bogus.
551 (dispatch-event (next-event)))))
553 (defun list-packages-mode ()
554 "Symbols in the leftmost column:
556 + The package is marked for installation.
557 - The package has not been installed.
558 D The package has been marked for deletion.
559 * The currently installed package is old, and a newer version is
564 `\\[pui-toggle-package-key]' to select/unselect the current package for installation.
565 `\\[pui-toggle-package-delete-key]' to select/unselect the current package for removal.
566 `\\[pui-add-required-packages]' to add any packages required by those selected.
567 `\\[pui-install-selected-packages]' to install/delete selected packages.
568 `\\[pui-display-info]' to display additional information about the package in the minibuffer.
569 `\\[pui-display-maintainer]' to display the package's maintainer in the minibuffer
570 `\\[pui-list-packages]' to refresh the package list.
571 `\\[pui-toggle-verbosity-redisplay]' to toggle between a verbose and non-verbose display.
572 `\\[pui-quit]' to kill this buffer.
574 (error 'invalid-operation
575 "You cannot enter this mode directly. Use `pui-list-packages'"))
577 (put 'list-packages-mode 'mode-class 'special)
580 (defun pui-list-packages ()
581 "List all packages and package information.
582 The package name, version, and description are displayed. From the displayed
583 buffer, the user can see which packages are installed, which are not, and
584 which are out-of-date (a newer version is available). The user can then
585 select packages for installation via the keyboard or mouse."
587 (package-get-require-base t)
588 (let ((outbuf (get-buffer-create pui-info-buffer))
589 (sep-string "===============================================================================\n")
591 (message "Creating package list ...") (sit-for 0)
593 (setq buffer-read-only nil)
594 (buffer-disable-undo outbuf)
595 (erase-buffer outbuf)
596 (kill-all-local-variables)
597 (use-local-map pui-display-keymap)
598 (setq major-mode 'list-packages-mode)
599 (setq mode-name "Packages")
600 (setq truncate-lines t)
602 (unless package-get-remote
604 Warning: No download sites specified. Package index may be out of date.
605 If you intend to install packages, specify download sites first.
610 (insert " Latest Installed
611 Package name Vers. Vers. Description
614 Package name Vers. Description
620 (let (pkg-sym info version desc
621 b e extent current-vers disp)
622 (setq pkg-sym (car pkg)
623 info (package-get-info-version (cdr pkg) nil))
624 (setq version (package-get-info-prop info 'version)
625 desc (package-get-info-prop info 'description))
627 (setq disp (pui-package-symbol-char pkg-sym
632 (setq current-vers (package-get-key pkg-sym :version))
635 (setq current-vers "-----"))
636 ((stringp current-vers)
639 (string-to-number current-vers))))
640 ((numberp current-vers)
641 (setq current-vers (format "%.2f" current-vers))))
643 (format "%s %-20s %-5.2f %-5s %s\n"
645 (if (stringp version)
646 (string-to-number version)
649 (insert (format "%s %-20s %-5s %s\n"
651 pkg-sym version desc)))
657 (setq extent (make-extent b e))
659 (set-extent-face extent (get-face (car (cdr disp))))
660 (set-extent-face extent (get-face 'default)))
661 (set-extent-property extent 'highlight t)
662 (set-extent-property extent 'pui t)
663 (set-extent-property extent 'pui-package pkg-sym)
664 (set-extent-property extent 'pui-info info)
665 (set-extent-property extent 'help-echo 'pui-help-echo)
666 (set-extent-property extent 'keymap pui-package-keymap)))
667 (sort (copy-sequence package-get-base)
669 (string< (symbol-name (car a))
670 (symbol-name (car b))))))
672 (insert (documentation 'list-packages-mode))
673 (set-buffer-modified-p nil)
674 (setq buffer-read-only t)
675 (pop-to-buffer outbuf)
676 (delete-other-windows)
678 (setq pui-selected-packages nil) ; Reset list
679 (setq pui-deleted-packages nil) ; Reset list
680 (when (featurep 'menubar)
681 (set-buffer-menubar current-menubar)
682 (add-submenu '() pui-menu)
683 (setq mode-popup-menu pui-menu))
687 (defalias 'list-packages 'pui-list-packages)
689 (provide 'package-ui)
691 ;;; package-ui.el ends here