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