Mercurial > hg > xemacs-beta

comparison lisp/gutter-items.el @ 404:2f8bb876ab1d r21-2-32

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-32
author cvs
date Mon, 13 Aug 2007 11:16:07 +0200
parents a86b2b5e0111
children b8cc9ab3f761
comparison
equal deleted inserted replaced
403:9f011ab08d48 404:2f8bb876ab1d
1 ;;; gutter-items.el --- Gutter content for XEmacs. 1 ;;; gutter-items.el --- Gutter content for XEmacs.
2 2
3 ;; Copyright (C) 1999 Free Software Foundation, Inc. 3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
4 ;; Copyright (C) 1999 Andy Piper. 4 ;; Copyright (C) 1999, 2000 Andy Piper.
5 5
6 ;; Maintainer: XEmacs Development Team 6 ;; Maintainer: XEmacs Development Team
7 ;; Keywords: frames, extensions, internal, dumped 7 ;; Keywords: frames, extensions, internal, dumped
8 8
9 ;; This file is part of XEmacs. 9 ;; This file is part of XEmacs.
28 28
29 (defgroup gutter nil 29 (defgroup gutter nil
30 "Input from the gutters." 30 "Input from the gutters."
31 :group 'environment) 31 :group 'environment)
32 32
33 (defvar gutter-buffers-tab nil 33 ;; Although these customizations appear bogus, they are neccessary in
34 "A tab widget in the gutter for displaying buffers. 34 ;; order to be able to save options through the options menu.
35 Do not set this. Use `glyph-image-instance' and
36 `set-image-instance-property' to change the properties of the tab.")
37
38 (defcustom gutter-visible-p
39 (specifier-instance default-gutter-visible-p)
40 "Whether the default gutter is globally visible. This option can be
41 customized through the options menu."
42 :group 'gutter
43 :type 'boolean
44 :set #'(lambda (var val)
45 (set-specifier default-gutter-visible-p val)
46 (setq gutter-visible-p val)
47 (when gutter-buffers-tab (update-tab-in-gutter))))
48
49 (defcustom default-gutter-position 35 (defcustom default-gutter-position
50 (default-gutter-position) 36 (default-gutter-position)
51 "The location of the default gutter. It can be 'top, 'bottom, 'left or 37 "The location of the default gutter. It can be 'top, 'bottom, 'left or
52 'right. This option can be customized through the options menu." 38 'right. This option should be customized through the options menu.
39 To set the gutter position explicitly use `set-default-gutter-position'"
53 :group 'gutter 40 :group 'gutter
54 :type '(choice (const :tag "top" top) 41 :type '(choice (const :tag "top" top)
55 (const :tag "bottom" bottom) 42 (const :tag "bottom" bottom)
56 (const :tag "left" left) 43 (const :tag "left" left)
57 (const :tag "right" right)) 44 (const :tag "right" right))
58 :set #'(lambda (var val) 45 :set #'(lambda (var val)
59 (set-default-gutter-position val) 46 (set-default-gutter-position val)
60 (setq default-gutter-position val) 47 (setq default-gutter-position val)))
61 (when gutter-buffers-tab (update-tab-in-gutter)))) 48
49 ;;; Gutter helper functions
50
51 ;; called by Fset_default_gutter_position()
52 (defvar default-gutter-position-changed-hook nil
53 "Function or functions to be called when the gutter position is changed.
54 The value of this variable may be buffer-local.")
55
56 ;; called by set-gutter-element-visible-p
57 (defvar gutter-element-visibility-changed-hook nil
58 "Function or functions to be called when the visibility of an
59 element in the gutter changes. The value of this variable may be
60 buffer-local. The gutter element symbol is passed as an argument to
61 the hook, as is the visibility flag.")
62
63 (defun set-gutter-element (gutter-specifier prop val &optional locale tag-set)
64 "Set GUTTER-SPECIFIER gutter element PROP to VAL in optional LOCALE.
65 This is a convenience function for setting gutter elements."
66 (map-extents #'(lambda (extent arg)
67 (set-extent-property extent 'duplicable t)) val)
68 (modify-specifier-instances gutter-specifier #'plist-put (list prop val)
69 'force nil locale tag-set))
70
71 (defun remove-gutter-element (gutter-specifier prop &optional locale tag-set)
72 "Remove gutter element PROP from GUTTER-SPECIFIER in optional LOCALE.
73 This is a convenience function for removing gutter elements."
74 (modify-specifier-instances gutter-specifier #'plist-remprop (list prop)
75 'force nil locale tag-set))
76
77 (defun set-gutter-element-visible-p (gutter-visible-specifier-p
78 prop &optional visible-p
79 locale tag-set)
80 "Change the visibility of gutter elements.
81 Set the visibility of element PROP to VISIBLE-P for
82 GUTTER-SPECIFIER-VISIBLE-P in optional LOCALE.
83 This is a convenience function for hiding and showing gutter elements."
84 (modify-specifier-instances
85 gutter-visible-specifier-p #'(lambda (spec prop visible-p)
86 (if (consp spec)
87 (if visible-p
88 (if (memq prop spec) spec
89 (cons prop spec))
90 (delq prop spec))
91 (if visible-p (list prop))))
92 (list prop visible-p)
93 'force nil locale tag-set)
94 (run-hook-with-args 'gutter-element-visibility-changed-hook prop visible-p))
95
96 (defun gutter-element-visible-p (gutter-visible-specifier-p
97 prop &optional domain)
98 "Determine whether a gutter element is visible.
99 Given GUTTER-VISIBLE-SPECIFIER-P and gutter element PROP, return
100 non-nil if it is visible in optional DOMAIN."
101 (let ((spec (specifier-instance gutter-visible-specifier-p domain)))
102 (or (and (listp spec) (memq 'buffers-tab spec))
103 spec)))
104
105 (defun init-gutter ()
106 "Initialize the gutter."
107 ;; do nothing as yet.
108 )
62 109
63 ;;; The Buffers tab 110 ;;; The Buffers tab
64 111
65 (defgroup buffers-tab nil 112 (defgroup buffers-tab nil
66 "Customization of `Buffers' tab." 113 "Customization of `Buffers' tab."
67 :group 'gutter) 114 :group 'gutter)
115
116 (defvar gutter-buffers-tab nil
117 "A tab widget in the gutter for displaying buffers.
118 Do not set this. Use `glyph-image-instance' and
119 `set-image-instance-property' to change the properties of the tab.")
120
121 (defcustom gutter-buffers-tab-visible-p
122 (gutter-element-visible-p default-gutter-visible-p 'buffers-tab)
123 "Whether the buffers tab is globally visible.
124 This option should be set through the options menu."
125 :group 'buffers-tab
126 :type 'boolean
127 :set #'(lambda (var val)
128 (set-gutter-element-visible-p default-gutter-visible-p 'buffers-tab val)
129 (setq gutter-buffers-tab-visible-p val)))
68 130
69 (defvar gutter-buffers-tab-orientation 'top 131 (defvar gutter-buffers-tab-orientation 'top
70 "Where the buffers tab currently is. Do not set this.") 132 "Where the buffers tab currently is. Do not set this.")
71 133
72 (defvar gutter-buffers-tab-extent nil) 134 (defvar gutter-buffers-tab-extent nil)
102 "*If non-nil, a function specifying the buffers to select from the 164 "*If non-nil, a function specifying the buffers to select from the
103 buffers tab. This is passed two buffers and should return non-nil if 165 buffers tab. This is passed two buffers and should return non-nil if
104 the second buffer should be selected. The default value 166 the second buffer should be selected. The default value
105 `select-buffers-tab-buffers-by-mode' groups buffers by major mode and 167 `select-buffers-tab-buffers-by-mode' groups buffers by major mode and
106 by `buffers-tab-grouping-regexp'." 168 by `buffers-tab-grouping-regexp'."
169
170 :type '(choice (const :tag "None" nil)
171 function)
172 :group 'buffers-tab)
173
174 (defcustom buffers-tab-sort-function nil
175 "*If non-nil, a function specifying the buffers to select from the
176 buffers tab. This is passed the buffer list and returns the list in the
177 order desired for the tab widget. The default value `nil' leaves the
178 list in `buffer-list' order (usual most-recently-selected-first)."
107 179
108 :type '(choice (const :tag "None" nil) 180 :type '(choice (const :tag "None" nil)
109 function) 181 function)
110 :group 'buffers-tab) 182 :group 'buffers-tab)
111 183
201 (concat (substring (buffer-name buffer) 273 (concat (substring (buffer-name buffer)
202 0 (- len 3)) "...")) 274 0 (- len 3)) "..."))
203 (buffer-name buffer)))) 275 (buffer-name buffer))))
204 276
205 (defsubst build-buffers-tab-internal (buffers) 277 (defsubst build-buffers-tab-internal (buffers)
206 (let (line) 278 (let ((selected t))
207 (mapcar 279 (mapcar
208 #'(lambda (buffer) 280 #'(lambda (buffer)
209 (setq line (funcall buffers-tab-format-buffer-line-function 281 (prog1
210 buffer)) 282 (vector
211 (vector line (list buffers-tab-switch-to-buffer-function 283 (funcall buffers-tab-format-buffer-line-function
212 (buffer-name buffer)))) 284 buffer)
285 (list buffers-tab-switch-to-buffer-function
286 (buffer-name buffer))
287 :selected selected)
288 (when selected (setq selected nil))))
213 buffers))) 289 buffers)))
214 290
215 (defun buffers-tab-items (&optional in-deletion frame) 291 ;;; #### SJT I'd really like this function to have just two hooks: (1) the
292 ;;; buffer filter list and (2) a sort function list. Both should be lists
293 ;;; of functions. Each filter takes two arguments: a buffer and a model
294 ;;; buffer. (The model buffer argument allows selecting according to the
295 ;;; mode or directory of that buffer.) The filter returns t if the buffer
296 ;;; should be listed and nil otherwise. Effectively the filter amounts to
297 ;;; the conjuction of the filter list. (Optionally the filter could take a
298 ;;; frame instead of a buffer or generalize to a locale as in a specifier?)
299 ;;; The filtering is done this way to preserve the ordering imposed by
300 ;;; `buffer-list'. In addition, the in-deletion argument will be used the
301 ;;; same way as in the current design.
302 ;;; The list is checked for length and pruned according to least-recently-
303 ;;; selected. (Optionally there could be some kind of sort function here,
304 ;;; too.)
305 ;;; Finally the list is sorted to gutter display order, and the tab data
306 ;;; structure is created and returned.
307 ;;; #### Docstring isn't very well expressed.
308 (defun buffers-tab-items (&optional in-deletion frame force-selection)
216 "This is the tab filter for the top-level buffers \"Buffers\" tab. 309 "This is the tab filter for the top-level buffers \"Buffers\" tab.
217 It dynamically creates a list of buffers to use as the contents of the tab. 310 It dynamically creates a list of buffers to use as the contents of the tab.
218 Only the most-recently-used few buffers will be listed on the tab, for 311 Only the most-recently-used few buffers will be listed on the tab, for
219 efficiency reasons. You can control how many buffers will be shown by 312 efficiency reasons. You can control how many buffers will be shown by
220 setting `buffers-tab-max-size'. You can control the text of the tab 313 setting `buffers-tab-max-size'. You can control the text of the tab
221 items by redefining the function `format-buffers-menu-line'." 314 items by redefining the function `format-buffers-menu-line'."
222 (save-match-data 315 (save-match-data
223 (let* ((buffers (delete-if buffers-tab-omit-function (buffer-list frame))) 316 (let* ((buffers (delete-if buffers-tab-omit-function (buffer-list frame)))
224 (first-buf (car buffers))) 317 (first-buf (car buffers)))
318 ;; maybe force the selected window
319 (when (and force-selection
320 (not in-deletion)
321 (not (eq first-buf (window-buffer (selected-window frame)))))
322 (setq buffers (cons (window-buffer (selected-window frame))
323 (delq first-buf buffers))))
225 ;; if we're in deletion ignore the current buffer 324 ;; if we're in deletion ignore the current buffer
226 (when in-deletion 325 (when in-deletion
227 (setq buffers (delq (current-buffer) buffers)) 326 (setq buffers (delq (current-buffer) buffers))
228 (setq first-buf (car buffers))) 327 (setq first-buf (car buffers)))
229 ;; group buffers by mode 328 ;; select buffers in group (default is by mode)
230 (when buffers-tab-selection-function 329 (when buffers-tab-selection-function
231 (delete-if-not #'(lambda (buf) 330 (delete-if-not #'(lambda (buf)
232 (funcall buffers-tab-selection-function 331 (funcall buffers-tab-selection-function
233 first-buf buf)) buffers)) 332 first-buf buf)) buffers))
333 ;; maybe shorten list of buffers
234 (and (integerp buffers-tab-max-size) 334 (and (integerp buffers-tab-max-size)
235 (> buffers-tab-max-size 1) 335 (> buffers-tab-max-size 1)
236 (> (length buffers) buffers-tab-max-size) 336 (> (length buffers) buffers-tab-max-size)
237 ;; shorten list of buffers
238 (setcdr (nthcdr buffers-tab-max-size buffers) nil)) 337 (setcdr (nthcdr buffers-tab-max-size buffers) nil))
338 ;; sort buffers in group (default is most-recently-selected)
339 (when buffers-tab-sort-function
340 (setq buffers (funcall buffers-tab-sort-function buffers)))
341 ;; convert list of buffers to list of structures used by tab widget
239 (setq buffers (build-buffers-tab-internal buffers)) 342 (setq buffers (build-buffers-tab-internal buffers))
240 buffers))) 343 buffers)))
241 344
242 (defun add-tab-to-gutter () 345 (defun add-tab-to-gutter ()
243 "Put a tab control in the gutter area to hold the most recent buffers." 346 "Put a tab control in the gutter area to hold the most recent buffers."
244 (setq gutter-buffers-tab-orientation (default-gutter-position)) 347 (setq gutter-buffers-tab-orientation (default-gutter-position))
245 (let ((gutter-string "")) 348 (let ((gutter-string "\n"))
246 (unless gutter-buffers-tab-extent 349 (unless gutter-buffers-tab-extent
247 (setq gutter-buffers-tab-extent (make-extent 0 0 gutter-string))) 350 (setq gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
248 (set-extent-begin-glyph 351 (set-extent-begin-glyph
249 gutter-buffers-tab-extent 352 gutter-buffers-tab-extent
250 (setq gutter-buffers-tab 353 (setq gutter-buffers-tab
251 (make-glyph 354 (make-glyph
252 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face 355 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
253 :orientation gutter-buffers-tab-orientation 356 :orientation gutter-buffers-tab-orientation
254 :properties (list :items (buffers-tab-items)))))) 357 (if (or (eq gutter-buffers-tab-orientation 'top)
255 ;; This looks better than a 3d border 358 (eq gutter-buffers-tab-orientation 'bottom))
256 (mapcar '(lambda (x) 359 :pixel-width :pixel-height)
257 (when (valid-image-instantiator-format-p 'tab-control x) 360 (if (or (eq gutter-buffers-tab-orientation 'top)
258 (set-specifier default-gutter-border-width 0 'global x) 361 (eq gutter-buffers-tab-orientation 'bottom))
259 (set-specifier top-gutter nil 'global x) 362 '(gutter-pixel-width) '(gutter-pixel-height))
260 (set-specifier bottom-gutter nil 'global x) 363 :properties (list :items (buffers-tab-items nil nil t))))))
261 (set-specifier left-gutter nil 'global x) 364
262 (set-specifier right-gutter nil 'global x) 365 ;; Nuke all existing tabs
263 (set-specifier left-gutter-width 0 'global x) 366 (remove-gutter-element top-gutter 'buffers-tab)
264 (set-specifier right-gutter-width 0 'global x) 367 (remove-gutter-element bottom-gutter 'buffers-tab)
265 (cond ((eq gutter-buffers-tab-orientation 'top) 368 (remove-gutter-element left-gutter 'buffers-tab)
266 (set-specifier top-gutter gutter-string 'global x)) 369 (remove-gutter-element right-gutter 'buffers-tab)
267 ((eq gutter-buffers-tab-orientation 'bottom) 370 ;; Put tabs into all devices that will be able to display them
268 (set-specifier bottom-gutter gutter-string 'global x)) 371 (mapcar
269 ((eq gutter-buffers-tab-orientation 'left) 372 #'(lambda (x)
270 (set-specifier left-gutter gutter-string 'global x) 373 (when (valid-image-instantiator-format-p 'tab-control x)
271 (set-specifier left-gutter-width 374 (cond ((eq gutter-buffers-tab-orientation 'top)
272 (glyph-width gutter-buffers-tab) 375 ;; This looks better than a 3d border
273 'global x)) 376 (set-specifier top-gutter-border-width 0 'global x)
274 ((eq gutter-buffers-tab-orientation 'right) 377 (set-gutter-element top-gutter 'buffers-tab
275 (set-specifier right-gutter gutter-string 'global x) 378 gutter-string 'global x))
276 (set-specifier right-gutter-width 379 ((eq gutter-buffers-tab-orientation 'bottom)
277 (glyph-width gutter-buffers-tab) 380 (set-specifier bottom-gutter-border-width 0 'global x)
278 'global x)) 381 (set-gutter-element bottom-gutter 'buffers-tab
279 ))) 382 gutter-string 'global x))
280 (console-type-list)))) 383 ((eq gutter-buffers-tab-orientation 'left)
281 384 (set-specifier left-gutter-border-width 0 'global x)
282 (defun update-tab-in-gutter (&optional frame-or-buffer) 385 (set-gutter-element left-gutter 'buffers-tab
386 gutter-string 'global x)
387 (set-specifier left-gutter-width
388 (glyph-width gutter-buffers-tab)
389 'global x))
390 ((eq gutter-buffers-tab-orientation 'right)
391 (set-specifier right-gutter-border-width 0 'global x)
392 (set-gutter-element right-gutter 'buffers-tab
393 gutter-string 'global x)
394 (set-specifier right-gutter-width
395 (glyph-width gutter-buffers-tab)
396 'global x))
397 )))
398 (console-type-list))))
399
400 (defun update-tab-in-gutter (&optional frame-or-buffer force-selection)
283 "Update the tab control in the gutter area." 401 "Update the tab control in the gutter area."
284 (let ((locale (if (framep frame-or-buffer) frame-or-buffer))) 402 (let ((locale (if (framep frame-or-buffer) frame-or-buffer)))
285 (when (specifier-instance default-gutter-visible-p locale) 403 ;; dedicated frames don't get tabs
286 (unless (and gutter-buffers-tab 404 (unless (and (framep locale)
287 (eq (default-gutter-position) 405 (window-dedicated-p (frame-selected-window locale)))
288 gutter-buffers-tab-orientation)) 406 (when (specifier-instance default-gutter-visible-p locale)
289 (add-tab-to-gutter)) 407 (unless (and gutter-buffers-tab
290 (when (valid-image-instantiator-format-p 'tab-control locale) 408 (eq (default-gutter-position)
291 (let ((inst (glyph-image-instance 409 gutter-buffers-tab-orientation))
292 gutter-buffers-tab 410 (add-tab-to-gutter))
293 (when (framep frame-or-buffer) 411 (when (valid-image-instantiator-format-p 'tab-control locale)
294 (last-nonminibuf-window frame-or-buffer))))) 412 (let ((inst (glyph-image-instance
295 (set-image-instance-property inst :items 413 gutter-buffers-tab
296 (buffers-tab-items 414 (when (framep frame-or-buffer)
297 nil locale))))))) 415 (last-nonminibuf-window frame-or-buffer)))))
416 (set-image-instance-property inst :items
417 (buffers-tab-items
418 nil locale force-selection))))))))
298 419
299 (defun remove-buffer-from-gutter-tab () 420 (defun remove-buffer-from-gutter-tab ()
300 "Remove the current buffer from the tab control in the gutter area." 421 "Remove the current buffer from the tab control in the gutter area."
301 (when (and (valid-image-instantiator-format-p 'tab-control) 422 (when (and (valid-image-instantiator-format-p 'tab-control)
302 (specifier-instance default-gutter-visible-p)) 423 (specifier-instance default-gutter-visible-p))
306 (setq buffers (build-buffers-tab-internal 427 (setq buffers (build-buffers-tab-internal
307 (list 428 (list
308 (get-buffer-create "*scratch*"))))) 429 (get-buffer-create "*scratch*")))))
309 (set-image-instance-property inst :items buffers)))) 430 (set-image-instance-property inst :items buffers))))
310 431
432 ;; A myriad of different update hooks all doing slightly different things
311 (add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab) 433 (add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab)
312 (add-hook 'create-frame-hook 'update-tab-in-gutter) 434 (add-hook 'create-frame-hook
435 #'(lambda (frame)
436 (when gutter-buffers-tab (update-tab-in-gutter frame t))))
313 (add-hook 'record-buffer-hook 'update-tab-in-gutter) 437 (add-hook 'record-buffer-hook 'update-tab-in-gutter)
438 (add-hook 'default-gutter-position-changed
439 #'(lambda (arg)
440 (when gutter-buffers-tab (update-tab-in-gutter arg))))
441 (add-hook 'gutter-element-visibility-changed-hook
442 #'(lambda (prop visible-p)
443 (when (and (eq prop 'buffers-tab) visible-p)
444 (update-tab-in-gutter))))
314 445
315 ;; 446 ;;
316 ;; progress display 447 ;; progress display
317 ;; ripped off from message display 448 ;; ripped off from message display
318 ;; 449 ;;
450 (defcustom progress-display-use-echo-area nil
451 "*Whether progress gauge display should display in the echo area.
452 If NIL then progress gauges will be displayed with whatever native widgets
453 are available on the current console. If non-NIL then progress display will be
454 textual and displayed in the echo area."
455 :type 'boolean
456 :group 'gutter)
457
319 (defvar progress-stack nil 458 (defvar progress-stack nil
320 "An alist of label/string pairs representing active progress gauges. 459 "An alist of label/string pairs representing active progress gauges.
321 The first element in the list is currently displayed in the gutter area. 460 The first element in the list is currently displayed in the gutter area.
322 Do not modify this directly--use the `progress' or 461 Do not modify this directly--use the `progress-display' or
323 `display-progress'/`clear-progress' functions.") 462 `display-progress-display'/`clear-progress-display' functions.")
324 463
325 (defvar progress-glyph-height 32 464 (defvar progress-glyph-height 32
326 "Height of the gutter area for progress messages.") 465 "Height of the gutter area for progress messages.")
327 466
328 (defvar progress-stop-callback 'progress-quit-function 467 (defvar progress-display-stop-callback 'progress-display-quit-function
329 "Function to call to stop the progress operation.") 468 "Function to call to stop the progress operation.")
330 469
331 (defun progress-quit-function () 470 (defvar progress-display-popup-period 0.5
471 "The time that the progress gauge should remain up after completion")
472
473 (defun progress-display-quit-function ()
332 "Default function to call for the stop button in a progress gauge. 474 "Default function to call for the stop button in a progress gauge.
333 This just removes the progress gauge and calls quit." 475 This just removes the progress gauge and calls quit."
334 (interactive) 476 (interactive)
335 (clear-progress) 477 (clear-progress-display)
336 (keyboard-quit)) 478 (keyboard-quit))
337 479
338 ;; private variables 480 ;; private variables
339 (defvar progress-gauge-glyph 481 (defvar progress-gauge-glyph
340 (make-glyph 482 (make-glyph
359 :items (list 501 :items (list
360 progress-gauge-glyph 502 progress-gauge-glyph
361 (vector 503 (vector
362 'button :pixel-height (- progress-glyph-height 8) 504 'button :pixel-height (- progress-glyph-height 8)
363 :descriptor " Stop " 505 :descriptor " Stop "
364 :callback '(funcall progress-stop-callback))))))))) 506 :callback '(funcall progress-display-stop-callback)))))))))
365 507
366 (defvar progress-abort-glyph 508 (defvar progress-abort-glyph
367 (make-glyph 509 (make-glyph
368 (vector 'layout :orientation 'vertical :justify 'left 510 (vector 'layout :orientation 'vertical :justify 'left
369 :items (list progress-text-glyph 511 :items (list progress-text-glyph
370 (make-glyph 512 (make-glyph
371 (vector 'layout 513 (vector 'layout
372 :pixel-height progress-glyph-height 514 :pixel-height progress-glyph-height
373 :orientation 'horizontal)))))) 515 :orientation 'horizontal))))))
374 516
375 (defvar progress-extent-text "") 517 (defvar progress-extent-text "\n")
376 (defvar progress-extent nil) 518 (defvar progress-extent nil)
377 519
378 (defun progress-displayed-p (&optional return-string frame) 520 (defun progress-displayed-p (&optional return-string frame)
379 "Return a non-nil value if a progress gauge is presently displayed in the 521 "Return a non-nil value if a progress gauge is presently displayed in the
380 gutter area. If optional argument RETURN-STRING is non-nil, 522 gutter area. If optional argument RETURN-STRING is non-nil,
385 (buffer-substring nil nil buffer) 527 (buffer-substring nil nil buffer)
386 t)))) 528 t))))
387 529
388 ;;; Returns the string which remains in the echo area, or nil if none. 530 ;;; Returns the string which remains in the echo area, or nil if none.
389 ;;; If label is nil, the whole message stack is cleared. 531 ;;; If label is nil, the whole message stack is cleared.
390 (defun clear-progress (&optional label frame no-restore) 532 (defun clear-progress-display (&optional label frame no-restore)
391 "Remove any progress gauge with the given LABEL from the progress gauge-stack, 533 "Remove any progress gauge with LABEL from the progress gauge-stack,
392 erasing it from the gutter area if it's currently displayed there. 534 erasing it from the gutter area if it's currently displayed there.
393 If a message remains at the head of the progress-stack and NO-RESTORE 535 If a message remains at the head of the progress-stack and NO-RESTORE
394 is nil, it will be displayed. The string which remains in the gutter 536 is nil, it will be displayed. The string which remains in the gutter
395 area will be returned, or nil if the progress-stack is now empty. 537 area will be returned, or nil if the progress-stack is now empty.
396 If LABEL is nil, the entire progress-stack is cleared. 538 If LABEL is nil, the entire progress-stack is cleared.
397 539
398 Unless you need the return value or you need to specify a label, 540 Unless you need the return value or you need to specify a label,
399 you should just use (progress nil)." 541 you should just use (progress nil)."
400 (or frame (setq frame (selected-frame))) 542 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
401 (remove-progress label frame) 543 progress-display-use-echo-area)
402 (let ((inhibit-read-only t) 544 (clear-message label frame nil no-restore)
403 (zmacs-region-stays zmacs-region-stays)) ; preserve from change 545 (or frame (setq frame (selected-frame)))
404 (erase-buffer " *Echo Area*") 546 (remove-progress-display label frame)
405 (erase-buffer (get-buffer-create " *Gutter Area*"))) 547 (let ((inhibit-read-only t)
406 (if no-restore 548 (zmacs-region-stays zmacs-region-stays)) ; preserve from change
407 nil ; just preparing to put another msg up 549 (erase-buffer (get-buffer-create " *Gutter Area*")))
408 (if progress-stack 550 (if no-restore
409 (let ((oldmsg (cdr (car progress-stack)))) 551 nil ; just preparing to put another msg up
410 (raw-append-progress oldmsg frame) 552 (if progress-stack
411 oldmsg) 553 (let ((oldmsg (cdr (car progress-stack))))
412 ;; nothing to display so get rid of the gauge 554 (raw-append-progress-display oldmsg frame)
413 (set-specifier bottom-gutter-border-width 0 frame) 555 oldmsg)
414 (set-specifier bottom-gutter-visible-p nil frame)))) 556 ;; nothing to display so get rid of the gauge
415 557 (set-specifier bottom-gutter-border-width 0 frame)
416 (defun remove-progress (&optional label frame) 558 (set-gutter-element-visible-p bottom-gutter-visible-p
559 'progress nil frame)))))
560
561 (defun progress-display-clear-when-idle (&optional label)
562 (add-hook 'pre-idle-hook
563 (defun progress-display-clear-pre-idle-hook ()
564 (clear-progress-display label)
565 (remove-hook 'pre-idle-hook
566 'progress-display-clear-pre-idle-hook))))
567
568 (defun remove-progress-display (&optional label frame)
417 ;; If label is nil, we want to remove all matching progress gauges. 569 ;; If label is nil, we want to remove all matching progress gauges.
418 (while (and progress-stack 570 (while (and progress-stack
419 (or (null label) ; null label means clear whole stack 571 (or (null label) ; null label means clear whole stack
420 (eq label (car (car progress-stack))))) 572 (eq label (car (car progress-stack)))))
421 (setq progress-stack (cdr progress-stack))) 573 (setq progress-stack (cdr progress-stack)))
425 (if (eq label (car msg)) 577 (if (eq label (car msg))
426 (progn 578 (progn
427 (setcdr s (cdr (cdr s)))) 579 (setcdr s (cdr (cdr s))))
428 (setq s (cdr s))))))) 580 (setq s (cdr s)))))))
429 581
430 (defun append-progress (label message &optional value frame) 582 (defun append-progress-display (label message &optional value frame)
431 (or frame (setq frame (selected-frame))) 583 (or frame (setq frame (selected-frame)))
432 ;; Add a new entry to the message-stack, or modify an existing one 584 ;; Add a new entry to the message-stack, or modify an existing one
433 (let* ((top (car progress-stack)) 585 (let* ((top (car progress-stack))
434 (tmsg (cdr top))) 586 (tmsg (cdr top)))
435 (if (eq label (car top)) 587 (if (eq label (car top))
436 (progn 588 (progn
437 (setcdr top message) 589 (setcdr top message)
438 (if (eq tmsg message) 590 (if (equal tmsg message)
439 (set-image-instance-property 591 (set-image-instance-property
440 (glyph-image-instance progress-gauge-glyph) 592 (glyph-image-instance progress-gauge-glyph)
441 :percent value) 593 :percent value)
442 (raw-append-progress message value frame)) 594 (raw-append-progress-display message value frame))
443 (redisplay-gutter-area) 595 (redisplay-gutter-area))
444 (when (input-pending-p)
445 (dispatch-event (next-command-event))))
446 (push (cons label message) progress-stack) 596 (push (cons label message) progress-stack)
447 (raw-append-progress message value frame)) 597 (raw-append-progress-display message value frame))
448 (when (eq value 100) 598 (dispatch-non-command-events)
449 (sit-for 0.5 nil) 599 ;; either get command events or sit waiting for them
450 (clear-progress label)))) 600 (if (not (eq value 100))
451 601 (when (input-pending-p)
452 (defun abort-progress (label message &optional frame) 602 (dispatch-event (next-command-event)))
453 (or frame (setq frame (selected-frame))) 603 (sit-for progress-display-popup-period nil)
454 ;; Add a new entry to the message-stack, or modify an existing one 604 (clear-progress-display label))))
455 (let* ((top (car progress-stack)) 605
456 (inhibit-read-only t) 606 (defun abort-progress-display (label message &optional frame)
457 (zmacs-region-stays zmacs-region-stays)) 607 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
458 (if (eq label (car top)) 608 progress-display-use-echo-area)
459 (setcdr top message) 609 (display-message label (concat message "aborted.") frame)
460 (push (cons label message) progress-stack)) 610 (or frame (setq frame (selected-frame)))
461 (unless (equal message "") 611 ;; Add a new entry to the message-stack, or modify an existing one
462 (insert-string message (get-buffer-create " *Gutter Area*")) 612 (let* ((top (car progress-stack))
463 ;; Do what the device is able to cope with. 613 (inhibit-read-only t)
464 (if (not (valid-image-instantiator-format-p 'progress-gauge frame)) 614 (zmacs-region-stays zmacs-region-stays))
465 (progn 615 (if (eq label (car top))
466 (insert-string message " *Echo Area*") 616 (setcdr top message)
467 (if (not executing-kbd-macro) 617 (push (cons label message) progress-stack))
468 (redisplay-echo-area))) 618 (unless (equal message "")
619 (insert-string message (get-buffer-create " *Gutter Area*"))
620 ;; Do what the device is able to cope with.
469 ;; do some funky display here. 621 ;; do some funky display here.
470 (unless progress-extent 622 (unless progress-extent
471 (setq progress-extent (make-extent 0 0 progress-extent-text))) 623 (setq progress-extent (make-extent 0 1 progress-extent-text)))
472 (let ((bglyph (extent-begin-glyph progress-extent))) 624 (let ((bglyph (extent-begin-glyph progress-extent)))
473 (set-extent-begin-glyph progress-extent progress-abort-glyph) 625 (set-extent-begin-glyph progress-extent progress-abort-glyph)
474 ;; fixup the gutter specifiers 626 ;; fixup the gutter specifiers
475 (set-specifier bottom-gutter progress-extent-text frame) 627 (set-gutter-element bottom-gutter
628 'progress progress-extent-text frame)
476 (set-specifier bottom-gutter-border-width 2 frame) 629 (set-specifier bottom-gutter-border-width 2 frame)
477 (set-image-instance-property 630 (set-image-instance-property
478 (glyph-image-instance progress-text-glyph) :data message) 631 (glyph-image-instance progress-text-glyph) :data message)
479 (set-specifier bottom-gutter-height 'autodetect frame) 632 (set-specifier bottom-gutter-height 'autodetect frame)
480 (set-specifier bottom-gutter-visible-p t frame) 633 (set-gutter-element-visible-p bottom-gutter-visible-p
634 'progress t frame)
481 ;; we have to do this so redisplay is up-to-date and so 635 ;; we have to do this so redisplay is up-to-date and so
482 ;; redisplay-gutter-area performs optimally. 636 ;; redisplay-gutter-area performs optimally.
483 (redisplay-gutter-area) 637 (redisplay-gutter-area)
484 (sit-for 0.5 nil) 638 (sit-for progress-display-popup-period nil)
485 (clear-progress label) 639 (clear-progress-display label)
486 (set-extent-begin-glyph progress-extent bglyph) 640 (set-extent-begin-glyph progress-extent bglyph)
487 ))))) 641 )))))
488 642
489 (defun raw-append-progress (message &optional value frame) 643 (defun raw-append-progress-display (message &optional value frame)
490 (unless (equal message "") 644 (unless (equal message "")
491 (let ((inhibit-read-only t) 645 (let ((inhibit-read-only t)
492 (zmacs-region-stays zmacs-region-stays) 646 (zmacs-region-stays zmacs-region-stays)
493 (val (or value 0))) ; preserve from change 647 (val (or value 0)))
494 (insert-string message (get-buffer-create " *Gutter Area*")) 648 (insert-string message (get-buffer-create " *Gutter Area*"))
495 ;; Do what the device is able to cope with. 649 ;; do some funky display here.
496 (if (not (valid-image-instantiator-format-p 'progress-gauge frame)) 650 (unless progress-extent
651 (setq progress-extent (make-extent 0 1 progress-extent-text))
652 (set-extent-begin-glyph progress-extent progress-layout-glyph))
653 ;; fixup the gutter specifiers
654 (set-gutter-element bottom-gutter 'progress progress-extent-text frame)
655 (set-specifier bottom-gutter-border-width 2 frame)
656 (set-image-instance-property
657 (glyph-image-instance progress-gauge-glyph) :percent val)
658 (set-image-instance-property
659 (glyph-image-instance progress-text-glyph) :data message)
660 (if (and (eq (specifier-instance bottom-gutter-height frame)
661 'autodetect)
662 (gutter-element-visible-p bottom-gutter-visible-p
663 'progress frame))
497 (progn 664 (progn
498 (insert-string 665 ;; if the gauge is already visible then just draw the gutter
499 (concat message (if (eq val 100) "done.") 666 ;; checking for user events
500 (make-string (/ val 5) ?.)) 667 (redisplay-gutter-area)
501 " *Echo Area*") 668 (dispatch-non-command-events)
502 (if (not executing-kbd-macro) 669 (when (input-pending-p)
503 (redisplay-echo-area))) 670 (dispatch-event (next-command-event))))
504 ;; do some funky display here. 671 ;; otherwise make the gutter visible and redraw the frame
505 (unless progress-extent 672 (set-specifier bottom-gutter-height 'autodetect frame)
506 (setq progress-extent (make-extent 0 0 progress-extent-text)) 673 (set-gutter-element-visible-p bottom-gutter-visible-p
507 (set-extent-begin-glyph progress-extent progress-layout-glyph)) 674 'progress t frame)
508 ;; fixup the gutter specifiers 675 ;; we have to do this so redisplay is up-to-date and so
509 (set-specifier bottom-gutter progress-extent-text frame) 676 ;; redisplay-gutter-area performs optimally. This may also
510 (set-specifier bottom-gutter-border-width 2 frame) 677 ;; make sure the frame geometry looks ok.
511 (set-image-instance-property 678 (dispatch-non-command-events)
512 (glyph-image-instance progress-gauge-glyph) :percent val) 679 (redisplay-frame)
513 (set-image-instance-property 680 ))))
514 (glyph-image-instance progress-text-glyph) :data message) 681
515 (if (and (eq (specifier-instance bottom-gutter-height frame) 682 (defun display-progress-display (label message &optional value frame)
516 'autodetect)
517 (specifier-instance bottom-gutter-visible-p frame))
518 (progn
519 ;; if the gauge is already visible then just draw the gutter
520 ;; checking for user events
521 (redisplay-gutter-area)
522 (when (input-pending-p)
523 (dispatch-event (next-command-event))))
524 ;; otherwise make the gutter visible and redraw the frame
525 (set-specifier bottom-gutter-height 'autodetect frame)
526 (set-specifier bottom-gutter-visible-p t frame)
527 ;; we have to do this so redisplay is up-to-date and so
528 ;; redisplay-gutter-area performs optimally.
529 (redisplay-frame)
530 )))))
531
532 (defun display-progress (label message &optional value frame)
533 "Display a progress gauge and message in the bottom gutter area. 683 "Display a progress gauge and message in the bottom gutter area.
534 First argument LABEL is an identifier for this message. MESSAGE is 684 First argument LABEL is an identifier for this message. MESSAGE is
535 the string to display. Use `clear-progress' to remove a labelled 685 the string to display. Use `clear-progress-display' to remove a labelled
536 message." 686 message."
537 (clear-progress label frame t) 687 (cond ((eq value 'abort)
538 (if (eq value 'abort) 688 (abort-progress-display label message frame))
539 (abort-progress label message frame) 689 ((or (not (valid-image-instantiator-format-p 'progress-gauge frame))
540 (append-progress label message value frame))) 690 progress-display-use-echo-area)
541 691 (display-message label
542 (defun current-progress (&optional frame) 692 (concat message (if (eq value 100) "done."
693 (make-string (/ value 5) ?.)))
694 frame))
695 (t
696 (append-progress-display label message value frame))))
697
698 (defun current-progress-display (&optional frame)
543 "Return the current progress gauge in the gutter area, or nil. 699 "Return the current progress gauge in the gutter area, or nil.
544 The FRAME argument is currently unused." 700 The FRAME argument is currently unused."
545 (cdr (car progress-stack))) 701 (cdr (car progress-stack)))
546 702
547 ;;; may eventually be frame-dependent 703 ;;; may eventually be frame-dependent
548 (defun current-progress-label (&optional frame) 704 (defun current-progress-display-label (&optional frame)
549 (car (car progress-stack))) 705 (car (car progress-stack)))
550 706
551 (defun progress (fmt &optional value &rest args) 707 (defun progress-display (fmt &optional value &rest args)
552 "Print a progress gauge and message in the bottom gutter area of the frame. 708 "Print a progress gauge and message in the bottom gutter area of the frame.
553 The arguments are the same as to `format'. 709 The arguments are the same as to `format'.
554 710
555 If the only argument is nil, clear any existing progress gauge." 711 If the only argument is nil, clear any existing progress gauge."
556 (if (and (null fmt) (null args)) 712 (save-excursion
557 (prog1 nil 713 (if (and (null fmt) (null args))
558 (clear-progress nil)) 714 (prog1 nil
559 (let ((str (apply 'format fmt args))) 715 (clear-progress-display nil))
560 (display-progress 'progress str value) 716 (let ((str (apply 'format fmt args)))
561 str))) 717 (display-progress-display 'progress str value)
562 718 str))))
563 (defun lprogress (label fmt &optional value &rest args) 719
720 (defun lprogress-display (label fmt &optional value &rest args)
564 "Print a progress gauge and message in the bottom gutter area of the frame. 721 "Print a progress gauge and message in the bottom gutter area of the frame.
565 First argument LABEL is an identifier for this progress gauge. The rest of the 722 First argument LABEL is an identifier for this progress gauge. The rest of the
566 arguments are the same as to `format'." 723 arguments are the same as to `format'."
567 (if (and (null fmt) (null args)) 724 ;; #### sometimes the buffer gets changed temporarily. I don't know
568 (prog1 nil 725 ;; why this is, so protect against it.
569 (clear-progress label nil)) 726 (save-excursion
570 (let ((str (apply 'format fmt args))) 727 (if (and (null fmt) (null args))
571 (display-progress label str value) 728 (prog1 nil
572 str))) 729 (clear-progress-display label nil))
730 (let ((str (apply 'format fmt args)))
731 (display-progress-display label str value)
732 str))))
573 733
574 (provide 'gutter-items) 734 (provide 'gutter-items)
575 ;;; gutter-items.el ends here. 735 ;;; gutter-items.el ends here.