Mercurial > hg > xemacs-beta

comparison lisp/gutter-items.el @ 442:abe6d1db359e r21-2-36

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-36
author cvs
date Mon, 13 Aug 2007 11:35:02 +0200
parents 8de8e3f6228a
children 576fb035e263
comparison
equal deleted inserted replaced
441:72a7cfa4a488 442:abe6d1db359e
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 ;; Copyright (C) 2000 Ben Wing.
5 6
6 ;; Maintainer: XEmacs Development Team 7 ;; Maintainer: XEmacs Development Team
7 ;; Keywords: frames, extensions, internal, dumped 8 ;; Keywords: frames, extensions, internal, dumped
8 9
9 ;; This file is part of XEmacs. 10 ;; This file is part of XEmacs.
22 ;; along with Xmacs; see the file COPYING. If not, write to the 23 ;; along with Xmacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, 59 Temple Place - Suite 330, 24 ;; Free Software Foundation, 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA. 25 ;; Boston, MA 02111-1307, USA.
25 26
26 ;; Some of this is taken from the buffer-menu stuff in menubar-items.el 27 ;; Some of this is taken from the buffer-menu stuff in menubar-items.el
27 ;; and the custom specs in toolbar.el.
28
29 (defgroup gutter nil
30 "Input from the gutters."
31 :group 'environment)
32
33 (defvar gutter-buffers-tab nil
34 "A tab widget in the gutter for displaying buffers.
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 'display
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
50 (default-gutter-position)
51 "The location of the default gutter. It can be 'top, 'bottom, 'left or
52 'right. This option can be customized through the options menu."
53 :group 'display
54 :type '(choice (const :tag "top" 'top)
55 (const :tag "bottom" 'bottom)
56 (const :tag "left" 'left)
57 (const :tag "right" 'right))
58 :set #'(lambda (var val)
59 (set-default-gutter-position val)
60 (setq default-gutter-position val)
61 (when gutter-buffers-tab (update-tab-in-gutter))))
62 28
63 ;;; The Buffers tab 29 ;;; The Buffers tab
64 30
65 (defgroup buffers-tab nil 31 (defgroup buffers-tab nil
66 "Customization of `Buffers' tab." 32 "Customization of `Buffers' tab."
67 :group 'gutter) 33 :group 'gutter)
34
35 (defvar gutter-buffers-tab nil
36 "A tab widget in the gutter for displaying buffers.
37 Do not set this. Use `set-glyph-image' to change the properties of the tab.")
38
39 (defcustom gutter-buffers-tab-visible-p
40 (gutter-element-visible-p default-gutter-visible-p 'buffers-tab)
41 "Whether the buffers tab is globally visible.
42 This option should be set through the options menu."
43 :group 'buffers-tab
44 :type 'boolean
45 :set #'(lambda (var val)
46 (set-gutter-element-visible-p default-gutter-visible-p
47 'buffers-tab val)
48 (setq gutter-buffers-tab-visible-p val)))
68 49
69 (defvar gutter-buffers-tab-orientation 'top 50 (defvar gutter-buffers-tab-orientation 'top
70 "Where the buffers tab currently is. Do not set this.") 51 "Where the buffers tab currently is. Do not set this.")
71 52
72 (defvar gutter-buffers-tab-extent nil) 53 (defvar gutter-buffers-tab-extent nil)
102 "*If non-nil, a function specifying the buffers to select from the 83 "*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 84 buffers tab. This is passed two buffers and should return non-nil if
104 the second buffer should be selected. The default value 85 the second buffer should be selected. The default value
105 `select-buffers-tab-buffers-by-mode' groups buffers by major mode and 86 `select-buffers-tab-buffers-by-mode' groups buffers by major mode and
106 by `buffers-tab-grouping-regexp'." 87 by `buffers-tab-grouping-regexp'."
88
89 :type '(choice (const :tag "None" nil)
90 function)
91 :group 'buffers-tab)
92
93 (defcustom buffers-tab-sort-function nil
94 "*If non-nil, a function specifying the buffers to select from the
95 buffers tab. This is passed the buffer list and returns the list in the
96 order desired for the tab widget. The default value `nil' leaves the
97 list in `buffer-list' order (usual most-recently-selected-first)."
107 98
108 :type '(choice (const :tag "None" nil) 99 :type '(choice (const :tag "None" nil)
109 function) 100 function)
110 :group 'buffers-tab) 101 :group 'buffers-tab)
111 102
157 (setq buffers-tab-max-buffer-line-length val))) 148 (setq buffers-tab-max-buffer-line-length val)))
158 149
159 (defun buffers-tab-switch-to-buffer (buffer) 150 (defun buffers-tab-switch-to-buffer (buffer)
160 "For use as a value for `buffers-tab-switch-to-buffer-function'." 151 "For use as a value for `buffers-tab-switch-to-buffer-function'."
161 (unless (eq (window-buffer) buffer) 152 (unless (eq (window-buffer) buffer)
153 ;; this used to add the norecord flag to both calls below.
154 ;; this is bogus because it is a pervasive assumption in XEmacs
155 ;; that the current buffer is at the front of the buffers list.
156 ;; for example, select an item and then do M-C-l
157 ;; (switch-to-other-buffer). Things get way confused.
162 (if (> (length (windows-of-buffer buffer)) 0) 158 (if (> (length (windows-of-buffer buffer)) 0)
163 (select-window (car (windows-of-buffer buffer))) 159 (select-window (car (windows-of-buffer buffer)))
164 (switch-to-buffer buffer t)))) 160 (switch-to-buffer buffer))))
165 161
166 (defun select-buffers-tab-buffers-by-mode (buf1 buf2) 162 (defun select-buffers-tab-buffers-by-mode (buf1 buf2)
167 "For use as a value of `buffers-tab-selection-function'. 163 "For use as a value of `buffers-tab-selection-function'.
168 This selects buffers by major mode `buffers-tab-grouping-regexp'." 164 This selects buffers by major mode `buffers-tab-grouping-regexp'."
169 (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1))) 165 (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1)))
201 (concat (substring (buffer-name buffer) 197 (concat (substring (buffer-name buffer)
202 0 (- len 3)) "...")) 198 0 (- len 3)) "..."))
203 (buffer-name buffer)))) 199 (buffer-name buffer))))
204 200
205 (defsubst build-buffers-tab-internal (buffers) 201 (defsubst build-buffers-tab-internal (buffers)
206 (let (line) 202 (let ((selected t))
207 (mapcar 203 (mapcar
208 #'(lambda (buffer) 204 #'(lambda (buffer)
209 (setq line (funcall buffers-tab-format-buffer-line-function 205 (prog1
210 buffer)) 206 (vector
211 (vector line (list buffers-tab-switch-to-buffer-function 207 (funcall buffers-tab-format-buffer-line-function
212 (buffer-name buffer)))) 208 buffer)
209 (list buffers-tab-switch-to-buffer-function
210 (buffer-name buffer))
211 :selected selected)
212 (when selected (setq selected nil))))
213 buffers))) 213 buffers)))
214 214
215 (defun buffers-tab-items (&optional in-deletion frame) 215 ;;; #### SJT I'd really like this function to have just two hooks: (1) the
216 ;;; buffer filter list and (2) a sort function list. Both should be lists
217 ;;; of functions. Each filter takes two arguments: a buffer and a model
218 ;;; buffer. (The model buffer argument allows selecting according to the
219 ;;; mode or directory of that buffer.) The filter returns t if the buffer
220 ;;; should be listed and nil otherwise. Effectively the filter amounts to
221 ;;; the conjuction of the filter list. (Optionally the filter could take a
222 ;;; frame instead of a buffer or generalize to a locale as in a specifier?)
223 ;;; The filtering is done this way to preserve the ordering imposed by
224 ;;; `buffer-list'. In addition, the in-deletion argument will be used the
225 ;;; same way as in the current design.
226 ;;; The list is checked for length and pruned according to least-recently-
227 ;;; selected. (Optionally there could be some kind of sort function here,
228 ;;; too.)
229 ;;; Finally the list is sorted to gutter display order, and the tab data
230 ;;; structure is created and returned.
231 ;;; #### Docstring isn't very well expressed.
232 (defun buffers-tab-items (&optional in-deletion frame force-selection)
216 "This is the tab filter for the top-level buffers \"Buffers\" tab. 233 "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. 234 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 235 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 236 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 237 setting `buffers-tab-max-size'. You can control the text of the tab
221 items by redefining the function `format-buffers-menu-line'." 238 items by redefining the function `format-buffers-menu-line'."
222 (save-match-data 239 (save-match-data
223 (let* ((buffers (delete-if buffers-tab-omit-function (buffer-list frame))) 240 (let* ((buffers (delete-if buffers-tab-omit-function (buffer-list frame)))
224 (first-buf (car buffers))) 241 (first-buf (car buffers)))
242 ;; maybe force the selected window
243 (when (and force-selection
244 (not in-deletion)
245 (not (eq first-buf (window-buffer (selected-window frame)))))
246 (setq buffers (cons (window-buffer (selected-window frame))
247 (delq first-buf buffers))))
225 ;; if we're in deletion ignore the current buffer 248 ;; if we're in deletion ignore the current buffer
226 (when in-deletion 249 (when in-deletion
227 (setq buffers (delq (current-buffer) buffers)) 250 (setq buffers (delq (current-buffer) buffers))
228 (setq first-buf (car buffers))) 251 (setq first-buf (car buffers)))
229 ;; group buffers by mode 252 ;; select buffers in group (default is by mode)
230 (when buffers-tab-selection-function 253 (when buffers-tab-selection-function
231 (delete-if-not #'(lambda (buf) 254 (delete-if-not #'(lambda (buf)
232 (funcall buffers-tab-selection-function 255 (funcall buffers-tab-selection-function
233 first-buf buf)) buffers)) 256 first-buf buf)) buffers))
257 ;; maybe shorten list of buffers
234 (and (integerp buffers-tab-max-size) 258 (and (integerp buffers-tab-max-size)
235 (> buffers-tab-max-size 1) 259 (> buffers-tab-max-size 1)
236 (> (length buffers) buffers-tab-max-size) 260 (> (length buffers) buffers-tab-max-size)
237 ;; shorten list of buffers
238 (setcdr (nthcdr buffers-tab-max-size buffers) nil)) 261 (setcdr (nthcdr buffers-tab-max-size buffers) nil))
262 ;; sort buffers in group (default is most-recently-selected)
263 (when buffers-tab-sort-function
264 (setq buffers (funcall buffers-tab-sort-function buffers)))
265 ;; convert list of buffers to list of structures used by tab widget
239 (setq buffers (build-buffers-tab-internal buffers)) 266 (setq buffers (build-buffers-tab-internal buffers))
240 buffers))) 267 buffers)))
241 268
242 (defun add-tab-to-gutter () 269 (defun add-tab-to-gutter ()
243 "Put a tab control in the gutter area to hold the most recent buffers." 270 "Put a tab control in the gutter area to hold the most recent buffers."
244 (setq gutter-buffers-tab-orientation (default-gutter-position)) 271 (setq gutter-buffers-tab-orientation (default-gutter-position))
245 (let ((gutter-string "")) 272 (let ((gutter-string (copy-sequence "\n")))
246 (unless gutter-buffers-tab-extent 273 (unless gutter-buffers-tab-extent
247 (setq gutter-buffers-tab-extent (make-extent 0 0 gutter-string))) 274 (setq gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
248 (set-extent-begin-glyph 275 (set-extent-begin-glyph
249 gutter-buffers-tab-extent 276 gutter-buffers-tab-extent
250 (setq gutter-buffers-tab 277 (setq gutter-buffers-tab
251 (make-glyph 278 (make-glyph)))
252 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face 279
253 :orientation gutter-buffers-tab-orientation 280 ;; Nuke all existing tabs
254 :properties (list :items (buffers-tab-items)))))) 281 (remove-gutter-element top-gutter 'buffers-tab)
255 ;; This looks better than a 3d border 282 (remove-gutter-element bottom-gutter 'buffers-tab)
256 (mapcar '(lambda (x) 283 (remove-gutter-element left-gutter 'buffers-tab)
257 (when (valid-image-instantiator-format-p 'tab-control x) 284 (remove-gutter-element right-gutter 'buffers-tab)
258 (set-specifier default-gutter-border-width 0 'global x) 285 ;; Put tabs into all devices that will be able to display them
259 (set-specifier top-gutter nil 'global x) 286 (mapcar
260 (set-specifier bottom-gutter nil 'global x) 287 #'(lambda (x)
261 (set-specifier left-gutter nil 'global x) 288 (when (valid-image-instantiator-format-p 'tab-control x)
262 (set-specifier right-gutter nil 'global x) 289 (cond ((eq gutter-buffers-tab-orientation 'top)
263 (set-specifier left-gutter-width 0 'global x) 290 ;; This looks better than a 3d border
264 (set-specifier right-gutter-width 0 'global x) 291 (set-specifier top-gutter-border-width 0 'global x)
265 (cond ((eq gutter-buffers-tab-orientation 'top) 292 (set-gutter-element top-gutter 'buffers-tab
266 (set-specifier top-gutter gutter-string 'global x)) 293 gutter-string 'global x))
267 ((eq gutter-buffers-tab-orientation 'bottom) 294 ((eq gutter-buffers-tab-orientation 'bottom)
268 (set-specifier bottom-gutter gutter-string 'global x)) 295 (set-specifier bottom-gutter-border-width 0 'global x)
269 ((eq gutter-buffers-tab-orientation 'left) 296 (set-gutter-element bottom-gutter 'buffers-tab
270 (set-specifier left-gutter gutter-string 'global x) 297 gutter-string 'global x))
271 (set-specifier left-gutter-width 298 ((eq gutter-buffers-tab-orientation 'left)
272 (glyph-width gutter-buffers-tab) 299 (set-specifier left-gutter-border-width 0 'global x)
273 'global x)) 300 (set-gutter-element left-gutter 'buffers-tab
274 ((eq gutter-buffers-tab-orientation 'right) 301 gutter-string 'global x)
275 (set-specifier right-gutter gutter-string 'global x) 302 (set-specifier left-gutter-width
276 (set-specifier right-gutter-width 303 (glyph-width gutter-buffers-tab)
277 (glyph-width gutter-buffers-tab) 304 'global x))
278 'global x)) 305 ((eq gutter-buffers-tab-orientation 'right)
279 ))) 306 (set-specifier right-gutter-border-width 0 'global x)
280 (console-type-list)))) 307 (set-gutter-element right-gutter 'buffers-tab
281 308 gutter-string 'global x)
282 (defun update-tab-in-gutter (&optional frame-or-buffer) 309 (set-specifier right-gutter-width
310 (glyph-width gutter-buffers-tab)
311 'global x))
312 )))
313 (console-type-list))))
314
315 (defun update-tab-in-gutter (frame &optional force-selection)
283 "Update the tab control in the gutter area." 316 "Update the tab control in the gutter area."
284 (let ((locale (if (framep frame-or-buffer) frame-or-buffer))) 317 ;; dedicated frames don't get tabs
285 (when (specifier-instance default-gutter-visible-p locale) 318 (unless (window-dedicated-p (frame-selected-window frame))
286 (unless (and gutter-buffers-tab 319 (when (specifier-instance default-gutter-visible-p frame)
320 (unless (and gutter-buffers-tab
287 (eq (default-gutter-position) 321 (eq (default-gutter-position)
288 gutter-buffers-tab-orientation)) 322 gutter-buffers-tab-orientation))
289 (add-tab-to-gutter)) 323 (add-tab-to-gutter))
290 (when (valid-image-instantiator-format-p 'tab-control locale) 324 (when (valid-image-instantiator-format-p 'tab-control frame)
291 (let ((inst (glyph-image-instance 325 (set-glyph-image
292 gutter-buffers-tab 326 gutter-buffers-tab
293 (when (framep frame-or-buffer) 327 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
294 (last-nonminibuf-window frame-or-buffer))))) 328 :orientation gutter-buffers-tab-orientation
295 (set-image-instance-property inst :items 329 (if (or (eq gutter-buffers-tab-orientation 'top)
296 (buffers-tab-items 330 (eq gutter-buffers-tab-orientation 'bottom))
297 nil locale))))))) 331 :pixel-width :pixel-height)
298 332 (if (or (eq gutter-buffers-tab-orientation 'top)
299 (defun remove-buffer-from-gutter-tab () 333 (eq gutter-buffers-tab-orientation 'bottom))
300 "Remove the current buffer from the tab control in the gutter area." 334 '(gutter-pixel-width) '(gutter-pixel-height))
301 (when (and (valid-image-instantiator-format-p 'tab-control) 335 :items (buffers-tab-items nil frame force-selection))
302 (specifier-instance default-gutter-visible-p)) 336 frame)))))
303 (let ((inst (glyph-image-instance gutter-buffers-tab)) 337
304 (buffers (buffers-tab-items t))) 338 ;; A myriad of different update hooks all doing slightly different things
305 (unless buffers 339 (add-hook 'create-frame-hook
306 (setq buffers (build-buffers-tab-internal 340 #'(lambda (frame)
307 (list 341 (when gutter-buffers-tab (update-tab-in-gutter frame t))))
308 (get-buffer-create "*scratch*"))))) 342 (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter)
309 (set-image-instance-property inst :items buffers)))) 343 (add-hook 'default-gutter-position-changed-hook
310 344 #'(lambda ()
311 (add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab) 345 (when gutter-buffers-tab
312 (add-hook 'create-frame-hook 'update-tab-in-gutter) 346 (mapc #'update-tab-in-gutter (frame-list)))))
313 (add-hook 'record-buffer-hook 'update-tab-in-gutter) 347 (add-hook 'gutter-element-visibility-changed-hook
314 348 #'(lambda (prop visible-p)
349 (when (and (eq prop 'buffers-tab) visible-p)
350 (mapc #'update-tab-in-gutter (frame-list)))))
315 ;; 351 ;;
316 ;; progress display 352 ;; progress display
317 ;; ripped off from message display 353 ;; ripped off from message display
318 ;; 354 ;;
355 (defcustom progress-feedback-use-echo-area nil
356 "*Whether progress gauge display should display in the echo area.
357 If NIL then progress gauges will be displayed with whatever native widgets
358 are available on the current console. If non-NIL then progress display will be
359 textual and displayed in the echo area."
360 :type 'boolean
361 :group 'gutter)
362
363 (defvar progress-glyph-height 24
364 "Height of the progress gauge glyph.")
365
366 (defvar progress-feedback-popup-period 0.5
367 "The time that the progress gauge should remain up after completion")
368
369 (defcustom progress-feedback-style 'large
370 "*Control the appearance of the progress gauge.
371 If 'large, the default, then the progress-feedback text is displayed
372 above the gauge itself. If 'small then the gauge and text are arranged
373 side-by-side."
374 :group 'gutter
375 :type '(choice (const :tag "large" large)
376 (const :tag "small" small)))
377
378 ;; private variables
379 (defvar progress-text-instantiator [string :data ""])
380 (defvar progress-layout-glyph (make-glyph))
381 (defvar progress-layout-instantiator nil)
382
383 (defvar progress-gauge-instantiator
384 [progress-gauge
385 :value 0
386 :pixel-height (eval progress-glyph-height)
387 :pixel-width 250
388 :descriptor "Progress"])
389
390 (defun set-progress-feedback-instantiator (&optional locale)
391 (cond
392 ((eq progress-feedback-style 'small)
393 (setq progress-glyph-height 16)
394 (setq progress-layout-instantiator
395 `[layout
396 :orientation horizontal
397 :margin-width 4
398 :items (,progress-gauge-instantiator
399 [button
400 :pixel-height (eval progress-glyph-height)
401 ;; 'quit is special and acts "asynchronously".
402 :descriptor "Stop" :callback 'quit]
403 ,progress-text-instantiator)])
404 (set-glyph-image progress-layout-glyph progress-layout-instantiator locale))
405 (t
406 (setq progress-glyph-height 24)
407 (setq progress-layout-instantiator
408 `[layout
409 :orientation vertical :justify left
410 :margin-width 4
411 :items (,progress-text-instantiator
412 [layout
413 :orientation horizontal
414 :items (,progress-gauge-instantiator
415 [button
416 :pixel-height (eval progress-glyph-height)
417 :descriptor " Stop "
418 ;; 'quit is special and acts "asynchronously".
419 :callback 'quit])])])
420 (set-glyph-image progress-layout-glyph progress-layout-instantiator locale))))
421
319 (defvar progress-stack nil 422 (defvar progress-stack nil
320 "An alist of label/string pairs representing active progress gauges. 423 "An alist of label/string pairs representing active progress gauges.
321 The first element in the list is currently displayed in the gutter area. 424 The first element in the list is currently displayed in the gutter area.
322 Do not modify this directly--use the `progress' or 425 Do not modify this directly--use the `progress-feedback' or
323 `display-progress'/`clear-progress' functions.") 426 `display-progress-feedback'/`clear-progress-feedback' functions.")
324
325 (defvar progress-glyph-height 32
326 "Height of the gutter area for progress messages.")
327
328 (defvar progress-stop-callback 'progress-quit-function
329 "Function to call to stop the progress operation.")
330
331 (defun progress-quit-function ()
332 "Default function to call for the stop button in a progress gauge.
333 This just removes the progress gauge and calls quit."
334 (interactive)
335 (clear-progress)
336 (keyboard-quit))
337
338 ;; private variables
339 (defvar progress-gauge-glyph
340 (make-glyph
341 (vector 'progress-gauge
342 :pixel-height (- progress-glyph-height 8)
343 :pixel-width 50
344 :descriptor "Progress")))
345
346 (defvar progress-text-glyph
347 (make-glyph [string :data ""]))
348
349 (defvar progress-layout-glyph
350 (make-glyph
351 (vector
352 'layout :orientation 'vertical :justify 'left
353 :items (list
354 progress-text-glyph
355 (make-glyph
356 (vector
357 'layout :pixel-height progress-glyph-height
358 :orientation 'horizontal
359 :items (list
360 progress-gauge-glyph
361 (vector
362 'button :pixel-height (- progress-glyph-height 8)
363 :descriptor " Stop "
364 :callback '(funcall progress-stop-callback)))))))))
365 427
366 (defvar progress-abort-glyph 428 (defvar progress-abort-glyph
367 (make-glyph 429 (make-glyph
368 (vector 'layout :orientation 'vertical :justify 'left 430 `[layout :orientation vertical :justify left
369 :items (list progress-text-glyph 431 :items (,progress-text-instantiator
370 (make-glyph 432 [layout
371 (vector 'layout 433 :margin-width 4
372 :pixel-height progress-glyph-height 434 :pixel-height progress-glyph-height
373 :orientation 'horizontal)))))) 435 :orientation horizontal])]))
374 436
375 (defvar progress-extent-text "") 437 (defun progress-feedback-displayed-p (&optional return-string frame)
376 (defvar progress-extent nil)
377
378 (defun progress-displayed-p (&optional return-string frame)
379 "Return a non-nil value if a progress gauge is presently displayed in the 438 "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, 439 gutter area. If optional argument RETURN-STRING is non-nil,
381 return a string containing the message, otherwise just return t." 440 return a string containing the message, otherwise just return t."
382 (let ((buffer (get-buffer-create " *Gutter Area*"))) 441 (let ((buffer (get-buffer-create " *Gutter Area*")))
383 (and (< (point-min buffer) (point-max buffer)) 442 (and (< (point-min buffer) (point-max buffer))
385 (buffer-substring nil nil buffer) 444 (buffer-substring nil nil buffer)
386 t)))) 445 t))))
387 446
388 ;;; Returns the string which remains in the echo area, or nil if none. 447 ;;; Returns the string which remains in the echo area, or nil if none.
389 ;;; If label is nil, the whole message stack is cleared. 448 ;;; If label is nil, the whole message stack is cleared.
390 (defun clear-progress (&optional label frame no-restore) 449 (defun clear-progress-feedback (&optional label frame no-restore)
391 "Remove any progress gauge with the given LABEL from the progress gauge-stack, 450 "Remove any progress gauge with LABEL from the progress gauge-stack,
392 erasing it from the gutter area if it's currently displayed there. 451 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 452 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 453 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. 454 area will be returned, or nil if the progress-stack is now empty.
396 If LABEL is nil, the entire progress-stack is cleared. 455 If LABEL is nil, the entire progress-stack is cleared.
397 456
398 Unless you need the return value or you need to specify a label, 457 Unless you need the return value or you need to specify a label,
399 you should just use (progress nil)." 458 you should just use (progress nil)."
400 (or frame (setq frame (selected-frame))) 459 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
401 (remove-progress label frame) 460 progress-feedback-use-echo-area)
402 (let ((inhibit-read-only t) 461 (clear-message label frame nil no-restore)
403 (zmacs-region-stays zmacs-region-stays)) ; preserve from change 462 (or frame (setq frame (selected-frame)))
404 (erase-buffer " *Echo Area*") 463 (remove-progress-feedback label frame)
405 (erase-buffer (get-buffer-create " *Gutter Area*"))) 464 (let ((inhibit-read-only t)
406 (if no-restore 465 (zmacs-region-stays zmacs-region-stays)) ; preserve from change
407 nil ; just preparing to put another msg up 466 (erase-buffer (get-buffer-create " *Gutter Area*")))
408 (if progress-stack 467 (if no-restore
409 (let ((oldmsg (cdr (car progress-stack)))) 468 nil ; just preparing to put another msg up
410 (raw-append-progress oldmsg frame) 469 (if progress-stack
411 oldmsg) 470 (let ((oldmsg (cdr (car progress-stack))))
412 ;; nothing to display so get rid of the gauge 471 (raw-append-progress-feedback oldmsg nil frame)
413 (set-specifier bottom-gutter-border-width 0 frame) 472 oldmsg)
414 (set-specifier bottom-gutter-visible-p nil frame)))) 473 ;; nothing to display so get rid of the gauge
415 474 (set-specifier bottom-gutter-border-width 0 frame)
416 (defun remove-progress (&optional label frame) 475 (set-gutter-element-visible-p bottom-gutter-visible-p
476 'progress nil frame)))))
477
478 (defun progress-feedback-clear-when-idle (&optional label)
479 (add-one-shot-hook 'pre-idle-hook
480 `(lambda ()
481 (clear-progress-feedback ',label))))
482
483 (defun remove-progress-feedback (&optional label frame)
417 ;; If label is nil, we want to remove all matching progress gauges. 484 ;; If label is nil, we want to remove all matching progress gauges.
418 (while (and progress-stack 485 (while (and progress-stack
419 (or (null label) ; null label means clear whole stack 486 (or (null label) ; null label means clear whole stack
420 (eq label (car (car progress-stack))))) 487 (eq label (car (car progress-stack)))))
421 (setq progress-stack (cdr progress-stack))) 488 (setq progress-stack (cdr progress-stack)))
425 (if (eq label (car msg)) 492 (if (eq label (car msg))
426 (progn 493 (progn
427 (setcdr s (cdr (cdr s)))) 494 (setcdr s (cdr (cdr s))))
428 (setq s (cdr s))))))) 495 (setq s (cdr s)))))))
429 496
430 (defun append-progress (label message &optional value frame) 497 (defun progress-feedback-dispatch-non-command-events ()
498 ;; don't allow errors to hose things
499 (condition-case t
500 ;; (sit-for 0) is too agressive and cause more display than we
501 ;; want.
502 (dispatch-non-command-events)
503 nil))
504
505 (defun append-progress-feedback (label message &optional value frame)
431 (or frame (setq frame (selected-frame))) 506 (or frame (setq frame (selected-frame)))
432 ;; Add a new entry to the message-stack, or modify an existing one 507 ;; Add a new entry to the message-stack, or modify an existing one
433 (let* ((top (car progress-stack)) 508 (let* ((top (car progress-stack))
434 (tmsg (cdr top))) 509 (tmsg (cdr top)))
435 (if (eq label (car top)) 510 (if (eq label (car top))
436 (progn 511 (progn
437 (setcdr top message) 512 (setcdr top message)
438 (if (eq tmsg message) 513 (if (equal tmsg message)
439 (set-image-instance-property 514 (progn
440 (glyph-image-instance progress-gauge-glyph) 515 (set-instantiator-property progress-gauge-instantiator :value value)
441 :percent value) 516 (set-progress-feedback-instantiator (frame-selected-window frame)))
442 (raw-append-progress message value frame)) 517 (raw-append-progress-feedback message value frame))
443 (redisplay-gutter-area) 518 (redisplay-gutter-area))
444 (when (input-pending-p)
445 (dispatch-event (next-command-event))))
446 (push (cons label message) progress-stack) 519 (push (cons label message) progress-stack)
447 (raw-append-progress message value frame)) 520 (raw-append-progress-feedback message value frame))
448 (when (eq value 100) 521 (progress-feedback-dispatch-non-command-events)
449 (sit-for 0.5 nil) 522 ;; either get command events or sit waiting for them
450 (clear-progress label)))) 523 (when (eq value 100)
451 524 ; (sit-for progress-feedback-popup-period nil)
452 (defun abort-progress (label message &optional frame) 525 (clear-progress-feedback label))))
453 (or frame (setq frame (selected-frame))) 526
454 ;; Add a new entry to the message-stack, or modify an existing one 527 (defun abort-progress-feedback (label message &optional frame)
455 (let* ((top (car progress-stack)) 528 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
456 (inhibit-read-only t) 529 progress-feedback-use-echo-area)
457 (zmacs-region-stays zmacs-region-stays)) 530 (display-message label (concat message "aborted.") frame)
458 (if (eq label (car top)) 531 (or frame (setq frame (selected-frame)))
459 (setcdr top message) 532 ;; Add a new entry to the message-stack, or modify an existing one
460 (push (cons label message) progress-stack)) 533 (let* ((top (car progress-stack))
461 (unless (equal message "") 534 (inhibit-read-only t)
462 (insert-string message (get-buffer-create " *Gutter Area*")) 535 (zmacs-region-stays zmacs-region-stays))
463 ;; Do what the device is able to cope with. 536 (if (eq label (car top))
464 (if (not (valid-image-instantiator-format-p 'progress-gauge frame)) 537 (setcdr top message)
465 (progn 538 (push (cons label message) progress-stack))
466 (insert-string message " *Echo Area*") 539 (unless (equal message "")
467 (if (not executing-kbd-macro) 540 (insert-string message (get-buffer-create " *Gutter Area*"))
468 (redisplay-echo-area))) 541 (let* ((gutter-string (copy-sequence "\n"))
469 ;; do some funky display here. 542 (ext (make-extent 0 1 gutter-string)))
470 (unless progress-extent 543 ;; do some funky display here.
471 (setq progress-extent (make-extent 0 0 progress-extent-text))) 544 (set-extent-begin-glyph ext progress-abort-glyph)
472 (let ((bglyph (extent-begin-glyph progress-extent)))
473 (set-extent-begin-glyph progress-extent progress-abort-glyph)
474 ;; fixup the gutter specifiers 545 ;; fixup the gutter specifiers
475 (set-specifier bottom-gutter progress-extent-text frame) 546 (set-gutter-element bottom-gutter 'progress gutter-string frame)
476 (set-specifier bottom-gutter-border-width 2 frame) 547 (set-specifier bottom-gutter-border-width 2 frame)
477 (set-image-instance-property 548 (set-instantiator-property progress-text-instantiator :datat message)
478 (glyph-image-instance progress-text-glyph) :data message) 549 (set-progress-feedback-instantiator (frame-selected-window frame))
479 (set-specifier bottom-gutter-height 'autodetect frame) 550 (set-specifier bottom-gutter-height 'autodetect frame)
480 (set-specifier bottom-gutter-visible-p t frame) 551 (set-gutter-element-visible-p bottom-gutter-visible-p
552 'progress t frame)
481 ;; we have to do this so redisplay is up-to-date and so 553 ;; we have to do this so redisplay is up-to-date and so
482 ;; redisplay-gutter-area performs optimally. 554 ;; redisplay-gutter-area performs optimally.
483 (redisplay-gutter-area) 555 (redisplay-gutter-area)
484 (sit-for 0.5 nil) 556 (sit-for progress-feedback-popup-period nil)
485 (clear-progress label) 557 (clear-progress-feedback label frame)
486 (set-extent-begin-glyph progress-extent bglyph) 558 (set-extent-begin-glyph ext progress-layout-glyph)
559 (set-gutter-element bottom-gutter 'progress gutter-string frame)
487 ))))) 560 )))))
488 561
489 (defun raw-append-progress (message &optional value frame) 562 (defun raw-append-progress-feedback (message &optional value frame)
490 (unless (equal message "") 563 (unless (equal message "")
491 (let ((inhibit-read-only t) 564 (let* ((inhibit-read-only t)
492 (zmacs-region-stays zmacs-region-stays) 565 (zmacs-region-stays zmacs-region-stays)
493 (val (or value 0))) ; preserve from change 566 (val (or value 0))
567 (gutter-string (copy-sequence "\n"))
568 (ext (make-extent 0 1 gutter-string)))
494 (insert-string message (get-buffer-create " *Gutter Area*")) 569 (insert-string message (get-buffer-create " *Gutter Area*"))
495 ;; Do what the device is able to cope with. 570 ;; do some funky display here.
496 (if (not (valid-image-instantiator-format-p 'progress-gauge frame)) 571 (set-extent-begin-glyph ext progress-layout-glyph)
572 ;; fixup the gutter specifiers
573 (set-gutter-element bottom-gutter 'progress gutter-string frame)
574 (set-specifier bottom-gutter-border-width 2 frame)
575 (set-instantiator-property progress-gauge-instantiator :value val)
576 (set-progress-feedback-instantiator (frame-selected-window frame))
577
578 (set-instantiator-property progress-text-instantiator :data message)
579 (set-progress-feedback-instantiator (frame-selected-window frame))
580 (if (and (eq (specifier-instance bottom-gutter-height frame)
581 'autodetect)
582 (gutter-element-visible-p bottom-gutter-visible-p
583 'progress frame))
584 ;; if the gauge is already visible then just draw the gutter
585 ;; checking for user events
497 (progn 586 (progn
498 (insert-string 587 (redisplay-gutter-area)
499 (concat message (if (eq val 100) "done.") 588 (progress-feedback-dispatch-non-command-events))
500 (make-string (/ val 5) ?.)) 589 ;; otherwise make the gutter visible and redraw the frame
501 " *Echo Area*") 590 (set-specifier bottom-gutter-height 'autodetect frame)
502 (if (not executing-kbd-macro) 591 (set-gutter-element-visible-p bottom-gutter-visible-p
503 (redisplay-echo-area))) 592 'progress t frame)
504 ;; do some funky display here. 593 ;; we have to do this so redisplay is up-to-date and so
505 (unless progress-extent 594 ;; redisplay-gutter-area performs optimally. This may also
506 (setq progress-extent (make-extent 0 0 progress-extent-text)) 595 ;; make sure the frame geometry looks ok.
507 (set-extent-begin-glyph progress-extent progress-layout-glyph)) 596 (progress-feedback-dispatch-non-command-events)
508 ;; fixup the gutter specifiers 597 (redisplay-frame frame)
509 (set-specifier bottom-gutter progress-extent-text frame) 598 ))))
510 (set-specifier bottom-gutter-border-width 2 frame) 599
511 (set-image-instance-property 600 (defun display-progress-feedback (label message &optional value frame)
512 (glyph-image-instance progress-gauge-glyph) :percent val)
513 (set-image-instance-property
514 (glyph-image-instance progress-text-glyph) :data message)
515 (if (and (eq (specifier-instance bottom-gutter-height 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. 601 "Display a progress gauge and message in the bottom gutter area.
534 First argument LABEL is an identifier for this message. MESSAGE is 602 First argument LABEL is an identifier for this message. MESSAGE is
535 the string to display. Use `clear-progress' to remove a labelled 603 the string to display. Use `clear-progress-feedback' to remove a labelled
536 message." 604 message."
537 (clear-progress label frame t) 605 (cond ((eq value 'abort)
538 (if (eq value 'abort) 606 (abort-progress-feedback label message frame))
539 (abort-progress label message frame) 607 ((or (not (valid-image-instantiator-format-p 'progress-gauge frame))
540 (append-progress label message value frame))) 608 progress-feedback-use-echo-area)
541 609 (display-message label
542 (defun current-progress (&optional frame) 610 (concat message (if (eq value 100) "done."
611 (make-string (/ value 5) ?.)))
612 frame))
613 (t
614 (append-progress-feedback label message value frame))))
615
616 (defun current-progress-feedback (&optional frame)
543 "Return the current progress gauge in the gutter area, or nil. 617 "Return the current progress gauge in the gutter area, or nil.
544 The FRAME argument is currently unused." 618 The FRAME argument is currently unused."
545 (cdr (car progress-stack))) 619 (cdr (car progress-stack)))
546 620
547 ;;; may eventually be frame-dependent 621 ;;; may eventually be frame-dependent
548 (defun current-progress-label (&optional frame) 622 (defun current-progress-feedback-label (&optional frame)
549 (car (car progress-stack))) 623 (car (car progress-stack)))
550 624
551 (defun progress (fmt &optional value &rest args) 625 (defun progress-feedback (fmt &optional value &rest args)
552 "Print a progress gauge and message in the bottom gutter area of the frame. 626 "Print a progress gauge and message in the bottom gutter area of the frame.
553 The arguments are the same as to `format'. 627 The arguments are the same as to `format'.
554 628
555 If the only argument is nil, clear any existing progress gauge." 629 If the only argument is nil, clear any existing progress gauge."
556 (if (and (null fmt) (null args)) 630 (save-excursion
557 (prog1 nil 631 (if (and (null fmt) (null args))
558 (clear-progress nil)) 632 (prog1 nil
559 (let ((str (apply 'format fmt args))) 633 (clear-progress-feedback nil))
560 (display-progress 'progress str value) 634 (let ((str (apply 'format fmt args)))
561 str))) 635 (display-progress-feedback 'progress str value)
562 636 str))))
563 (defun lprogress (label fmt &optional value &rest args) 637
638 (defun progress-feedback-with-label (label fmt &optional value &rest args)
564 "Print a progress gauge and message in the bottom gutter area of the frame. 639 "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 640 First argument LABEL is an identifier for this progress gauge. The rest of the
566 arguments are the same as to `format'." 641 arguments are the same as to `format'."
567 (if (and (null fmt) (null args)) 642 ;; #### sometimes the buffer gets changed temporarily. I don't know
568 (prog1 nil 643 ;; why this is, so protect against it.
569 (clear-progress label nil)) 644 (save-excursion
570 (let ((str (apply 'format fmt args))) 645 (if (and (null fmt) (null args))
571 (display-progress label str value) 646 (prog1 nil
572 str))) 647 (clear-progress-feedback label nil))
648 (let ((str (apply 'format fmt args)))
649 (display-progress-feedback label str value)
650 str))))
573 651
574 (provide 'gutter-items) 652 (provide 'gutter-items)
575 ;;; gutter-items.el ends here. 653 ;;; gutter-items.el ends here.