Mercurial > hg > xemacs-beta

comparison lisp/gutter-items.el @ 438:84b14dcb0985 r21-2-27

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-27
author cvs
date Mon, 13 Aug 2007 11:32:25 +0200
parents a5df635868b2
children 8de8e3f6228a
comparison
equal deleted inserted replaced
437:e2a4e8b94b82 438:84b14dcb0985
37 :group 'display 37 :group 'display
38 :type 'boolean 38 :type 'boolean
39 :set #'(lambda (var val) 39 :set #'(lambda (var val)
40 (set-specifier default-gutter-visible-p val) 40 (set-specifier default-gutter-visible-p val)
41 (setq gutter-visible-p val))) 41 (setq gutter-visible-p val)))
42
43 (defvar gutter-buffers-tab nil
44 "A tab widget in the gutter for displaying buffers.
45 Do not set this. Use `glyph-image-instance' and
46 `set-image-instance-property' to change the properties of the tab.")
42 47
43 (defcustom default-gutter-position 48 (defcustom default-gutter-position
44 (default-gutter-position) 49 (default-gutter-position)
45 "The location of the default gutter. It can be 'top, 'bottom, 'left or 50 "The location of the default gutter. It can be 'top, 'bottom, 'left or
46 'right. This option can be customized through the options menu." 51 'right. This option can be customized through the options menu."
49 (const :tag "bottom" 'bottom) 54 (const :tag "bottom" 'bottom)
50 (const :tag "left" 'left) 55 (const :tag "left" 'left)
51 (const :tag "right" 'right)) 56 (const :tag "right" 'right))
52 :set #'(lambda (var val) 57 :set #'(lambda (var val)
53 (set-default-gutter-position val) 58 (set-default-gutter-position val)
54 (setq default-gutter-position val))) 59 (setq default-gutter-position val)
60 (when gutter-buffers-tab (update-tab-in-gutter))))
55 61
56 ;;; The Buffers tab 62 ;;; The Buffers tab
57 63
58 (defgroup buffers-tab nil 64 (defgroup buffers-tab nil
59 "Customization of `Buffers' tab." 65 "Customization of `Buffers' tab."
60 :group 'gutter) 66 :group 'gutter)
61 67
62 (defvar gutter-buffers-tab nil 68 (defvar gutter-buffers-tab-orientation 'top
63 "A tab widget in the gutter for displaying buffers. 69 "Where the buffers tab currently is. Do not set this.")
64 Do not set this. Use `glyph-image-instance' and 70
65 `set-image-instance-property' to change the properties of the tab.") 71 (defvar gutter-buffers-tab-extent nil)
66 72
67 (defcustom buffers-tab-max-size 6 73 (defcustom buffers-tab-max-size 6
68 "*Maximum number of entries which may appear on the \"Buffers\" tab. 74 "*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 75 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 76 shown. If this is nil, then all buffers will be shown. Setting this to
100 106
101 :type '(choice (const :tag "None" nil) 107 :type '(choice (const :tag "None" nil)
102 function) 108 function)
103 :group 'buffers-tab) 109 :group 'buffers-tab)
104 110
105 (defcustom buffers-tab-face 'default 111 (make-face 'buffers-tab "Face for displaying the buffers tab.")
112 (set-face-parent 'buffers-tab 'default)
113
114 (defcustom buffers-tab-face 'buffers-tab
106 "*Face to use for displaying the buffers tab." 115 "*Face to use for displaying the buffers tab."
107 :type 'face 116 :type 'face
108 :group 'buffers-tab) 117 :group 'buffers-tab)
109 118
110 (defcustom buffers-tab-grouping-regexp 119 (defcustom buffers-tab-grouping-regexp
225 (setq buffers (build-buffers-tab-internal buffers)) 234 (setq buffers (build-buffers-tab-internal buffers))
226 buffers))) 235 buffers)))
227 236
228 (defun add-tab-to-gutter () 237 (defun add-tab-to-gutter ()
229 "Put a tab control in the gutter area to hold the most recent buffers." 238 "Put a tab control in the gutter area to hold the most recent buffers."
239 (setq gutter-buffers-tab-orientation (default-gutter-position))
230 (let ((gutter-string "")) 240 (let ((gutter-string ""))
241 (unless gutter-buffers-tab-extent
242 (setq gutter-buffers-tab-extent (make-extent 0 0 gutter-string)))
231 (set-extent-begin-glyph 243 (set-extent-begin-glyph
232 (make-extent 0 0 gutter-string) 244 gutter-buffers-tab-extent
233 (setq gutter-buffers-tab 245 (setq gutter-buffers-tab
234 (make-glyph 246 (make-glyph
235 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face 247 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
248 :orientation gutter-buffers-tab-orientation
236 :properties (list :items (buffers-tab-items)))))) 249 :properties (list :items (buffers-tab-items))))))
237 ;; This looks better than a 3d border 250 ;; This looks better than a 3d border
238 (mapcar '(lambda (x) 251 (mapcar '(lambda (x)
239 (when (valid-image-instantiator-format-p 'tab-control x) 252 (when (valid-image-instantiator-format-p 'tab-control x)
240 (set-specifier default-gutter-border-width 0 'global x) 253 (set-specifier default-gutter-border-width 0 'global x)
241 (set-specifier default-gutter gutter-string 'global x))) 254 (set-specifier top-gutter nil 'global x)
255 (set-specifier bottom-gutter nil 'global x)
256 (set-specifier left-gutter nil 'global x)
257 (set-specifier right-gutter nil 'global x)
258 (set-specifier left-gutter-width 0 'global x)
259 (set-specifier right-gutter-width 0 'global x)
260 (cond ((eq gutter-buffers-tab-orientation 'top)
261 (set-specifier top-gutter gutter-string 'global x))
262 ((eq gutter-buffers-tab-orientation 'bottom)
263 (set-specifier bottom-gutter gutter-string 'global x))
264 ((eq gutter-buffers-tab-orientation 'left)
265 (set-specifier left-gutter gutter-string 'global x)
266 (set-specifier left-gutter-width
267 (glyph-width gutter-buffers-tab)
268 'global x))
269 ((eq gutter-buffers-tab-orientation 'right)
270 (set-specifier right-gutter gutter-string 'global x)
271 (set-specifier right-gutter-width
272 (glyph-width gutter-buffers-tab)
273 'global x))
274 )))
242 (console-type-list)))) 275 (console-type-list))))
243 276
244 (defun update-tab-in-gutter (&optional frame-or-buffer) 277 (defun update-tab-in-gutter (&optional frame-or-buffer)
245 "Update the tab control in the gutter area." 278 "Update the tab control in the gutter area."
246 (let ((locale (if (framep frame-or-buffer) frame-or-buffer))) 279 (let ((locale (if (framep frame-or-buffer) frame-or-buffer)))
247 (when (specifier-instance default-gutter-visible-p locale) 280 (when (specifier-instance default-gutter-visible-p locale)
248 (unless gutter-buffers-tab 281 (unless (and gutter-buffers-tab
282 (eq (default-gutter-position)
283 gutter-buffers-tab-orientation))
249 (add-tab-to-gutter)) 284 (add-tab-to-gutter))
250 (when (valid-image-instantiator-format-p 'tab-control) 285 (when (valid-image-instantiator-format-p 'tab-control)
251 (let ((inst (glyph-image-instance 286 (let ((inst (glyph-image-instance
252 gutter-buffers-tab 287 gutter-buffers-tab
253 (when (framep frame-or-buffer) 288 (when (framep frame-or-buffer)
254 (last-nonminibuf-window frame-or-buffer))))) 289 (last-nonminibuf-window frame-or-buffer)))))
255 (set-image-instance-property inst :items 290 (set-image-instance-property inst :items
256 (buffers-tab-items 291 (buffers-tab-items
257 nil locale)) 292 nil locale)))))))
258 (resize-subwindow inst (gutter-pixel-width) nil))
259 ))))
260 293
261 (defun remove-buffer-from-gutter-tab () 294 (defun remove-buffer-from-gutter-tab ()
262 "Remove the current buffer from the tab control in the gutter area." 295 "Remove the current buffer from the tab control in the gutter area."
263 (when (and (valid-image-instantiator-format-p 'tab-control) 296 (when (and (valid-image-instantiator-format-p 'tab-control)
264 (specifier-instance default-gutter-visible-p)) 297 (specifier-instance default-gutter-visible-p))
266 (buffers (buffers-tab-items t))) 299 (buffers (buffers-tab-items t)))
267 (unless buffers 300 (unless buffers
268 (setq buffers (build-buffers-tab-internal 301 (setq buffers (build-buffers-tab-internal
269 (list 302 (list
270 (get-buffer-create "*scratch*"))))) 303 (get-buffer-create "*scratch*")))))
271 (set-image-instance-property inst :items buffers) 304 (set-image-instance-property inst :items buffers))))
272 (resize-subwindow inst (gutter-pixel-width) nil)
273 )))
274 305
275 (add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab) 306 (add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab)
276 (add-hook 'create-frame-hook 'update-tab-in-gutter) 307 (add-hook 'create-frame-hook 'update-tab-in-gutter)
277 (add-hook 'record-buffer-hook 'update-tab-in-gutter) 308 (add-hook 'record-buffer-hook 'update-tab-in-gutter)
278 309