1 ;;; gutter-items.el --- Gutter content for XEmacs.
3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
4 ;; Copyright (C) 1999, 2000 Andy Piper.
6 ;; Maintainer: XEmacs Development Team
7 ;; Keywords: frames, extensions, internal, dumped
9 ;; This file is part of XEmacs.
11 ;; XEmacs is free software; you can redistribute it and/or modify it
12 ;; under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; XEmacs is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with Xmacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
26 ;; Some of this is taken from the buffer-menu stuff in menubar-items.el
30 (defgroup buffers-tab nil
31 "Customization of `Buffers' tab."
34 (defvar gutter-buffers-tab nil
35 "A tab widget in the gutter for displaying buffers.
36 Do not set this. Use `glyph-image-instance' and
37 `set-image-instance-property' 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.
42 This option should be set through the options menu."
45 :set #'(lambda (var val)
46 (set-gutter-element-visible-p default-gutter-visible-p
48 (setq gutter-buffers-tab-visible-p val)))
50 (defvar gutter-buffers-tab-orientation 'top
51 "Where the buffers tab currently is. Do not set this.")
53 (defvar gutter-buffers-tab-extent nil)
55 (defcustom buffers-tab-max-size 6
56 "*Maximum number of entries which may appear on the \"Buffers\" tab.
57 If this is 10, then only the ten most-recently-selected buffers will be
58 shown. If this is nil, then all buffers will be shown. Setting this to
59 a large number or nil will slow down tab responsiveness."
60 :type '(choice (const :tag "Show all" nil)
64 (defcustom buffers-tab-switch-to-buffer-function 'buffers-tab-switch-to-buffer
65 "*The function to call to select a buffer from the buffers tab.
66 `switch-to-buffer' is a good choice, as is `pop-to-buffer'."
67 :type '(radio (function-item switch-to-buffer)
68 (function-item pop-to-buffer)
69 (function :tag "Other"))
72 (defcustom buffers-tab-omit-function 'buffers-menu-omit-invisible-buffers
73 "*If non-nil, a function specifying the buffers to omit from the buffers tab.
74 This is passed a buffer and should return non-nil if the buffer should be
75 omitted. The default value `buffers-tab-omit-invisible-buffers' omits
76 buffers that are normally considered \"invisible\" (those whose name
77 begins with a space)."
78 :type '(choice (const :tag "None" nil)
82 (defcustom buffers-tab-selection-function 'select-buffers-tab-buffers-by-mode
83 "*If non-nil, a function specifying the buffers to select from the
84 buffers tab. This is passed two buffers and should return non-nil if
85 the second buffer should be selected. The default value
86 `select-buffers-tab-buffers-by-mode' groups buffers by major mode and
87 by `buffers-tab-grouping-regexp'."
89 :type '(choice (const :tag "None" nil)
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)."
99 :type '(choice (const :tag "None" nil)
103 (make-face 'buffers-tab "Face for displaying the buffers tab.")
104 (set-face-parent 'buffers-tab 'default)
106 (defcustom buffers-tab-face 'buffers-tab
107 "*Face to use for displaying the buffers tab."
111 (defcustom buffers-tab-grouping-regexp
112 '("^\\(gnus-\\|message-mode\\|mime/viewer-mode\\)"
113 "^\\(emacs-lisp-\\|lisp-\\)")
114 "*If non-nil, a list of regular expressions for buffer grouping.
115 Each regular expression is applied to the current major-mode symbol
116 name and mode-name, if it matches then any other buffers that match
117 the same regular expression be added to the current group."
118 :type '(choice (const :tag "None" nil)
122 (defcustom buffers-tab-format-buffer-line-function 'format-buffers-tab-line
123 "*The function to call to return a string to represent a buffer in the
124 buffers tab. The function is passed a buffer and should return a
125 string. The default value `format-buffers-tab-line' just returns the
126 name of the buffer, optionally truncated to
127 `buffers-tab-max-buffer-line-length'. Also check out
128 `slow-format-buffers-menu-line' which returns a whole bunch of info
133 (defvar buffers-tab-default-buffer-line-length
134 (make-specifier-and-init 'generic '((global ((default) . 25))) t)
135 "*Maximum length of text which may appear in a \"Buffers\" tab.
136 This is a specifier, use set-specifier to modify it.")
138 (defcustom buffers-tab-max-buffer-line-length
139 (specifier-instance buffers-tab-default-buffer-line-length)
140 "*Maximum length of text which may appear in a \"Buffers\" tab.
141 Buffer names over this length will be truncated with elipses.
142 If this is 0, then the full buffer name will be shown."
143 :type '(choice (const :tag "Show all" 0)
146 :set #'(lambda (var val)
147 (set-specifier buffers-tab-default-buffer-line-length val)
148 (setq buffers-tab-max-buffer-line-length val)))
150 (defun buffers-tab-switch-to-buffer (buffer)
151 "For use as a value for `buffers-tab-switch-to-buffer-function'."
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.
159 ;; Andy, if you want to maintain the current look, you must
160 ;; *uncouple* the gutter order and buffers order.
161 (if (> (length (windows-of-buffer buffer)) 0)
162 (select-window (car (windows-of-buffer buffer)))
163 (switch-to-buffer buffer))))
165 (defun select-buffers-tab-buffers-by-mode (buf1 buf2)
166 "For use as a value of `buffers-tab-selection-function'.
167 This selects buffers by major mode `buffers-tab-grouping-regexp'."
168 (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1)))
169 (mode2 (symbol-name (symbol-value-in-buffer 'major-mode buf2)))
170 (modenm1 (symbol-value-in-buffer 'mode-name buf1))
171 (modenm2 (symbol-value-in-buffer 'mode-name buf2)))
172 (cond ((or (eq mode1 mode2)
174 (and (string-match "^[^-]+-" mode1)
176 (concat "^" (regexp-quote
177 (substring mode1 0 (match-end 0))))
179 (and buffers-tab-grouping-regexp
180 (find-if #'(lambda (x)
182 (and (string-match x mode1)
183 (string-match x mode2))
184 (and (string-match x modenm1)
185 (string-match x modenm2))))
186 buffers-tab-grouping-regexp)))
190 (defun format-buffers-tab-line (buffer)
191 "For use as a value of `buffers-tab-format-buffer-line-function'.
192 This just returns the buffer's name, optionally truncated."
193 (let ((len (specifier-instance buffers-tab-default-buffer-line-length)))
195 (> (length (buffer-name buffer)) len))
196 (if (string-match ".*<.>$" (buffer-name buffer))
197 (concat (substring (buffer-name buffer)
199 (substring (buffer-name buffer) -3))
200 (concat (substring (buffer-name buffer)
202 (buffer-name buffer))))
204 (defsubst build-buffers-tab-internal (buffers)
210 (funcall buffers-tab-format-buffer-line-function
212 (list buffers-tab-switch-to-buffer-function
213 (buffer-name buffer))
215 (when selected (setq selected nil))))
218 ;;; #### SJT I'd really like this function to have just two hooks: (1) the
219 ;;; buffer filter list and (2) a sort function list. Both should be lists
220 ;;; of functions. Each filter takes two arguments: a buffer and a model
221 ;;; buffer. (The model buffer argument allows selecting according to the
222 ;;; mode or directory of that buffer.) The filter returns t if the buffer
223 ;;; should be listed and nil otherwise. Effectively the filter amounts to
224 ;;; the conjuction of the filter list. (Optionally the filter could take a
225 ;;; frame instead of a buffer or generalize to a locale as in a specifier?)
226 ;;; The filtering is done this way to preserve the ordering imposed by
227 ;;; `buffer-list'. In addition, the in-deletion argument will be used the
228 ;;; same way as in the current design.
229 ;;; The list is checked for length and pruned according to least-recently-
230 ;;; selected. (Optionally there could be some kind of sort function here,
232 ;;; Finally the list is sorted to gutter display order, and the tab data
233 ;;; structure is created and returned.
234 ;;; #### Docstring isn't very well expressed.
235 (defun buffers-tab-items (&optional in-deletion frame force-selection)
236 "This is the tab filter for the top-level buffers \"Buffers\" tab.
237 It dynamically creates a list of buffers to use as the contents of the tab.
238 Only the most-recently-used few buffers will be listed on the tab, for
239 efficiency reasons. You can control how many buffers will be shown by
240 setting `buffers-tab-max-size'. You can control the text of the tab
241 items by redefining the function `format-buffers-menu-line'."
243 (let* ((buffers (delete-if buffers-tab-omit-function (buffer-list frame)))
244 (first-buf (car buffers)))
245 ;; maybe force the selected window
246 (when (and force-selection
248 (not (eq first-buf (window-buffer (selected-window frame)))))
249 (setq buffers (cons (window-buffer (selected-window frame))
250 (delq first-buf buffers))))
251 ;; if we're in deletion ignore the current buffer
253 (setq buffers (delq (current-buffer) buffers))
254 (setq first-buf (car buffers)))
255 ;; select buffers in group (default is by mode)
256 (when buffers-tab-selection-function
257 (delete-if-not #'(lambda (buf)
258 (funcall buffers-tab-selection-function
259 first-buf buf)) buffers))
260 ;; maybe shorten list of buffers
261 (and (integerp buffers-tab-max-size)
262 (> buffers-tab-max-size 1)
263 (> (length buffers) buffers-tab-max-size)
264 (setcdr (nthcdr buffers-tab-max-size buffers) nil))
265 ;; sort buffers in group (default is most-recently-selected)
266 (when buffers-tab-sort-function
267 (setq buffers (funcall buffers-tab-sort-function buffers)))
268 ;; convert list of buffers to list of structures used by tab widget
269 (setq buffers (build-buffers-tab-internal buffers))
272 (defun add-tab-to-gutter ()
273 "Put a tab control in the gutter area to hold the most recent buffers."
274 (setq gutter-buffers-tab-orientation (default-gutter-position))
275 (let ((gutter-string (copy-sequence "\n")))
276 (unless gutter-buffers-tab-extent
277 (setq gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
278 (set-extent-begin-glyph
279 gutter-buffers-tab-extent
280 (setq gutter-buffers-tab
282 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
283 :orientation gutter-buffers-tab-orientation
284 (if (or (eq gutter-buffers-tab-orientation 'top)
285 (eq gutter-buffers-tab-orientation 'bottom))
286 :pixel-width :pixel-height)
287 (if (or (eq gutter-buffers-tab-orientation 'top)
288 (eq gutter-buffers-tab-orientation 'bottom))
289 '(gutter-pixel-width) '(gutter-pixel-height))
290 :properties (list :items (buffers-tab-items nil nil t))))))
292 ;; Nuke all existing tabs
293 (remove-gutter-element top-gutter 'buffers-tab)
294 (remove-gutter-element bottom-gutter 'buffers-tab)
295 (remove-gutter-element left-gutter 'buffers-tab)
296 (remove-gutter-element right-gutter 'buffers-tab)
297 ;; Put tabs into all devices that will be able to display them
300 (when (valid-image-instantiator-format-p 'tab-control x)
301 (cond ((eq gutter-buffers-tab-orientation 'top)
302 ;; This looks better than a 3d border
303 (set-specifier top-gutter-border-width 0 'global x)
304 (set-gutter-element top-gutter 'buffers-tab
305 gutter-string 'global x))
306 ((eq gutter-buffers-tab-orientation 'bottom)
307 (set-specifier bottom-gutter-border-width 0 'global x)
308 (set-gutter-element bottom-gutter 'buffers-tab
309 gutter-string 'global x))
310 ((eq gutter-buffers-tab-orientation 'left)
311 (set-specifier left-gutter-border-width 0 'global x)
312 (set-gutter-element left-gutter 'buffers-tab
313 gutter-string 'global x)
314 (set-specifier left-gutter-width
315 (glyph-width gutter-buffers-tab)
317 ((eq gutter-buffers-tab-orientation 'right)
318 (set-specifier right-gutter-border-width 0 'global x)
319 (set-gutter-element right-gutter 'buffers-tab
320 gutter-string 'global x)
321 (set-specifier right-gutter-width
322 (glyph-width gutter-buffers-tab)
325 (console-type-list))))
327 (defun update-tab-in-gutter (&optional frame-or-buffer force-selection)
328 "Update the tab control in the gutter area."
329 (let ((locale (if (framep frame-or-buffer) frame-or-buffer)))
330 ;; dedicated frames don't get tabs
331 (unless (and (framep locale)
332 (window-dedicated-p (frame-selected-window locale)))
333 (when (specifier-instance default-gutter-visible-p locale)
334 (unless (and gutter-buffers-tab
335 (eq (default-gutter-position)
336 gutter-buffers-tab-orientation))
338 (when (valid-image-instantiator-format-p 'tab-control locale)
339 (let ((inst (glyph-image-instance
341 (when (framep frame-or-buffer)
342 (last-nonminibuf-window frame-or-buffer)))))
343 (set-image-instance-property inst :items
345 nil locale force-selection))))))))
347 (defun remove-buffer-from-gutter-tab ()
348 "Remove the current buffer from the tab control in the gutter area."
349 (when (and (valid-image-instantiator-format-p 'tab-control)
350 (specifier-instance default-gutter-visible-p))
351 (let ((inst (glyph-image-instance gutter-buffers-tab))
352 (buffers (buffers-tab-items t)))
354 (setq buffers (build-buffers-tab-internal
356 (get-buffer-create "*scratch*")))))
357 (set-image-instance-property inst :items buffers))))
359 ;; A myriad of different update hooks all doing slightly different things
360 (add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab)
361 (add-hook 'create-frame-hook
363 (when gutter-buffers-tab (update-tab-in-gutter frame t))))
364 (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter)
365 (add-hook 'default-gutter-position-changed-hook
367 (when gutter-buffers-tab (update-tab-in-gutter))))
368 (add-hook 'gutter-element-visibility-changed-hook
369 #'(lambda (prop visible-p)
370 (when (and (eq prop 'buffers-tab) visible-p)
371 (update-tab-in-gutter))))
375 ;; ripped off from message display
377 (defcustom progress-display-use-echo-area nil
378 "*Whether progress gauge display should display in the echo area.
379 If NIL then progress gauges will be displayed with whatever native widgets
380 are available on the current console. If non-NIL then progress display will be
381 textual and displayed in the echo area."
385 (defvar progress-glyph-height 32
386 "Height of the gutter area for progress messages.")
388 (defvar progress-display-popup-period 0.5
389 "The time that the progress gauge should remain up after completion")
392 (defvar progress-text-glyph
393 (make-glyph [string :data ""]))
395 (defvar progress-layout-glyph nil)
396 (defvar progress-gauge-glyph
399 :pixel-height (- progress-glyph-height 8)
401 :descriptor "Progress"]))
403 (defun set-progress-display-style (style)
404 "Control the appearance of the progress gauge.
405 If STYLE is 'large, the default, then the progress-display text is
406 displayed above the gauge itself. If STYLE is 'small then the gauge
407 and text are arranged side-by-side."
410 (setq progress-glyph-height 24)
411 (setq progress-layout-glyph
414 :orientation horizontal
415 :items (,progress-gauge-glyph
417 :pixel-height (- progress-glyph-height 8)
418 ;; 'quit is special and acts "asynchronously".
419 :descriptor "Stop" :callback 'quit]
420 ,progress-text-glyph)])))
422 (setq progress-glyph-height 32)
423 (setq progress-layout-glyph
426 :orientation vertical :justify left
427 :items (,progress-text-glyph
429 :pixel-height (eval progress-glyph-height)
430 :orientation horizontal
431 :items (,progress-gauge-glyph
433 :pixel-height (- progress-glyph-height 8)
435 ;; 'quit is special and acts "asynchronously".
436 :callback 'quit])])])))))
438 (defcustom progress-display-style 'large
439 "*Control the appearance of the progress gauge.
440 If 'large, the default, then the progress-display text is displayed
441 above the gauge itself. If 'small then the gauge and text are arranged
444 :type '(choice (const :tag "large" large)
445 (const :tag "small" small))
446 :set #'(lambda (var val)
447 (set-progress-display-style val)))
449 (defvar progress-stack nil
450 "An alist of label/string pairs representing active progress gauges.
451 The first element in the list is currently displayed in the gutter area.
452 Do not modify this directly--use the `progress-display' or
453 `display-progress-display'/`clear-progress-display' functions.")
455 (defvar progress-abort-glyph
457 `[layout :orientation vertical :justify left
458 :items (,progress-text-glyph
460 :pixel-height progress-glyph-height
461 :orientation horizontal])]))
463 (defun progress-displayed-p (&optional return-string frame)
464 "Return a non-nil value if a progress gauge is presently displayed in the
465 gutter area. If optional argument RETURN-STRING is non-nil,
466 return a string containing the message, otherwise just return t."
467 (let ((buffer (get-buffer-create " *Gutter Area*")))
468 (and (< (point-min buffer) (point-max buffer))
470 (buffer-substring nil nil buffer)
473 ;;; Returns the string which remains in the echo area, or nil if none.
474 ;;; If label is nil, the whole message stack is cleared.
475 (defun clear-progress-display (&optional label frame no-restore)
476 "Remove any progress gauge with LABEL from the progress gauge-stack,
477 erasing it from the gutter area if it's currently displayed there.
478 If a message remains at the head of the progress-stack and NO-RESTORE
479 is nil, it will be displayed. The string which remains in the gutter
480 area will be returned, or nil if the progress-stack is now empty.
481 If LABEL is nil, the entire progress-stack is cleared.
483 Unless you need the return value or you need to specify a label,
484 you should just use (progress nil)."
485 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
486 progress-display-use-echo-area)
487 (clear-message label frame nil no-restore)
488 (or frame (setq frame (selected-frame)))
489 (remove-progress-display label frame)
490 (let ((inhibit-read-only t)
491 (zmacs-region-stays zmacs-region-stays)) ; preserve from change
492 (erase-buffer (get-buffer-create " *Gutter Area*")))
494 nil ; just preparing to put another msg up
496 (let ((oldmsg (cdr (car progress-stack))))
497 (raw-append-progress-display oldmsg nil frame)
499 ;; nothing to display so get rid of the gauge
500 (set-specifier bottom-gutter-border-width 0 frame)
501 (set-gutter-element-visible-p bottom-gutter-visible-p
502 'progress nil frame)))))
504 (defun progress-display-clear-when-idle (&optional label)
505 (add-one-shot-hook 'pre-idle-hook
507 (clear-progress-display ',label))))
509 (defun remove-progress-display (&optional label frame)
510 ;; If label is nil, we want to remove all matching progress gauges.
511 (while (and progress-stack
512 (or (null label) ; null label means clear whole stack
513 (eq label (car (car progress-stack)))))
514 (setq progress-stack (cdr progress-stack)))
515 (let ((s progress-stack))
517 (let ((msg (car (cdr s))))
518 (if (eq label (car msg))
520 (setcdr s (cdr (cdr s))))
521 (setq s (cdr s)))))))
523 (defun progress-display-dispatch-non-command-events ()
524 ;; don't allow errors to hose things
526 ;; (sit-for 0) is too agressive and cause more display than we
528 (dispatch-non-command-events)
531 (defun append-progress-display (label message &optional value frame)
532 (or frame (setq frame (selected-frame)))
533 ;; Add a new entry to the message-stack, or modify an existing one
534 (let* ((top (car progress-stack))
536 (if (eq label (car top))
539 (if (equal tmsg message)
540 (set-image-instance-property
541 (glyph-image-instance progress-gauge-glyph
542 (frame-selected-window frame))
544 (raw-append-progress-display message value frame))
545 (redisplay-gutter-area))
546 (push (cons label message) progress-stack)
547 (raw-append-progress-display message value frame))
548 (progress-display-dispatch-non-command-events)
549 ;; either get command events or sit waiting for them
551 ; (sit-for progress-display-popup-period nil)
552 (clear-progress-display label))))
554 (defun abort-progress-display (label message &optional frame)
555 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
556 progress-display-use-echo-area)
557 (display-message label (concat message "aborted.") frame)
558 (or frame (setq frame (selected-frame)))
559 ;; Add a new entry to the message-stack, or modify an existing one
560 (let* ((top (car progress-stack))
561 (inhibit-read-only t)
562 (zmacs-region-stays zmacs-region-stays))
563 (if (eq label (car top))
565 (push (cons label message) progress-stack))
566 (unless (equal message "")
567 (insert-string message (get-buffer-create " *Gutter Area*"))
568 (let* ((gutter-string (copy-sequence "\n"))
569 (ext (make-extent 0 1 gutter-string)))
570 ;; do some funky display here.
571 (set-extent-begin-glyph ext progress-abort-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-image-instance-property
576 (glyph-image-instance progress-text-glyph
577 (frame-selected-window frame)) :data message)
578 (set-specifier bottom-gutter-height 'autodetect frame)
579 (set-gutter-element-visible-p bottom-gutter-visible-p
581 ;; we have to do this so redisplay is up-to-date and so
582 ;; redisplay-gutter-area performs optimally.
583 (redisplay-gutter-area)
584 (sit-for progress-display-popup-period nil)
585 (clear-progress-display label frame)
586 (set-extent-begin-glyph ext progress-layout-glyph)
587 (set-gutter-element bottom-gutter 'progress gutter-string frame)
590 (defun raw-append-progress-display (message &optional value frame)
591 (unless (equal message "")
592 (let* ((inhibit-read-only t)
593 (zmacs-region-stays zmacs-region-stays)
595 (gutter-string (copy-sequence "\n"))
596 (ext (make-extent 0 1 gutter-string)))
597 (insert-string message (get-buffer-create " *Gutter Area*"))
598 ;; do some funky display here.
599 (set-extent-begin-glyph ext progress-layout-glyph)
600 ;; fixup the gutter specifiers
601 (set-gutter-element bottom-gutter 'progress gutter-string frame)
602 (set-specifier bottom-gutter-border-width 2 frame)
603 (set-image-instance-property
604 (glyph-image-instance progress-gauge-glyph
605 (frame-selected-window frame))
607 (set-image-instance-property
608 (glyph-image-instance progress-text-glyph (frame-selected-window frame))
610 (if (and (eq (specifier-instance bottom-gutter-height frame)
612 (gutter-element-visible-p bottom-gutter-visible-p
614 ;; if the gauge is already visible then just draw the gutter
615 ;; checking for user events
617 (redisplay-gutter-area)
618 (progress-display-dispatch-non-command-events))
619 ;; otherwise make the gutter visible and redraw the frame
620 (set-specifier bottom-gutter-height 'autodetect frame)
621 (set-gutter-element-visible-p bottom-gutter-visible-p
623 ;; we have to do this so redisplay is up-to-date and so
624 ;; redisplay-gutter-area performs optimally. This may also
625 ;; make sure the frame geometry looks ok.
626 (progress-display-dispatch-non-command-events)
627 (redisplay-frame frame)
630 (defun display-progress-display (label message &optional value frame)
631 "Display a progress gauge and message in the bottom gutter area.
632 First argument LABEL is an identifier for this message. MESSAGE is
633 the string to display. Use `clear-progress-display' to remove a labelled
635 (cond ((eq value 'abort)
636 (abort-progress-display label message frame))
637 ((or (not (valid-image-instantiator-format-p 'progress-gauge frame))
638 progress-display-use-echo-area)
639 (display-message label
640 (concat message (if (eq value 100) "done."
641 (make-string (/ value 5) ?.)))
644 (append-progress-display label message value frame))))
646 (defun current-progress-display (&optional frame)
647 "Return the current progress gauge in the gutter area, or nil.
648 The FRAME argument is currently unused."
649 (cdr (car progress-stack)))
651 ;;; may eventually be frame-dependent
652 (defun current-progress-display-label (&optional frame)
653 (car (car progress-stack)))
655 (defun progress-display (fmt &optional value &rest args)
656 "Print a progress gauge and message in the bottom gutter area of the frame.
657 The arguments are the same as to `format'.
659 If the only argument is nil, clear any existing progress gauge."
661 (if (and (null fmt) (null args))
663 (clear-progress-display nil))
664 (let ((str (apply 'format fmt args)))
665 (display-progress-display 'progress str value)
668 (defun lprogress-display (label fmt &optional value &rest args)
669 "Print a progress gauge and message in the bottom gutter area of the frame.
670 First argument LABEL is an identifier for this progress gauge. The rest of the
671 arguments are the same as to `format'."
672 ;; #### sometimes the buffer gets changed temporarily. I don't know
673 ;; why this is, so protect against it.
675 (if (and (null fmt) (null args))
677 (clear-progress-display label nil))
678 (let ((str (apply 'format fmt args)))
679 (display-progress-display label str value)
683 ;; Simple search dialog
685 (defvar search-dialog-direction t)
686 (defvar search-dialog-text
688 [edit-field :width 15 :descriptor "" :active t :face default]))
690 (defun search-dialog-callback (parent image-instance event)
692 (select-frame parent)
693 (funcall (if search-dialog-direction
694 'search-forward 'search-backward)
695 (image-instance-property
696 (glyph-image-instance search-dialog-text
697 (frame-selected-window
698 (event-channel event))) :text))
699 (isearch-highlight (match-beginning 0) (match-end 0))))
701 (defun make-search-dialog ()
702 "Popup a search dialog box."
704 (let* ((parent (selected-frame)))
705 (set-buffer-dedicated-frame
706 (get-buffer-create "Dialog")
710 :orientation horizontal :justify left
712 :border [string :data "Search"]
714 ([layout :orientation vertical :justify left
716 ([string :data "Search for:"]
717 [button :descriptor "Match case"
719 :selected (not case-fold-search)
720 :callback (setq case-fold-search
721 (not case-fold-search))]
722 [button :descriptor "Forwards"
724 :selected search-dialog-direction
725 :callback (setq search-dialog-direction t)]
726 [button :descriptor "Backwards"
728 :selected (not search-dialog-direction)
729 :callback (setq search-dialog-direction nil)]
731 [layout :orientation vertical :justify left
734 [button :width 10 :descriptor "Find Next"
736 (lambda (image-instance event)
737 (search-dialog-callback ,parent
738 image-instance event))]
739 [button :width 10 :descriptor "Cancel"
741 (lambda (image-instance event)
742 (isearch-dehighlight)
744 (event-channel event)))])])])
745 '(height 10 width 40)))))
747 (provide 'gutter-items)
748 ;;; gutter-items.el ends here.