XEmacs 21.2.28 "Hermes".

[chise/xemacs-chise.git.1] / lisp / gutter-items.el

diff --git a/lisp/gutter-items.el b/lisp/gutter-items.el
index 6b0b8f0..7f50e18 100644 (file)
--- a/lisp/gutter-items.el
+++ b/lisp/gutter-items.el
@@ -30,6 +30,11 @@
   "Input from the gutters."
   :group 'environment)
 
+(defvar gutter-buffers-tab nil
+  "A tab widget in the gutter for displaying buffers.
+Do not set this. Use `glyph-image-instance' and
+`set-image-instance-property' to change the properties of the tab.")
+
 (defcustom gutter-visible-p 
   (specifier-instance default-gutter-visible-p)
   "Whether the default gutter is globally visible. This option can be
@@ -38,7 +43,8 @@ customized through the options menu."
   :type 'boolean
   :set #'(lambda (var val)
           (set-specifier default-gutter-visible-p val)
-          (setq gutter-visible-p val)))
+          (setq gutter-visible-p val)
+          (when gutter-buffers-tab (update-tab-in-gutter))))
 
 (defcustom default-gutter-position
   (default-gutter-position)
@@ -51,7 +57,8 @@ customized through the options menu."
                 (const :tag "right" 'right))
   :set #'(lambda (var val)
           (set-default-gutter-position val)
-          (setq default-gutter-position val)))
+          (setq default-gutter-position val)
+          (when gutter-buffers-tab (update-tab-in-gutter))))
 
 ;;; The Buffers tab
 
@@ -59,10 +66,10 @@ customized through the options menu."
   "Customization of `Buffers' tab."
   :group 'gutter)
 
-(defvar gutter-buffers-tab nil
-  "A tab widget in the gutter for displaying buffers.
-Do not set this. Use `glyph-image-instance' and
-`set-image-instance-property' to change the properties of the tab.")
+(defvar gutter-buffers-tab-orientation 'top
+  "Where the buffers tab currently is. Do not set this.")
+
+(defvar gutter-buffers-tab-extent nil)
 
 (defcustom buffers-tab-max-size 6
   "*Maximum number of entries which may appear on the \"Buffers\" tab.
@@ -102,7 +109,10 @@ by `buffers-tab-grouping-regexp'."
                 function)
   :group 'buffers-tab)
 
-(defcustom buffers-tab-face 'default
+(make-face 'buffers-tab "Face for displaying the buffers tab.")
+(set-face-parent 'buffers-tab 'default)
+
+(defcustom buffers-tab-face 'buffers-tab
   "*Face to use for displaying the buffers tab."
   :type 'face
   :group 'buffers-tab)
@@ -184,8 +194,12 @@ This just returns the buffer's name, optionally truncated."
   (let ((len (specifier-instance buffers-tab-default-buffer-line-length)))
     (if (and (> len 0)
             (> (length (buffer-name buffer)) len))
-       (concat (substring (buffer-name buffer) 
-                          0 (- len 3)) "...")
+       (if (string-match ".*<.>$" (buffer-name buffer))
+           (concat (substring (buffer-name buffer) 
+                              0 (- len 6)) "..."
+                              (substring (buffer-name buffer) -3))
+         (concat (substring (buffer-name buffer)
+                            0 (- len 3)) "..."))
       (buffer-name buffer))))
 
 (defsubst build-buffers-tab-internal (buffers)
@@ -227,36 +241,60 @@ items by redefining the function `format-buffers-menu-line'."
 
 (defun add-tab-to-gutter ()
   "Put a tab control in the gutter area to hold the most recent buffers."
+  (setq gutter-buffers-tab-orientation (default-gutter-position))
   (let ((gutter-string ""))
+    (unless gutter-buffers-tab-extent
+      (setq gutter-buffers-tab-extent (make-extent 0 0 gutter-string)))
     (set-extent-begin-glyph 
-     (make-extent 0 0 gutter-string)
+     gutter-buffers-tab-extent
      (setq gutter-buffers-tab 
           (make-glyph 
            (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
+                   :orientation gutter-buffers-tab-orientation
                    :properties (list :items (buffers-tab-items))))))
     ;; This looks better than a 3d border
     (mapcar '(lambda (x)
               (when (valid-image-instantiator-format-p 'tab-control x)
                 (set-specifier default-gutter-border-width 0 'global x)
-                (set-specifier default-gutter gutter-string 'global x)))
+                (set-specifier top-gutter nil 'global x)
+                (set-specifier bottom-gutter nil 'global x)
+                (set-specifier left-gutter nil 'global x)
+                (set-specifier right-gutter nil 'global x)
+                (set-specifier left-gutter-width 0 'global x)
+                (set-specifier right-gutter-width 0 'global x)
+                (cond ((eq gutter-buffers-tab-orientation 'top)
+                       (set-specifier top-gutter gutter-string 'global x))
+                      ((eq gutter-buffers-tab-orientation 'bottom)
+                       (set-specifier bottom-gutter gutter-string 'global x))
+                      ((eq gutter-buffers-tab-orientation 'left)
+                       (set-specifier left-gutter gutter-string 'global x)
+                       (set-specifier left-gutter-width
+                                      (glyph-width gutter-buffers-tab)
+                                      'global x))
+                      ((eq gutter-buffers-tab-orientation 'right)
+                       (set-specifier right-gutter gutter-string 'global x)
+                       (set-specifier right-gutter-width
+                                      (glyph-width gutter-buffers-tab)
+                                      'global x))
+                      )))
            (console-type-list))))
 
 (defun update-tab-in-gutter (&optional frame-or-buffer)
   "Update the tab control in the gutter area."
   (let ((locale (if (framep frame-or-buffer) frame-or-buffer)))
     (when (specifier-instance default-gutter-visible-p locale)
-      (unless gutter-buffers-tab 
+      (unless (and gutter-buffers-tab 
+                  (eq (default-gutter-position)
+                      gutter-buffers-tab-orientation))
        (add-tab-to-gutter))
-      (when (valid-image-instantiator-format-p 'tab-control)
+      (when (valid-image-instantiator-format-p 'tab-control locale)
        (let ((inst (glyph-image-instance 
                     gutter-buffers-tab
                     (when (framep frame-or-buffer)
                       (last-nonminibuf-window frame-or-buffer)))))
          (set-image-instance-property inst :items 
                                       (buffers-tab-items 
-                                       nil locale))
-         (resize-subwindow inst (gutter-pixel-width) nil))
-       ))))
+                                       nil locale)))))))
 
 (defun remove-buffer-from-gutter-tab ()
   "Remove the current buffer from the tab control in the gutter area."
@@ -268,9 +306,7 @@ items by redefining the function `format-buffers-menu-line'."
        (setq buffers (build-buffers-tab-internal 
                       (list 
                        (get-buffer-create "*scratch*")))))
-      (set-image-instance-property inst :items buffers)
-      (resize-subwindow inst (gutter-pixel-width) nil)
-      )))
+      (set-image-instance-property inst :items buffers))))
 
 (add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab)
 (add-hook 'create-frame-hook 'update-tab-in-gutter)
@@ -304,7 +340,7 @@ This just removes the progress gauge and calls quit."
   (make-glyph
    (vector 'progress-gauge
           :pixel-height (- progress-glyph-height 8)
-          :pixel-width 250
+          :pixel-width 50
           :descriptor "Progress")))
 
 (defvar progress-text-glyph