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