1 ;;; gutter-items.el --- Gutter content for XEmacs.
3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
4 ;; Copyright (C) 1999, 2000 Andy Piper.
5 ;; Copyright (C) 2000 Ben Wing.
7 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: frames, extensions, internal, dumped
10 ;; This file is part of XEmacs.
12 ;; XEmacs is free software; you can redistribute it and/or modify it
13 ;; under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; XEmacs is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with Xmacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
27 ;; Some of this is taken from the buffer-menu stuff in menubar-items.el
31 (defgroup buffers-tab nil
32 "Customization of `Buffers' tab."
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.")
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.
43 There are side-effects, so don't setq it; use Customize or the options menu."
46 :set #'(lambda (var val)
47 (set-gutter-element-visible-p default-gutter-visible-p
49 (setq gutter-buffers-tab-visible-p val)))
51 (defcustom gutter-buffers-tab-enabled t
52 "*Whether to enable support for buffers tab in the gutter.
53 This is different to `gutter-buffers-tab-visible-p' which still runs hooks
54 even when the gutter is invisible."
58 (defvar gutter-buffers-tab-orientation 'top
59 "Where the buffers tab currently is. Do not set this.")
61 (defcustom buffers-tab-max-size 6
62 "*Maximum number of entries which may appear on the \"Buffers\" tab.
63 If this is 10, then only the ten most-recently-selected buffers will be
64 shown. If this is nil, then all buffers will be shown. Setting this to
65 a large number or nil will slow down tab responsiveness."
66 :type '(choice (const :tag "Show all" nil)
70 (defcustom buffers-tab-switch-to-buffer-function 'buffers-tab-switch-to-buffer
71 "*The function to call to select a buffer from the buffers tab.
72 `switch-to-buffer' is a good choice, as is `pop-to-buffer'."
73 :type '(radio (function-item switch-to-buffer)
74 (function-item pop-to-buffer)
75 (function :tag "Other"))
78 (defcustom buffers-tab-omit-function 'buffers-menu-omit-invisible-buffers
79 "*A function specifying the buffers to omit from the buffers tab, or nil.
80 This is passed a buffer and should return non-nil if the buffer should be
81 omitted. The default value `buffers-menu-omit-invisible-buffers' omits
82 buffers that are normally considered \"invisible\" (those whose name
83 begins with a space)."
84 :type '(choice (const :tag "None" nil)
88 (make-obsolete-variable 'buffers-tab-selection-function
89 'buffers-tab-filter-functions)
90 (defcustom buffers-tab-selection-function nil
91 "*A function specifying buffers to display in the buffers tab, or nil.
92 Don't use this---it is never consulted. Use `buffers-tab-filter-functions'
95 The function must take arguments (BUF1 BUF2). BUF1 is a candidate for
96 display in the buffers tab control. BUF2 is current (first in the buffers
97 list). Return non-nil if BUF1 should be added to the tab control."
98 :type '(choice function (const :tag "None" nil))
101 (defcustom buffers-tab-filter-functions '(select-buffers-tab-buffers-by-mode)
102 "*A list of functions specifying buffers to display in the buffers tab.
103 May be empty. Each function in the list must take arguments (BUF1 BUF2).
104 BUF1 is the candidate, and BUF2 is the current buffer (first in the buffers
105 list). Return non-nil if BUF1 should be added to the buffers tab. The
106 default adds BUF1 if BUF1 and BUF2 have the same major mode, or if both
107 match `buffers-tab-grouping-regexp'."
108 :type '(repeat function)
111 (defcustom buffers-tab-sort-function nil
112 "*If non-nil, a function specifying the buffers to select from the
113 buffers tab. This is passed the buffer list and returns the list in the
114 order desired for the tab widget. The default value `nil' leaves the
115 list in `buffer-list' order (usual most-recently-selected-first)."
117 :type '(choice (const :tag "None" nil)
121 (make-face 'buffers-tab "Face for displaying the buffers tab.")
122 (set-face-parent 'buffers-tab 'modeline)
124 (defcustom buffers-tab-face 'buffers-tab
125 "*Face to use for displaying the buffers tab."
129 (defcustom buffers-tab-grouping-regexp
130 '("^\\(gnus-\\|message-mode\\|mime/viewer-mode\\)"
131 "^\\(emacs-lisp-\\|lisp-\\)")
132 "*If non-nil, a list of regular expressions for buffer grouping.
133 Each regular expression is applied to the current major-mode symbol
134 name and mode-name, if it matches then any other buffers that match
135 the same regular expression be added to the current group."
136 :type '(choice (const :tag "None" nil)
140 (defcustom buffers-tab-format-buffer-line-function 'format-buffers-tab-line
141 "*The function to call to return a string to represent a buffer in the
142 buffers tab. The function is passed a buffer and should return a
143 string. The default value `format-buffers-tab-line' just returns the
144 name of the buffer, optionally truncated to
145 `buffers-tab-max-buffer-line-length'. Also check out
146 `slow-format-buffers-menu-line' which returns a whole bunch of info
151 (defvar buffers-tab-default-buffer-line-length
152 (make-specifier-and-init 'generic '((global ((default) . 25))) t)
153 "*Maximum length of text which may appear in a \"Buffers\" tab.
154 This is a specifier, use set-specifier to modify it.")
156 (defcustom buffers-tab-max-buffer-line-length
157 (specifier-instance buffers-tab-default-buffer-line-length)
158 "*Maximum length of text which may appear in a \"Buffers\" tab.
159 Buffer names over this length will be truncated with elipses.
160 If this is 0, then the full buffer name will be shown."
161 :type '(choice (const :tag "Show all" 0)
164 :set #'(lambda (var val)
165 (set-specifier buffers-tab-default-buffer-line-length val)
166 (setq buffers-tab-max-buffer-line-length val)))
168 (defun buffers-tab-switch-to-buffer (buffer)
169 "For use as a value for `buffers-tab-switch-to-buffer-function'."
170 (unless (eq (window-buffer) buffer)
171 ;; this used to add the norecord flag to both calls below.
172 ;; this is bogus because it is a pervasive assumption in XEmacs
173 ;; that the current buffer is at the front of the buffers list.
174 ;; for example, select an item and then do M-C-l
175 ;; (switch-to-other-buffer). Things get way confused.
176 (if (> (length (windows-of-buffer buffer)) 0)
177 (select-window (car (windows-of-buffer buffer)))
178 (switch-to-buffer buffer))))
180 (defun select-buffers-tab-buffers-by-mode (buffer-to-select buf1)
181 "For use as a value of `buffers-tab-selection-function'.
182 This selects buffers by major mode `buffers-tab-grouping-regexp'."
183 (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1)))
184 (mode2 (symbol-name (symbol-value-in-buffer 'major-mode
186 (modenm1 (symbol-value-in-buffer 'mode-name buf1))
187 (modenm2 (symbol-value-in-buffer 'mode-name buffer-to-select)))
188 (cond ((or (eq mode1 mode2)
190 (and (string-match "^[^-]+-" mode1)
192 (concat "^" (regexp-quote
193 (substring mode1 0 (match-end 0))))
195 (and buffers-tab-grouping-regexp
196 (find-if #'(lambda (x)
198 (and (string-match x mode1)
199 (string-match x mode2))
200 (and (string-match x modenm1)
201 (string-match x modenm2))))
202 buffers-tab-grouping-regexp)))
206 (defun format-buffers-tab-line (buffer)
207 "For use as a value of `buffers-tab-format-buffer-line-function'.
208 This just returns the buffer's name, optionally truncated."
209 (let ((len (specifier-instance buffers-tab-default-buffer-line-length)))
211 (> (length (buffer-name buffer)) len))
212 (if (string-match ".*<.>$" (buffer-name buffer))
213 (concat (substring (buffer-name buffer)
215 (substring (buffer-name buffer) -3))
216 (concat (substring (buffer-name buffer)
218 (buffer-name buffer))))
220 (defsubst build-buffers-tab-internal (buffers)
226 (funcall buffers-tab-format-buffer-line-function
228 (list buffers-tab-switch-to-buffer-function
229 (buffer-name buffer))
231 (when selected (setq selected nil))))
234 ;;; #### SJT would like this function to have a sort function list. I
235 ;;; don't see how this could work given that sorting is not
236 ;;; cumulative --andyp.
237 (defun buffers-tab-items (&optional in-deletion frame force-selection)
238 "Return a list of tab instantiators based on the current buffers list.
239 This function is used as the tab filter for the top-level buffers
240 \"Buffers\" tab. It dynamically creates a list of tab instantiators
241 to use as the contents of the tab. The contents and order of the list
242 is controlled by `buffers-tab-filter-functions' which by default
243 groups buffers according to major mode and removes invisible buffers.
244 You can control how many buffers will be shown by setting
245 `buffers-tab-max-size'. You can control the text of the tab items by
246 redefining the function `format-buffers-menu-line'."
248 ;; NB it is too late if we run the omit function as part of the
249 ;; filter functions because we need to know which buffer is the
250 ;; context buffer before they get run.
251 (let* ((buffers (delete-if
252 buffers-tab-omit-function (buffer-list frame)))
253 (first-buf (car buffers)))
254 ;; maybe force the selected window
255 (when (and force-selection
257 (not (eq first-buf (window-buffer (selected-window frame)))))
258 (setq buffers (cons (window-buffer (selected-window frame))
259 (delq first-buf buffers))))
260 ;; if we're in deletion ignore the current buffer
262 (setq buffers (delq (current-buffer) buffers))
263 (setq first-buf (car buffers)))
265 (when buffers-tab-filter-functions
269 (mapcar #'(lambda (buf)
271 (mapc #'(lambda (fun)
272 (unless (funcall fun buf first-buf)
274 buffers-tab-filter-functions)
277 ;; maybe shorten list of buffers
278 (and (integerp buffers-tab-max-size)
279 (> buffers-tab-max-size 1)
280 (> (length buffers) buffers-tab-max-size)
281 (setcdr (nthcdr (1- buffers-tab-max-size) buffers) nil))
282 ;; sort buffers in group (default is most-recently-selected)
283 (when buffers-tab-sort-function
284 (setq buffers (funcall buffers-tab-sort-function buffers)))
285 ;; convert list of buffers to list of structures used by tab widget
286 (setq buffers (build-buffers-tab-internal buffers))
289 (defun add-tab-to-gutter ()
290 "Put a tab control in the gutter area to hold the most recent buffers."
291 (setq gutter-buffers-tab-orientation (default-gutter-position))
292 (let* ((gutter-string (copy-sequence "\n"))
293 (gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
294 (set-extent-begin-glyph gutter-buffers-tab-extent
295 (setq gutter-buffers-tab
297 ;; Nuke all existing tabs
298 (remove-gutter-element top-gutter 'buffers-tab)
299 (remove-gutter-element bottom-gutter 'buffers-tab)
300 (remove-gutter-element left-gutter 'buffers-tab)
301 (remove-gutter-element right-gutter 'buffers-tab)
302 ;; Put tabs into all devices that will be able to display them
305 (when (valid-image-instantiator-format-p 'tab-control x)
306 (cond ((eq gutter-buffers-tab-orientation 'top)
307 ;; This looks better than a 3d border
308 (set-specifier top-gutter-border-width 0 'global x)
309 (set-gutter-element top-gutter 'buffers-tab
310 gutter-string 'global x))
311 ((eq gutter-buffers-tab-orientation 'bottom)
312 (set-specifier bottom-gutter-border-width 0 'global x)
313 (set-gutter-element bottom-gutter 'buffers-tab
314 gutter-string 'global x))
315 ((eq gutter-buffers-tab-orientation 'left)
316 (set-specifier left-gutter-border-width 0 'global x)
317 (set-gutter-element left-gutter 'buffers-tab
318 gutter-string 'global x))
319 ((eq gutter-buffers-tab-orientation 'right)
320 (set-specifier right-gutter-border-width 0 'global x)
321 (set-gutter-element right-gutter 'buffers-tab
322 gutter-string 'global x))
324 (console-type-list))))
326 (defun update-tab-in-gutter (frame &optional force-selection)
327 "Update the tab control in the gutter area."
328 ;; dedicated frames don't get tabs
329 (unless (or (window-dedicated-p (frame-selected-window frame))
330 (frame-property frame 'popup))
331 (when (specifier-instance default-gutter-visible-p frame)
332 (unless (and gutter-buffers-tab
333 (eq (default-gutter-position)
334 gutter-buffers-tab-orientation))
336 (when (valid-image-instantiator-format-p 'tab-control frame)
337 (let ((items (buffers-tab-items nil frame force-selection)))
341 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
342 :orientation gutter-buffers-tab-orientation
343 (if (or (eq gutter-buffers-tab-orientation 'top)
344 (eq gutter-buffers-tab-orientation 'bottom))
345 :pixel-width :pixel-height)
346 (if (or (eq gutter-buffers-tab-orientation 'top)
347 (eq gutter-buffers-tab-orientation 'bottom))
348 '(gutter-pixel-width) '(gutter-pixel-height))
351 ;; set-glyph-image will not make the gutter dirty
352 (set-gutter-dirty-p gutter-buffers-tab-orientation)))))))
354 ;; A myriad of different update hooks all doing slightly different things
358 ;; don't add the hooks if the user really doesn't want them
359 (when gutter-buffers-tab-enabled
360 (add-hook 'create-frame-hook
362 (when gutter-buffers-tab (update-tab-in-gutter frame t))))
363 (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter)
364 (add-hook 'default-gutter-position-changed-hook
366 (when gutter-buffers-tab
367 (mapc #'update-tab-in-gutter (frame-list)))))
368 (add-hook 'gutter-element-visibility-changed-hook
369 #'(lambda (prop visible-p)
370 (when (and (eq prop 'buffers-tab) visible-p)
371 (mapc #'update-tab-in-gutter (frame-list)))))
372 (update-tab-in-gutter (selected-frame) t))))
376 ;; ripped off from message display
378 (defcustom progress-feedback-use-echo-area nil
379 "*Whether progress gauge display should display in the echo area.
380 If NIL then progress gauges will be displayed with whatever native widgets
381 are available on the current console. If non-NIL then progress display will be
382 textual and displayed in the echo area."
386 (defvar progress-glyph-height 24
387 "Height of the progress gauge glyph.")
389 (defvar progress-feedback-popup-period 0.5
390 "The time that the progress gauge should remain up after completion")
392 (defcustom progress-feedback-style 'large
393 "*Control the appearance of the progress gauge.
394 If 'large, the default, then the progress-feedback text is displayed
395 above the gauge itself. If 'small then the gauge and text are arranged
398 :type '(choice (const :tag "large" large)
399 (const :tag "small" small)))
402 (defvar progress-text-instantiator [string :data ""])
403 (defvar progress-layout-glyph (make-glyph))
404 (defvar progress-layout-instantiator nil)
406 (defvar progress-gauge-instantiator
409 :pixel-height (eval progress-glyph-height)
411 :descriptor "Progress"])
413 (defun set-progress-feedback-instantiator (&optional locale)
415 ((eq progress-feedback-style 'small)
416 (setq progress-glyph-height 16)
417 (setq progress-layout-instantiator
419 :orientation vertical :margin-width 4
420 :horizontally-justify left :vertically-justify center
421 :items (,progress-gauge-instantiator
423 :pixel-height (eval progress-glyph-height)
424 ;; 'quit is special and acts "asynchronously".
425 :descriptor "Stop" :callback 'quit]
426 ,progress-text-instantiator)])
427 (set-glyph-image progress-layout-glyph progress-layout-instantiator
430 (setq progress-glyph-height 24)
431 (setq progress-layout-instantiator
433 :orientation vertical :margin-width 4
434 :horizontally-justify left :vertically-justify center
435 :items (,progress-text-instantiator
437 :orientation horizontal
438 :items (,progress-gauge-instantiator
440 :pixel-height (eval progress-glyph-height)
442 ;; 'quit is special and acts "asynchronously".
443 :callback 'quit])])])
444 (set-glyph-image progress-layout-glyph progress-layout-instantiator
447 (defvar progress-abort-glyph (make-glyph))
449 (defun set-progress-abort-instantiator (&optional locale)
450 (set-glyph-image progress-abort-glyph
451 `[layout :orientation vertical
452 :horizontally-justify left :vertically-justify center
453 :items (,progress-text-instantiator
456 :pixel-height progress-glyph-height
457 :orientation horizontal])]
460 (defvar progress-stack nil
461 "An alist of label/string pairs representing active progress gauges.
462 The first element in the list is currently displayed in the gutter area.
463 Do not modify this directly--use the `progress-feedback' or
464 `display-progress-feedback'/`clear-progress-feedback' functions.")
466 (defun progress-feedback-displayed-p (&optional return-string frame)
467 "Return a non-nil value if a progress gauge is presently displayed in the
468 gutter area. If optional argument RETURN-STRING is non-nil,
469 return a string containing the message, otherwise just return t."
470 (let ((buffer (get-buffer-create " *Gutter Area*")))
471 (and (< (point-min buffer) (point-max buffer))
473 (buffer-substring nil nil buffer)
476 ;;; Returns the string which remains in the echo area, or nil if none.
477 ;;; If label is nil, the whole message stack is cleared.
478 (defun clear-progress-feedback (&optional label frame no-restore)
479 "Remove any progress gauge with LABEL from the progress gauge-stack,
480 erasing it from the gutter area if it's currently displayed there.
481 If a message remains at the head of the progress-stack and NO-RESTORE
482 is nil, it will be displayed. The string which remains in the gutter
483 area will be returned, or nil if the progress-stack is now empty.
484 If LABEL is nil, the entire progress-stack is cleared.
486 Unless you need the return value or you need to specify a label,
487 you should just use (progress nil)."
488 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
489 progress-feedback-use-echo-area)
490 (clear-message label frame nil no-restore)
491 (or frame (setq frame (selected-frame)))
492 (remove-progress-feedback label frame)
493 (let ((inhibit-read-only t)
494 (zmacs-region-stays zmacs-region-stays)) ; preserve from change
495 (erase-buffer (get-buffer-create " *Gutter Area*")))
497 nil ; just preparing to put another msg up
499 (let ((oldmsg (cdr (car progress-stack))))
500 (raw-append-progress-feedback oldmsg nil frame)
502 ;; nothing to display so get rid of the gauge
503 (set-specifier bottom-gutter-border-width 0 frame)
504 (set-gutter-element-visible-p bottom-gutter-visible-p
505 'progress nil frame)))))
507 (defun progress-feedback-clear-when-idle (&optional label)
508 (add-one-shot-hook 'pre-idle-hook
510 (clear-progress-feedback ',label))))
512 (defun remove-progress-feedback (&optional label frame)
513 ;; If label is nil, we want to remove all matching progress gauges.
514 (while (and progress-stack
515 (or (null label) ; null label means clear whole stack
516 (eq label (car (car progress-stack)))))
517 (setq progress-stack (cdr progress-stack)))
518 (let ((s progress-stack))
520 (let ((msg (car (cdr s))))
521 (if (eq label (car msg))
523 (setcdr s (cdr (cdr s))))
524 (setq s (cdr s)))))))
526 (defun progress-feedback-dispatch-non-command-events ()
527 ;; don't allow errors to hose things
529 ;; (sit-for 0) is too agressive and cause more display than we
531 (dispatch-non-command-events)
534 (defun append-progress-feedback (label message &optional value frame)
535 (or frame (setq frame (selected-frame)))
536 ;; Add a new entry to the message-stack, or modify an existing one
537 (let* ((top (car progress-stack))
539 (if (eq label (car top))
542 (if (equal tmsg message)
544 (set-instantiator-property progress-gauge-instantiator :value value)
545 (set-progress-feedback-instantiator (frame-selected-window frame)))
546 (raw-append-progress-feedback message value frame))
547 (redisplay-gutter-area))
548 (push (cons label message) progress-stack)
549 (raw-append-progress-feedback message value frame))
550 (progress-feedback-dispatch-non-command-events)
551 ;; either get command events or sit waiting for them
553 ; (sit-for progress-feedback-popup-period nil)
554 (clear-progress-feedback label))))
556 (defun abort-progress-feedback (label message &optional frame)
557 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
558 progress-feedback-use-echo-area)
559 (display-message label (concat message "aborted.") frame)
560 (or frame (setq frame (selected-frame)))
561 ;; Add a new entry to the message-stack, or modify an existing one
562 (let* ((top (car progress-stack))
563 (inhibit-read-only t)
564 (zmacs-region-stays zmacs-region-stays))
565 (if (eq label (car top))
567 (push (cons label message) progress-stack))
568 (unless (equal message "")
569 (insert-string message (get-buffer-create " *Gutter Area*"))
570 (let* ((gutter-string (copy-sequence "\n"))
571 (ext (make-extent 0 1 gutter-string)))
572 ;; do some funky display here.
573 (set-extent-begin-glyph ext progress-abort-glyph)
574 ;; fixup the gutter specifiers
575 (set-gutter-element bottom-gutter 'progress gutter-string frame)
576 (set-specifier bottom-gutter-border-width 2 frame)
577 (set-instantiator-property progress-text-instantiator :data message)
578 (set-progress-abort-instantiator (frame-selected-window frame))
579 (set-specifier bottom-gutter-height 'autodetect frame)
580 (set-gutter-element-visible-p bottom-gutter-visible-p
582 ;; we have to do this so redisplay is up-to-date and so
583 ;; redisplay-gutter-area performs optimally.
584 (redisplay-gutter-area)
585 (sit-for progress-feedback-popup-period nil)
586 (clear-progress-feedback label frame)
587 (set-extent-begin-glyph ext progress-layout-glyph)
588 (set-gutter-element bottom-gutter 'progress gutter-string frame)
591 (defun raw-append-progress-feedback (message &optional value frame)
592 (unless (equal message "")
593 (let* ((inhibit-read-only t)
594 (zmacs-region-stays zmacs-region-stays)
596 (gutter-string (copy-sequence "\n"))
597 (ext (make-extent 0 1 gutter-string)))
598 (insert-string message (get-buffer-create " *Gutter Area*"))
599 ;; do some funky display here.
600 (set-extent-begin-glyph ext progress-layout-glyph)
601 ;; fixup the gutter specifiers
602 (set-gutter-element bottom-gutter 'progress gutter-string frame)
603 (set-specifier bottom-gutter-border-width 2 frame)
604 (set-instantiator-property progress-gauge-instantiator :value val)
605 (set-progress-feedback-instantiator (frame-selected-window frame))
607 (set-instantiator-property progress-text-instantiator :data message)
608 (set-progress-feedback-instantiator (frame-selected-window frame))
609 (if (and (eq (specifier-instance bottom-gutter-height frame)
611 (gutter-element-visible-p bottom-gutter-visible-p
613 ;; if the gauge is already visible then just draw the gutter
614 ;; checking for user events
616 (redisplay-gutter-area)
617 (progress-feedback-dispatch-non-command-events))
618 ;; otherwise make the gutter visible and redraw the frame
619 (set-specifier bottom-gutter-height 'autodetect frame)
620 (set-gutter-element-visible-p bottom-gutter-visible-p
622 ;; we have to do this so redisplay is up-to-date and so
623 ;; redisplay-gutter-area performs optimally. This may also
624 ;; make sure the frame geometry looks ok.
625 (progress-feedback-dispatch-non-command-events)
626 (redisplay-frame frame)
629 (defun display-progress-feedback (label message &optional value frame)
630 "Display a progress gauge and message in the bottom gutter area.
631 First argument LABEL is an identifier for this message. MESSAGE is
632 the string to display. Use `clear-progress-feedback' to remove a labelled
634 (cond ((eq value 'abort)
635 (abort-progress-feedback label message frame))
636 ((or (not (valid-image-instantiator-format-p 'progress-gauge frame))
637 progress-feedback-use-echo-area)
638 (display-message label
639 (concat message (if (eq value 100) "done."
640 (make-string (/ value 5) ?.)))
643 (append-progress-feedback label message value frame))))
645 (defun current-progress-feedback (&optional frame)
646 "Return the current progress gauge in the gutter area, or nil.
647 The FRAME argument is currently unused."
648 (cdr (car progress-stack)))
650 ;;; may eventually be frame-dependent
651 (defun current-progress-feedback-label (&optional frame)
652 (car (car progress-stack)))
654 (defun progress-feedback (fmt &optional value &rest args)
655 "Print a progress gauge and message in the bottom gutter area of the frame.
656 The arguments are the same as to `format'.
658 If the only argument is nil, clear any existing progress gauge."
660 (if (and (null fmt) (null args))
662 (clear-progress-feedback nil))
663 (let ((str (apply 'format fmt args)))
664 (display-progress-feedback 'progress str value)
667 (defun progress-feedback-with-label (label fmt &optional value &rest args)
668 "Print a progress gauge and message in the bottom gutter area of the frame.
669 First argument LABEL is an identifier for this progress gauge. The rest of the
670 arguments are the same as to `format'."
671 ;; #### sometimes the buffer gets changed temporarily. I don't know
672 ;; why this is, so protect against it.
674 (if (and (null fmt) (null args))
676 (clear-progress-feedback label nil))
677 (let ((str (apply 'format fmt args)))
678 (display-progress-feedback label str value)
681 (provide 'gutter-items)
682 ;;; gutter-items.el ends here.