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   (save-match-data
 209     (let* ((buffers (delete-if buffers-tab-omit-function (buffer-list frame)))
 210            (first-buf (car buffers)))
 211       ;; if we're in deletion ignore the current buffer
 212       (when in-deletion
 213         (setq buffers (delq (current-buffer) buffers))
 214         (setq first-buf (car buffers)))
 215       ;; group buffers by mode
 216       (when buffers-tab-selection-function
 217         (delete-if-not #'(lambda (buf)
 218                            (funcall buffers-tab-selection-function
 219                                     first-buf buf)) buffers))
 220       (and (integerp buffers-tab-max-size)
 221            (> buffers-tab-max-size 1)
 222            (> (length buffers) buffers-tab-max-size)
 223            ;; shorten list of buffers
 224            (setcdr (nthcdr buffers-tab-max-size buffers) nil))
 225       (setq buffers (build-buffers-tab-internal buffers))
 226       buffers)))
 227
 228 (defun add-tab-to-gutter ()
 229   "Put a tab control in the gutter area to hold the most recent buffers."
 230   (let ((gutter-string ""))
 231     (set-extent-begin-glyph
 232      (make-extent 0 0 gutter-string)
 233      (setq gutter-buffers-tab
 234            (make-glyph
 235             (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
 236                     :properties (list :items (buffers-tab-items))))))
 237     ;; This looks better than a 3d border
 238     (mapcar '(lambda (x)
 239                (when (valid-image-instantiator-format-p 'tab-control x)
 240                  (set-specifier default-gutter-border-width 0 'global x)
 241                  (set-specifier default-gutter gutter-string 'global x)))
 242             (console-type-list))))
 243
 244 (defun update-tab-in-gutter (&optional frame-or-buffer)
 245   "Update the tab control in the gutter area."
 246   (let ((locale (if (framep frame-or-buffer) frame-or-buffer)))
 247     (when (specifier-instance default-gutter-visible-p locale)
 248       (unless gutter-buffers-tab
 249         (add-tab-to-gutter))
 250       (when (valid-image-instantiator-format-p 'tab-control)
 251         (let ((inst (glyph-image-instance
 252                      gutter-buffers-tab
 253                      (when (framep frame-or-buffer)
 254                        (last-nonminibuf-window frame-or-buffer)))))
 255           (set-image-instance-property inst :items
 256                                        (buffers-tab-items
 257                                         nil locale))
 258           (resize-subwindow inst (gutter-pixel-width) nil))
 259         ))))
 260
 261 (defun remove-buffer-from-gutter-tab ()
 262   "Remove the current buffer from the tab control in the gutter area."
 263   (when (and (valid-image-instantiator-format-p 'tab-control)
 264              (specifier-instance default-gutter-visible-p))
 265     (let ((inst (glyph-image-instance gutter-buffers-tab))
 266           (buffers (buffers-tab-items t)))
 267       (unless buffers
 268         (setq buffers (build-buffers-tab-internal
 269                        (list
 270                         (get-buffer-create "*scratch*")))))
 271       (set-image-instance-property inst :items buffers)
 272       (resize-subwindow inst (gutter-pixel-width) nil)
 273       )))
 274
 275 (add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab)
 276 (add-hook 'create-frame-hook 'update-tab-in-gutter)
 277 (add-hook 'record-buffer-hook 'update-tab-in-gutter)
 278
 279 ;;
 280 ;; progress display
 281 ;; ripped off from message display
 282 ;;
 283 (defvar progress-stack nil
 284   "An alist of label/string pairs representing active progress gauges.
 285 The first element in the list is currently displayed in the gutter area.
 286 Do not modify this directly--use the `progress' or
 287 `display-progress'/`clear-progress' functions.")
 288
 289 (defvar progress-glyph-height 32
 290   "Height of the gutter area for progress messages.")
 291
 292 (defvar progress-stop-callback 'progress-quit-function
 293   "Function to call to stop the progress operation.")
 294
 295 (defun progress-quit-function ()
 296   "Default function to call for the stop button in a progress gauge.
 297 This just removes the progress gauge and calls quit."
 298   (interactive)
 299   (clear-progress)
 300   (keyboard-quit))
 301
 302 ;; private variables
 303 (defvar progress-gauge-glyph
 304   (make-glyph
 305    (vector 'progress-gauge
 306            :pixel-height (- progress-glyph-height 8)
 307            :pixel-width 250
 308            :descriptor "Progress")))
 309
 310 (defvar progress-text-glyph
 311   (make-glyph [string :data ""]))
 312
 313 (defvar progress-layout-glyph
 314   (make-glyph
 315    (vector
 316     'layout :orientation 'vertical :justify 'left
 317     :items (list
 318             progress-text-glyph
 319             (make-glyph
 320              (vector
 321               'layout :pixel-height progress-glyph-height
 322               :orientation 'horizontal
 323               :items (list
 324                       progress-gauge-glyph
 325                       (vector
 326                        'button :pixel-height (- progress-glyph-height 8)
 327                        :descriptor " Stop "
 328                        :callback '(funcall progress-stop-callback)))))))))
 329
 330 (defvar progress-abort-glyph
 331   (make-glyph
 332    (vector 'layout :orientation 'vertical :justify 'left
 333            :items (list progress-text-glyph
 334                         (make-glyph
 335                          (vector 'layout
 336                                  :pixel-height progress-glyph-height
 337                                  :orientation 'horizontal))))))
 338
 339 (defvar progress-extent-text "")
 340 (defvar progress-extent nil)
 341
 342 (defun progress-displayed-p (&optional return-string frame)
 343   "Return a non-nil value if a progress gauge is presently displayed in the
 344 gutter area.  If optional argument RETURN-STRING is non-nil,
 345 return a string containing the message, otherwise just return t."
 346   (let ((buffer (get-buffer-create " *Gutter Area*")))
 347     (and (< (point-min buffer) (point-max buffer))
 348          (if return-string
 349              (buffer-substring nil nil buffer)
 350            t))))
 351
 352 ;;; Returns the string which remains in the echo area, or nil if none.
 353 ;;; If label is nil, the whole message stack is cleared.
 354 (defun clear-progress (&optional label frame no-restore)
 355   "Remove any progress gauge with the given LABEL from the progress gauge-stack,
 356 erasing it from the gutter area if it's currently displayed there.
 357 If a message remains at the head of the progress-stack and NO-RESTORE
 358 is nil, it will be displayed.  The string which remains in the gutter
 359 area will be returned, or nil if the progress-stack is now empty.
 360 If LABEL is nil, the entire progress-stack is cleared.
 361
 362 Unless you need the return value or you need to specify a label,
 363 you should just use (progress nil)."
 364   (or frame (setq frame (selected-frame)))
 365   (remove-progress label frame)
 366   (let ((inhibit-read-only t)
 367         (zmacs-region-stays zmacs-region-stays)) ; preserve from change
 368     (erase-buffer " *Echo Area*")
 369     (erase-buffer (get-buffer-create " *Gutter Area*")))
 370   (if no-restore
 371       nil                       ; just preparing to put another msg up
 372     (if progress-stack
 373         (let ((oldmsg (cdr (car progress-stack))))
 374           (raw-append-progress oldmsg frame)
 375           oldmsg)
 376       ;; nothing to display so get rid of the gauge
 377       (set-specifier bottom-gutter-border-width 0 frame)
 378       (set-specifier bottom-gutter-visible-p nil frame))))
 379
 380 (defun remove-progress (&optional label frame)
 381   ;; If label is nil, we want to remove all matching progress gauges.
 382   (while (and progress-stack
 383               (or (null label)  ; null label means clear whole stack
 384                   (eq label (car (car progress-stack)))))
 385     (setq progress-stack (cdr progress-stack)))
 386   (let ((s  progress-stack))
 387     (while (cdr s)
 388       (let ((msg (car (cdr s))))
 389         (if (eq label (car msg))
 390             (progn
 391               (setcdr s (cdr (cdr s))))
 392           (setq s (cdr s)))))))
 393
 394 (defun append-progress (label message &optional value frame)
 395   (or frame (setq frame (selected-frame)))
 396   ;; Add a new entry to the message-stack, or modify an existing one
 397   (let* ((top (car progress-stack))
 398          (tmsg (cdr top)))
 399     (if (eq label (car top))
 400         (progn
 401           (setcdr top message)
 402           (if (eq tmsg message)
 403               (set-image-instance-property
 404                (glyph-image-instance progress-gauge-glyph)
 405                :percent value)
 406             (raw-append-progress message value frame))
 407           (redisplay-gutter-area)
 408           (when (input-pending-p)
 409             (dispatch-event (next-command-event))))
 410       (push (cons label message) progress-stack)
 411       (raw-append-progress message value frame))
 412     (when (eq value 100)
 413       (sit-for 0.5 nil)
 414       (clear-progress label))))
 415
 416 (defun abort-progress (label message &optional frame)
 417   (or frame (setq frame (selected-frame)))
 418   ;; Add a new entry to the message-stack, or modify an existing one
 419   (let* ((top (car progress-stack))
 420          (inhibit-read-only t)
 421          (zmacs-region-stays zmacs-region-stays))
 422     (if (eq label (car top))
 423         (setcdr top message)
 424       (push (cons label message) progress-stack))
 425     (unless (equal message "")
 426       (insert-string message (get-buffer-create " *Gutter Area*"))
 427       ;; Do what the device is able to cope with.
 428       (if (not (valid-image-instantiator-format-p 'progress-gauge frame))
 429           (progn
 430             (insert-string message " *Echo Area*")
 431             (if (not executing-kbd-macro)
 432                 (redisplay-echo-area)))
 433         ;; do some funky display here.
 434         (unless progress-extent
 435           (setq progress-extent (make-extent 0 0 progress-extent-text)))
 436         (let ((bglyph (extent-begin-glyph progress-extent)))
 437           (set-extent-begin-glyph progress-extent progress-abort-glyph)
 438           ;; fixup the gutter specifiers
 439           (set-specifier bottom-gutter progress-extent-text frame)
 440           (set-specifier bottom-gutter-border-width 2 frame)
 441           (set-image-instance-property
 442            (glyph-image-instance progress-text-glyph) :data message)
 443           (set-specifier bottom-gutter-height 'autodetect frame)
 444           (set-specifier bottom-gutter-visible-p t frame)
 445           ;; we have to do this so redisplay is up-to-date and so
 446           ;; redisplay-gutter-area performs optimally.
 447           (redisplay-gutter-area)
 448           (sit-for 0.5 nil)
 449           (clear-progress label)
 450           (set-extent-begin-glyph progress-extent bglyph)
 451           )))))
 452
 453 (defun raw-append-progress (message &optional value frame)
 454   (unless (equal message "")
 455     (let ((inhibit-read-only t)
 456           (zmacs-region-stays zmacs-region-stays)
 457           (val (or value 0))) ; preserve from change
 458       (insert-string message (get-buffer-create " *Gutter Area*"))
 459       ;; Do what the device is able to cope with.
 460       (if (not (valid-image-instantiator-format-p 'progress-gauge frame))
 461           (progn
 462             (insert-string
 463              (concat message (if (eq val 100) "done.")
 464                      (make-string (/ val 5) ?.))
 465              " *Echo Area*")
 466             (if (not executing-kbd-macro)
 467                 (redisplay-echo-area)))
 468         ;; do some funky display here.
 469         (unless progress-extent
 470           (setq progress-extent (make-extent 0 0 progress-extent-text))
 471           (set-extent-begin-glyph progress-extent progress-layout-glyph))
 472         ;; fixup the gutter specifiers
 473         (set-specifier bottom-gutter progress-extent-text frame)
 474         (set-specifier bottom-gutter-border-width 2 frame)
 475         (set-image-instance-property
 476          (glyph-image-instance progress-gauge-glyph) :percent val)
 477         (set-image-instance-property
 478          (glyph-image-instance progress-text-glyph) :data message)
 479         (if (and (eq (specifier-instance bottom-gutter-height frame)
 480                      'autodetect)
 481                  (specifier-instance bottom-gutter-visible-p frame))
 482             (progn
 483               ;; if the gauge is already visible then just draw the gutter
 484               ;; checking for user events
 485               (redisplay-gutter-area)
 486               (when (input-pending-p)
 487                 (dispatch-event (next-command-event))))
 488           ;; otherwise make the gutter visible and redraw the frame
 489           (set-specifier bottom-gutter-height 'autodetect frame)
 490           (set-specifier bottom-gutter-visible-p t frame)
 491           ;; we have to do this so redisplay is up-to-date and so
 492           ;; redisplay-gutter-area performs optimally.
 493           (redisplay-frame)
 494           )))))
 495
 496 (defun display-progress (label message &optional value frame)
 497   "Display a progress gauge and message in the bottom gutter area.
 498  First argument LABEL is an identifier for this message.  MESSAGE is
 499 the string to display.  Use `clear-progress' to remove a labelled
 500 message."
 501   (clear-progress label frame t)
 502   (if (eq value 'abort)
 503       (abort-progress label message frame)
 504     (append-progress label message value frame)))
 505
 506 (defun current-progress (&optional frame)
 507   "Return the current progress gauge in the gutter area, or nil.
 508 The FRAME argument is currently unused."
 509   (cdr (car progress-stack)))
 510
 511 ;;; may eventually be frame-dependent
 512 (defun current-progress-label (&optional frame)
 513   (car (car progress-stack)))
 514
 515 (defun progress (fmt &optional value &rest args)
 516   "Print a progress gauge and message in the bottom gutter area of the frame.
 517 The arguments are the same as to `format'.
 518
 519 If the only argument is nil, clear any existing progress gauge."
 520   (if (and (null fmt) (null args))
 521       (prog1 nil
 522         (clear-progress nil))
 523     (let ((str (apply 'format fmt args)))
 524       (display-progress 'progress str value)
 525       str)))
 526
 527 (defun lprogress (label fmt &optional value &rest args)
 528   "Print a progress gauge and message in the bottom gutter area of the frame.
 529 First argument LABEL is an identifier for this progress gauge.  The rest of the
 530 arguments are the same as to `format'."
 531   (if (and (null fmt) (null args))
 532       (prog1 nil
 533         (clear-progress label nil))
 534     (let ((str (apply 'format fmt args)))
 535       (display-progress label str value)
 536       str)))
 537
 538 (provide 'gutter-items)
 539 ;;; gutter-items.el ends here.