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