git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/gutter-items.el

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