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 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 (defvar gutter-buffers-tab nil
  34   "A tab widget in the gutter for displaying buffers.
  35 Do not set this. Use `glyph-image-instance' and
  36 `set-image-instance-property' to change the properties of the tab.")
  37
  38 (defcustom gutter-visible-p
  39   (specifier-instance default-gutter-visible-p)
  40   "Whether the default gutter is globally visible. This option can be
  41 customized through the options menu."
  42   :group 'display
  43   :type 'boolean
  44   :set #'(lambda (var val)
  45            (set-specifier default-gutter-visible-p val)
  46            (setq gutter-visible-p val)
  47            (when gutter-buffers-tab (update-tab-in-gutter))))
  48
  49 (defcustom default-gutter-position
  50   (default-gutter-position)
  51   "The location of the default gutter. It can be 'top, 'bottom, 'left or
  52 'right. This option can be customized through the options menu."
  53   :group 'display
  54   :type '(choice (const :tag "top" 'top)
  55                  (const :tag "bottom" 'bottom)
  56                  (const :tag "left" 'left)
  57                  (const :tag "right" 'right))
  58   :set #'(lambda (var val)
  59            (set-default-gutter-position val)
  60            (setq default-gutter-position val)
  61            (when gutter-buffers-tab (update-tab-in-gutter))))
  62
  63 ;;; The Buffers tab
  64
  65 (defgroup buffers-tab nil
  66   "Customization of `Buffers' tab."
  67   :group 'gutter)
  68
  69 (defvar gutter-buffers-tab-orientation 'top
  70   "Where the buffers tab currently is. Do not set this.")
  71
  72 (defvar gutter-buffers-tab-extent nil)
  73
  74 (defcustom buffers-tab-max-size 6
  75   "*Maximum number of entries which may appear on the \"Buffers\" tab.
  76 If this is 10, then only the ten most-recently-selected buffers will be
  77 shown.  If this is nil, then all buffers will be shown.  Setting this to
  78 a large number or nil will slow down tab responsiveness."
  79   :type '(choice (const :tag "Show all" nil)
  80                  (integer 6))
  81   :group 'buffers-tab)
  82
  83 (defcustom buffers-tab-switch-to-buffer-function 'buffers-tab-switch-to-buffer
  84   "*The function to call to select a buffer from the buffers tab.
  85 `switch-to-buffer' is a good choice, as is `pop-to-buffer'."
  86   :type '(radio (function-item switch-to-buffer)
  87                 (function-item pop-to-buffer)
  88                 (function :tag "Other"))
  89   :group 'buffers-tab)
  90
  91 (defcustom buffers-tab-omit-function 'buffers-menu-omit-invisible-buffers
  92   "*If non-nil, a function specifying the buffers to omit from the buffers tab.
  93 This is passed a buffer and should return non-nil if the buffer should be
  94 omitted.  The default value `buffers-tab-omit-invisible-buffers' omits
  95 buffers that are normally considered \"invisible\" (those whose name
  96 begins with a space)."
  97   :type '(choice (const :tag "None" nil)
  98                  function)
  99   :group 'buffers-tab)
 100
 101 (defcustom buffers-tab-selection-function 'select-buffers-tab-buffers-by-mode
 102   "*If non-nil, a function specifying the buffers to select from the
 103 buffers tab.  This is passed two buffers and should return non-nil if
 104 the second buffer should be selected.  The default value
 105 `select-buffers-tab-buffers-by-mode' groups buffers by major mode and
 106 by `buffers-tab-grouping-regexp'."
 107
 108   :type '(choice (const :tag "None" nil)
 109                  function)
 110   :group 'buffers-tab)
 111
 112 (make-face 'buffers-tab "Face for displaying the buffers tab.")
 113 (set-face-parent 'buffers-tab 'default)
 114
 115 (defcustom buffers-tab-face 'buffers-tab
 116   "*Face to use for displaying the buffers tab."
 117   :type 'face
 118   :group 'buffers-tab)
 119
 120 (defcustom buffers-tab-grouping-regexp
 121   '("^\\(gnus-\\|message-mode\\|mime/viewer-mode\\)"
 122     "^\\(emacs-lisp-\\|lisp-\\)")
 123   "*If non-nil, a list of regular expressions for buffer grouping.
 124 Each regular expression is applied to the current major-mode symbol
 125 name and mode-name, if it matches then any other buffers that match
 126 the same regular expression be added to the current group."
 127   :type '(choice (const :tag "None" nil)
 128                  sexp)
 129   :group 'buffers-tab)
 130
 131 (defcustom buffers-tab-format-buffer-line-function 'format-buffers-tab-line
 132   "*The function to call to return a string to represent a buffer in the
 133 buffers tab.  The function is passed a buffer and should return a
 134 string.  The default value `format-buffers-tab-line' just returns the
 135 name of the buffer, optionally truncated to
 136 `buffers-tab-max-buffer-line-length'.  Also check out
 137 `slow-format-buffers-menu-line' which returns a whole bunch of info
 138 about a buffer."
 139   :type 'function
 140   :group 'buffers-tab)
 141
 142 (defvar buffers-tab-default-buffer-line-length
 143   (make-specifier-and-init 'generic '((global ((default) . 25))) t)
 144   "*Maximum length of text which may appear in a \"Buffers\" tab.
 145 This is a specifier, use set-specifier to modify it.")
 146
 147 (defcustom buffers-tab-max-buffer-line-length
 148   (specifier-instance buffers-tab-default-buffer-line-length)
 149   "*Maximum length of text which may appear in a \"Buffers\" tab.
 150 Buffer names over this length will be truncated with elipses.
 151 If this is 0, then the full buffer name will be shown."
 152   :type '(choice (const :tag "Show all" 0)
 153                  (integer 25))
 154   :group 'buffers-tab
 155   :set #'(lambda (var val)
 156            (set-specifier buffers-tab-default-buffer-line-length val)
 157            (setq buffers-tab-max-buffer-line-length val)))
 158
 159 (defun buffers-tab-switch-to-buffer (buffer)
 160   "For use as a value for `buffers-tab-switch-to-buffer-function'."
 161   (unless (eq (window-buffer) buffer)
 162     (if (> (length (windows-of-buffer buffer)) 0)
 163         (select-window (car (windows-of-buffer buffer)))
 164       (switch-to-buffer buffer t))))
 165
 166 (defun select-buffers-tab-buffers-by-mode (buf1 buf2)
 167   "For use as a value of `buffers-tab-selection-function'.
 168 This selects buffers by major mode `buffers-tab-grouping-regexp'."
 169   (let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1)))
 170         (mode2 (symbol-name (symbol-value-in-buffer 'major-mode buf2)))
 171         (modenm1 (symbol-value-in-buffer 'mode-name buf1))
 172         (modenm2 (symbol-value-in-buffer 'mode-name buf2)))
 173     (cond ((or (eq mode1 mode2)
 174                (eq modenm1 modenm2)
 175                (and (string-match "^[^-]+-" mode1)
 176                     (string-match
 177                      (concat "^" (regexp-quote
 178                                   (substring mode1 0 (match-end 0))))
 179                      mode2))
 180                (and buffers-tab-grouping-regexp
 181                     (find-if #'(lambda (x)
 182                                  (or
 183                                   (and (string-match x mode1)
 184                                        (string-match x mode2))
 185                                   (and (string-match x modenm1)
 186                                        (string-match x modenm2))))
 187                              buffers-tab-grouping-regexp)))
 188            t)
 189           (t nil))))
 190
 191 (defun format-buffers-tab-line (buffer)
 192   "For use as a value of `buffers-tab-format-buffer-line-function'.
 193 This just returns the buffer's name, optionally truncated."
 194   (let ((len (specifier-instance buffers-tab-default-buffer-line-length)))
 195     (if (and (> len 0)
 196              (> (length (buffer-name buffer)) len))
 197         (if (string-match ".*<.>$" (buffer-name buffer))
 198             (concat (substring (buffer-name buffer)
 199                                0 (- len 6)) "..."
 200                                (substring (buffer-name buffer) -3))
 201           (concat (substring (buffer-name buffer)
 202                              0 (- len 3)) "..."))
 203       (buffer-name buffer))))
 204
 205 (defsubst build-buffers-tab-internal (buffers)
 206   (let (line)
 207     (mapcar
 208      #'(lambda (buffer)
 209          (setq line (funcall buffers-tab-format-buffer-line-function
 210                              buffer))
 211          (vector line (list buffers-tab-switch-to-buffer-function
 212                             (buffer-name buffer))))
 213      buffers)))
 214
 215 (defun buffers-tab-items (&optional in-deletion frame)
 216   "This is the tab filter for the top-level buffers \"Buffers\" tab.
 217 It dynamically creates a list of buffers to use as the contents of the tab.
 218 Only the most-recently-used few buffers will be listed on the tab, for
 219 efficiency reasons.  You can control how many buffers will be shown by
 220 setting `buffers-tab-max-size'.  You can control the text of the tab
 221 items by redefining the function `format-buffers-menu-line'."
 222   (save-match-data
 223     (let* ((buffers (delete-if buffers-tab-omit-function (buffer-list frame)))
 224            (first-buf (car buffers)))
 225       ;; if we're in deletion ignore the current buffer
 226       (when in-deletion
 227         (setq buffers (delq (current-buffer) buffers))
 228         (setq first-buf (car buffers)))
 229       ;; group buffers by mode
 230       (when buffers-tab-selection-function
 231         (delete-if-not #'(lambda (buf)
 232                            (funcall buffers-tab-selection-function
 233                                     first-buf buf)) buffers))
 234       (and (integerp buffers-tab-max-size)
 235            (> buffers-tab-max-size 1)
 236            (> (length buffers) buffers-tab-max-size)
 237            ;; shorten list of buffers
 238            (setcdr (nthcdr buffers-tab-max-size buffers) nil))
 239       (setq buffers (build-buffers-tab-internal buffers))
 240       buffers)))
 241
 242 (defun add-tab-to-gutter ()
 243   "Put a tab control in the gutter area to hold the most recent buffers."
 244   (setq gutter-buffers-tab-orientation (default-gutter-position))
 245   (let ((gutter-string ""))
 246     (unless gutter-buffers-tab-extent
 247       (setq gutter-buffers-tab-extent (make-extent 0 0 gutter-string)))
 248     (set-extent-begin-glyph
 249      gutter-buffers-tab-extent
 250      (setq gutter-buffers-tab
 251            (make-glyph
 252             (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
 253                     :orientation gutter-buffers-tab-orientation
 254                     :properties (list :items (buffers-tab-items))))))
 255     ;; This looks better than a 3d border
 256     (mapcar '(lambda (x)
 257                (when (valid-image-instantiator-format-p 'tab-control x)
 258                  (set-specifier default-gutter-border-width 0 'global x)
 259                  (set-specifier top-gutter nil 'global x)
 260                  (set-specifier bottom-gutter nil 'global x)
 261                  (set-specifier left-gutter nil 'global x)
 262                  (set-specifier right-gutter nil 'global x)
 263                  (set-specifier left-gutter-width 0 'global x)
 264                  (set-specifier right-gutter-width 0 'global x)
 265                  (cond ((eq gutter-buffers-tab-orientation 'top)
 266                         (set-specifier top-gutter gutter-string 'global x))
 267                        ((eq gutter-buffers-tab-orientation 'bottom)
 268                         (set-specifier bottom-gutter gutter-string 'global x))
 269                        ((eq gutter-buffers-tab-orientation 'left)
 270                         (set-specifier left-gutter gutter-string 'global x)
 271                         (set-specifier left-gutter-width
 272                                        (glyph-width gutter-buffers-tab)
 273                                        'global x))
 274                        ((eq gutter-buffers-tab-orientation 'right)
 275                         (set-specifier right-gutter gutter-string 'global x)
 276                         (set-specifier right-gutter-width
 277                                        (glyph-width gutter-buffers-tab)
 278                                        'global x))
 279                        )))
 280             (console-type-list))))
 281
 282 (defun update-tab-in-gutter (&optional frame-or-buffer)
 283   "Update the tab control in the gutter area."
 284   (let ((locale (if (framep frame-or-buffer) frame-or-buffer)))
 285     (when (specifier-instance default-gutter-visible-p locale)
 286       (unless (and gutter-buffers-tab
 287                    (eq (default-gutter-position)
 288                        gutter-buffers-tab-orientation))
 289         (add-tab-to-gutter))
 290       (when (valid-image-instantiator-format-p 'tab-control locale)
 291         (let ((inst (glyph-image-instance
 292                      gutter-buffers-tab
 293                      (when (framep frame-or-buffer)
 294                        (last-nonminibuf-window frame-or-buffer)))))
 295           (set-image-instance-property inst :items
 296                                        (buffers-tab-items
 297                                         nil locale)))))))
 298
 299 (defun remove-buffer-from-gutter-tab ()
 300   "Remove the current buffer from the tab control in the gutter area."
 301   (when (and (valid-image-instantiator-format-p 'tab-control)
 302              (specifier-instance default-gutter-visible-p))
 303     (let ((inst (glyph-image-instance gutter-buffers-tab))
 304           (buffers (buffers-tab-items t)))
 305       (unless buffers
 306         (setq buffers (build-buffers-tab-internal
 307                        (list
 308                         (get-buffer-create "*scratch*")))))
 309       (set-image-instance-property inst :items buffers))))
 310
 311 (add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab)
 312 (add-hook 'create-frame-hook 'update-tab-in-gutter)
 313 (add-hook 'record-buffer-hook 'update-tab-in-gutter)
 314
 315 ;;
 316 ;; progress display
 317 ;; ripped off from message display
 318 ;;
 319 (defvar progress-stack nil
 320   "An alist of label/string pairs representing active progress gauges.
 321 The first element in the list is currently displayed in the gutter area.
 322 Do not modify this directly--use the `progress' or
 323 `display-progress'/`clear-progress' functions.")
 324
 325 (defvar progress-glyph-height 32
 326   "Height of the gutter area for progress messages.")
 327
 328 (defvar progress-stop-callback 'progress-quit-function
 329   "Function to call to stop the progress operation.")
 330
 331 (defun progress-quit-function ()
 332   "Default function to call for the stop button in a progress gauge.
 333 This just removes the progress gauge and calls quit."
 334   (interactive)
 335   (clear-progress)
 336   (keyboard-quit))
 337
 338 ;; private variables
 339 (defvar progress-gauge-glyph
 340   (make-glyph
 341    (vector 'progress-gauge
 342            :pixel-height (- progress-glyph-height 8)
 343            :pixel-width 50
 344            :descriptor "Progress")))
 345
 346 (defvar progress-text-glyph
 347   (make-glyph [string :data ""]))
 348
 349 (defvar progress-layout-glyph
 350   (make-glyph
 351    (vector
 352     'layout :orientation 'vertical :justify 'left
 353     :items (list
 354             progress-text-glyph
 355             (make-glyph
 356              (vector
 357               'layout :pixel-height progress-glyph-height
 358               :orientation 'horizontal
 359               :items (list
 360                       progress-gauge-glyph
 361                       (vector
 362                        'button :pixel-height (- progress-glyph-height 8)
 363                        :descriptor " Stop "
 364                        :callback '(funcall progress-stop-callback)))))))))
 365
 366 (defvar progress-abort-glyph
 367   (make-glyph
 368    (vector 'layout :orientation 'vertical :justify 'left
 369            :items (list progress-text-glyph
 370                         (make-glyph
 371                          (vector 'layout
 372                                  :pixel-height progress-glyph-height
 373                                  :orientation 'horizontal))))))
 374
 375 (defvar progress-extent-text "")
 376 (defvar progress-extent nil)
 377
 378 (defun progress-displayed-p (&optional return-string frame)
 379   "Return a non-nil value if a progress gauge is presently displayed in the
 380 gutter area.  If optional argument RETURN-STRING is non-nil,
 381 return a string containing the message, otherwise just return t."
 382   (let ((buffer (get-buffer-create " *Gutter Area*")))
 383     (and (< (point-min buffer) (point-max buffer))
 384          (if return-string
 385              (buffer-substring nil nil buffer)
 386            t))))
 387
 388 ;;; Returns the string which remains in the echo area, or nil if none.
 389 ;;; If label is nil, the whole message stack is cleared.
 390 (defun clear-progress (&optional label frame no-restore)
 391   "Remove any progress gauge with the given LABEL from the progress gauge-stack,
 392 erasing it from the gutter area if it's currently displayed there.
 393 If a message remains at the head of the progress-stack and NO-RESTORE
 394 is nil, it will be displayed.  The string which remains in the gutter
 395 area will be returned, or nil if the progress-stack is now empty.
 396 If LABEL is nil, the entire progress-stack is cleared.
 397
 398 Unless you need the return value or you need to specify a label,
 399 you should just use (progress nil)."
 400   (or frame (setq frame (selected-frame)))
 401   (remove-progress label frame)
 402   (let ((inhibit-read-only t)
 403         (zmacs-region-stays zmacs-region-stays)) ; preserve from change
 404     (erase-buffer " *Echo Area*")
 405     (erase-buffer (get-buffer-create " *Gutter Area*")))
 406   (if no-restore
 407       nil                       ; just preparing to put another msg up
 408     (if progress-stack
 409         (let ((oldmsg (cdr (car progress-stack))))
 410           (raw-append-progress oldmsg frame)
 411           oldmsg)
 412       ;; nothing to display so get rid of the gauge
 413       (set-specifier bottom-gutter-border-width 0 frame)
 414       (set-specifier bottom-gutter-visible-p nil frame))))
 415
 416 (defun remove-progress (&optional label frame)
 417   ;; If label is nil, we want to remove all matching progress gauges.
 418   (while (and progress-stack
 419               (or (null label)  ; null label means clear whole stack
 420                   (eq label (car (car progress-stack)))))
 421     (setq progress-stack (cdr progress-stack)))
 422   (let ((s  progress-stack))
 423     (while (cdr s)
 424       (let ((msg (car (cdr s))))
 425         (if (eq label (car msg))
 426             (progn
 427               (setcdr s (cdr (cdr s))))
 428           (setq s (cdr s)))))))
 429
 430 (defun append-progress (label message &optional value frame)
 431   (or frame (setq frame (selected-frame)))
 432   ;; Add a new entry to the message-stack, or modify an existing one
 433   (let* ((top (car progress-stack))
 434          (tmsg (cdr top)))
 435     (if (eq label (car top))
 436         (progn
 437           (setcdr top message)
 438           (if (eq tmsg message)
 439               (set-image-instance-property
 440                (glyph-image-instance progress-gauge-glyph)
 441                :percent value)
 442             (raw-append-progress message value frame))
 443           (redisplay-gutter-area)
 444           (when (input-pending-p)
 445             (dispatch-event (next-command-event))))
 446       (push (cons label message) progress-stack)
 447       (raw-append-progress message value frame))
 448     (when (eq value 100)
 449       (sit-for 0.5 nil)
 450       (clear-progress label))))
 451
 452 (defun abort-progress (label message &optional frame)
 453   (or frame (setq frame (selected-frame)))
 454   ;; Add a new entry to the message-stack, or modify an existing one
 455   (let* ((top (car progress-stack))
 456          (inhibit-read-only t)
 457          (zmacs-region-stays zmacs-region-stays))
 458     (if (eq label (car top))
 459         (setcdr top message)
 460       (push (cons label message) progress-stack))
 461     (unless (equal message "")
 462       (insert-string message (get-buffer-create " *Gutter Area*"))
 463       ;; Do what the device is able to cope with.
 464       (if (not (valid-image-instantiator-format-p 'progress-gauge frame))
 465           (progn
 466             (insert-string message " *Echo Area*")
 467             (if (not executing-kbd-macro)
 468                 (redisplay-echo-area)))
 469         ;; do some funky display here.
 470         (unless progress-extent
 471           (setq progress-extent (make-extent 0 0 progress-extent-text)))
 472         (let ((bglyph (extent-begin-glyph progress-extent)))
 473           (set-extent-begin-glyph progress-extent progress-abort-glyph)
 474           ;; fixup the gutter specifiers
 475           (set-specifier bottom-gutter progress-extent-text frame)
 476           (set-specifier bottom-gutter-border-width 2 frame)
 477           (set-image-instance-property
 478            (glyph-image-instance progress-text-glyph) :data message)
 479           (set-specifier bottom-gutter-height 'autodetect frame)
 480           (set-specifier bottom-gutter-visible-p t frame)
 481           ;; we have to do this so redisplay is up-to-date and so
 482           ;; redisplay-gutter-area performs optimally.
 483           (redisplay-gutter-area)
 484           (sit-for 0.5 nil)
 485           (clear-progress label)
 486           (set-extent-begin-glyph progress-extent bglyph)
 487           )))))
 488
 489 (defun raw-append-progress (message &optional value frame)
 490   (unless (equal message "")
 491     (let ((inhibit-read-only t)
 492           (zmacs-region-stays zmacs-region-stays)
 493           (val (or value 0))) ; preserve from change
 494       (insert-string message (get-buffer-create " *Gutter Area*"))
 495       ;; Do what the device is able to cope with.
 496       (if (not (valid-image-instantiator-format-p 'progress-gauge frame))
 497           (progn
 498             (insert-string
 499              (concat message (if (eq val 100) "done.")
 500                      (make-string (/ val 5) ?.))
 501              " *Echo Area*")
 502             (if (not executing-kbd-macro)
 503                 (redisplay-echo-area)))
 504         ;; do some funky display here.
 505         (unless progress-extent
 506           (setq progress-extent (make-extent 0 0 progress-extent-text))
 507           (set-extent-begin-glyph progress-extent progress-layout-glyph))
 508         ;; fixup the gutter specifiers
 509         (set-specifier bottom-gutter progress-extent-text frame)
 510         (set-specifier bottom-gutter-border-width 2 frame)
 511         (set-image-instance-property
 512          (glyph-image-instance progress-gauge-glyph) :percent val)
 513         (set-image-instance-property
 514          (glyph-image-instance progress-text-glyph) :data message)
 515         (if (and (eq (specifier-instance bottom-gutter-height frame)
 516                      'autodetect)
 517                  (specifier-instance bottom-gutter-visible-p frame))
 518             (progn
 519               ;; if the gauge is already visible then just draw the gutter
 520               ;; checking for user events
 521               (redisplay-gutter-area)
 522               (when (input-pending-p)
 523                 (dispatch-event (next-command-event))))
 524           ;; otherwise make the gutter visible and redraw the frame
 525           (set-specifier bottom-gutter-height 'autodetect frame)
 526           (set-specifier bottom-gutter-visible-p t frame)
 527           ;; we have to do this so redisplay is up-to-date and so
 528           ;; redisplay-gutter-area performs optimally.
 529           (redisplay-frame)
 530           )))))
 531
 532 (defun display-progress (label message &optional value frame)
 533   "Display a progress gauge and message in the bottom gutter area.
 534  First argument LABEL is an identifier for this message.  MESSAGE is
 535 the string to display.  Use `clear-progress' to remove a labelled
 536 message."
 537   (clear-progress label frame t)
 538   (if (eq value 'abort)
 539       (abort-progress label message frame)
 540     (append-progress label message value frame)))
 541
 542 (defun current-progress (&optional frame)
 543   "Return the current progress gauge in the gutter area, or nil.
 544 The FRAME argument is currently unused."
 545   (cdr (car progress-stack)))
 546
 547 ;;; may eventually be frame-dependent
 548 (defun current-progress-label (&optional frame)
 549   (car (car progress-stack)))
 550
 551 (defun progress (fmt &optional value &rest args)
 552   "Print a progress gauge and message in the bottom gutter area of the frame.
 553 The arguments are the same as to `format'.
 554
 555 If the only argument is nil, clear any existing progress gauge."
 556   (if (and (null fmt) (null args))
 557       (prog1 nil
 558         (clear-progress nil))
 559     (let ((str (apply 'format fmt args)))
 560       (display-progress 'progress str value)
 561       str)))
 562
 563 (defun lprogress (label fmt &optional value &rest args)
 564   "Print a progress gauge and message in the bottom gutter area of the frame.
 565 First argument LABEL is an identifier for this progress gauge.  The rest of the
 566 arguments are the same as to `format'."
 567   (if (and (null fmt) (null args))
 568       (prog1 nil
 569         (clear-progress label nil))
 570     (let ((str (apply 'format fmt args)))
 571       (display-progress label str value)
 572       str)))
 573
 574 (provide 'gutter-items)
 575 ;;; gutter-items.el ends here.