cgit.sxemacs.org Git - sxemacs/blob - lisp/gutter-items.el

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