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