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 10))
  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-format-buffer-line-function 'format-buffers-menu-line
  95   "*The function to call to return a string to represent a buffer in the
  96 buffers tab.  The function is passed a buffer and should return a string.
  97 The default value `format-buffers-menu-line' just returns the name of
  98 the buffer.  Also check out `slow-format-buffers-menu-line' which
  99 returns a whole bunch of info about a buffer."
 100   :type 'function
 101   :group 'buffers-tab)
 102
 103 (defun buffers-tab-switch-to-buffer (buffer)
 104   "For use as a value for `buffers-tab-switch-to-buffer-function'."
 105   (switch-to-buffer buffer t))
 106
 107 (defsubst build-buffers-tab-internal (buffers)
 108   (let (line)
 109     (mapcar
 110      #'(lambda (buffer)
 111          (setq line (funcall buffers-tab-format-buffer-line-function
 112                              buffer))
 113          (vector line (list buffers-tab-switch-to-buffer-function
 114                             (buffer-name buffer))))
 115      buffers)))
 116
 117 (defun buffers-tab-items ()
 118   "This is the tab filter for the top-level buffers \"Buffers\" tab.
 119 It dynamically creates a list of buffers to use as the contents of the tab.
 120 Only the most-recently-used few buffers will be listed on the tab, for
 121 efficiency reasons.  You can control how many buffers will be shown by
 122 setting `buffers-tab-max-size'.  You can control the text of the tab
 123 items by redefining the function `format-buffers-menu-line'."
 124   (let ((buffers (delete-if buffers-tab-omit-function (buffer-list))))
 125     (and (integerp buffers-tab-max-size)
 126          (> buffers-tab-max-size 1)
 127          (> (length buffers) buffers-tab-max-size)
 128          ;; shorten list of buffers
 129          (setcdr (nthcdr buffers-tab-max-size buffers) nil))
 130     (setq buffers (build-buffers-tab-internal buffers))
 131     buffers))
 132
 133 (defun add-tab-to-gutter ()
 134   "Put a tab control in the gutter area to hold the most recent buffers."
 135   (let ((gutter-string ""))
 136     (set-extent-begin-glyph
 137      (make-extent 0 0 gutter-string)
 138      (setq gutter-buffers-tab
 139            (make-glyph
 140             (vector 'tab-control :descriptor "Buffers"
 141                     :properties (list :items (buffers-tab-items))))))
 142     ;; This looks better than a 3d border
 143     (set-specifier default-gutter-border-width 0 'global 'mswindows)
 144     (set-specifier default-gutter gutter-string 'global 'mswindows)))
 145
 146 (defun update-tab-in-gutter (&optional notused)
 147   "Update the tab control in the gutter area."
 148   (when (valid-image-instantiator-format-p 'tab-control)
 149     (set-image-instance-property (glyph-image-instance gutter-buffers-tab)
 150                                  :items
 151                                  (buffers-tab-items))
 152     (resize-subwindow (glyph-image-instance gutter-buffers-tab)
 153                       (gutter-pixel-width) nil)))
 154
 155 (add-tab-to-gutter)
 156 (add-hook 'switch-to-buffer-hooks 'update-tab-in-gutter)
 157 (add-hook 'create-frame-hook 'update-tab-in-gutter)
 158
 159 (provide 'gutter-items)
 160 ;;; gutter-items.el ends here.