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