Mercurial > hg > xemacs-beta

comparison lisp/gutter-items.el @ 408:501cfd01ee6d r21-2-34

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-34
author cvs
date Mon, 13 Aug 2007 11:18:11 +0200
parents b8cc9ab3f761
children
comparison
equal deleted inserted replaced
407:ed6218a7d4d3 408:501cfd01ee6d
31 "Customization of `Buffers' tab." 31 "Customization of `Buffers' tab."
32 :group 'gutter) 32 :group 'gutter)
33 33
34 (defvar gutter-buffers-tab nil 34 (defvar gutter-buffers-tab nil
35 "A tab widget in the gutter for displaying buffers. 35 "A tab widget in the gutter for displaying buffers.
36 Do not set this. Use `glyph-image-instance' and 36 Do not set this. Use `set-glyph-image' to change the properties of the tab.")
37 `set-image-instance-property' to change the properties of the tab.")
38 37
39 (defcustom gutter-buffers-tab-visible-p 38 (defcustom gutter-buffers-tab-visible-p
40 (gutter-element-visible-p default-gutter-visible-p 'buffers-tab) 39 (gutter-element-visible-p default-gutter-visible-p 'buffers-tab)
41 "Whether the buffers tab is globally visible. 40 "Whether the buffers tab is globally visible.
42 This option should be set through the options menu." 41 This option should be set through the options menu."
276 (unless gutter-buffers-tab-extent 275 (unless gutter-buffers-tab-extent
277 (setq gutter-buffers-tab-extent (make-extent 0 1 gutter-string))) 276 (setq gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
278 (set-extent-begin-glyph 277 (set-extent-begin-glyph
279 gutter-buffers-tab-extent 278 gutter-buffers-tab-extent
280 (setq gutter-buffers-tab 279 (setq gutter-buffers-tab
281 (make-glyph 280 (make-glyph)))
282 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
283 :orientation gutter-buffers-tab-orientation
284 (if (or (eq gutter-buffers-tab-orientation 'top)
285 (eq gutter-buffers-tab-orientation 'bottom))
286 :pixel-width :pixel-height)
287 (if (or (eq gutter-buffers-tab-orientation 'top)
288 (eq gutter-buffers-tab-orientation 'bottom))
289 '(gutter-pixel-width) '(gutter-pixel-height))
290 :properties (list :items (buffers-tab-items nil nil t))))))
291 281
292 ;; Nuke all existing tabs 282 ;; Nuke all existing tabs
293 (remove-gutter-element top-gutter 'buffers-tab) 283 (remove-gutter-element top-gutter 'buffers-tab)
294 (remove-gutter-element bottom-gutter 'buffers-tab) 284 (remove-gutter-element bottom-gutter 'buffers-tab)
295 (remove-gutter-element left-gutter 'buffers-tab) 285 (remove-gutter-element left-gutter 'buffers-tab)
322 (glyph-width gutter-buffers-tab) 312 (glyph-width gutter-buffers-tab)
323 'global x)) 313 'global x))
324 ))) 314 )))
325 (console-type-list)))) 315 (console-type-list))))
326 316
327 (defun update-tab-in-gutter (&optional frame-or-buffer force-selection) 317 (defun update-tab-in-gutter (frame &optional force-selection)
328 "Update the tab control in the gutter area." 318 "Update the tab control in the gutter area."
329 (let ((locale (if (framep frame-or-buffer) frame-or-buffer)))
330 ;; dedicated frames don't get tabs 319 ;; dedicated frames don't get tabs
331 (unless (and (framep locale) 320 (unless (window-dedicated-p (frame-selected-window frame))
332 (window-dedicated-p (frame-selected-window locale))) 321 (when (specifier-instance default-gutter-visible-p frame)
333 (when (specifier-instance default-gutter-visible-p locale) 322 (unless (and gutter-buffers-tab
334 (unless (and gutter-buffers-tab 323 (eq (default-gutter-position)
335 (eq (default-gutter-position) 324 gutter-buffers-tab-orientation))
336 gutter-buffers-tab-orientation)) 325 (add-tab-to-gutter))
337 (add-tab-to-gutter)) 326 (when (valid-image-instantiator-format-p 'tab-control frame)
338 (when (valid-image-instantiator-format-p 'tab-control locale) 327 (set-glyph-image
339 (let ((inst (glyph-image-instance 328 gutter-buffers-tab
340 gutter-buffers-tab 329 (vector 'tab-control :descriptor "Buffers" :face buffers-tab-face
341 (when (framep frame-or-buffer) 330 :orientation gutter-buffers-tab-orientation
342 (last-nonminibuf-window frame-or-buffer))))) 331 (if (or (eq gutter-buffers-tab-orientation 'top)
343 (set-image-instance-property inst :items 332 (eq gutter-buffers-tab-orientation 'bottom))
344 (buffers-tab-items 333 :pixel-width :pixel-height)
345 nil locale force-selection)))))))) 334 (if (or (eq gutter-buffers-tab-orientation 'top)
346 335 (eq gutter-buffers-tab-orientation 'bottom))
347 (defun remove-buffer-from-gutter-tab () 336 '(gutter-pixel-width) '(gutter-pixel-height))
348 "Remove the current buffer from the tab control in the gutter area." 337 :properties
349 (when (and (valid-image-instantiator-format-p 'tab-control) 338 (list :items
350 (specifier-instance default-gutter-visible-p)) 339 (buffers-tab-items nil frame force-selection)))
351 (let ((inst (glyph-image-instance gutter-buffers-tab)) 340 frame)))))
352 (buffers (buffers-tab-items t)))
353 (unless buffers
354 (setq buffers (build-buffers-tab-internal
355 (list
356 (get-buffer-create "*scratch*")))))
357 (set-image-instance-property inst :items buffers))))
358 341
359 ;; A myriad of different update hooks all doing slightly different things 342 ;; A myriad of different update hooks all doing slightly different things
360 (add-hook 'kill-buffer-hook 'remove-buffer-from-gutter-tab)
361 (add-hook 'create-frame-hook 343 (add-hook 'create-frame-hook
362 #'(lambda (frame) 344 #'(lambda (frame)
363 (when gutter-buffers-tab (update-tab-in-gutter frame t)))) 345 (when gutter-buffers-tab (update-tab-in-gutter frame t))))
364 (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter) 346 (add-hook 'buffer-list-changed-hook 'update-tab-in-gutter)
365 (add-hook 'default-gutter-position-changed-hook 347 (add-hook 'default-gutter-position-changed-hook
366 #'(lambda () 348 #'(lambda ()
367 (when gutter-buffers-tab (update-tab-in-gutter)))) 349 (when gutter-buffers-tab
350 (mapc #'update-tab-in-gutter (frame-list)))))
368 (add-hook 'gutter-element-visibility-changed-hook 351 (add-hook 'gutter-element-visibility-changed-hook
369 #'(lambda (prop visible-p) 352 #'(lambda (prop visible-p)
370 (when (and (eq prop 'buffers-tab) visible-p) 353 (when (and (eq prop 'buffers-tab) visible-p)
371 (update-tab-in-gutter)))) 354 (mapc #'update-tab-in-gutter (frame-list)))))
372
373 ;; 355 ;;
374 ;; progress display 356 ;; progress display
375 ;; ripped off from message display 357 ;; ripped off from message display
376 ;; 358 ;;
377 (defcustom progress-display-use-echo-area nil 359 (defcustom progress-display-use-echo-area nil
380 are available on the current console. If non-NIL then progress display will be 362 are available on the current console. If non-NIL then progress display will be
381 textual and displayed in the echo area." 363 textual and displayed in the echo area."
382 :type 'boolean 364 :type 'boolean
383 :group 'gutter) 365 :group 'gutter)
384 366
385 (defvar progress-glyph-height 32 367 (defvar progress-glyph-height 24
386 "Height of the gutter area for progress messages.") 368 "Height of the progress gauge glyph.")
387 369
388 (defvar progress-display-popup-period 0.5 370 (defvar progress-display-popup-period 0.5
389 "The time that the progress gauge should remain up after completion") 371 "The time that the progress gauge should remain up after completion")
390 372
391 ;; private variables 373 ;; private variables
394 376
395 (defvar progress-layout-glyph nil) 377 (defvar progress-layout-glyph nil)
396 (defvar progress-gauge-glyph 378 (defvar progress-gauge-glyph
397 (make-glyph 379 (make-glyph
398 `[progress-gauge 380 `[progress-gauge
399 :pixel-height (- progress-glyph-height 8) 381 :pixel-height (eval progress-glyph-height)
400 :pixel-width 250 382 :pixel-width 250
401 :descriptor "Progress"])) 383 :descriptor "Progress"]))
402 384
403 (defun set-progress-display-style (style) 385 (defun set-progress-display-style (style)
404 "Control the appearance of the progress gauge. 386 "Control the appearance of the progress gauge.
405 If STYLE is 'large, the default, then the progress-display text is 387 If STYLE is 'large, the default, then the progress-display text is
406 displayed above the gauge itself. If STYLE is 'small then the gauge 388 displayed above the gauge itself. If STYLE is 'small then the gauge
407 and text are arranged side-by-side." 389 and text are arranged side-by-side."
408 (cond 390 (cond
409 ((eq style 'small) 391 ((eq style 'small)
410 (setq progress-glyph-height 24) 392 (setq progress-glyph-height 16)
411 (setq progress-layout-glyph 393 (setq progress-layout-glyph
412 (make-glyph 394 (make-glyph
413 `[layout 395 `[layout
414 :orientation horizontal 396 :orientation horizontal
397 :margin-width 4
415 :items (,progress-gauge-glyph 398 :items (,progress-gauge-glyph
416 [button 399 [button
417 :pixel-height (- progress-glyph-height 8) 400 :pixel-height (eval progress-glyph-height)
418 ;; 'quit is special and acts "asynchronously". 401 ;; 'quit is special and acts "asynchronously".
419 :descriptor "Stop" :callback 'quit] 402 :descriptor "Stop" :callback 'quit]
420 ,progress-text-glyph)]))) 403 ,progress-text-glyph)])))
421 (t 404 (t
422 (setq progress-glyph-height 32) 405 (setq progress-glyph-height 24)
423 (setq progress-layout-glyph 406 (setq progress-layout-glyph
424 (make-glyph 407 (make-glyph
425 `[layout 408 `[layout
426 :orientation vertical :justify left 409 :orientation vertical :justify left
410 :margin-width 4
427 :items (,progress-text-glyph 411 :items (,progress-text-glyph
428 [layout 412 [layout
429 :pixel-height (eval progress-glyph-height)
430 :orientation horizontal 413 :orientation horizontal
431 :items (,progress-gauge-glyph 414 :items (,progress-gauge-glyph
432 [button 415 [button
433 :pixel-height (- progress-glyph-height 8) 416 :pixel-height (eval progress-glyph-height)
434 :descriptor " Stop " 417 :descriptor " Stop "
435 ;; 'quit is special and acts "asynchronously". 418 ;; 'quit is special and acts "asynchronously".
436 :callback 'quit])])]))))) 419 :callback 'quit])])])))))
437 420
438 (defcustom progress-display-style 'large 421 (defcustom progress-display-style 'large
455 (defvar progress-abort-glyph 438 (defvar progress-abort-glyph
456 (make-glyph 439 (make-glyph
457 `[layout :orientation vertical :justify left 440 `[layout :orientation vertical :justify left
458 :items (,progress-text-glyph 441 :items (,progress-text-glyph
459 [layout 442 [layout
443 :margin-width 4
460 :pixel-height progress-glyph-height 444 :pixel-height progress-glyph-height
461 :orientation horizontal])])) 445 :orientation horizontal])]))
462 446
463 (defun progress-displayed-p (&optional return-string frame) 447 (defun progress-displayed-p (&optional return-string frame)
464 "Return a non-nil value if a progress gauge is presently displayed in the 448 "Return a non-nil value if a progress gauge is presently displayed in the
535 (tmsg (cdr top))) 519 (tmsg (cdr top)))
536 (if (eq label (car top)) 520 (if (eq label (car top))
537 (progn 521 (progn
538 (setcdr top message) 522 (setcdr top message)
539 (if (equal tmsg message) 523 (if (equal tmsg message)
524 ;; #### use of set-image-instance-property is wrong.
525 ;; use set-glyph-image instead.
540 (set-image-instance-property 526 (set-image-instance-property
541 (glyph-image-instance progress-gauge-glyph 527 (glyph-image-instance progress-gauge-glyph
542 (frame-selected-window frame)) 528 (frame-selected-window frame))
543 :value value) 529 :value value)
544 (raw-append-progress-display message value frame)) 530 (raw-append-progress-display message value frame))
570 ;; do some funky display here. 556 ;; do some funky display here.
571 (set-extent-begin-glyph ext progress-abort-glyph) 557 (set-extent-begin-glyph ext progress-abort-glyph)
572 ;; fixup the gutter specifiers 558 ;; fixup the gutter specifiers
573 (set-gutter-element bottom-gutter 'progress gutter-string frame) 559 (set-gutter-element bottom-gutter 'progress gutter-string frame)
574 (set-specifier bottom-gutter-border-width 2 frame) 560 (set-specifier bottom-gutter-border-width 2 frame)
561 ;; #### use of set-image-instance-property is wrong.
562 ;; use set-glyph-image instead.
575 (set-image-instance-property 563 (set-image-instance-property
576 (glyph-image-instance progress-text-glyph 564 (glyph-image-instance progress-text-glyph
577 (frame-selected-window frame)) :data message) 565 (frame-selected-window frame)) :data message)
578 (set-specifier bottom-gutter-height 'autodetect frame) 566 (set-specifier bottom-gutter-height 'autodetect frame)
579 (set-gutter-element-visible-p bottom-gutter-visible-p 567 (set-gutter-element-visible-p bottom-gutter-visible-p
598 ;; do some funky display here. 586 ;; do some funky display here.
599 (set-extent-begin-glyph ext progress-layout-glyph) 587 (set-extent-begin-glyph ext progress-layout-glyph)
600 ;; fixup the gutter specifiers 588 ;; fixup the gutter specifiers
601 (set-gutter-element bottom-gutter 'progress gutter-string frame) 589 (set-gutter-element bottom-gutter 'progress gutter-string frame)
602 (set-specifier bottom-gutter-border-width 2 frame) 590 (set-specifier bottom-gutter-border-width 2 frame)
591 ;; #### use of set-image-instance-property is wrong.
592 ;; use set-glyph-image instead.
603 (set-image-instance-property 593 (set-image-instance-property
604 (glyph-image-instance progress-gauge-glyph 594 (glyph-image-instance progress-gauge-glyph
605 (frame-selected-window frame)) 595 (frame-selected-window frame))
606 :value val) 596 :value val)
607 (set-image-instance-property 597 (set-image-instance-property