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