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