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