annotate lisp/gutter-items.el @ 801:2b676dc88c66

[xemacs-hg @ 2002-04-01 03:58:02 by ben] bug fixes (e.g. ballooning on X windows) Makefile.in.in: Try to make the Makefile notice if its source Makefile.in.in is changed, and regenerate and run itself. Use a bigger default SHEAP_ADJUSTMENT on Cygwin; otherwise you can't compile under Mule if a Lisp file has changed. (can't run temacs) TODO.ben-mule-21-5: update. mule/mule-cmds.el: Hash the result of mswindows-get-language-environment-from-locale, since it's very expensive (and causes huge ballooning of memory under X Windows, since it's called from x-get-resource). cl-extra.el, code-files.el, files.el, simple.el, subr.el, x-faces.el: Create new string-equal-ignore-case, based on built-in compare-strings -- compare strings ignoring case without the need to generate garbage by calling downcase. Use it in equalp and elsewhere. alloc.c, bytecode.c, chartab.c, data.c, elhash.c, emacs.c, eval.c, event-Xt.c, event-unixoid.c, extents.c, file-coding.c, fileio.c, fns.c, glyphs.c, gutter.c, lisp-union.h, lisp.h, mule-charset.c, nt.c, process-unix.c, process.c, specifier.c, symbols.c, sysdep.c, sysdep.h, text.c, toolbar.c: Try to implement GC triggering based on percentage of total memory usage. Not currently activated (percentage set to 0) because not quite working. Add `memory-usage' primitive to return XEmacs' idea of its memory usage. Add primitive compare-strings, compatible with FSF 21.1 -- can compare any part of two strings, optionally ignoring case. Improve qxe() functions in text.c for text comparison. Use RETURN_NOT_REACHED to try to avoid warnings about unreachable code. Add volatile_make_int() to fix warning in unix_send_process().
author ben
date Mon, 01 Apr 2002 03:59:04 +0000
parents 943eaba38521
children 42375619fa45
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 ;;; gutter-items.el --- Gutter content for XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5 ;; Maintainer: XEmacs Development Team
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 ;; Keywords: frames, extensions, internal, dumped
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 ;; This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 ;; XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 ;; under the terms of the GNU General Public License as published by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 ;; the Free Software Foundation; either version 2, or (at your option)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 ;; any later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 ;; XEmacs is distributed in the hope that it will be useful, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 ;; General Public License for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 ;; You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21 ;; along with Xmacs; see the file COPYING. If not, write to the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 ;; Boston, MA 02111-1307, USA.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 502
diff changeset
25 ;;; Gutter-specific buffers tab code
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
27 (defvar gutter-buffers-tab nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
28 "A tab widget in the gutter for displaying buffers.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
29 Do not set this. Use `set-glyph-image' to change the properties of the tab.")
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
30
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
31 (defcustom gutter-buffers-tab-visible-p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
32 (gutter-element-visible-p default-gutter-visible-p 'buffers-tab)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
33 "Whether the buffers tab is globally visible.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
34 This option should be set through the options menu."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
35 :group 'buffers-tab
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
36 :type 'boolean
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
37 :set #'(lambda (var val)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
38 (set-gutter-element-visible-p default-gutter-visible-p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
39 'buffers-tab val)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
40 (setq gutter-buffers-tab-visible-p val)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
41
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
42 (defcustom gutter-buffers-tab-enabled t
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
43 "*Whether to enable support for buffers tab in the gutter.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
44 This is different to `gutter-buffers-tab-visible-p' which still runs hooks
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
45 even when the gutter is invisible."
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
46 :group 'buffers-tab
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
47 :type 'boolean)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
48
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
49 (defvar gutter-buffers-tab-orientation 'top
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
50 "Where the buffers tab currently is. Do not set this.")
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
51
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 (defun add-tab-to-gutter ()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 "Put a tab control in the gutter area to hold the most recent buffers."
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
54 (setq gutter-buffers-tab-orientation (default-gutter-position))
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
55 (let* ((gutter-string (copy-sequence "\n"))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
56 (gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
57 (set-extent-begin-glyph gutter-buffers-tab-extent
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
58 (setq gutter-buffers-tab
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
59 (make-glyph)))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
60 ;; Nuke all existing tabs
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
61 (remove-gutter-element top-gutter 'buffers-tab)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
62 (remove-gutter-element bottom-gutter 'buffers-tab)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
63 (remove-gutter-element left-gutter 'buffers-tab)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
64 (remove-gutter-element right-gutter 'buffers-tab)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
65 ;; Put tabs into all devices that will be able to display them
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
66 (mapcar
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
67 #'(lambda (x)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
68 (when (valid-image-instantiator-format-p 'tab-control x)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
69 (cond ((eq gutter-buffers-tab-orientation 'top)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
70 ;; This looks better than a 3d border
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
71 (set-specifier top-gutter-border-width 0 'global x)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
72 (set-gutter-element top-gutter 'buffers-tab
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
73 gutter-string 'global x))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
74 ((eq gutter-buffers-tab-orientation 'bottom)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
75 (set-specifier bottom-gutter-border-width 0 'global x)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
76 (set-gutter-element bottom-gutter 'buffers-tab
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
77 gutter-string 'global x))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
78 ((eq gutter-buffers-tab-orientation 'left)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
79 (set-specifier left-gutter-border-width 0 'global x)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
80 (set-gutter-element left-gutter 'buffers-tab
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
81 gutter-string 'global x))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
82 ((eq gutter-buffers-tab-orientation 'right)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
83 (set-specifier right-gutter-border-width 0 'global x)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
84 (set-gutter-element right-gutter 'buffers-tab
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
85 gutter-string 'global x))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
86 )))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
87 (console-type-list))))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
88
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
89 (defun update-tab-in-gutter (frame &optional force-selection)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 "Update the tab control in the gutter area."
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
91 ;; dedicated frames don't get tabs
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
92 (unless (or (window-dedicated-p (frame-selected-window frame))
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
93 (frame-property frame 'popup))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
94 (when (specifier-instance default-gutter-visible-p frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
95 (unless (and gutter-buffers-tab
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
96 (eq (default-gutter-position)
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 430
diff changeset
97 gutter-buffers-tab-orientation))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 (add-tab-to-gutter))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
99 (when (valid-image-instantiator-format-p 'tab-control frame)
446
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
100 (let ((items (buffers-tab-items nil frame force-selection)))
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
101 (when items
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
102 (set-glyph-image
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
103 gutter-buffers-tab
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
104 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
105 :orientation gutter-buffers-tab-orientation
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
106 (if (or (eq gutter-buffers-tab-orientation 'top)
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
107 (eq gutter-buffers-tab-orientation 'bottom))
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
108 :pixel-width :pixel-height)
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
109 (if (or (eq gutter-buffers-tab-orientation 'top)
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
110 (eq gutter-buffers-tab-orientation 'bottom))
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
111 '(gutter-pixel-width) '(gutter-pixel-height))
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
112 :items items)
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
113 frame)
1ccc32a20af4 Import from CVS: tag r21-2-38
cvs
parents: 444
diff changeset
114 ;; set-glyph-image will not make the gutter dirty
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
115 (set-gutter-dirty-p gutter-buffers-tab-orientation)))))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
117 ;; A myriad of different update hooks all doing slightly different things
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
118 (add-one-shot-hook
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
119 'after-init-hook
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
120 #'(lambda ()
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
121 ;; don't add the hooks if the user really doesn't want them
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
122 (when gutter-buffers-tab-enabled
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
123 (add-hook 'create-frame-hook
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
124 #'(lambda (frame)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
125 (when gutter-buffers-tab (update-tab-in-gutter frame t))))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
126 (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
127 (add-hook 'default-gutter-position-changed-hook
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
128 #'(lambda ()
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
129 (when gutter-buffers-tab
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
130 (mapc #'update-tab-in-gutter (frame-list)))))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
131 (add-hook 'gutter-element-visibility-changed-hook
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
132 #'(lambda (prop visible-p)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
133 (when (and (eq prop 'buffers-tab) visible-p)
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
134 (mapc #'update-tab-in-gutter (frame-list)))))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
135 (update-tab-in-gutter (selected-frame) t))))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
136
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 ;;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 ;; progress display
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 ;; ripped off from message display
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 ;;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
141 (defcustom progress-feedback-use-echo-area nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
142 "*Whether progress gauge display should display in the echo area.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
143 If NIL then progress gauges will be displayed with whatever native widgets
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
144 are available on the current console. If non-NIL then progress display will be
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
145 textual and displayed in the echo area."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
146 :type 'boolean
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
147 :group 'gutter)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
148
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
149 (defvar progress-glyph-height 24
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
150 "Height of the progress gauge glyph.")
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
151
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
152 (defvar progress-feedback-popup-period 0.5
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
153 "The time that the progress gauge should remain up after completion")
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
154
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
155 (defcustom progress-feedback-style 'large
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
156 "*Control the appearance of the progress gauge.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
157 If 'large, the default, then the progress-feedback text is displayed
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
158 above the gauge itself. If 'small then the gauge and text are arranged
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
159 side-by-side."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
160 :group 'gutter
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
161 :type '(choice (const :tag "large" large)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
162 (const :tag "small" small)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
163
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
164 ;; private variables
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
165 (defvar progress-text-instantiator [string :data ""])
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
166 (defvar progress-layout-glyph (make-glyph))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
167 (defvar progress-layout-instantiator nil)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
168
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
169 (defvar progress-gauge-instantiator
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
170 [progress-gauge
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
171 :value 0
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
172 :pixel-height (eval progress-glyph-height)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
173 :pixel-width 250
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
174 :descriptor "Progress"])
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
175
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
176 (defun set-progress-feedback-instantiator (&optional locale)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
177 (cond
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
178 ((eq progress-feedback-style 'small)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
179 (setq progress-glyph-height 16)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
180 (setq progress-layout-instantiator
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
181 `[layout
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
182 :orientation horizontal
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
183 :margin-width 4
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
184 :items (,progress-gauge-instantiator
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
185 [button
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
186 :pixel-height (eval progress-glyph-height)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
187 ;; 'quit is special and acts "asynchronously".
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
188 :descriptor "Stop" :callback 'quit]
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
189 ,progress-text-instantiator)])
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
190 (set-glyph-image progress-layout-glyph progress-layout-instantiator
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
191 locale))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
192 (t
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
193 (setq progress-glyph-height 24)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
194 (setq progress-layout-instantiator
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
195 `[layout
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
196 :orientation vertical :justify left
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
197 :margin-width 4
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
198 :items (,progress-text-instantiator
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
199 [layout
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
200 :orientation horizontal
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
201 :items (,progress-gauge-instantiator
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
202 [button
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
203 :pixel-height (eval progress-glyph-height)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
204 :descriptor " Stop "
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
205 ;; 'quit is special and acts "asynchronously".
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
206 :callback 'quit])])])
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
207 (set-glyph-image progress-layout-glyph progress-layout-instantiator
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
208 locale))))
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
209
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
210 (defvar progress-abort-glyph (make-glyph))
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
211
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
212 (defun set-progress-abort-instantiator (&optional locale)
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
213 (set-glyph-image progress-abort-glyph
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
214 `[layout :orientation vertical :justify left
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
215 :items (,progress-text-instantiator
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
216 [layout
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
217 :margin-width 4
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
218 :pixel-height progress-glyph-height
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
219 :orientation horizontal])]
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
220 locale))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
221
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 (defvar progress-stack nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 "An alist of label/string pairs representing active progress gauges.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224 The first element in the list is currently displayed in the gutter area.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
225 Do not modify this directly--use the `progress-feedback' or
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
226 `display-progress-feedback'/`clear-progress-feedback' functions.")
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
228 (defun progress-feedback-displayed-p (&optional return-string frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 "Return a non-nil value if a progress gauge is presently displayed in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 gutter area. If optional argument RETURN-STRING is non-nil,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 return a string containing the message, otherwise just return t."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 (let ((buffer (get-buffer-create " *Gutter Area*")))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 (and (< (point-min buffer) (point-max buffer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 (if return-string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 (buffer-substring nil nil buffer)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 t))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 ;;; Returns the string which remains in the echo area, or nil if none.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 ;;; If label is nil, the whole message stack is cleared.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
240 (defun clear-progress-feedback (&optional label frame no-restore)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
241 "Remove any progress gauge with LABEL from the progress gauge-stack,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 erasing it from the gutter area if it's currently displayed there.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 If a message remains at the head of the progress-stack and NO-RESTORE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 is nil, it will be displayed. The string which remains in the gutter
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 area will be returned, or nil if the progress-stack is now empty.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 If LABEL is nil, the entire progress-stack is cleared.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248 Unless you need the return value or you need to specify a label,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 you should just use (progress nil)."
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
250 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
251 progress-feedback-use-echo-area)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
252 (clear-message label frame nil no-restore)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
253 (or frame (setq frame (selected-frame)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
254 (remove-progress-feedback label frame)
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 458
diff changeset
255 (let ((inhibit-read-only t))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
256 (erase-buffer (get-buffer-create " *Gutter Area*")))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
257 (if no-restore
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
258 nil ; just preparing to put another msg up
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
259 (if progress-stack
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
260 (let ((oldmsg (cdr (car progress-stack))))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
261 (raw-append-progress-feedback oldmsg nil frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
262 oldmsg)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
263 ;; nothing to display so get rid of the gauge
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
264 (set-specifier bottom-gutter-border-width 0 frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
265 (set-gutter-element-visible-p bottom-gutter-visible-p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
266 'progress nil frame)))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
268 (defun progress-feedback-clear-when-idle (&optional label)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
269 (add-one-shot-hook 'pre-idle-hook
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
270 `(lambda ()
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
271 (clear-progress-feedback ',label))))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
272
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
273 (defun remove-progress-feedback (&optional label frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 ;; If label is nil, we want to remove all matching progress gauges.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 (while (and progress-stack
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 (or (null label) ; null label means clear whole stack
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277 (eq label (car (car progress-stack)))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278 (setq progress-stack (cdr progress-stack)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 (let ((s progress-stack))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280 (while (cdr s)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281 (let ((msg (car (cdr s))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 (if (eq label (car msg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 (setcdr s (cdr (cdr s))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 (setq s (cdr s)))))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
287 (defun progress-feedback-dispatch-non-command-events ()
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
288 ;; don't allow errors to hose things
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
289 (condition-case t
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
290 ;; (sit-for 0) is too agressive and cause more display than we
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
291 ;; want.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
292 (dispatch-non-command-events)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
293 nil))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
294
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
295 (defun append-progress-feedback (label message &optional value frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 (or frame (setq frame (selected-frame)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 ;; Add a new entry to the message-stack, or modify an existing one
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 (let* ((top (car progress-stack))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 (tmsg (cdr top)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300 (if (eq label (car top))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 (progn
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 (setcdr top message)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
303 (if (equal tmsg message)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
304 (progn
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
305 (set-instantiator-property progress-gauge-instantiator :value value)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
306 (set-progress-feedback-instantiator (frame-selected-window frame)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
307 (raw-append-progress-feedback message value frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
308 (redisplay-gutter-area))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 (push (cons label message) progress-stack)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
310 (raw-append-progress-feedback message value frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
311 (progress-feedback-dispatch-non-command-events)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
312 ;; either get command events or sit waiting for them
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
313 (when (eq value 100)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
314 ; (sit-for progress-feedback-popup-period nil)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
315 (clear-progress-feedback label))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
317 (defun abort-progress-feedback (label message &optional frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
318 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
319 progress-feedback-use-echo-area)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
320 (display-message label (concat message "aborted.") frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
321 (or frame (setq frame (selected-frame)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
322 ;; Add a new entry to the message-stack, or modify an existing one
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
323 (let* ((top (car progress-stack))
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 458
diff changeset
324 (inhibit-read-only t))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
325 (if (eq label (car top))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
326 (setcdr top message)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
327 (push (cons label message) progress-stack))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
328 (unless (equal message "")
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
329 (insert-string message (get-buffer-create " *Gutter Area*"))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
330 (let* ((gutter-string (copy-sequence "\n"))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
331 (ext (make-extent 0 1 gutter-string)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
332 ;; do some funky display here.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
333 (set-extent-begin-glyph ext progress-abort-glyph)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 ;; fixup the gutter specifiers
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
335 (set-gutter-element bottom-gutter 'progress gutter-string frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 (set-specifier bottom-gutter-border-width 2 frame)
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
337 (set-instantiator-property progress-text-instantiator :data message)
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 452
diff changeset
338 (set-progress-abort-instantiator (frame-selected-window frame))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 (set-specifier bottom-gutter-height 'autodetect frame)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
340 (set-gutter-element-visible-p bottom-gutter-visible-p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
341 'progress t frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 ;; we have to do this so redisplay is up-to-date and so
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 ;; redisplay-gutter-area performs optimally.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344 (redisplay-gutter-area)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
345 (sit-for progress-feedback-popup-period nil)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
346 (clear-progress-feedback label frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
347 (set-extent-begin-glyph ext progress-layout-glyph)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
348 (set-gutter-element bottom-gutter 'progress gutter-string frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 )))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
351 (defun raw-append-progress-feedback (message &optional value frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 (unless (equal message "")
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
353 (let* ((inhibit-read-only t)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
354 (val (or value 0))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
355 (gutter-string (copy-sequence "\n"))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
356 (ext (make-extent 0 1 gutter-string)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 (insert-string message (get-buffer-create " *Gutter Area*"))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
358 ;; do some funky display here.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
359 (set-extent-begin-glyph ext progress-layout-glyph)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
360 ;; fixup the gutter specifiers
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
361 (set-gutter-element bottom-gutter 'progress gutter-string frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
362 (set-specifier bottom-gutter-border-width 2 frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
363 (set-instantiator-property progress-gauge-instantiator :value val)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
364 (set-progress-feedback-instantiator (frame-selected-window frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
365
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
366 (set-instantiator-property progress-text-instantiator :data message)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
367 (set-progress-feedback-instantiator (frame-selected-window frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
368 (if (and (eq (specifier-instance bottom-gutter-height frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
369 'autodetect)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
370 (gutter-element-visible-p bottom-gutter-visible-p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
371 'progress frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
372 ;; if the gauge is already visible then just draw the gutter
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
373 ;; checking for user events
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 (progn
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
375 (redisplay-gutter-area)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
376 (progress-feedback-dispatch-non-command-events))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
377 ;; otherwise make the gutter visible and redraw the frame
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
378 (set-specifier bottom-gutter-height 'autodetect frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
379 (set-gutter-element-visible-p bottom-gutter-visible-p
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
380 'progress t frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
381 ;; we have to do this so redisplay is up-to-date and so
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
382 ;; redisplay-gutter-area performs optimally. This may also
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
383 ;; make sure the frame geometry looks ok.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
384 (progress-feedback-dispatch-non-command-events)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
385 (redisplay-frame frame)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
386 ))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
388 (defun display-progress-feedback (label message &optional value frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 "Display a progress gauge and message in the bottom gutter area.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 First argument LABEL is an identifier for this message. MESSAGE is
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
391 the string to display. Use `clear-progress-feedback' to remove a labelled
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 message."
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
393 (cond ((eq value 'abort)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
394 (abort-progress-feedback label message frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
395 ((or (not (valid-image-instantiator-format-p 'progress-gauge frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
396 progress-feedback-use-echo-area)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
397 (display-message label
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
398 (concat message (if (eq value 100) "done."
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
399 (make-string (/ value 5) ?.)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
400 frame))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
401 (t
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
402 (append-progress-feedback label message value frame))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
404 (defun current-progress-feedback (&optional frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 "Return the current progress gauge in the gutter area, or nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 The FRAME argument is currently unused."
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 (cdr (car progress-stack)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 ;;; may eventually be frame-dependent
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
410 (defun current-progress-feedback-label (&optional frame)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 (car (car progress-stack)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
413 (defun progress-feedback (fmt &optional value &rest args)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 "Print a progress gauge and message in the bottom gutter area of the frame.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 The arguments are the same as to `format'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 If the only argument is nil, clear any existing progress gauge."
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
418 (save-excursion
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
419 (if (and (null fmt) (null args))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
420 (prog1 nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
421 (clear-progress-feedback nil))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
422 (let ((str (apply 'format fmt args)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
423 (display-progress-feedback 'progress str value)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
424 str))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
426 (defun progress-feedback-with-label (label fmt &optional value &rest args)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 "Print a progress gauge and message in the bottom gutter area of the frame.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 First argument LABEL is an identifier for this progress gauge. The rest of the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 arguments are the same as to `format'."
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
430 ;; #### sometimes the buffer gets changed temporarily. I don't know
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
431 ;; why this is, so protect against it.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
432 (save-excursion
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
433 (if (and (null fmt) (null args))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
434 (prog1 nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
435 (clear-progress-feedback label nil))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
436 (let ((str (apply 'format fmt args)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
437 (display-progress-feedback label str value)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
438 str))))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 (provide 'gutter-items)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 ;;; gutter-items.el ends here.