Mercurial > hg > xemacs-beta
annotate lisp/gutter-items.el @ 5420:b9167d522a9a
Rebase with 21.5 trunk.
| author | Mats Lidell <matsl@xemacs.org> |
|---|---|
| date | Thu, 28 Oct 2010 23:53:24 +0200 |
| parents | 308d34e9f07d cd167465bf69 |
| children | bcd74c477a38 |
| 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)) | |
| 273 (delq first-buf buffers)))) | |
| 274 ;; if we're in deletion ignore the current buffer | |
| 275 (when in-deletion | |
| 276 (setq buffers (delq (current-buffer) buffers)) | |
| 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 | |
| 317 (mapcar | |
| 318 #'(lambda (x) | |
| 319 (when (valid-image-instantiator-format-p 'tab-control x) | |
| 320 (cond ((eq gutter-buffers-tab-orientation 'top) | |
| 321 ;; This looks better than a 3d border | |
| 322 (set-specifier top-gutter-border-width 0 'global x) | |
| 323 (set-gutter-element top-gutter 'buffers-tab | |
| 324 gutter-string 'global x)) | |
| 325 ((eq gutter-buffers-tab-orientation 'bottom) | |
| 326 (set-specifier bottom-gutter-border-width 0 'global x) | |
| 327 (set-gutter-element bottom-gutter 'buffers-tab | |
| 328 gutter-string 'global x)) | |
| 329 ((eq gutter-buffers-tab-orientation 'left) | |
| 330 (set-specifier left-gutter-border-width 0 'global x) | |
| 331 (set-gutter-element left-gutter 'buffers-tab | |
| 444 | 332 gutter-string 'global x)) |
| 442 | 333 ((eq gutter-buffers-tab-orientation 'right) |
| 334 (set-specifier right-gutter-border-width 0 'global x) | |
| 335 (set-gutter-element right-gutter 'buffers-tab | |
| 444 | 336 gutter-string 'global x)) |
| 442 | 337 ))) |
| 338 (console-type-list)))) | |
| 339 | |
| 340 (defun update-tab-in-gutter (frame &optional force-selection) | |
| 428 | 341 "Update the tab control in the gutter area." |
| 442 | 342 ;; dedicated frames don't get tabs |
| 446 | 343 (unless (or (window-dedicated-p (frame-selected-window frame)) |
| 344 (frame-property frame 'popup)) | |
| 442 | 345 (when (specifier-instance default-gutter-visible-p frame) |
| 346 (unless (and gutter-buffers-tab | |
| 438 | 347 (eq (default-gutter-position) |
| 348 gutter-buffers-tab-orientation)) | |
| 428 | 349 (add-tab-to-gutter)) |
| 442 | 350 (when (valid-image-instantiator-format-p 'tab-control frame) |
| 446 | 351 (let ((items (buffers-tab-items nil frame force-selection))) |
| 352 (when items | |
| 353 (set-glyph-image | |
| 354 gutter-buffers-tab | |
| 355 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face | |
| 356 :orientation gutter-buffers-tab-orientation | |
| 357 (if (or (eq gutter-buffers-tab-orientation 'top) | |
| 358 (eq gutter-buffers-tab-orientation 'bottom)) | |
| 359 :pixel-width :pixel-height) | |
| 360 (if (or (eq gutter-buffers-tab-orientation 'top) | |
| 361 (eq gutter-buffers-tab-orientation 'bottom)) | |
| 362 '(gutter-pixel-width) '(gutter-pixel-height)) | |
| 363 :items items) | |
| 364 frame) | |
| 365 ;; set-glyph-image will not make the gutter dirty | |
| 458 | 366 (set-gutter-dirty-p gutter-buffers-tab-orientation))))))) |
| 428 | 367 |
| 442 | 368 ;; A myriad of different update hooks all doing slightly different things |
| 444 | 369 (add-one-shot-hook |
| 370 'after-init-hook | |
| 371 #'(lambda () | |
| 372 ;; don't add the hooks if the user really doesn't want them | |
| 373 (when gutter-buffers-tab-enabled | |
| 374 (add-hook 'create-frame-hook | |
| 375 #'(lambda (frame) | |
| 376 (when gutter-buffers-tab (update-tab-in-gutter frame t)))) | |
| 377 (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter) | |
| 378 (add-hook 'default-gutter-position-changed-hook | |
| 379 #'(lambda () | |
| 380 (when gutter-buffers-tab | |
| 381 (mapc #'update-tab-in-gutter (frame-list))))) | |
| 382 (add-hook 'gutter-element-visibility-changed-hook | |
| 383 #'(lambda (prop visible-p) | |
| 384 (when (and (eq prop 'buffers-tab) visible-p) | |
| 385 (mapc #'update-tab-in-gutter (frame-list))))) | |
| 386 (update-tab-in-gutter (selected-frame) t)))) | |
| 387 | |
| 428 | 388 ;; |
| 389 ;; progress display | |
| 390 ;; ripped off from message display | |
| 391 ;; | |
| 442 | 392 (defcustom progress-feedback-use-echo-area nil |
| 393 "*Whether progress gauge display should display in the echo area. | |
| 394 If NIL then progress gauges will be displayed with whatever native widgets | |
| 395 are available on the current console. If non-NIL then progress display will be | |
| 396 textual and displayed in the echo area." | |
| 397 :type 'boolean | |
| 398 :group 'gutter) | |
| 399 | |
| 400 (defvar progress-glyph-height 24 | |
| 401 "Height of the progress gauge glyph.") | |
| 402 | |
| 403 (defvar progress-feedback-popup-period 0.5 | |
| 404 "The time that the progress gauge should remain up after completion") | |
| 405 | |
| 406 (defcustom progress-feedback-style 'large | |
| 407 "*Control the appearance of the progress gauge. | |
| 408 If 'large, the default, then the progress-feedback text is displayed | |
| 409 above the gauge itself. If 'small then the gauge and text are arranged | |
| 410 side-by-side." | |
| 411 :group 'gutter | |
| 412 :type '(choice (const :tag "large" large) | |
| 413 (const :tag "small" small))) | |
| 414 | |
| 415 ;; private variables | |
| 416 (defvar progress-text-instantiator [string :data ""]) | |
| 417 (defvar progress-layout-glyph (make-glyph)) | |
| 418 (defvar progress-layout-instantiator nil) | |
| 419 | |
| 420 (defvar progress-gauge-instantiator | |
| 421 [progress-gauge | |
| 422 :value 0 | |
| 423 :pixel-height (eval progress-glyph-height) | |
| 424 :pixel-width 250 | |
| 425 :descriptor "Progress"]) | |
| 426 | |
| 427 (defun set-progress-feedback-instantiator (&optional locale) | |
| 428 (cond | |
| 429 ((eq progress-feedback-style 'small) | |
| 430 (setq progress-glyph-height 16) | |
| 431 (setq progress-layout-instantiator | |
| 432 `[layout | |
| 433 :orientation horizontal | |
| 434 :margin-width 4 | |
| 435 :items (,progress-gauge-instantiator | |
| 436 [button | |
| 437 :pixel-height (eval progress-glyph-height) | |
| 438 ;; 'quit is special and acts "asynchronously". | |
| 439 :descriptor "Stop" :callback 'quit] | |
| 440 ,progress-text-instantiator)]) | |
| 458 | 441 (set-glyph-image progress-layout-glyph progress-layout-instantiator |
| 442 locale)) | |
| 442 | 443 (t |
| 444 (setq progress-glyph-height 24) | |
| 445 (setq progress-layout-instantiator | |
| 446 `[layout | |
| 863 | 447 :orientation vertical :margin-width 4 |
| 448 :horizontally-justify left :vertically-justify center | |
| 442 | 449 :items (,progress-text-instantiator |
| 450 [layout | |
| 451 :orientation horizontal | |
| 452 :items (,progress-gauge-instantiator | |
| 453 [button | |
| 454 :pixel-height (eval progress-glyph-height) | |
| 455 :descriptor " Stop " | |
| 456 ;; 'quit is special and acts "asynchronously". | |
| 457 :callback 'quit])])]) | |
| 458 | 458 (set-glyph-image progress-layout-glyph progress-layout-instantiator |
| 459 locale)))) | |
| 460 | |
| 461 (defvar progress-abort-glyph (make-glyph)) | |
| 462 | |
| 463 (defun set-progress-abort-instantiator (&optional locale) | |
| 464 (set-glyph-image progress-abort-glyph | |
| 863 | 465 `[layout :orientation vertical |
| 466 :horizontally-justify left :vertically-justify center | |
| 458 | 467 :items (,progress-text-instantiator |
| 468 [layout | |
| 469 :margin-width 4 | |
| 470 :pixel-height progress-glyph-height | |
| 471 :orientation horizontal])] | |
| 472 locale)) | |
| 442 | 473 |
| 428 | 474 (defvar progress-stack nil |
| 475 "An alist of label/string pairs representing active progress gauges. | |
| 476 The first element in the list is currently displayed in the gutter area. | |
| 442 | 477 Do not modify this directly--use the `progress-feedback' or |
| 478 `display-progress-feedback'/`clear-progress-feedback' functions.") | |
| 428 | 479 |
| 442 | 480 (defun progress-feedback-displayed-p (&optional return-string frame) |
| 428 | 481 "Return a non-nil value if a progress gauge is presently displayed in the |
| 482 gutter area. If optional argument RETURN-STRING is non-nil, | |
| 483 return a string containing the message, otherwise just return t." | |
| 484 (let ((buffer (get-buffer-create " *Gutter Area*"))) | |
| 485 (and (< (point-min buffer) (point-max buffer)) | |
| 486 (if return-string | |
| 487 (buffer-substring nil nil buffer) | |
| 488 t)))) | |
| 489 | |
| 490 ;;; Returns the string which remains in the echo area, or nil if none. | |
| 491 ;;; If label is nil, the whole message stack is cleared. | |
| 442 | 492 (defun clear-progress-feedback (&optional label frame no-restore) |
| 493 "Remove any progress gauge with LABEL from the progress gauge-stack, | |
| 428 | 494 erasing it from the gutter area if it's currently displayed there. |
| 495 If a message remains at the head of the progress-stack and NO-RESTORE | |
| 496 is nil, it will be displayed. The string which remains in the gutter | |
| 497 area will be returned, or nil if the progress-stack is now empty. | |
| 498 If LABEL is nil, the entire progress-stack is cleared. | |
| 499 | |
| 500 Unless you need the return value or you need to specify a label, | |
| 501 you should just use (progress nil)." | |
| 442 | 502 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame)) |
| 503 progress-feedback-use-echo-area) | |
| 504 (clear-message label frame nil no-restore) | |
| 505 (or frame (setq frame (selected-frame))) | |
| 506 (remove-progress-feedback label frame) | |
| 502 | 507 (let ((inhibit-read-only t)) |
| 442 | 508 (erase-buffer (get-buffer-create " *Gutter Area*"))) |
| 509 (if no-restore | |
| 510 nil ; just preparing to put another msg up | |
| 511 (if progress-stack | |
| 512 (let ((oldmsg (cdr (car progress-stack)))) | |
| 513 (raw-append-progress-feedback oldmsg nil frame) | |
| 514 oldmsg) | |
| 515 ;; nothing to display so get rid of the gauge | |
| 516 (set-specifier bottom-gutter-border-width 0 frame) | |
| 517 (set-gutter-element-visible-p bottom-gutter-visible-p | |
| 518 'progress nil frame))))) | |
| 428 | 519 |
| 442 | 520 (defun progress-feedback-clear-when-idle (&optional label) |
| 521 (add-one-shot-hook 'pre-idle-hook | |
| 522 `(lambda () | |
| 523 (clear-progress-feedback ',label)))) | |
| 524 | |
| 525 (defun remove-progress-feedback (&optional label frame) | |
| 428 | 526 ;; If label is nil, we want to remove all matching progress gauges. |
| 527 (while (and progress-stack | |
| 528 (or (null label) ; null label means clear whole stack | |
| 529 (eq label (car (car progress-stack))))) | |
| 530 (setq progress-stack (cdr progress-stack))) | |
| 531 (let ((s progress-stack)) | |
| 532 (while (cdr s) | |
| 533 (let ((msg (car (cdr s)))) | |
| 534 (if (eq label (car msg)) | |
| 535 (progn | |
| 536 (setcdr s (cdr (cdr s)))) | |
| 537 (setq s (cdr s))))))) | |
| 538 | |
| 442 | 539 (defun progress-feedback-dispatch-non-command-events () |
| 540 ;; 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
|
541 (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
|
542 ;; (sit-for 0) causes more redisplay than we want. |
| 442 | 543 (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
|
544 (t nil))) |
| 442 | 545 |
| 546 (defun append-progress-feedback (label message &optional value frame) | |
| 428 | 547 (or frame (setq frame (selected-frame))) |
| 548 ;; Add a new entry to the message-stack, or modify an existing one | |
| 549 (let* ((top (car progress-stack)) | |
| 550 (tmsg (cdr top))) | |
| 551 (if (eq label (car top)) | |
| 552 (progn | |
| 553 (setcdr top message) | |
| 442 | 554 (if (equal tmsg message) |
| 555 (progn | |
| 556 (set-instantiator-property progress-gauge-instantiator :value value) | |
| 557 (set-progress-feedback-instantiator (frame-selected-window frame))) | |
| 558 (raw-append-progress-feedback message value frame)) | |
| 559 (redisplay-gutter-area)) | |
| 428 | 560 (push (cons label message) progress-stack) |
| 442 | 561 (raw-append-progress-feedback message value frame)) |
| 562 (progress-feedback-dispatch-non-command-events) | |
| 563 ;; either get command events or sit waiting for them | |
| 564 (when (eq value 100) | |
| 565 ; (sit-for progress-feedback-popup-period nil) | |
| 566 (clear-progress-feedback label)))) | |
| 428 | 567 |
| 442 | 568 (defun abort-progress-feedback (label message &optional frame) |
| 569 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame)) | |
| 570 progress-feedback-use-echo-area) | |
| 571 (display-message label (concat message "aborted.") frame) | |
| 572 (or frame (setq frame (selected-frame))) | |
| 573 ;; Add a new entry to the message-stack, or modify an existing one | |
| 574 (let* ((top (car progress-stack)) | |
| 502 | 575 (inhibit-read-only t)) |
| 442 | 576 (if (eq label (car top)) |
| 577 (setcdr top message) | |
| 578 (push (cons label message) progress-stack)) | |
| 579 (unless (equal message "") | |
| 580 (insert-string message (get-buffer-create " *Gutter Area*")) | |
| 581 (let* ((gutter-string (copy-sequence "\n")) | |
| 582 (ext (make-extent 0 1 gutter-string))) | |
| 583 ;; do some funky display here. | |
| 584 (set-extent-begin-glyph ext progress-abort-glyph) | |
| 428 | 585 ;; fixup the gutter specifiers |
| 442 | 586 (set-gutter-element bottom-gutter 'progress gutter-string frame) |
| 428 | 587 (set-specifier bottom-gutter-border-width 2 frame) |
| 458 | 588 (set-instantiator-property progress-text-instantiator :data message) |
| 589 (set-progress-abort-instantiator (frame-selected-window frame)) | |
| 428 | 590 (set-specifier bottom-gutter-height 'autodetect frame) |
| 442 | 591 (set-gutter-element-visible-p bottom-gutter-visible-p |
| 592 'progress t frame) | |
| 428 | 593 ;; we have to do this so redisplay is up-to-date and so |
| 594 ;; redisplay-gutter-area performs optimally. | |
| 595 (redisplay-gutter-area) | |
| 442 | 596 (sit-for progress-feedback-popup-period nil) |
| 597 (clear-progress-feedback label frame) | |
| 598 (set-extent-begin-glyph ext progress-layout-glyph) | |
| 599 (set-gutter-element bottom-gutter 'progress gutter-string frame) | |
| 428 | 600 ))))) |
| 601 | |
| 442 | 602 (defun raw-append-progress-feedback (message &optional value frame) |
| 428 | 603 (unless (equal message "") |
| 442 | 604 (let* ((inhibit-read-only t) |
| 605 (val (or value 0)) | |
| 606 (gutter-string (copy-sequence "\n")) | |
| 607 (ext (make-extent 0 1 gutter-string))) | |
| 428 | 608 (insert-string message (get-buffer-create " *Gutter Area*")) |
| 442 | 609 ;; do some funky display here. |
| 610 (set-extent-begin-glyph ext progress-layout-glyph) | |
| 611 ;; fixup the gutter specifiers | |
| 612 (set-gutter-element bottom-gutter 'progress gutter-string frame) | |
| 613 (set-specifier bottom-gutter-border-width 2 frame) | |
| 614 (set-instantiator-property progress-gauge-instantiator :value val) | |
| 615 (set-progress-feedback-instantiator (frame-selected-window frame)) | |
| 616 | |
| 617 (set-instantiator-property progress-text-instantiator :data message) | |
| 618 (set-progress-feedback-instantiator (frame-selected-window frame)) | |
| 619 (if (and (eq (specifier-instance bottom-gutter-height frame) | |
| 620 'autodetect) | |
| 621 (gutter-element-visible-p bottom-gutter-visible-p | |
| 622 'progress frame)) | |
| 623 ;; if the gauge is already visible then just draw the gutter | |
| 624 ;; checking for user events | |
| 428 | 625 (progn |
| 442 | 626 (redisplay-gutter-area) |
| 627 (progress-feedback-dispatch-non-command-events)) | |
| 628 ;; otherwise make the gutter visible and redraw the frame | |
| 629 (set-specifier bottom-gutter-height 'autodetect frame) | |
| 630 (set-gutter-element-visible-p bottom-gutter-visible-p | |
| 631 'progress t frame) | |
| 632 ;; we have to do this so redisplay is up-to-date and so | |
| 633 ;; redisplay-gutter-area performs optimally. This may also | |
| 634 ;; make sure the frame geometry looks ok. | |
| 635 (progress-feedback-dispatch-non-command-events) | |
| 636 (redisplay-frame frame) | |
| 637 )))) | |
| 428 | 638 |
| 442 | 639 (defun display-progress-feedback (label message &optional value frame) |
| 428 | 640 "Display a progress gauge and message in the bottom gutter area. |
| 641 First argument LABEL is an identifier for this message. MESSAGE is | |
| 442 | 642 the string to display. Use `clear-progress-feedback' to remove a labelled |
| 428 | 643 message." |
| 442 | 644 (cond ((eq value 'abort) |
| 645 (abort-progress-feedback label message frame)) | |
| 646 ((or (not (valid-image-instantiator-format-p 'progress-gauge frame)) | |
| 647 progress-feedback-use-echo-area) | |
| 648 (display-message label | |
| 649 (concat message (if (eq value 100) "done." | |
| 650 (make-string (/ value 5) ?.))) | |
| 651 frame)) | |
| 652 (t | |
| 653 (append-progress-feedback label message value frame)))) | |
| 428 | 654 |
| 442 | 655 (defun current-progress-feedback (&optional frame) |
| 428 | 656 "Return the current progress gauge in the gutter area, or nil. |
| 657 The FRAME argument is currently unused." | |
| 658 (cdr (car progress-stack))) | |
| 659 | |
| 660 ;;; may eventually be frame-dependent | |
| 442 | 661 (defun current-progress-feedback-label (&optional frame) |
| 428 | 662 (car (car progress-stack))) |
| 663 | |
| 442 | 664 (defun progress-feedback (fmt &optional value &rest args) |
| 428 | 665 "Print a progress gauge and message in the bottom gutter area of the frame. |
| 666 The arguments are the same as to `format'. | |
| 667 | |
| 668 If the only argument is nil, clear any existing progress gauge." | |
| 442 | 669 (save-excursion |
| 670 (if (and (null fmt) (null args)) | |
| 671 (prog1 nil | |
| 672 (clear-progress-feedback nil)) | |
| 673 (let ((str (apply 'format fmt args))) | |
| 674 (display-progress-feedback 'progress str value) | |
| 675 str)))) | |
| 428 | 676 |
| 442 | 677 (defun progress-feedback-with-label (label fmt &optional value &rest args) |
| 428 | 678 "Print a progress gauge and message in the bottom gutter area of the frame. |
| 3968 | 679 LABEL is an identifier for this progress gauge. |
| 680 FMT is a format string to be passed to `format' along with ARGS. | |
| 681 Optional VALUE is the current degree of progress, an integer 0-100. | |
| 682 The remaining ARGS are passed with FMT `(apply #'format FMT ARGS)'." | |
| 442 | 683 ;; #### sometimes the buffer gets changed temporarily. I don't know |
| 684 ;; why this is, so protect against it. | |
| 685 (save-excursion | |
| 686 (if (and (null fmt) (null args)) | |
| 687 (prog1 nil | |
| 688 (clear-progress-feedback label nil)) | |
| 689 (let ((str (apply 'format fmt args))) | |
| 690 (display-progress-feedback label str value) | |
| 691 str)))) | |
| 428 | 692 |
| 931 | 693 (defun buffers-tab-omit-some-buffers (buf) |
| 694 "For use as a value of `buffers-tab-omit-function'. | |
| 695 Omit buffers based on the value of `buffers-tab-omit-list', which | |
| 696 see." | |
| 697 (let ((regexp (mapconcat 'concat buffers-tab-omit-list "\\|"))) | |
| 698 (not (null (string-match regexp (buffer-name buf)))))) | |
| 699 | |
| 428 | 700 (provide 'gutter-items) |
| 701 ;;; gutter-items.el ends here. |