314
|
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 (defvar pui-up-to-date-package-face nil
|
|
34 "The face to use for packages that are up-to-date.")
|
|
35
|
|
36 (defvar pui-selected-package-face (get-face 'bold)
|
|
37 "The face to use for selected packages.
|
|
38 Set this to `nil' to use the `default' face.")
|
|
39
|
|
40 (defvar pui-outdated-package-face (get-face 'red)
|
|
41 "The face to use for outdated packages.
|
|
42 Set this to `nil' to use the `default' face.")
|
|
43
|
|
44 (defvar pui-uninstalled-package-face (get-face 'italic)
|
|
45 "The face to use for uninstalled packages.
|
|
46 Set this to `nil' to use the `default' face.")
|
|
47
|
|
48 (defvar pui-list-verbose t
|
|
49 "If non-nil, display verbose info in the package list buffer.")
|
|
50
|
|
51 (defvar pui-info-buffer "*Packages*"
|
|
52 "Buffer to use for displaying package information.")
|
|
53
|
|
54 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
55 ;; End of user-changeable variables.
|
|
56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
57
|
|
58 (defvar pui-selected-packages nil
|
|
59 "The list of user-selected packages to install.")
|
|
60
|
|
61 (defvar pui-display-keymap
|
|
62 (let ((m (make-keymap)))
|
|
63 (suppress-keymap m)
|
|
64 (set-keymap-name m 'pui-display-keymap)
|
|
65 (define-key m "q" 'pui-quit)
|
|
66 (define-key m "g" 'pui-list-packages)
|
|
67 (define-key m " " 'pui-display-info)
|
|
68 (define-key m "?" 'pui-help)
|
|
69 (define-key m "v" 'pui-toggle-verbosity-redisplay)
|
|
70 (define-key m "d" 'pui-toggle-verbosity-redisplay)
|
|
71 (define-key m [return] 'pui-toggle-package-key)
|
|
72 (define-key m "x" 'pui-install-selected-packages)
|
|
73 (define-key m "I" 'pui-install-selected-packages)
|
|
74 (define-key m "n" 'next-line)
|
|
75 (define-key m "+" 'next-line)
|
|
76 (define-key m "p" 'previous-line)
|
|
77 (define-key m "-" 'previous-line)
|
|
78 m)
|
|
79 "Keymap to use in the `pui-info-buffer' buffer")
|
|
80
|
|
81 (defvar pui-package-keymap
|
|
82 (let ((m (make-sparse-keymap)))
|
|
83 (set-keymap-name m 'pui-package-keymap)
|
|
84 (define-key m 'button2 'pui-toggle-package-event)
|
|
85 (define-key m 'button3 'pui-toggle-package-event)
|
|
86 m)
|
|
87 "Keymap to use over package names/descriptions.")
|
|
88
|
|
89 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
90 ;; End of variables
|
|
91
|
|
92
|
|
93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
94 ;; Configuration routines
|
|
95
|
|
96 (defun pui-directory-exists (dir)
|
|
97 "Check to see if DIR exists in `package-get-remote'."
|
|
98 (let (found)
|
|
99 (mapcar '(lambda (item)
|
|
100 (if (and (null (car item))
|
|
101 (string-equal (file-name-as-directory (car (cdr item)))
|
|
102 (file-name-as-directory dir)))
|
|
103 (setq found t))
|
|
104 ) package-get-remote)
|
|
105 found
|
|
106 ))
|
|
107
|
|
108 (defun pui-package-dir-list (buffer)
|
|
109 "In BUFFER, format the list of package binary paths."
|
|
110 (let ( (count 1) paths sys dir)
|
|
111 (set-buffer buffer)
|
|
112 (buffer-disable-undo buffer)
|
|
113 (erase-buffer buffer)
|
|
114 (insert "Existing package binary paths:\n\n")
|
|
115 (setq paths package-get-remote)
|
|
116 (while paths
|
|
117 (setq sys (car (car paths))
|
|
118 dir (car (cdr (car paths))))
|
|
119 (insert (format "%2s. " count))
|
|
120 (if (null sys)
|
|
121 (insert dir)
|
|
122 (insert sys ":" dir))
|
|
123 (insert "\n")
|
|
124 (setq count (1+ count))
|
|
125 (setq paths (cdr paths))
|
|
126 )
|
|
127 (insert "\nThese are the places that will be searched for package binaries.\n")
|
|
128 (goto-char (point-min))
|
|
129 ))
|
|
130
|
|
131 ;;;###autoload
|
|
132 (defun pui-add-install-directory (dir)
|
|
133 "Add a new package binary directory to the head of `package-get-remote'.
|
|
134 Note that no provision is made for saving any changes made by this function.
|
|
135 It exists mainly as a convenience for one-time package installations from
|
|
136 disk."
|
|
137 (interactive (let ( (tmpbuf (get-buffer-create
|
|
138 "*Existing Package Binary Paths*"))
|
|
139 dir)
|
|
140 (save-window-excursion
|
|
141 (save-excursion
|
|
142 (unwind-protect
|
|
143 (progn
|
|
144 (pui-package-dir-list tmpbuf)
|
|
145 (display-buffer tmpbuf)
|
|
146 (setq dir (read-directory-name
|
|
147 "New package binary directory to add? "
|
|
148 nil nil t))
|
|
149 )
|
|
150 (kill-buffer tmpbuf)
|
|
151 )))
|
|
152 (list dir)
|
|
153 ))
|
|
154 (progn
|
|
155 (if (not (pui-directory-exists dir))
|
|
156 (progn
|
|
157 (setq package-get-remote (cons (list nil dir) package-get-remote))
|
|
158 (message "Package directory \"%s\" added." dir)
|
|
159 )
|
|
160 (message "Directory \"%s\" already exists in `package-get-remote'." dir))
|
|
161 ))
|
|
162
|
|
163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
164 ;; Package list/installer routines
|
|
165
|
|
166 (defun pui-quit ()
|
|
167 (interactive)
|
|
168 (kill-buffer nil))
|
|
169
|
|
170 (defun pui-help ()
|
|
171 (interactive)
|
|
172 (let ( (help-buffer (get-buffer-create "*Help*")) )
|
|
173 (display-buffer help-buffer t)
|
|
174 (save-window-excursion
|
|
175 (set-buffer help-buffer)
|
|
176 (buffer-disable-undo help-buffer)
|
|
177 (erase-buffer help-buffer)
|
|
178 (insert (pui-help-string))
|
|
179 )
|
|
180 ))
|
|
181
|
|
182 (defun pui-package-symbol-char (pkg-sym version)
|
|
183 (progn
|
|
184 (if (package-get-info-find-package packages-package-list pkg-sym)
|
|
185 (if (package-get-installedp pkg-sym version)
|
|
186 (list " " pui-up-to-date-package-face)
|
|
187 (list "*" pui-outdated-package-face))
|
|
188 (list "-" pui-uninstalled-package-face))
|
|
189 ))
|
|
190
|
|
191 (defun pui-update-package-display (extent &optional pkg-sym version)
|
|
192 "Update the package status for EXTENT.
|
|
193 If PKG-SYM or VERSION are not given, they are read from the extent.
|
|
194 These are used to determine whether or not the package is installed,
|
|
195 and whether or not it is up-to-date."
|
|
196 (let (buffer-read-only disp sym-char)
|
|
197 (if (not pkg-sym)
|
|
198 (setq pkg-sym (extent-property extent 'pui-package)))
|
|
199 (if (not version)
|
|
200 (setq version (package-get-info-prop (extent-property extent 'pui-info)
|
|
201 'version)))
|
|
202 (if (member pkg-sym pui-selected-packages)
|
|
203 (progn
|
|
204 (if pui-selected-package-face
|
|
205 (set-extent-face extent (get-face pui-selected-package-face))
|
|
206 (set-extent-face extent (get-face 'default)))
|
|
207 (setq sym-char "+")
|
|
208 )
|
|
209 (progn
|
|
210 (setq disp (pui-package-symbol-char pkg-sym version))
|
|
211 (setq sym-char (car disp))
|
|
212 (if (cdr disp)
|
|
213 (set-extent-face extent (car (cdr disp)))
|
|
214 (set-extent-face extent (get-face 'default)))
|
|
215 ))
|
|
216 (save-excursion
|
|
217 (goto-char (extent-start-position extent))
|
|
218 (delete-char 1)
|
|
219 (insert sym-char)
|
|
220 (set-buffer-modified-p nil)
|
|
221 )
|
|
222 ))
|
|
223
|
|
224 (defun pui-toggle-package (extent)
|
|
225 (let (pkg-sym)
|
|
226 (setq pkg-sym (extent-property extent 'pui-package))
|
|
227 (if (member pkg-sym pui-selected-packages)
|
|
228 (setq pui-selected-packages
|
|
229 (delete pkg-sym pui-selected-packages))
|
|
230 (setq pui-selected-packages
|
|
231 (cons pkg-sym pui-selected-packages)))
|
|
232 (pui-update-package-display extent pkg-sym)
|
|
233 ))
|
|
234
|
|
235 (defun pui-toggle-package-key ()
|
|
236 "Select/unselect package for installation, using the keyboard."
|
|
237 (interactive)
|
|
238 (let (extent)
|
|
239 (if (setq extent (extent-at (point) (current-buffer) 'pui))
|
|
240 (progn
|
|
241 (pui-toggle-package extent)
|
|
242 (forward-line 1)
|
|
243 )
|
|
244 (error "No package under cursor!"))
|
|
245 ))
|
|
246
|
|
247 (defun pui-toggle-package-event (event)
|
|
248 "Select/unselect package for installation, using the mouse."
|
|
249 (interactive "e")
|
|
250 (let* ( (ep (event-point event))
|
|
251 (buffer (window-buffer (event-window event)))
|
|
252 (extent (extent-at ep buffer 'pui-package))
|
|
253 )
|
|
254 (pui-toggle-package extent)
|
|
255 ))
|
|
256
|
|
257 (defun pui-toggle-verbosity-redisplay ()
|
|
258 "Toggle verbose package info."
|
|
259 (interactive)
|
|
260 (progn
|
|
261 (setq pui-list-verbose (not pui-list-verbose))
|
|
262 (pui-list-packages)
|
|
263 ))
|
|
264
|
|
265 (defun pui-install-selected-packages ()
|
|
266 "Install selected packages."
|
|
267 (interactive)
|
|
268 (let ( (tmpbuf "*Packages-To-Install*") do-install)
|
|
269 (if pui-selected-packages
|
|
270 (progn
|
|
271 ;; Don't change window config when asking the user if he really
|
|
272 ;; wants to install the packages. We do this to avoid messing up
|
|
273 ;; the window configuration if errors occur (we don't want to
|
|
274 ;; display random buffers in addition to the error buffer, if
|
|
275 ;; errors occur, which would normally be caused by display-buffer).
|
|
276 (save-window-excursion
|
|
277 (with-output-to-temp-buffer tmpbuf
|
|
278 (display-completion-list (sort
|
|
279 (mapcar '(lambda (pkg)
|
|
280 (symbol-name pkg)
|
|
281 )
|
|
282 pui-selected-packages)
|
|
283 'string<)
|
|
284 :activate-callback nil
|
|
285 :help-string "Packages selected for installation:\n"
|
|
286 :completion-string t
|
|
287 ))
|
|
288 (setq tmpbuf (get-buffer-create tmpbuf))
|
|
289 (display-buffer tmpbuf)
|
|
290 (setq do-install (y-or-n-p "Install these packages? "))
|
|
291 (kill-buffer tmpbuf)
|
|
292 )
|
|
293 (if do-install
|
|
294 (progn
|
|
295 (save-excursion
|
|
296 ;; Clear old temp buffer history
|
|
297 (set-buffer (get-buffer-create package-admin-temp-buffer))
|
|
298 (buffer-disable-undo package-admin-temp-buffer)
|
|
299 (erase-buffer package-admin-temp-buffer)
|
|
300 )
|
|
301 (message "Installing selected packages ...") (sit-for 0)
|
|
302 (if (catch 'done
|
|
303 (mapcar (lambda (pkg)
|
|
304 (if (not (package-get-all pkg nil))
|
|
305 (throw 'done nil)))
|
|
306 pui-selected-packages)
|
|
307 t)
|
|
308 (progn
|
|
309 (pui-list-packages)
|
|
310 (message "Packages installed")
|
|
311 ))
|
|
312 )
|
|
313 (clear-message)
|
|
314 )
|
|
315 )
|
|
316 (error "No packages have been selected!"))
|
|
317 ))
|
|
318
|
|
319 (defun pui-help-echo (extent &optional force-update)
|
|
320 "Display additional package info in the modeline.
|
|
321 EXTENT determines the package to display (the package information is
|
|
322 attached to the extent as properties)."
|
|
323 (let (pkg-sym info inst-ver auth-ver date maintainer)
|
|
324 (if (or force-update (not (current-message))
|
|
325 (string-match ".*: .*: " (current-message))
|
|
326 )
|
|
327 (progn
|
|
328 (setq pkg-sym (extent-property extent 'pui-package)
|
|
329 info (extent-property extent 'pui-info)
|
|
330 inst-ver (package-get-key pkg-sym :version)
|
|
331 auth-ver (package-get-info-prop info 'author-version)
|
|
332 date (package-get-info-prop info 'date)
|
|
333 maintainer (package-get-info-prop info 'maintainer))
|
|
334 (if (not inst-ver)
|
|
335 (setq inst-ver ""))
|
|
336 (if pui-list-verbose
|
|
337 (format "Author version: %-8s %11s: %s"
|
|
338 auth-ver date maintainer)
|
|
339 (format "%-6s: %-8s %11s: %s"
|
|
340 inst-ver auth-ver date maintainer))
|
|
341 ))
|
|
342 ))
|
|
343
|
|
344 (defun pui-display-info (&optional no-error)
|
|
345 "Display additional package info in the modeline.
|
|
346 Designed to be called interactively (from a keypress)."
|
|
347 (interactive)
|
|
348 (let (extent)
|
|
349 (save-excursion
|
|
350 (beginning-of-line)
|
|
351 (if (setq extent (extent-at (point) (current-buffer) 'pui))
|
|
352 (message (pui-help-echo extent t))
|
|
353 (if no-error
|
|
354 (clear-message nil)
|
|
355 (error "No package under cursor!")))
|
|
356 )))
|
|
357
|
|
358 (defun pui-help-string ()
|
|
359 "Return the help string for the package-info buffer.
|
|
360 This is not a defconst because of the call to substitute-command-keys."
|
|
361 (save-excursion
|
|
362 (set-buffer (get-buffer pui-info-buffer))
|
|
363 (substitute-command-keys
|
|
364 "Symbols in the leftmost column:
|
|
365
|
|
366 + The package is marked for installation.
|
|
367 - The package has not been installed.
|
|
368 * The currently installed package is old, and a newer version is
|
|
369 available.
|
|
370
|
|
371 Useful keys:
|
|
372
|
|
373 `\\[pui-toggle-package-key]' to select/unselect the current package for installation.
|
|
374 `\\[pui-install-selected-packages]' to install selected packages.
|
|
375 `\\[pui-display-info]' to display additional information about the package in the modeline.
|
|
376 `\\[pui-list-packages]' to refresh the package list.
|
|
377 `\\[pui-toggle-verbosity-redisplay]' to toggle between a verbose and non-verbose display.
|
|
378 `\\[pui-quit]' to kill this buffer.
|
|
379 ")
|
|
380 ))
|
|
381
|
|
382 ;;;###autoload
|
|
383 (defun pui-list-packages ()
|
|
384 "List all packages and package information.
|
|
385 The package name, version, and description are displayed. From the displayed
|
|
386 buffer, the user can see which packages are installed, which are not, and
|
|
387 which are out-of-date (a newer version is available). The user can then
|
|
388 select packages for installation via the keyboard or mouse."
|
|
389 (interactive)
|
|
390 (let ( (outbuf (get-buffer-create pui-info-buffer))
|
|
391 (sep-string "===============================================================================\n")
|
|
392 start )
|
|
393 (message "Creating package list ...") (sit-for 0)
|
|
394 (set-buffer outbuf)
|
|
395 (setq buffer-read-only nil)
|
|
396 (buffer-disable-undo outbuf)
|
|
397 (erase-buffer outbuf)
|
|
398 (use-local-map pui-display-keymap)
|
|
399 (if pui-list-verbose
|
|
400 (insert " Latest Installed
|
|
401 Package name Vers. Vers. Description
|
|
402 ")
|
|
403 (insert " Latest
|
|
404 Package name Vers. Description
|
|
405 "))
|
|
406 (insert sep-string)
|
|
407 (setq start (point))
|
|
408 (mapcar '(lambda (pkg)
|
|
409 (let (pkg-sym info version desc
|
|
410 b e extent current-vers disp)
|
|
411 (setq pkg-sym (car pkg)
|
|
412 info (package-get-info-version (cdr pkg) nil))
|
|
413 (setq version (package-get-info-prop info 'version)
|
|
414 desc (package-get-info-prop info 'description))
|
|
415
|
|
416 (setq disp (pui-package-symbol-char pkg-sym
|
|
417 version))
|
|
418 (setq b (point))
|
|
419 (if pui-list-verbose
|
|
420 (progn
|
|
421 (setq current-vers (package-get-key pkg-sym :version))
|
316
|
422 (cond
|
|
423 ( (not current-vers)
|
|
424 (setq current-vers "-----") )
|
|
425 ( (stringp current-vers)
|
|
426 (setq current-vers
|
|
427 (format "%.2f"
|
|
428 (string-to-number current-vers))) )
|
|
429 ( (numberp current-vers)
|
|
430 (setq current-vers (format "%.2f" current-vers)) )
|
|
431 )
|
314
|
432 (insert
|
316
|
433 (format "%s %-15s %-5.2f %-5s %s\n"
|
|
434 (car disp) pkg-sym
|
|
435 (if (stringp version)
|
|
436 (string-to-number version)
|
|
437 version)
|
|
438 current-vers desc))
|
314
|
439 ;; (insert
|
|
440 ;; (format "\t\t %-12s %s\n"
|
|
441 ;; (package-get-info-prop info 'author-version)
|
|
442 ;; (package-get-info-prop info 'date)
|
|
443 ;; ))
|
|
444 )
|
|
445 (insert (format "%s %-15s %-5s %s\n"
|
|
446 (car disp)
|
|
447 pkg-sym version desc)))
|
|
448 (save-excursion
|
|
449 (setq e (progn
|
|
450 (forward-line -1)
|
|
451 (end-of-line)
|
|
452 (point)))
|
|
453 )
|
|
454 (setq extent (make-extent b e))
|
|
455 (if (cdr disp)
|
|
456 (set-extent-face extent (car (cdr disp)))
|
|
457 (set-extent-face extent (get-face 'default)))
|
|
458 (set-extent-property extent 'highlight t)
|
|
459 (set-extent-property extent 'pui t)
|
|
460 (set-extent-property extent 'pui-package pkg-sym)
|
|
461 (set-extent-property extent 'pui-info info)
|
|
462 (set-extent-property extent 'help-echo 'pui-help-echo)
|
|
463 (set-extent-property extent 'keymap pui-package-keymap)
|
|
464 )) (sort (copy-sequence package-get-base)
|
|
465 '(lambda (a b)
|
|
466 (string< (symbol-name (car a))
|
|
467 (symbol-name (car b)))
|
|
468 )))
|
|
469 (insert sep-string)
|
|
470 (insert (pui-help-string))
|
|
471 (set-buffer-modified-p nil)
|
|
472 (setq buffer-read-only t)
|
|
473 (pop-to-buffer outbuf)
|
|
474 (delete-other-windows)
|
|
475 (goto-char start)
|
|
476 (setq pui-selected-packages nil) ; Reset list
|
|
477 (clear-message)
|
|
478 ; (message (substitute-command-keys "Press `\\[pui-help]' for help."))
|
|
479 ))
|
|
480
|
|
481 (provide 'package-ui)
|
|
482
|
|
483 ;;; package-ui.el ends here
|