|
428
|
1 ;;; gutter-items.el --- Gutter content for XEmacs.
|
|
|
2
|
|
|
3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
|
|
|
4
|
|
|
5 ;; Maintainer: XEmacs Development Team
|
|
|
6 ;; Keywords: frames, extensions, internal, dumped
|
|
|
7
|
|
|
8 ;; This file is part of XEmacs.
|
|
|
9
|
|
|
10 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
11 ;; under the terms of the GNU General Public License as published by
|
|
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
|
15 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
18 ;; General Public License for more details.
|
|
|
19
|
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
|
21 ;; along with Xmacs; see the file COPYING. If not, write to the
|
|
|
22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
|
|
|
23 ;; Boston, MA 02111-1307, USA.
|
|
|
24
|
|
771
|
25 ;;; Gutter-specific buffers tab code
|
|
428
|
26
|
|
442
|
27 (defvar gutter-buffers-tab nil
|
|
|
28 "A tab widget in the gutter for displaying buffers.
|
|
|
29 Do not set this. Use `set-glyph-image' to change the properties of the tab.")
|
|
|
30
|
|
|
31 (defcustom gutter-buffers-tab-visible-p
|
|
|
32 (gutter-element-visible-p default-gutter-visible-p 'buffers-tab)
|
|
|
33 "Whether the buffers tab is globally visible.
|
|
|
34 This option should be set through the options menu."
|
|
|
35 :group 'buffers-tab
|
|
|
36 :type 'boolean
|
|
|
37 :set #'(lambda (var val)
|
|
|
38 (set-gutter-element-visible-p default-gutter-visible-p
|
|
|
39 'buffers-tab val)
|
|
|
40 (setq gutter-buffers-tab-visible-p val)))
|
|
|
41
|
|
444
|
42 (defcustom gutter-buffers-tab-enabled t
|
|
|
43 "*Whether to enable support for buffers tab in the gutter.
|
|
|
44 This is different to `gutter-buffers-tab-visible-p' which still runs hooks
|
|
|
45 even when the gutter is invisible."
|
|
|
46 :group 'buffers-tab
|
|
|
47 :type 'boolean)
|
|
|
48
|
|
438
|
49 (defvar gutter-buffers-tab-orientation 'top
|
|
|
50 "Where the buffers tab currently is. Do not set this.")
|
|
|
51
|
|
903
|
52 (defcustom buffers-tab-max-size 6
|
|
|
53 "*Maximum number of entries which may appear on the \"Buffers\" tab.
|
|
|
54 If this is 10, then only the ten most-recently-selected buffers will be
|
|
|
55 shown. If this is nil, then all buffers will be shown. Setting this to
|
|
|
56 a large number or nil will slow down tab responsiveness."
|
|
|
57 :type '(choice (const :tag "Show all" nil)
|
|
|
58 (integer 6))
|
|
|
59 :group 'buffers-tab)
|
|
|
60
|
|
|
61 (defcustom buffers-tab-switch-to-buffer-function 'buffers-tab-switch-to-buffer
|
|
|
62 "*The function to call to select a buffer from the buffers tab.
|
|
|
63 `switch-to-buffer' is a good choice, as is `pop-to-buffer'."
|
|
|
64 :type '(radio (function-item switch-to-buffer)
|
|
|
65 (function-item pop-to-buffer)
|
|
|
66 (function :tag "Other"))
|
|
|
67 :group 'buffers-tab)
|
|
|
68
|
|
931
|
69 (defcustom buffers-tab-omit-function 'buffers-tab-omit-some-buffers
|
|
903
|
70 "*If non-nil, a function specifying the buffers to omit from the buffers tab.
|
|
|
71 This is passed a buffer and should return non-nil if the buffer should be
|
|
931
|
72 omitted. The default value `buffers-tab-omit-some-buffers' omits
|
|
|
73 buffers based on the value of `buffers-tab-omit-list'."
|
|
903
|
74 :type '(choice (const :tag "None" nil)
|
|
931
|
75 function)
|
|
|
76 :group 'buffers-tab)
|
|
|
77
|
|
|
78 (defcustom buffers-tab-omit-list '("\\` ")
|
|
|
79 "*A list of types of buffers to omit from the buffers tab.
|
|
|
80 This is only used if `buffers-tab-omit-function' is set to
|
|
|
81 `buffers-tab-omit-some-buffers', its default value."
|
|
|
82 :type '(checklist
|
|
|
83 :greedy t
|
|
|
84 :format "%{Omit List%}: \n%v"
|
|
|
85 (const
|
|
|
86 :tag "Invisible buffers (those whose names start with a space) "
|
|
|
87 "\\` ")
|
|
|
88 (const
|
|
|
89 :tag "Help buffers "
|
|
|
90 "\\`\\*Help")
|
|
|
91 (const
|
|
|
92 :tag "Customize buffers "
|
|
|
93 "\\`\\*Customize")
|
|
|
94 (const
|
|
|
95 :tag "`special' buffers (those whose names start with *) "
|
|
|
96 "\\`\\*")
|
|
|
97 (const
|
|
|
98 :tag "`special' buffers other than *scratch*"
|
|
|
99 "\\`\\*\\([^s]\\|s[^c]\\|sc[^r]\\|scr[^a]\\|scra[^t]\\|scrat[^c]\\|scratc[^h]\\|scratch[^*]\\|scratch\\*.+\\)"))
|
|
903
|
100 :group 'buffers-tab)
|
|
|
101
|
|
|
102 (defvar buffers-tab-selection-function 'select-buffers-tab-buffers-by-mode
|
|
|
103 "*If non-nil, a function specifying the buffers to select in the
|
|
|
104 buffers tab. This is passed two buffers and should return non-nil if
|
|
|
105 the first buffer should be selected. The default value
|
|
|
106 `select-buffers-tab-buffers-by-mode' groups buffers by major mode and
|
|
|
107 by `buffers-tab-grouping-regexp'.")
|
|
|
108
|
|
|
109 (make-obsolete-variable buffers-tab-selection-function
|
|
|
110 "Set `buffers-tab-filter-functions' instead.")
|
|
|
111
|
|
|
112 (defcustom buffers-tab-filter-functions (list 'select-buffers-tab-buffers-by-mode)
|
|
1362
|
113 "*A list of functions specifying buffers to display in the buffers tab.
|
|
|
114
|
|
|
115 If nil, all buffers are kept, up to `buffers-tab-max-size', in usual order.
|
|
|
116 Otherwise, each function in the list must take arguments (BUF1 BUF2).
|
|
|
117 BUF1 is the candidate, and BUF2 is the current buffer (first in the buffers
|
|
|
118 list). The function should return non-nil if BUF1 should be added to the
|
|
|
119 buffers tab. BUF1 will be omitted if any of the functions returns nil.
|
|
|
120
|
|
|
121 Defaults to `select-buffers-tab-buffers-by-mode', which adds BUF1 if BUF1 and
|
|
|
122 BUF2 have the same major mode, or both match `buffers-tab-grouping-regexp'."
|
|
903
|
123
|
|
|
124 :type '(repeat function)
|
|
|
125 :group 'buffers-tab)
|
|
|
126
|
|
|
127 (defcustom buffers-tab-sort-function nil
|
|
|
128 "*If non-nil, a function specifying the buffers to select from the
|
|
|
129 buffers tab. This is passed the buffer list and returns the list in the
|
|
|
130 order desired for the tab widget. The default value `nil' leaves the
|
|
|
131 list in `buffer-list' order (usual most-recently-selected-first)."
|
|
|
132
|
|
|
133 :type '(choice (const :tag "None" nil)
|
|
|
134 function)
|
|
|
135 :group 'buffers-tab)
|
|
|
136
|
|
|
137 (make-face 'buffers-tab "Face for displaying the buffers tab.")
|
|
|
138 (set-face-parent 'buffers-tab 'modeline)
|
|
|
139
|
|
|
140 (defcustom buffers-tab-face 'buffers-tab
|
|
|
141 "*Face to use for displaying the buffers tab."
|
|
|
142 :type 'face
|
|
|
143 :group 'buffers-tab)
|
|
|
144
|
|
|
145 (defcustom buffers-tab-grouping-regexp
|
|
|
146 '("^\\(gnus-\\|message-mode\\|mime/viewer-mode\\)"
|
|
|
147 "^\\(emacs-lisp-\\|lisp-\\)")
|
|
|
148 "*If non-nil, a list of regular expressions for buffer grouping.
|
|
|
149 Each regular expression is applied to the current major-mode symbol
|
|
|
150 name and mode-name, if it matches then any other buffers that match
|
|
|
151 the same regular expression be added to the current group."
|
|
|
152 :type '(choice (const :tag "None" nil)
|
|
|
153 sexp)
|
|
|
154 :group 'buffers-tab)
|
|
|
155
|
|
|
156 (defcustom buffers-tab-format-buffer-line-function 'format-buffers-tab-line
|
|
|
157 "*The function to call to return a string to represent a buffer in the
|
|
|
158 buffers tab. The function is passed a buffer and should return a
|
|
|
159 string. The default value `format-buffers-tab-line' just returns the
|
|
|
160 name of the buffer, optionally truncated to
|
|
|
161 `buffers-tab-max-buffer-line-length'. Also check out
|
|
|
162 `slow-format-buffers-menu-line' which returns a whole bunch of info
|
|
|
163 about a buffer."
|
|
|
164 :type 'function
|
|
|
165 :group 'buffers-tab)
|
|
|
166
|
|
|
167 (defvar buffers-tab-default-buffer-line-length
|
|
|
168 (make-specifier-and-init 'generic '((global ((default) . 25))) t)
|
|
|
169 "*Maximum length of text which may appear in a \"Buffers\" tab.
|
|
|
170 This is a specifier, use set-specifier to modify it.")
|
|
|
171
|
|
|
172 (defcustom buffers-tab-max-buffer-line-length
|
|
|
173 (specifier-instance buffers-tab-default-buffer-line-length)
|
|
|
174 "*Maximum length of text which may appear in a \"Buffers\" tab.
|
|
|
175 Buffer names over this length will be truncated with elipses.
|
|
|
176 If this is 0, then the full buffer name will be shown."
|
|
|
177 :type '(choice (const :tag "Show all" 0)
|
|
|
178 (integer 25))
|
|
|
179 :group 'buffers-tab
|
|
|
180 :set #'(lambda (var val)
|
|
|
181 (set-specifier buffers-tab-default-buffer-line-length val)
|
|
|
182 (setq buffers-tab-max-buffer-line-length val)))
|
|
|
183
|
|
|
184 (defun buffers-tab-switch-to-buffer (buffer)
|
|
|
185 "For use as a value for `buffers-tab-switch-to-buffer-function'."
|
|
|
186 (unless (eq (window-buffer) buffer)
|
|
|
187 ;; this used to add the norecord flag to both calls below.
|
|
|
188 ;; this is bogus because it is a pervasive assumption in XEmacs
|
|
|
189 ;; that the current buffer is at the front of the buffers list.
|
|
|
190 ;; for example, select an item and then do M-C-l
|
|
|
191 ;; (switch-to-other-buffer). Things get way confused.
|
|
|
192 (if (> (length (windows-of-buffer buffer)) 0)
|
|
|
193 (select-window (car (windows-of-buffer buffer)))
|
|
|
194 (switch-to-buffer buffer))))
|
|
|
195
|
|
|
196 (defun select-buffers-tab-buffers-by-mode (buffer-to-select buf1)
|
|
|
197 "For use as a value of `buffers-tab-selection-function'.
|
|
|
198 This selects buffers by major mode `buffers-tab-grouping-regexp'."
|
|
|
199 (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1)))
|
|
|
200 (mode2 (symbol-name (symbol-value-in-buffer 'major-mode
|
|
|
201 buffer-to-select)))
|
|
|
202 (modenm1 (symbol-value-in-buffer 'mode-name buf1))
|
|
|
203 (modenm2 (symbol-value-in-buffer 'mode-name buffer-to-select)))
|
|
|
204 (cond ((or (eq mode1 mode2)
|
|
|
205 (eq modenm1 modenm2)
|
|
|
206 (and (string-match "^[^-]+-" mode1)
|
|
|
207 (string-match
|
|
|
208 (concat "^" (regexp-quote
|
|
|
209 (substring mode1 0 (match-end 0))))
|
|
|
210 mode2))
|
|
|
211 (and buffers-tab-grouping-regexp
|
|
|
212 (find-if #'(lambda (x)
|
|
|
213 (or
|
|
|
214 (and (string-match x mode1)
|
|
|
215 (string-match x mode2))
|
|
|
216 (and (string-match x modenm1)
|
|
|
217 (string-match x modenm2))))
|
|
|
218 buffers-tab-grouping-regexp)))
|
|
|
219 t)
|
|
|
220 (t nil))))
|
|
|
221
|
|
|
222 (defun format-buffers-tab-line (buffer)
|
|
|
223 "For use as a value of `buffers-tab-format-buffer-line-function'.
|
|
|
224 This just returns the buffer's name, optionally truncated."
|
|
|
225 (let ((len (specifier-instance buffers-tab-default-buffer-line-length)))
|
|
|
226 (if (and (> len 0)
|
|
|
227 (> (length (buffer-name buffer)) len))
|
|
|
228 (if (string-match ".*<.>$" (buffer-name buffer))
|
|
|
229 (concat (substring (buffer-name buffer)
|
|
|
230 0 (- len 6)) "..."
|
|
|
231 (substring (buffer-name buffer) -3))
|
|
|
232 (concat (substring (buffer-name buffer)
|
|
|
233 0 (- len 3)) "..."))
|
|
|
234 (buffer-name buffer))))
|
|
|
235
|
|
|
236 (defsubst build-buffers-tab-internal (buffers)
|
|
|
237 (let ((selected t))
|
|
|
238 (mapcar
|
|
|
239 #'(lambda (buffer)
|
|
|
240 (prog1
|
|
|
241 (vector
|
|
|
242 (funcall buffers-tab-format-buffer-line-function
|
|
|
243 buffer)
|
|
|
244 (list buffers-tab-switch-to-buffer-function
|
|
|
245 (buffer-name buffer))
|
|
|
246 :selected selected)
|
|
|
247 (when selected (setq selected nil))))
|
|
|
248 buffers)))
|
|
|
249
|
|
|
250 ;;; #### SJT would like this function to have a sort function list. I
|
|
|
251 ;;; don't see how this could work given that sorting is not
|
|
|
252 ;;; cumulative --andyp.
|
|
|
253 (defun buffers-tab-items (&optional in-deletion frame force-selection)
|
|
|
254 "Return a list of tab instantiators based on the current buffers list.
|
|
|
255 This function is used as the tab filter for the top-level buffers
|
|
|
256 \"Buffers\" tab. It dynamically creates a list of tab instantiators
|
|
|
257 to use as the contents of the tab. The contents and order of the list
|
|
|
258 is controlled by `buffers-tab-filter-functions' which by default
|
|
|
259 groups buffers according to major mode and removes invisible buffers.
|
|
|
260 You can control how many buffers will be shown by setting
|
|
|
261 `buffers-tab-max-size'. You can control the text of the tab items by
|
|
|
262 redefining the function `format-buffers-menu-line'."
|
|
|
263 (save-match-data
|
|
|
264 ;; NB it is too late if we run the omit function as part of the
|
|
|
265 ;; filter functions because we need to know which buffer is the
|
|
|
266 ;; context buffer before they get run.
|
|
|
267 (let* ((buffers (delete-if
|
|
|
268 buffers-tab-omit-function (buffer-list frame)))
|
|
|
269 (first-buf (car buffers)))
|
|
|
270 ;; maybe force the selected window
|
|
|
271 (when (and force-selection
|
|
|
272 (not in-deletion)
|
|
|
273 (not (eq first-buf (window-buffer (selected-window frame)))))
|
|
|
274 (setq buffers (cons (window-buffer (selected-window frame))
|
|
|
275 (delq first-buf buffers))))
|
|
|
276 ;; if we're in deletion ignore the current buffer
|
|
|
277 (when in-deletion
|
|
|
278 (setq buffers (delq (current-buffer) buffers))
|
|
|
279 (setq first-buf (car buffers)))
|
|
|
280 ;; filter buffers
|
|
|
281 (when buffers-tab-filter-functions
|
|
|
282 (setq buffers
|
|
|
283 (delete-if
|
|
|
284 #'null
|
|
|
285 (mapcar #'(lambda (buf)
|
|
|
286 (let ((tmp-buf buf))
|
|
|
287 (mapc #'(lambda (fun)
|
|
|
288 (unless (funcall fun buf first-buf)
|
|
|
289 (setq tmp-buf nil)))
|
|
|
290 buffers-tab-filter-functions)
|
|
|
291 tmp-buf))
|
|
|
292 buffers))))
|
|
|
293 ;; maybe shorten list of buffers
|
|
|
294 (and (integerp buffers-tab-max-size)
|
|
|
295 (> buffers-tab-max-size 1)
|
|
|
296 (> (length buffers) buffers-tab-max-size)
|
|
|
297 (setcdr (nthcdr (1- buffers-tab-max-size) buffers) nil))
|
|
|
298 ;; sort buffers in group (default is most-recently-selected)
|
|
|
299 (when buffers-tab-sort-function
|
|
|
300 (setq buffers (funcall buffers-tab-sort-function buffers)))
|
|
|
301 ;; convert list of buffers to list of structures used by tab widget
|
|
|
302 (setq buffers (build-buffers-tab-internal buffers))
|
|
|
303 buffers)))
|
|
|
304
|
|
428
|
305 (defun add-tab-to-gutter ()
|
|
|
306 "Put a tab control in the gutter area to hold the most recent buffers."
|
|
438
|
307 (setq gutter-buffers-tab-orientation (default-gutter-position))
|
|
444
|
308 (let* ((gutter-string (copy-sequence "\n"))
|
|
|
309 (gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
|
|
|
310 (set-extent-begin-glyph gutter-buffers-tab-extent
|
|
|
311 (setq gutter-buffers-tab
|
|
|
312 (make-glyph)))
|
|
442
|
313 ;; Nuke all existing tabs
|
|
|
314 (remove-gutter-element top-gutter 'buffers-tab)
|
|
|
315 (remove-gutter-element bottom-gutter 'buffers-tab)
|
|
|
316 (remove-gutter-element left-gutter 'buffers-tab)
|
|
|
317 (remove-gutter-element right-gutter 'buffers-tab)
|
|
|
318 ;; Put tabs into all devices that will be able to display them
|
|
|
319 (mapcar
|
|
|
320 #'(lambda (x)
|
|
|
321 (when (valid-image-instantiator-format-p 'tab-control x)
|
|
|
322 (cond ((eq gutter-buffers-tab-orientation 'top)
|
|
|
323 ;; This looks better than a 3d border
|
|
|
324 (set-specifier top-gutter-border-width 0 'global x)
|
|
|
325 (set-gutter-element top-gutter 'buffers-tab
|
|
|
326 gutter-string 'global x))
|
|
|
327 ((eq gutter-buffers-tab-orientation 'bottom)
|
|
|
328 (set-specifier bottom-gutter-border-width 0 'global x)
|
|
|
329 (set-gutter-element bottom-gutter 'buffers-tab
|
|
|
330 gutter-string 'global x))
|
|
|
331 ((eq gutter-buffers-tab-orientation 'left)
|
|
|
332 (set-specifier left-gutter-border-width 0 'global x)
|
|
|
333 (set-gutter-element left-gutter 'buffers-tab
|
|
444
|
334 gutter-string 'global x))
|
|
442
|
335 ((eq gutter-buffers-tab-orientation 'right)
|
|
|
336 (set-specifier right-gutter-border-width 0 'global x)
|
|
|
337 (set-gutter-element right-gutter 'buffers-tab
|
|
444
|
338 gutter-string 'global x))
|
|
442
|
339 )))
|
|
|
340 (console-type-list))))
|
|
|
341
|
|
|
342 (defun update-tab-in-gutter (frame &optional force-selection)
|
|
428
|
343 "Update the tab control in the gutter area."
|
|
442
|
344 ;; dedicated frames don't get tabs
|
|
446
|
345 (unless (or (window-dedicated-p (frame-selected-window frame))
|
|
|
346 (frame-property frame 'popup))
|
|
442
|
347 (when (specifier-instance default-gutter-visible-p frame)
|
|
|
348 (unless (and gutter-buffers-tab
|
|
438
|
349 (eq (default-gutter-position)
|
|
|
350 gutter-buffers-tab-orientation))
|
|
428
|
351 (add-tab-to-gutter))
|
|
442
|
352 (when (valid-image-instantiator-format-p 'tab-control frame)
|
|
446
|
353 (let ((items (buffers-tab-items nil frame force-selection)))
|
|
|
354 (when items
|
|
|
355 (set-glyph-image
|
|
|
356 gutter-buffers-tab
|
|
|
357 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
|
|
|
358 :orientation gutter-buffers-tab-orientation
|
|
|
359 (if (or (eq gutter-buffers-tab-orientation 'top)
|
|
|
360 (eq gutter-buffers-tab-orientation 'bottom))
|
|
|
361 :pixel-width :pixel-height)
|
|
|
362 (if (or (eq gutter-buffers-tab-orientation 'top)
|
|
|
363 (eq gutter-buffers-tab-orientation 'bottom))
|
|
|
364 '(gutter-pixel-width) '(gutter-pixel-height))
|
|
|
365 :items items)
|
|
|
366 frame)
|
|
|
367 ;; set-glyph-image will not make the gutter dirty
|
|
458
|
368 (set-gutter-dirty-p gutter-buffers-tab-orientation)))))))
|
|
428
|
369
|
|
442
|
370 ;; A myriad of different update hooks all doing slightly different things
|
|
444
|
371 (add-one-shot-hook
|
|
|
372 'after-init-hook
|
|
|
373 #'(lambda ()
|
|
|
374 ;; don't add the hooks if the user really doesn't want them
|
|
|
375 (when gutter-buffers-tab-enabled
|
|
|
376 (add-hook 'create-frame-hook
|
|
|
377 #'(lambda (frame)
|
|
|
378 (when gutter-buffers-tab (update-tab-in-gutter frame t))))
|
|
|
379 (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter)
|
|
|
380 (add-hook 'default-gutter-position-changed-hook
|
|
|
381 #'(lambda ()
|
|
|
382 (when gutter-buffers-tab
|
|
|
383 (mapc #'update-tab-in-gutter (frame-list)))))
|
|
|
384 (add-hook 'gutter-element-visibility-changed-hook
|
|
|
385 #'(lambda (prop visible-p)
|
|
|
386 (when (and (eq prop 'buffers-tab) visible-p)
|
|
|
387 (mapc #'update-tab-in-gutter (frame-list)))))
|
|
|
388 (update-tab-in-gutter (selected-frame) t))))
|
|
|
389
|
|
428
|
390 ;;
|
|
|
391 ;; progress display
|
|
|
392 ;; ripped off from message display
|
|
|
393 ;;
|
|
442
|
394 (defcustom progress-feedback-use-echo-area nil
|
|
|
395 "*Whether progress gauge display should display in the echo area.
|
|
|
396 If NIL then progress gauges will be displayed with whatever native widgets
|
|
|
397 are available on the current console. If non-NIL then progress display will be
|
|
|
398 textual and displayed in the echo area."
|
|
|
399 :type 'boolean
|
|
|
400 :group 'gutter)
|
|
|
401
|
|
|
402 (defvar progress-glyph-height 24
|
|
|
403 "Height of the progress gauge glyph.")
|
|
|
404
|
|
|
405 (defvar progress-feedback-popup-period 0.5
|
|
|
406 "The time that the progress gauge should remain up after completion")
|
|
|
407
|
|
|
408 (defcustom progress-feedback-style 'large
|
|
|
409 "*Control the appearance of the progress gauge.
|
|
|
410 If 'large, the default, then the progress-feedback text is displayed
|
|
|
411 above the gauge itself. If 'small then the gauge and text are arranged
|
|
|
412 side-by-side."
|
|
|
413 :group 'gutter
|
|
|
414 :type '(choice (const :tag "large" large)
|
|
|
415 (const :tag "small" small)))
|
|
|
416
|
|
|
417 ;; private variables
|
|
|
418 (defvar progress-text-instantiator [string :data ""])
|
|
|
419 (defvar progress-layout-glyph (make-glyph))
|
|
|
420 (defvar progress-layout-instantiator nil)
|
|
|
421
|
|
|
422 (defvar progress-gauge-instantiator
|
|
|
423 [progress-gauge
|
|
|
424 :value 0
|
|
|
425 :pixel-height (eval progress-glyph-height)
|
|
|
426 :pixel-width 250
|
|
|
427 :descriptor "Progress"])
|
|
|
428
|
|
|
429 (defun set-progress-feedback-instantiator (&optional locale)
|
|
|
430 (cond
|
|
|
431 ((eq progress-feedback-style 'small)
|
|
|
432 (setq progress-glyph-height 16)
|
|
|
433 (setq progress-layout-instantiator
|
|
|
434 `[layout
|
|
|
435 :orientation horizontal
|
|
|
436 :margin-width 4
|
|
|
437 :items (,progress-gauge-instantiator
|
|
|
438 [button
|
|
|
439 :pixel-height (eval progress-glyph-height)
|
|
|
440 ;; 'quit is special and acts "asynchronously".
|
|
|
441 :descriptor "Stop" :callback 'quit]
|
|
|
442 ,progress-text-instantiator)])
|
|
458
|
443 (set-glyph-image progress-layout-glyph progress-layout-instantiator
|
|
|
444 locale))
|
|
442
|
445 (t
|
|
|
446 (setq progress-glyph-height 24)
|
|
|
447 (setq progress-layout-instantiator
|
|
|
448 `[layout
|
|
863
|
449 :orientation vertical :margin-width 4
|
|
|
450 :horizontally-justify left :vertically-justify center
|
|
442
|
451 :items (,progress-text-instantiator
|
|
|
452 [layout
|
|
|
453 :orientation horizontal
|
|
|
454 :items (,progress-gauge-instantiator
|
|
|
455 [button
|
|
|
456 :pixel-height (eval progress-glyph-height)
|
|
|
457 :descriptor " Stop "
|
|
|
458 ;; 'quit is special and acts "asynchronously".
|
|
|
459 :callback 'quit])])])
|
|
458
|
460 (set-glyph-image progress-layout-glyph progress-layout-instantiator
|
|
|
461 locale))))
|
|
|
462
|
|
|
463 (defvar progress-abort-glyph (make-glyph))
|
|
|
464
|
|
|
465 (defun set-progress-abort-instantiator (&optional locale)
|
|
|
466 (set-glyph-image progress-abort-glyph
|
|
863
|
467 `[layout :orientation vertical
|
|
|
468 :horizontally-justify left :vertically-justify center
|
|
458
|
469 :items (,progress-text-instantiator
|
|
|
470 [layout
|
|
|
471 :margin-width 4
|
|
|
472 :pixel-height progress-glyph-height
|
|
|
473 :orientation horizontal])]
|
|
|
474 locale))
|
|
442
|
475
|
|
428
|
476 (defvar progress-stack nil
|
|
|
477 "An alist of label/string pairs representing active progress gauges.
|
|
|
478 The first element in the list is currently displayed in the gutter area.
|
|
442
|
479 Do not modify this directly--use the `progress-feedback' or
|
|
|
480 `display-progress-feedback'/`clear-progress-feedback' functions.")
|
|
428
|
481
|
|
442
|
482 (defun progress-feedback-displayed-p (&optional return-string frame)
|
|
428
|
483 "Return a non-nil value if a progress gauge is presently displayed in the
|
|
|
484 gutter area. If optional argument RETURN-STRING is non-nil,
|
|
|
485 return a string containing the message, otherwise just return t."
|
|
|
486 (let ((buffer (get-buffer-create " *Gutter Area*")))
|
|
|
487 (and (< (point-min buffer) (point-max buffer))
|
|
|
488 (if return-string
|
|
|
489 (buffer-substring nil nil buffer)
|
|
|
490 t))))
|
|
|
491
|
|
|
492 ;;; Returns the string which remains in the echo area, or nil if none.
|
|
|
493 ;;; If label is nil, the whole message stack is cleared.
|
|
442
|
494 (defun clear-progress-feedback (&optional label frame no-restore)
|
|
|
495 "Remove any progress gauge with LABEL from the progress gauge-stack,
|
|
428
|
496 erasing it from the gutter area if it's currently displayed there.
|
|
|
497 If a message remains at the head of the progress-stack and NO-RESTORE
|
|
|
498 is nil, it will be displayed. The string which remains in the gutter
|
|
|
499 area will be returned, or nil if the progress-stack is now empty.
|
|
|
500 If LABEL is nil, the entire progress-stack is cleared.
|
|
|
501
|
|
|
502 Unless you need the return value or you need to specify a label,
|
|
|
503 you should just use (progress nil)."
|
|
442
|
504 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
|
|
|
505 progress-feedback-use-echo-area)
|
|
|
506 (clear-message label frame nil no-restore)
|
|
|
507 (or frame (setq frame (selected-frame)))
|
|
|
508 (remove-progress-feedback label frame)
|
|
502
|
509 (let ((inhibit-read-only t))
|
|
442
|
510 (erase-buffer (get-buffer-create " *Gutter Area*")))
|
|
|
511 (if no-restore
|
|
|
512 nil ; just preparing to put another msg up
|
|
|
513 (if progress-stack
|
|
|
514 (let ((oldmsg (cdr (car progress-stack))))
|
|
|
515 (raw-append-progress-feedback oldmsg nil frame)
|
|
|
516 oldmsg)
|
|
|
517 ;; nothing to display so get rid of the gauge
|
|
|
518 (set-specifier bottom-gutter-border-width 0 frame)
|
|
|
519 (set-gutter-element-visible-p bottom-gutter-visible-p
|
|
|
520 'progress nil frame)))))
|
|
428
|
521
|
|
442
|
522 (defun progress-feedback-clear-when-idle (&optional label)
|
|
|
523 (add-one-shot-hook 'pre-idle-hook
|
|
|
524 `(lambda ()
|
|
|
525 (clear-progress-feedback ',label))))
|
|
|
526
|
|
|
527 (defun remove-progress-feedback (&optional label frame)
|
|
428
|
528 ;; If label is nil, we want to remove all matching progress gauges.
|
|
|
529 (while (and progress-stack
|
|
|
530 (or (null label) ; null label means clear whole stack
|
|
|
531 (eq label (car (car progress-stack)))))
|
|
|
532 (setq progress-stack (cdr progress-stack)))
|
|
|
533 (let ((s progress-stack))
|
|
|
534 (while (cdr s)
|
|
|
535 (let ((msg (car (cdr s))))
|
|
|
536 (if (eq label (car msg))
|
|
|
537 (progn
|
|
|
538 (setcdr s (cdr (cdr s))))
|
|
|
539 (setq s (cdr s)))))))
|
|
|
540
|
|
442
|
541 (defun progress-feedback-dispatch-non-command-events ()
|
|
|
542 ;; don't allow errors to hose things
|
|
|
543 (condition-case t
|
|
|
544 ;; (sit-for 0) is too agressive and cause more display than we
|
|
|
545 ;; want.
|
|
|
546 (dispatch-non-command-events)
|
|
|
547 nil))
|
|
|
548
|
|
|
549 (defun append-progress-feedback (label message &optional value frame)
|
|
428
|
550 (or frame (setq frame (selected-frame)))
|
|
|
551 ;; Add a new entry to the message-stack, or modify an existing one
|
|
|
552 (let* ((top (car progress-stack))
|
|
|
553 (tmsg (cdr top)))
|
|
|
554 (if (eq label (car top))
|
|
|
555 (progn
|
|
|
556 (setcdr top message)
|
|
442
|
557 (if (equal tmsg message)
|
|
|
558 (progn
|
|
|
559 (set-instantiator-property progress-gauge-instantiator :value value)
|
|
|
560 (set-progress-feedback-instantiator (frame-selected-window frame)))
|
|
|
561 (raw-append-progress-feedback message value frame))
|
|
|
562 (redisplay-gutter-area))
|
|
428
|
563 (push (cons label message) progress-stack)
|
|
442
|
564 (raw-append-progress-feedback message value frame))
|
|
|
565 (progress-feedback-dispatch-non-command-events)
|
|
|
566 ;; either get command events or sit waiting for them
|
|
|
567 (when (eq value 100)
|
|
|
568 ; (sit-for progress-feedback-popup-period nil)
|
|
|
569 (clear-progress-feedback label))))
|
|
428
|
570
|
|
442
|
571 (defun abort-progress-feedback (label message &optional frame)
|
|
|
572 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame))
|
|
|
573 progress-feedback-use-echo-area)
|
|
|
574 (display-message label (concat message "aborted.") frame)
|
|
|
575 (or frame (setq frame (selected-frame)))
|
|
|
576 ;; Add a new entry to the message-stack, or modify an existing one
|
|
|
577 (let* ((top (car progress-stack))
|
|
502
|
578 (inhibit-read-only t))
|
|
442
|
579 (if (eq label (car top))
|
|
|
580 (setcdr top message)
|
|
|
581 (push (cons label message) progress-stack))
|
|
|
582 (unless (equal message "")
|
|
|
583 (insert-string message (get-buffer-create " *Gutter Area*"))
|
|
|
584 (let* ((gutter-string (copy-sequence "\n"))
|
|
|
585 (ext (make-extent 0 1 gutter-string)))
|
|
|
586 ;; do some funky display here.
|
|
|
587 (set-extent-begin-glyph ext progress-abort-glyph)
|
|
428
|
588 ;; fixup the gutter specifiers
|
|
442
|
589 (set-gutter-element bottom-gutter 'progress gutter-string frame)
|
|
428
|
590 (set-specifier bottom-gutter-border-width 2 frame)
|
|
458
|
591 (set-instantiator-property progress-text-instantiator :data message)
|
|
|
592 (set-progress-abort-instantiator (frame-selected-window frame))
|
|
428
|
593 (set-specifier bottom-gutter-height 'autodetect frame)
|
|
442
|
594 (set-gutter-element-visible-p bottom-gutter-visible-p
|
|
|
595 'progress t frame)
|
|
428
|
596 ;; we have to do this so redisplay is up-to-date and so
|
|
|
597 ;; redisplay-gutter-area performs optimally.
|
|
|
598 (redisplay-gutter-area)
|
|
442
|
599 (sit-for progress-feedback-popup-period nil)
|
|
|
600 (clear-progress-feedback label frame)
|
|
|
601 (set-extent-begin-glyph ext progress-layout-glyph)
|
|
|
602 (set-gutter-element bottom-gutter 'progress gutter-string frame)
|
|
428
|
603 )))))
|
|
|
604
|
|
442
|
605 (defun raw-append-progress-feedback (message &optional value frame)
|
|
428
|
606 (unless (equal message "")
|
|
442
|
607 (let* ((inhibit-read-only t)
|
|
|
608 (val (or value 0))
|
|
|
609 (gutter-string (copy-sequence "\n"))
|
|
|
610 (ext (make-extent 0 1 gutter-string)))
|
|
428
|
611 (insert-string message (get-buffer-create " *Gutter Area*"))
|
|
442
|
612 ;; do some funky display here.
|
|
|
613 (set-extent-begin-glyph ext progress-layout-glyph)
|
|
|
614 ;; fixup the gutter specifiers
|
|
|
615 (set-gutter-element bottom-gutter 'progress gutter-string frame)
|
|
|
616 (set-specifier bottom-gutter-border-width 2 frame)
|
|
|
617 (set-instantiator-property progress-gauge-instantiator :value val)
|
|
|
618 (set-progress-feedback-instantiator (frame-selected-window frame))
|
|
|
619
|
|
|
620 (set-instantiator-property progress-text-instantiator :data message)
|
|
|
621 (set-progress-feedback-instantiator (frame-selected-window frame))
|
|
|
622 (if (and (eq (specifier-instance bottom-gutter-height frame)
|
|
|
623 'autodetect)
|
|
|
624 (gutter-element-visible-p bottom-gutter-visible-p
|
|
|
625 'progress frame))
|
|
|
626 ;; if the gauge is already visible then just draw the gutter
|
|
|
627 ;; checking for user events
|
|
428
|
628 (progn
|
|
442
|
629 (redisplay-gutter-area)
|
|
|
630 (progress-feedback-dispatch-non-command-events))
|
|
|
631 ;; otherwise make the gutter visible and redraw the frame
|
|
|
632 (set-specifier bottom-gutter-height 'autodetect frame)
|
|
|
633 (set-gutter-element-visible-p bottom-gutter-visible-p
|
|
|
634 'progress t frame)
|
|
|
635 ;; we have to do this so redisplay is up-to-date and so
|
|
|
636 ;; redisplay-gutter-area performs optimally. This may also
|
|
|
637 ;; make sure the frame geometry looks ok.
|
|
|
638 (progress-feedback-dispatch-non-command-events)
|
|
|
639 (redisplay-frame frame)
|
|
|
640 ))))
|
|
428
|
641
|
|
442
|
642 (defun display-progress-feedback (label message &optional value frame)
|
|
428
|
643 "Display a progress gauge and message in the bottom gutter area.
|
|
|
644 First argument LABEL is an identifier for this message. MESSAGE is
|
|
442
|
645 the string to display. Use `clear-progress-feedback' to remove a labelled
|
|
428
|
646 message."
|
|
442
|
647 (cond ((eq value 'abort)
|
|
|
648 (abort-progress-feedback label message frame))
|
|
|
649 ((or (not (valid-image-instantiator-format-p 'progress-gauge frame))
|
|
|
650 progress-feedback-use-echo-area)
|
|
|
651 (display-message label
|
|
|
652 (concat message (if (eq value 100) "done."
|
|
|
653 (make-string (/ value 5) ?.)))
|
|
|
654 frame))
|
|
|
655 (t
|
|
|
656 (append-progress-feedback label message value frame))))
|
|
428
|
657
|
|
442
|
658 (defun current-progress-feedback (&optional frame)
|
|
428
|
659 "Return the current progress gauge in the gutter area, or nil.
|
|
|
660 The FRAME argument is currently unused."
|
|
|
661 (cdr (car progress-stack)))
|
|
|
662
|
|
|
663 ;;; may eventually be frame-dependent
|
|
442
|
664 (defun current-progress-feedback-label (&optional frame)
|
|
428
|
665 (car (car progress-stack)))
|
|
|
666
|
|
442
|
667 (defun progress-feedback (fmt &optional value &rest args)
|
|
428
|
668 "Print a progress gauge and message in the bottom gutter area of the frame.
|
|
|
669 The arguments are the same as to `format'.
|
|
|
670
|
|
|
671 If the only argument is nil, clear any existing progress gauge."
|
|
442
|
672 (save-excursion
|
|
|
673 (if (and (null fmt) (null args))
|
|
|
674 (prog1 nil
|
|
|
675 (clear-progress-feedback nil))
|
|
|
676 (let ((str (apply 'format fmt args)))
|
|
|
677 (display-progress-feedback 'progress str value)
|
|
|
678 str))))
|
|
428
|
679
|
|
442
|
680 (defun progress-feedback-with-label (label fmt &optional value &rest args)
|
|
428
|
681 "Print a progress gauge and message in the bottom gutter area of the frame.
|
|
|
682 First argument LABEL is an identifier for this progress gauge. The rest of the
|
|
|
683 arguments are the same as to `format'."
|
|
442
|
684 ;; #### sometimes the buffer gets changed temporarily. I don't know
|
|
|
685 ;; why this is, so protect against it.
|
|
|
686 (save-excursion
|
|
|
687 (if (and (null fmt) (null args))
|
|
|
688 (prog1 nil
|
|
|
689 (clear-progress-feedback label nil))
|
|
|
690 (let ((str (apply 'format fmt args)))
|
|
|
691 (display-progress-feedback label str value)
|
|
|
692 str))))
|
|
428
|
693
|
|
931
|
694 (defun buffers-tab-omit-some-buffers (buf)
|
|
|
695 "For use as a value of `buffers-tab-omit-function'.
|
|
|
696 Omit buffers based on the value of `buffers-tab-omit-list', which
|
|
|
697 see."
|
|
|
698 (let ((regexp (mapconcat 'concat buffers-tab-omit-list "\\|")))
|
|
|
699 (not (null (string-match regexp (buffer-name buf))))))
|
|
|
700
|
|
428
|
701 (provide 'gutter-items)
|
|
|
702 ;;; gutter-items.el ends here.
|
