Mercurial > hg > xemacs-beta
annotate lisp/gutter-items.el @ 5075:868a9ffcc37b
Normally return a compiled function if one argument, #'constantly.
2010-02-24 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (constantly):
Normally return a compiled function from #'constantly if we are
handed a single argument. Shouldn't actually matter, the overhead
for returning a single constant in a lambda form vs. in a compiled
function is minuscule, but using compiled functions as much as
possible is good style in XEmacs, our interpreter is not stellar
(nor indeed should it need to be).
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 24 Feb 2010 17:17:13 +0000 |
| parents | c1784fd59d7d |
| children | cd167465bf69 308d34e9f07d |
| 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 | |
| 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 | |
|
4755
c1784fd59d7d
Fix syntax of some uses of condition-case and with-trapping-errors.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
3968
diff
changeset
|
543 (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
|
544 ;; (sit-for 0) causes more redisplay than we want. |
| 442 | 545 (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
|
546 (t nil))) |
| 442 | 547 |
| 548 (defun append-progress-feedback (label message &optional value frame) | |
| 428 | 549 (or frame (setq frame (selected-frame))) |
| 550 ;; Add a new entry to the message-stack, or modify an existing one | |
| 551 (let* ((top (car progress-stack)) | |
| 552 (tmsg (cdr top))) | |
| 553 (if (eq label (car top)) | |
| 554 (progn | |
| 555 (setcdr top message) | |
| 442 | 556 (if (equal tmsg message) |
| 557 (progn | |
| 558 (set-instantiator-property progress-gauge-instantiator :value value) | |
| 559 (set-progress-feedback-instantiator (frame-selected-window frame))) | |
| 560 (raw-append-progress-feedback message value frame)) | |
| 561 (redisplay-gutter-area)) | |
| 428 | 562 (push (cons label message) progress-stack) |
| 442 | 563 (raw-append-progress-feedback message value frame)) |
| 564 (progress-feedback-dispatch-non-command-events) | |
| 565 ;; either get command events or sit waiting for them | |
| 566 (when (eq value 100) | |
| 567 ; (sit-for progress-feedback-popup-period nil) | |
| 568 (clear-progress-feedback label)))) | |
| 428 | 569 |
| 442 | 570 (defun abort-progress-feedback (label message &optional frame) |
| 571 (if (or (not (valid-image-instantiator-format-p 'progress-gauge frame)) | |
| 572 progress-feedback-use-echo-area) | |
| 573 (display-message label (concat message "aborted.") frame) | |
| 574 (or frame (setq frame (selected-frame))) | |
| 575 ;; Add a new entry to the message-stack, or modify an existing one | |
| 576 (let* ((top (car progress-stack)) | |
| 502 | 577 (inhibit-read-only t)) |
| 442 | 578 (if (eq label (car top)) |
| 579 (setcdr top message) | |
| 580 (push (cons label message) progress-stack)) | |
| 581 (unless (equal message "") | |
| 582 (insert-string message (get-buffer-create " *Gutter Area*")) | |
| 583 (let* ((gutter-string (copy-sequence "\n")) | |
| 584 (ext (make-extent 0 1 gutter-string))) | |
| 585 ;; do some funky display here. | |
| 586 (set-extent-begin-glyph ext progress-abort-glyph) | |
| 428 | 587 ;; fixup the gutter specifiers |
| 442 | 588 (set-gutter-element bottom-gutter 'progress gutter-string frame) |
| 428 | 589 (set-specifier bottom-gutter-border-width 2 frame) |
| 458 | 590 (set-instantiator-property progress-text-instantiator :data message) |
| 591 (set-progress-abort-instantiator (frame-selected-window frame)) | |
| 428 | 592 (set-specifier bottom-gutter-height 'autodetect frame) |
| 442 | 593 (set-gutter-element-visible-p bottom-gutter-visible-p |
| 594 'progress t frame) | |
| 428 | 595 ;; we have to do this so redisplay is up-to-date and so |
| 596 ;; redisplay-gutter-area performs optimally. | |
| 597 (redisplay-gutter-area) | |
| 442 | 598 (sit-for progress-feedback-popup-period nil) |
| 599 (clear-progress-feedback label frame) | |
| 600 (set-extent-begin-glyph ext progress-layout-glyph) | |
| 601 (set-gutter-element bottom-gutter 'progress gutter-string frame) | |
| 428 | 602 ))))) |
| 603 | |
| 442 | 604 (defun raw-append-progress-feedback (message &optional value frame) |
| 428 | 605 (unless (equal message "") |
| 442 | 606 (let* ((inhibit-read-only t) |
| 607 (val (or value 0)) | |
| 608 (gutter-string (copy-sequence "\n")) | |
| 609 (ext (make-extent 0 1 gutter-string))) | |
| 428 | 610 (insert-string message (get-buffer-create " *Gutter Area*")) |
| 442 | 611 ;; do some funky display here. |
| 612 (set-extent-begin-glyph ext progress-layout-glyph) | |
| 613 ;; fixup the gutter specifiers | |
| 614 (set-gutter-element bottom-gutter 'progress gutter-string frame) | |
| 615 (set-specifier bottom-gutter-border-width 2 frame) | |
| 616 (set-instantiator-property progress-gauge-instantiator :value val) | |
| 617 (set-progress-feedback-instantiator (frame-selected-window frame)) | |
| 618 | |
| 619 (set-instantiator-property progress-text-instantiator :data message) | |
| 620 (set-progress-feedback-instantiator (frame-selected-window frame)) | |
| 621 (if (and (eq (specifier-instance bottom-gutter-height frame) | |
| 622 'autodetect) | |
| 623 (gutter-element-visible-p bottom-gutter-visible-p | |
| 624 'progress frame)) | |
| 625 ;; if the gauge is already visible then just draw the gutter | |
| 626 ;; checking for user events | |
| 428 | 627 (progn |
| 442 | 628 (redisplay-gutter-area) |
| 629 (progress-feedback-dispatch-non-command-events)) | |
| 630 ;; otherwise make the gutter visible and redraw the frame | |
| 631 (set-specifier bottom-gutter-height 'autodetect frame) | |
| 632 (set-gutter-element-visible-p bottom-gutter-visible-p | |
| 633 'progress t frame) | |
| 634 ;; we have to do this so redisplay is up-to-date and so | |
| 635 ;; redisplay-gutter-area performs optimally. This may also | |
| 636 ;; make sure the frame geometry looks ok. | |
| 637 (progress-feedback-dispatch-non-command-events) | |
| 638 (redisplay-frame frame) | |
| 639 )))) | |
| 428 | 640 |
| 442 | 641 (defun display-progress-feedback (label message &optional value frame) |
| 428 | 642 "Display a progress gauge and message in the bottom gutter area. |
| 643 First argument LABEL is an identifier for this message. MESSAGE is | |
| 442 | 644 the string to display. Use `clear-progress-feedback' to remove a labelled |
| 428 | 645 message." |
| 442 | 646 (cond ((eq value 'abort) |
| 647 (abort-progress-feedback label message frame)) | |
| 648 ((or (not (valid-image-instantiator-format-p 'progress-gauge frame)) | |
| 649 progress-feedback-use-echo-area) | |
| 650 (display-message label | |
| 651 (concat message (if (eq value 100) "done." | |
| 652 (make-string (/ value 5) ?.))) | |
| 653 frame)) | |
| 654 (t | |
| 655 (append-progress-feedback label message value frame)))) | |
| 428 | 656 |
| 442 | 657 (defun current-progress-feedback (&optional frame) |
| 428 | 658 "Return the current progress gauge in the gutter area, or nil. |
| 659 The FRAME argument is currently unused." | |
| 660 (cdr (car progress-stack))) | |
| 661 | |
| 662 ;;; may eventually be frame-dependent | |
| 442 | 663 (defun current-progress-feedback-label (&optional frame) |
| 428 | 664 (car (car progress-stack))) |
| 665 | |
| 442 | 666 (defun progress-feedback (fmt &optional value &rest args) |
| 428 | 667 "Print a progress gauge and message in the bottom gutter area of the frame. |
| 668 The arguments are the same as to `format'. | |
| 669 | |
| 670 If the only argument is nil, clear any existing progress gauge." | |
| 442 | 671 (save-excursion |
| 672 (if (and (null fmt) (null args)) | |
| 673 (prog1 nil | |
| 674 (clear-progress-feedback nil)) | |
| 675 (let ((str (apply 'format fmt args))) | |
| 676 (display-progress-feedback 'progress str value) | |
| 677 str)))) | |
| 428 | 678 |
| 442 | 679 (defun progress-feedback-with-label (label fmt &optional value &rest args) |
| 428 | 680 "Print a progress gauge and message in the bottom gutter area of the frame. |
| 3968 | 681 LABEL is an identifier for this progress gauge. |
| 682 FMT is a format string to be passed to `format' along with ARGS. | |
| 683 Optional VALUE is the current degree of progress, an integer 0-100. | |
| 684 The remaining ARGS are passed with FMT `(apply #'format FMT ARGS)'." | |
| 442 | 685 ;; #### sometimes the buffer gets changed temporarily. I don't know |
| 686 ;; why this is, so protect against it. | |
| 687 (save-excursion | |
| 688 (if (and (null fmt) (null args)) | |
| 689 (prog1 nil | |
| 690 (clear-progress-feedback label nil)) | |
| 691 (let ((str (apply 'format fmt args))) | |
| 692 (display-progress-feedback label str value) | |
| 693 str)))) | |
| 428 | 694 |
| 931 | 695 (defun buffers-tab-omit-some-buffers (buf) |
| 696 "For use as a value of `buffers-tab-omit-function'. | |
| 697 Omit buffers based on the value of `buffers-tab-omit-list', which | |
| 698 see." | |
| 699 (let ((regexp (mapconcat 'concat buffers-tab-omit-list "\\|"))) | |
| 700 (not (null (string-match regexp (buffer-name buf)))))) | |
| 701 | |
| 428 | 702 (provide 'gutter-items) |
| 703 ;;; gutter-items.el ends here. |