|
398
|
1 ;;; gutter-items.el --- Gutter content for XEmacs.
|
|
|
2
|
|
|
3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
|
|
|
4 ;; Copyright (C) 1999 Andy Piper.
|
|
|
5
|
|
|
6 ;; Maintainer: XEmacs Development Team
|
|
|
7 ;; Keywords: frames, extensions, internal, dumped
|
|
|
8
|
|
|
9 ;; This file is part of XEmacs.
|
|
|
10
|
|
|
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)
|
|
|
14 ;; any later version.
|
|
|
15
|
|
|
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.
|
|
|
20
|
|
|
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.
|
|
|
25
|
|
|
26 ;; Some of this is taken from the buffer-menu stuff in menubar-items.el
|
|
|
27 ;; and the custom specs in toolbar.el.
|
|
|
28
|
|
|
29 (defgroup gutter nil
|
|
|
30 "Input from the gutters."
|
|
|
31 :group 'environment)
|
|
|
32
|
|
|
33 (defvar gutter-buffers-tab nil
|
|
|
34 "A tab widget in the gutter for displaying buffers.
|
|
|
35 Do not set this. Use `glyph-image-instance' and
|
|
|
36 `set-image-instance-property' to change the properties of the tab.")
|
|
|
37
|
|
|
38 (defcustom gutter-visible-p
|
|
|
39 (specifier-instance default-gutter-visible-p)
|
|
|
40 "Whether the default gutter is globally visible. This option can be
|
|
|
41 customized through the options menu."
|
|
|
42 :group 'gutter
|
|
|
43 :type 'boolean
|
|
|
44 :set #'(lambda (var val)
|
|
|
45 (set-specifier default-gutter-visible-p val)
|
|
|
46 (setq gutter-visible-p val)
|
|
|
47 (when gutter-buffers-tab (update-tab-in-gutter))))
|
|
|
48
|
|
|
49 (defcustom default-gutter-position
|
|
|
50 (default-gutter-position)
|
|
|
51 "The location of the default gutter. It can be 'top, 'bottom, 'left or
|
|
|
52 'right. This option can be customized through the options menu."
|
|
|
53 :group 'gutter
|
|
|
54 :type '(choice (const :tag "top" top)
|
|
|
55 (const :tag "bottom" bottom)
|
|
|
56 (const :tag "left" left)
|
|
|
57 (const :tag "right" right))
|
|
|
58 :set #'(lambda (var val)
|
|
|
59 (set-default-gutter-position val)
|
|
|
60 (setq default-gutter-position val)
|
|
|
61 (when gutter-buffers-tab (update-tab-in-gutter))))
|
|
|
62
|
|
|
63 ;;; The Buffers tab
|
|
|
64
|
|
|
65 (defgroup buffers-tab nil
|
|
|
66 "Customization of `Buffers' tab."
|
|
|
67 :group 'gutter)
|
|
|
68
|
|
|
69 (defvar gutter-buffers-tab-orientation 'top
|
|
|
70 "Where the buffers tab currently is. Do not set this.")
|
|
|
71
|
|
|
72 (defvar gutter-buffers-tab-extent nil)
|
|
|
73
|
|
|
74 (defcustom buffers-tab-max-size 6
|
|
|
75 "*Maximum number of entries which may appear on the \"Buffers\" tab.
|
|
|
76 If this is 10, then only the ten most-recently-selected buffers will be
|
|
|
77 shown. If this is nil, then all buffers will be shown. Setting this to
|
|
|
78 a large number or nil will slow down tab responsiveness."
|
|
|
79 :type '(choice (const :tag "Show all" nil)
|
|
|
80 (integer 6))
|
|
|
81 :group 'buffers-tab)
|
|
|
82
|
|
|
83 (defcustom buffers-tab-switch-to-buffer-function 'buffers-tab-switch-to-buffer
|
|
|
84 "*The function to call to select a buffer from the buffers tab.
|
|
|
85 `switch-to-buffer' is a good choice, as is `pop-to-buffer'."
|
|
|
86 :type '(radio (function-item switch-to-buffer)
|
|
|
87 (function-item pop-to-buffer)
|
|
|
88 (function :tag "Other"))
|
|
|
89 :group 'buffers-tab)
|
|
|
90
|
|
|
91 (defcustom buffers-tab-omit-function 'buffers-menu-omit-invisible-buffers
|
|
|
92 "*If non-nil, a function specifying the buffers to omit from the buffers tab.
|
|
|
93 This is passed a buffer and should return non-nil if the buffer should be
|
|
|
94 omitted. The default value `buffers-tab-omit-invisible-buffers' omits
|
|
|
95 buffers that are normally considered \"invisible\" (those whose name
|
|
|
96 begins with a space)."
|
|
|
97 :type '(choice (const :tag "None" nil)
|
|
|
98 function)
|
|
|
99 :group 'buffers-tab)
|
|
|
100
|
|
|
101 (defcustom buffers-tab-selection-function 'select-buffers-tab-buffers-by-mode
|
|
|
102 "*If non-nil, a function specifying the buffers to select from the
|
|
|
103 buffers tab. This is passed two buffers and should return non-nil if
|
|
|
104 the second buffer should be selected. The default value
|
|
|
105 `select-buffers-tab-buffers-by-mode' groups buffers by major mode and
|
|
|
106 by `buffers-tab-grouping-regexp'."
|
|
|
107
|
|
|
108 :type '(choice (const :tag "None" nil)
|
|
|
109 function)
|
|
|
110 :group 'buffers-tab)
|
|
|
111
|
|
|
112 (make-face 'buffers-tab "Face for displaying the buffers tab.")
|
|
|
113 (set-face-parent 'buffers-tab 'default)
|
|
|
114
|
|
|
115 (defcustom buffers-tab-face 'buffers-tab
|
|
|
116 "*Face to use for displaying the buffers tab."
|
|
|
117 :type 'face
|
|
|
118 :group 'buffers-tab)
|
|
|
119
|
|
|
120 (defcustom buffers-tab-grouping-regexp
|
|
|
121 '("^\\(gnus-\\|message-mode\\|mime/viewer-mode\\)"
|
|
|
122 "^\\(emacs-lisp-\\|lisp-\\)")
|
|
|
123 "*If non-nil, a list of regular expressions for buffer grouping.
|
|
|
124 Each regular expression is applied to the current major-mode symbol
|
|
|
125 name and mode-name, if it matches then any other buffers that match
|
|
|
126 the same regular expression be added to the current group."
|
|
|
127 :type '(choice (const :tag "None" nil)
|
|
|
128 sexp)
|
|
|
129 :group 'buffers-tab)
|
|
|
130
|
|
|
131 (defcustom buffers-tab-format-buffer-line-function 'format-buffers-tab-line
|
|
|
132 "*The function to call to return a string to represent a buffer in the
|
|
|
133 buffers tab. The function is passed a buffer and should return a
|
|
|
134 string. The default value `format-buffers-tab-line' just returns the
|
|
|
135 name of the buffer, optionally truncated to
|
|
|
136 `buffers-tab-max-buffer-line-length'. Also check out
|
|
|
137 `slow-format-buffers-menu-line' which returns a whole bunch of info
|
|
|
138 about a buffer."
|
|
|
139 :type 'function
|
|
|
140 :group 'buffers-tab)
|
|
|
141
|
|
|
142 (defvar buffers-tab-default-buffer-line-length
|
|
|
143 (make-specifier-and-init 'generic '((global ((default) . 25))) t)
|
|
|
144 "*Maximum length of text which may appear in a \"Buffers\" tab.
|
|
|
145 This is a specifier, use set-specifier to modify it.")
|
|
|
146
|
|
|
147 (defcustom buffers-tab-max-buffer-line-length
|
|
|
148 (specifier-instance buffers-tab-default-buffer-line-length)
|
|
|
149 "*Maximum length of text which may appear in a \"Buffers\" tab.
|
|
|
150 Buffer names over this length will be truncated with elipses.
|
|
|
151 If this is 0, then the full buffer name will be shown."
|
|
|
152 :type '(choice (const :tag "Show all" 0)
|
|
|
153 (integer 25))
|
|
|
154 :group 'buffers-tab
|
|
|
155 :set #'(lambda (var val)
|
|
|
156 (set-specifier buffers-tab-default-buffer-line-length val)
|
|
|
157 (setq buffers-tab-max-buffer-line-length val)))
|
|
|
158
|
|
|
159 (defun buffers-tab-switch-to-buffer (buffer)
|
|
|
160 "For use as a value for `buffers-tab-switch-to-buffer-function'."
|
|
|
161 (unless (eq (window-buffer) buffer)
|
|
|
162 (if (> (length (windows-of-buffer buffer)) 0)
|
|
|
163 (select-window (car (windows-of-buffer buffer)))
|
|
|
164 (switch-to-buffer buffer t))))
|
|
|
165
|
|
|
166 (defun select-buffers-tab-buffers-by-mode (buf1 buf2)
|
|
|
167 "For use as a value of `buffers-tab-selection-function'.
|
|
|
168 This selects buffers by major mode `buffers-tab-grouping-regexp'."
|
|
|
169 (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1)))
|
|
|
170 (mode2 (symbol-name (symbol-value-in-buffer 'major-mode buf2)))
|
|
|
171 (modenm1 (symbol-value-in-buffer 'mode-name buf1))
|
|
|
172 (modenm2 (symbol-value-in-buffer 'mode-name buf2)))
|
|
|
173 (cond ((or (eq mode1 mode2)
|
|
|
174 (eq modenm1 modenm2)
|
|
|
175 (and (string-match "^[^-]+-" mode1)
|
|
|
176 (string-match
|
|
|
177 (concat "^" (regexp-quote
|
|
|
178 (substring mode1 0 (match-end 0))))
|
|
|
179 mode2))
|
|
|
180 (and buffers-tab-grouping-regexp
|
|
|
181 (find-if #'(lambda (x)
|
|
|
182 (or
|
|
|
183 (and (string-match x mode1)
|
|
|
184 (string-match x mode2))
|
|
|
185 (and (string-match x modenm1)
|
|
|
186 (string-match x modenm2))))
|
|
|
187 buffers-tab-grouping-regexp)))
|
|
|
188 t)
|
|
|
189 (t nil))))
|
|
|
190
|
|
|
191 (defun format-buffers-tab-line (buffer)
|
|
|
192 "For use as a value of `buffers-tab-format-buffer-line-function'.
|
|
|
193 This just returns the buffer's name, optionally truncated."
|
|
|
194 (let ((len (specifier-instance buffers-tab-default-buffer-line-length)))
|
|
|
195 (if (and (> len 0)
|
|
|
196 (> (length (buffer-name buffer)) len))
|
|
|
197 (if (string-match ".*<.>$" (buffer-name buffer))
|
|
|
198 (concat (substring (buffer-name buffer)
|
|
|
199 0 (- len 6)) "..."
|
|
|
200 (substring (buffer-name buffer) -3))
|
|
|
201 (concat (substring (buffer-name buffer)
|
|
|
202 0 (- len 3)) "..."))
|
|
|
203 (buffer-name buffer))))
|
|
|
204
|
|
|
205 (defsubst build-buffers-tab-internal (buffers)
|
|
|
206 (let (line)
|
|
|
207 (mapcar
|
|
|
208 #'(lambda (buffer)
|
|
|
209 (setq line (funcall buffers-tab-format-buffer-line-function
|
|
|
210 buffer))
|
|
|
211 (vector line (list buffers-tab-switch-to-buffer-function
|
|
|
212 (buffer-name buffer))))
|
|
|
213 buffers)))
|
|
|
214
|
|
|
215 (defun buffers-tab-items (&optional in-deletion frame)
|
|
|
216 "This is the tab filter for the top-level buffers \"Buffers\" tab.
|
|
|
217 It dynamically creates a list of buffers to use as the contents of the tab.
|
|
|
218 Only the most-recently-used few buffers will be listed on the tab, for
|
|
|
219 efficiency reasons. You can control how many buffers will be shown by
|
|
|
220 setting `buffers-tab-max-size'. You can control the text of the tab
|
|
|
221 items by redefining the function `format-buffers-menu-line'."
|
|
|
222 (save-match-data
|
|
|
223 (let* ((buffers (delete-if buffers-tab-omit-function (buffer-list frame)))
|
|
|
224 (first-buf (car buffers)))
|
|
|
225 ;; if we're in deletion ignore the current buffer
|
|
|
226 (when in-deletion
|
|
|
227 (setq buffers (delq (current-buffer) buffers))
|
|
|
228 (setq first-buf (car buffers)))
|
|
|
229 ;; group buffers by mode
|
|
|
230 (when buffers-tab-selection-function
|
|
|
231 (delete-if-not #'(lambda (buf)
|
|
|
232 (funcall buffers-tab-selection-function
|
|
|
233 first-buf buf)) buffers))
|
|
|
234 (and (integerp buffers-tab-max-size)
|
|
|
235 (> buffers-tab-max-size 1)
|
|
|
236 (> (length buffers) buffers-tab-max-size)
|
|
|
237 ;; shorten list of buffers
|
|
|
238 (setcdr (nthcdr buffers-tab-max-size buffers) nil))
|
|
|
239 (setq buffers (build-buffers-tab-internal buffers))
|
|
|
240 buffers)))
|
|
|
241
|
|
|
242 (defun add-tab-to-gutter ()
|
|
|
243 "Put a tab control in the gutter area to hold the most recent buffers."
|
|
|
244 (setq gutter-buffers-tab-orientation (default-gutter-position))
|
|
|
245 (let ((gutter-string ""))
|
|
|
246 (unless gutter-buffers-tab-extent
|
|
|
247 (setq gutter-buffers-tab-extent (make-extent 0 0 gutter-string)))
|
|
|
248 (set-extent-begin-glyph
|
|
|
249 gutter-buffers-tab-extent
|
|
|
250 (setq gutter-buffers-tab
|
|
|
251 (make-glyph
|
|
|
252 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
|
|
|
253 :orientation gutter-buffers-tab-orientation
|
|
|
254 :properties (list :items (buffers-tab-items))))))
|
|
|
255 ;; This looks better than a 3d border
|
|
|
256 (mapcar '(lambda (x)
|
|
|
257 (when (valid-image-instantiator-format-p 'tab-control x)
|
|
|
258 (set-specifier default-gutter-border-width 0 'global x)
|
|
|
259 (set-specifier top-gutter nil 'global x)
|
|
|
260 (set-specifier bottom-gutter nil 'global x)
|
|
|
261 (set-specifier left-gutter nil 'global x)
|
|
|
262 (set-specifier right-gutter nil 'global x)
|
|
|
263 (set-specifier left-gutter-width 0 'global x)
|
|
|
264 (set-specifier right-gutter-width 0 'global x)
|
|
|
265 (cond ((eq gutter-buffers-tab-orientation 'top)
|
|
|
266 (set-specifier top-gutter gutter-string 'global x))
|
|
|
267 ((eq gutter-buffers-tab-orientation 'bottom)
|
|
|
268 (set-specifier bottom-gutter gutter-string 'global x))
|
|
|
269 ((eq gutter-buffers-tab-orientation 'left)
|
|
|
270 (set-specifier left-gutter gutter-string 'global x)
|
|
|
271 (set-specifier left-gutter-width
|
|
|
272 (glyph-width gutter-buffers-tab)
|
|
|
273 'global x))
|
|
|
274 ((eq gutter-buffers-tab-orientation 'right)
|
|
|
275 (set-specifier right-gutter gutter-string 'global x)
|
|
|
276 (set-specifier right-gutter-width
|
|
|
277 (glyph-width gutter-buffers-tab)
|
|
|
278 'global x))
|
|
|
279 )))
|
|
|
280 (console-type-list))))
|
|
|
281
|
|
|
282 (defun update-tab-in-gutter (&optional frame-or-buffer)
|
|
|
283 "Update the tab control in the gutter area."
|
|
|
284 (let ((locale (if (framep frame-or-buffer) frame-or-buffer)))
|
|
|
285 (when (specifier-instance default-gutter-visible-p locale)
|
|
|
286 (unless (and gutter-buffers-tab
|
|
|
287 (eq (default-gutter-position)
|
|
|
288 gutter-buffers-tab-orientation))
|
|
|
289 (add-tab-to-gutter))
|
|
|
290 (when (valid-image-instantiator-format-p 'tab-control locale)
|
|
|
291 (let ((inst (glyph-image-instance
|
|
|
292 gutter-buffers-tab
|
|
|
293 (when (framep frame-or-buffer)
|
|
|
294 (last-nonminibuf-window frame-or-buffer)))))
|
|
|
295 (set-image-instance-property inst :items
|
|
|
296 (buffers-tab-items
|
|
|
297 nil locale)))))))
|
|
|
298
|
|
|
299 (defun remove-buffer-from-gutter-tab ()
|
|
|
300 "Remove the current buffer from the tab control in the gutter area."
|
|
|
301 (when (and (valid-image-instantiator-format-p 'tab-control)
|
|
|
302 (specifier-instance default-gutter-visible-p))
|
|
|
303 (let ((inst (glyph-image-instance gutter-buffers-tab))
|
|
|
304 (buffers (buffers-tab-items t)))
|
|
|
305 (unless buffers
|
|
|
306 (setq buffers (build-buffers-tab-internal
|
|
|
307 (list
|
|
|
308 (get-buffer-create "*scratch*")))))
|
|
|
309 (set-image-instance-property inst :items buffers))))
|
|
|
310
|
|
|
311 (add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab)
|
|
|
312 (add-hook 'create-frame-hook 'update-tab-in-gutter)
|
|
|
313 (add-hook 'record-buffer-hook 'update-tab-in-gutter)
|
|
|
314
|
|
|
315 ;;
|
|
|
316 ;; progress display
|
|
|
317 ;; ripped off from message display
|
|
|
318 ;;
|
|
|
319 (defvar progress-stack nil
|
|
|
320 "An alist of label/string pairs representing active progress gauges.
|
|
|
321 The first element in the list is currently displayed in the gutter area.
|
|
|
322 Do not modify this directly--use the `progress' or
|
|
|
323 `display-progress'/`clear-progress' functions.")
|
|
|
324
|
|
|
325 (defvar progress-glyph-height 32
|
|
|
326 "Height of the gutter area for progress messages.")
|
|
|
327
|
|
|
328 (defvar progress-stop-callback 'progress-quit-function
|
|
|
329 "Function to call to stop the progress operation.")
|
|
|
330
|
|
|
331 (defun progress-quit-function ()
|
|
|
332 "Default function to call for the stop button in a progress gauge.
|
|
|
333 This just removes the progress gauge and calls quit."
|
|
|
334 (interactive)
|
|
|
335 (clear-progress)
|
|
|
336 (keyboard-quit))
|
|
|
337
|
|
|
338 ;; private variables
|
|
|
339 (defvar progress-gauge-glyph
|
|
|
340 (make-glyph
|
|
|
341 (vector 'progress-gauge
|
|
|
342 :pixel-height (- progress-glyph-height 8)
|
|
|
343 :pixel-width 250
|
|
|
344 :descriptor "Progress")))
|
|
|
345
|
|
|
346 (defvar progress-text-glyph
|
|
|
347 (make-glyph [string :data ""]))
|
|
|
348
|
|
|
349 (defvar progress-layout-glyph
|
|
|
350 (make-glyph
|
|
|
351 (vector
|
|
|
352 'layout :orientation 'vertical :justify 'left
|
|
|
353 :items (list
|
|
|
354 progress-text-glyph
|
|
|
355 (make-glyph
|
|
|
356 (vector
|
|
|
357 'layout :pixel-height progress-glyph-height
|
|
|
358 :orientation 'horizontal
|
|
|
359 :items (list
|
|
|
360 progress-gauge-glyph
|
|
|
361 (vector
|
|
|
362 'button :pixel-height (- progress-glyph-height 8)
|
|
|
363 :descriptor " Stop "
|
|
|
364 :callback '(funcall progress-stop-callback)))))))))
|
|
|
365
|
|
|
366 (defvar progress-abort-glyph
|
|
|
367 (make-glyph
|
|
|
368 (vector 'layout :orientation 'vertical :justify 'left
|
|
|
369 :items (list progress-text-glyph
|
|
|
370 (make-glyph
|
|
|
371 (vector 'layout
|
|
|
372 :pixel-height progress-glyph-height
|
|
|
373 :orientation 'horizontal))))))
|
|
|
374
|
|
|
375 (defvar progress-extent-text "")
|
|
|
376 (defvar progress-extent nil)
|
|
|
377
|
|
|
378 (defun progress-displayed-p (&optional return-string frame)
|
|
|
379 "Return a non-nil value if a progress gauge is presently displayed in the
|
|
|
380 gutter area. If optional argument RETURN-STRING is non-nil,
|
|
|
381 return a string containing the message, otherwise just return t."
|
|
|
382 (let ((buffer (get-buffer-create " *Gutter Area*")))
|
|
|
383 (and (< (point-min buffer) (point-max buffer))
|
|
|
384 (if return-string
|
|
|
385 (buffer-substring nil nil buffer)
|
|
|
386 t))))
|
|
|
387
|
|
|
388 ;;; Returns the string which remains in the echo area, or nil if none.
|
|
|
389 ;;; If label is nil, the whole message stack is cleared.
|
|
|
390 (defun clear-progress (&optional label frame no-restore)
|
|
|
391 "Remove any progress gauge with the given LABEL from the progress gauge-stack,
|
|
|
392 erasing it from the gutter area if it's currently displayed there.
|
|
|
393 If a message remains at the head of the progress-stack and NO-RESTORE
|
|
|
394 is nil, it will be displayed. The string which remains in the gutter
|
|
|
395 area will be returned, or nil if the progress-stack is now empty.
|
|
|
396 If LABEL is nil, the entire progress-stack is cleared.
|
|
|
397
|
|
|
398 Unless you need the return value or you need to specify a label,
|
|
|
399 you should just use (progress nil)."
|
|
|
400 (or frame (setq frame (selected-frame)))
|
|
|
401 (remove-progress label frame)
|
|
|
402 (let ((inhibit-read-only t)
|
|
|
403 (zmacs-region-stays zmacs-region-stays)) ; preserve from change
|
|
|
404 (erase-buffer " *Echo Area*")
|
|
|
405 (erase-buffer (get-buffer-create " *Gutter Area*")))
|
|
|
406 (if no-restore
|
|
|
407 nil ; just preparing to put another msg up
|
|
|
408 (if progress-stack
|
|
|
409 (let ((oldmsg (cdr (car progress-stack))))
|
|
|
410 (raw-append-progress oldmsg frame)
|
|
|
411 oldmsg)
|
|
|
412 ;; nothing to display so get rid of the gauge
|
|
|
413 (set-specifier bottom-gutter-border-width 0 frame)
|
|
|
414 (set-specifier bottom-gutter-visible-p nil frame))))
|
|
|
415
|
|
|
416 (defun remove-progress (&optional label frame)
|
|
|
417 ;; If label is nil, we want to remove all matching progress gauges.
|
|
|
418 (while (and progress-stack
|
|
|
419 (or (null label) ; null label means clear whole stack
|
|
|
420 (eq label (car (car progress-stack)))))
|
|
|
421 (setq progress-stack (cdr progress-stack)))
|
|
|
422 (let ((s progress-stack))
|
|
|
423 (while (cdr s)
|
|
|
424 (let ((msg (car (cdr s))))
|
|
|
425 (if (eq label (car msg))
|
|
|
426 (progn
|
|
|
427 (setcdr s (cdr (cdr s))))
|
|
|
428 (setq s (cdr s)))))))
|
|
|
429
|
|
|
430 (defun append-progress (label message &optional value frame)
|
|
|
431 (or frame (setq frame (selected-frame)))
|
|
|
432 ;; Add a new entry to the message-stack, or modify an existing one
|
|
|
433 (let* ((top (car progress-stack))
|
|
|
434 (tmsg (cdr top)))
|
|
|
435 (if (eq label (car top))
|
|
|
436 (progn
|
|
|
437 (setcdr top message)
|
|
|
438 (if (eq tmsg message)
|
|
|
439 (set-image-instance-property
|
|
|
440 (glyph-image-instance progress-gauge-glyph)
|
|
|
441 :percent value)
|
|
|
442 (raw-append-progress message value frame))
|
|
|
443 (redisplay-gutter-area)
|
|
|
444 (when (input-pending-p)
|
|
|
445 (dispatch-event (next-command-event))))
|
|
|
446 (push (cons label message) progress-stack)
|
|
|
447 (raw-append-progress message value frame))
|
|
|
448 (when (eq value 100)
|
|
|
449 (sit-for 0.5 nil)
|
|
|
450 (clear-progress label))))
|
|
|
451
|
|
|
452 (defun abort-progress (label message &optional frame)
|
|
|
453 (or frame (setq frame (selected-frame)))
|
|
|
454 ;; Add a new entry to the message-stack, or modify an existing one
|
|
|
455 (let* ((top (car progress-stack))
|
|
|
456 (inhibit-read-only t)
|
|
|
457 (zmacs-region-stays zmacs-region-stays))
|
|
|
458 (if (eq label (car top))
|
|
|
459 (setcdr top message)
|
|
|
460 (push (cons label message) progress-stack))
|
|
|
461 (unless (equal message "")
|
|
|
462 (insert-string message (get-buffer-create " *Gutter Area*"))
|
|
|
463 ;; Do what the device is able to cope with.
|
|
|
464 (if (not (valid-image-instantiator-format-p 'progress-gauge frame))
|
|
|
465 (progn
|
|
|
466 (insert-string message " *Echo Area*")
|
|
|
467 (if (not executing-kbd-macro)
|
|
|
468 (redisplay-echo-area)))
|
|
|
469 ;; do some funky display here.
|
|
|
470 (unless progress-extent
|
|
|
471 (setq progress-extent (make-extent 0 0 progress-extent-text)))
|
|
|
472 (let ((bglyph (extent-begin-glyph progress-extent)))
|
|
|
473 (set-extent-begin-glyph progress-extent progress-abort-glyph)
|
|
|
474 ;; fixup the gutter specifiers
|
|
|
475 (set-specifier bottom-gutter progress-extent-text frame)
|
|
|
476 (set-specifier bottom-gutter-border-width 2 frame)
|
|
|
477 (set-image-instance-property
|
|
|
478 (glyph-image-instance progress-text-glyph) :data message)
|
|
|
479 (set-specifier bottom-gutter-height 'autodetect frame)
|
|
|
480 (set-specifier bottom-gutter-visible-p t frame)
|
|
|
481 ;; we have to do this so redisplay is up-to-date and so
|
|
|
482 ;; redisplay-gutter-area performs optimally.
|
|
|
483 (redisplay-gutter-area)
|
|
|
484 (sit-for 0.5 nil)
|
|
|
485 (clear-progress label)
|
|
|
486 (set-extent-begin-glyph progress-extent bglyph)
|
|
|
487 )))))
|
|
|
488
|
|
|
489 (defun raw-append-progress (message &optional value frame)
|
|
|
490 (unless (equal message "")
|
|
|
491 (let ((inhibit-read-only t)
|
|
|
492 (zmacs-region-stays zmacs-region-stays)
|
|
|
493 (val (or value 0))) ; preserve from change
|
|
|
494 (insert-string message (get-buffer-create " *Gutter Area*"))
|
|
|
495 ;; Do what the device is able to cope with.
|
|
|
496 (if (not (valid-image-instantiator-format-p 'progress-gauge frame))
|
|
|
497 (progn
|
|
|
498 (insert-string
|
|
|
499 (concat message (if (eq val 100) "done.")
|
|
|
500 (make-string (/ val 5) ?.))
|
|
|
501 " *Echo Area*")
|
|
|
502 (if (not executing-kbd-macro)
|
|
|
503 (redisplay-echo-area)))
|
|
|
504 ;; do some funky display here.
|
|
|
505 (unless progress-extent
|
|
|
506 (setq progress-extent (make-extent 0 0 progress-extent-text))
|
|
|
507 (set-extent-begin-glyph progress-extent progress-layout-glyph))
|
|
|
508 ;; fixup the gutter specifiers
|
|
|
509 (set-specifier bottom-gutter progress-extent-text frame)
|
|
|
510 (set-specifier bottom-gutter-border-width 2 frame)
|
|
|
511 (set-image-instance-property
|
|
|
512 (glyph-image-instance progress-gauge-glyph) :percent val)
|
|
|
513 (set-image-instance-property
|
|
|
514 (glyph-image-instance progress-text-glyph) :data message)
|
|
|
515 (if (and (eq (specifier-instance bottom-gutter-height frame)
|
|
|
516 'autodetect)
|
|
|
517 (specifier-instance bottom-gutter-visible-p frame))
|
|
|
518 (progn
|
|
|
519 ;; if the gauge is already visible then just draw the gutter
|
|
|
520 ;; checking for user events
|
|
|
521 (redisplay-gutter-area)
|
|
|
522 (when (input-pending-p)
|
|
|
523 (dispatch-event (next-command-event))))
|
|
|
524 ;; otherwise make the gutter visible and redraw the frame
|
|
|
525 (set-specifier bottom-gutter-height 'autodetect frame)
|
|
|
526 (set-specifier bottom-gutter-visible-p t frame)
|
|
|
527 ;; we have to do this so redisplay is up-to-date and so
|
|
|
528 ;; redisplay-gutter-area performs optimally.
|
|
|
529 (redisplay-frame)
|
|
|
530 )))))
|
|
|
531
|
|
|
532 (defun display-progress (label message &optional value frame)
|
|
|
533 "Display a progress gauge and message in the bottom gutter area.
|
|
|
534 First argument LABEL is an identifier for this message. MESSAGE is
|
|
|
535 the string to display. Use `clear-progress' to remove a labelled
|
|
|
536 message."
|
|
|
537 (clear-progress label frame t)
|
|
|
538 (if (eq value 'abort)
|
|
|
539 (abort-progress label message frame)
|
|
|
540 (append-progress label message value frame)))
|
|
|
541
|
|
|
542 (defun current-progress (&optional frame)
|
|
|
543 "Return the current progress gauge in the gutter area, or nil.
|
|
|
544 The FRAME argument is currently unused."
|
|
|
545 (cdr (car progress-stack)))
|
|
|
546
|
|
|
547 ;;; may eventually be frame-dependent
|
|
|
548 (defun current-progress-label (&optional frame)
|
|
|
549 (car (car progress-stack)))
|
|
|
550
|
|
|
551 (defun progress (fmt &optional value &rest args)
|
|
|
552 "Print a progress gauge and message in the bottom gutter area of the frame.
|
|
|
553 The arguments are the same as to `format'.
|
|
|
554
|
|
|
555 If the only argument is nil, clear any existing progress gauge."
|
|
|
556 (if (and (null fmt) (null args))
|
|
|
557 (prog1 nil
|
|
|
558 (clear-progress nil))
|
|
|
559 (let ((str (apply 'format fmt args)))
|
|
|
560 (display-progress 'progress str value)
|
|
|
561 str)))
|
|
|
562
|
|
|
563 (defun lprogress (label fmt &optional value &rest args)
|
|
|
564 "Print a progress gauge and message in the bottom gutter area of the frame.
|
|
|
565 First argument LABEL is an identifier for this progress gauge. The rest of the
|
|
|
566 arguments are the same as to `format'."
|
|
|
567 (if (and (null fmt) (null args))
|
|
|
568 (prog1 nil
|
|
|
569 (clear-progress label nil))
|
|
|
570 (let ((str (apply 'format fmt args)))
|
|
|
571 (display-progress label str value)
|
|
|
572 str)))
|
|
|
573
|
|
|
574 (provide 'gutter-items)
|
|
|
575 ;;; gutter-items.el ends here.
|
