Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-window.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents c0c698873ce1
children 4be1180a9e89
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;;; Window management code for VM 1 ;;; Window management code for VM
2 ;;; Copyright (C) 1989, 1990, 1991, 1993, 1994, 1995 Kyle E. Jones 2 ;;; Copyright (C) 1989-1997 Kyle E. Jones
3 ;;; 3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify 4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by 5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 1, or (at your option) 6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version. 7 ;;; any later version.
15 ;;; along with this program; if not, write to the Free Software 15 ;;; along with this program; if not, write to the Free Software
16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
17 17
18 (provide 'vm-window) 18 (provide 'vm-window)
19 19
20 (defun vm-display (buffer display commands configs) 20 (defun vm-display (buffer display commands configs
21 &optional do-not-raise)
21 ;; the clearinghouse VM display function. 22 ;; the clearinghouse VM display function.
22 ;; 23 ;;
23 ;; First arg BUFFER non-nil is a buffer to display or undisplay. 24 ;; First arg BUFFER non-nil is a buffer to display or undisplay.
24 ;; nil means there is no request to display or undisplay a 25 ;; nil means there is no request to display or undisplay a
25 ;; buffer. 26 ;; buffer.
60 ;; 61 ;;
61 ;; If display/undisplay is not requested, only window 62 ;; If display/undisplay is not requested, only window
62 ;; configuration is done, and only then if the value of 63 ;; configuration is done, and only then if the value of
63 ;; this-command is found in the COMMANDS list. 64 ;; this-command is found in the COMMANDS list.
64 (vm-save-buffer-excursion 65 (vm-save-buffer-excursion
65 (let ((w (and buffer (vm-get-buffer-window buffer)))) 66 (let* ((w (and buffer (vm-get-buffer-window buffer)))
67 (wf (and w (vm-window-frame w))))
66 (and buffer (set-buffer buffer)) 68 (and buffer (set-buffer buffer))
67 (and w display (vm-raise-frame (vm-window-frame w))) 69 (if (and w display (not do-not-raise))
68 (and w display (not (eq (vm-selected-frame) (vm-window-frame w))) 70 (vm-raise-frame wf))
69 (vm-select-frame (vm-window-frame w))) 71 (if (and w display (not (eq (vm-selected-frame) wf)))
72 (vm-select-frame wf))
70 (cond ((and buffer display) 73 (cond ((and buffer display)
71 (if (and vm-display-buffer-hook 74 (if (and vm-display-buffer-hook
72 (null (vm-get-visible-buffer-window buffer))) 75 (null (vm-get-visible-buffer-window buffer)))
73 (progn (run-hooks 'vm-display-buffer-hook) 76 (progn (run-hooks 'vm-display-buffer-hook)
74 (switch-to-buffer buffer) 77 (switch-to-buffer buffer)
153 (throw 'done nil) 156 (throw 'done nil)
154 (setq summary (current-buffer)) 157 (setq summary (current-buffer))
155 (setq message vm-mail-buffer))) 158 (setq message vm-mail-buffer)))
156 ((eq major-mode 'vm-mode) 159 ((eq major-mode 'vm-mode)
157 (setq message (current-buffer))) 160 (setq message (current-buffer)))
161 ((eq major-mode 'vm-presentation-mode)
162 (setq message vm-mail-buffer))
158 ((eq major-mode 'vm-virtual-mode) 163 ((eq major-mode 'vm-virtual-mode)
159 (setq message (current-buffer))) 164 (setq message (current-buffer)))
160 ((eq major-mode 'mail-mode) 165 ((eq major-mode 'mail-mode)
161 (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) 166 (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer)))
162 (throw 'done nil) 167 (throw 'done nil)
163 (setq message vm-mail-buffer))) 168 (setq message vm-mail-buffer
169 ;; assume that the proximity implies affinity
170 composition (current-buffer))))
164 ((eq vm-system-state 'editing) 171 ((eq vm-system-state 'editing)
165 (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) 172 (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer)))
166 (throw 'done nil) 173 (throw 'done nil)
167 (setq edit (current-buffer)) 174 (setq edit (current-buffer))
168 (setq message vm-mail-buffer))) 175 (setq message vm-mail-buffer)))
169 ;; not in a VM related buffer, bail... 176 ;; not in a VM related buffer, bail...
170 (t (throw 'done nil))) 177 (t (throw 'done nil)))
171 (set-buffer message) 178 (set-buffer message)
179 (vm-check-for-killed-presentation)
180 (if vm-presentation-buffer
181 (setq message vm-presentation-buffer))
172 ;; if this configuration is already the current one, don't 182 ;; if this configuration is already the current one, don't
173 ;; set it up again. 183 ;; set it up again.
174 (if (or (and vm-mutable-frames (eq (car config) vm-window-configuration)) 184 (if (or (and vm-mutable-frames (eq (car config) vm-window-configuration))
175 (and (not vm-mutable-frames) 185 (and (not vm-mutable-frames)
176 (listp vm-window-configuration) 186 (listp vm-window-configuration)
393 (while (not done) 403 (while (not done)
394 (if delete-me 404 (if delete-me
395 (progn 405 (progn
396 (condition-case nil 406 (condition-case nil
397 (progn 407 (progn
398 (vm-delete-frame delete-me) 408 (if (vm-created-this-frame-p delete-me)
409 (vm-delete-frame delete-me))
399 (if (eq delete-me start) 410 (if (eq delete-me start)
400 (setq start nil))) 411 (setq start nil)))
401 (error nil)) 412 (error nil))
402 (setq delete-me nil))) 413 (setq delete-me nil)))
403 (cond ((and (eq action 'delete) 414 (cond ((and (eq action 'delete)
471 (wrong-number-of-arguments 482 (wrong-number-of-arguments
472 (get-buffer-window buffer)))))) 483 (get-buffer-window buffer))))))
473 484
474 (defun vm-set-hooks-for-frame-deletion () 485 (defun vm-set-hooks-for-frame-deletion ()
475 (make-local-variable 'vm-undisplay-buffer-hook) 486 (make-local-variable 'vm-undisplay-buffer-hook)
476 (make-local-variable 'kill-buffer-hook)
477 (add-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame) 487 (add-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame)
478 (add-hook 'kill-buffer-hook 'vm-delete-buffer-frame)) 488 (add-hook 'kill-buffer-hook 'vm-delete-buffer-frame))
479 489
490 (defun vm-created-this-frame-p (&optional frame)
491 (memq (or frame (vm-selected-frame)) vm-frame-list))
492
480 (defun vm-delete-buffer-frame () 493 (defun vm-delete-buffer-frame ()
481 (save-excursion 494 ;; kludge. we only want to this to run on VM related buffers
482 (let ((w (vm-get-visible-buffer-window (current-buffer))) 495 ;; but this function is generally on a global hook. Check for
483 (b (current-buffer))) 496 ;; vm-undisplay-buffer-hook set; this is a good sign that this
484 (and w (eq (vm-selected-frame) (vm-window-frame w)) 497 ;; is a VM buffer.
485 (vm-error-free-call 'vm-delete-frame (vm-window-frame w))) 498 (if vm-undisplay-buffer-hook
486 (and w (let ((vm-mutable-frames t)) 499 (save-excursion
487 (vm-delete-windows-or-frames-on b))))) 500 ;; run once only per buffer.
488 ;; do it only once 501 (remove-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame)
489 (remove-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame) 502 (let* ((w (vm-get-visible-buffer-window (current-buffer)))
490 (remove-hook 'kill-buffer-hook 'vm-delete-buffer-frame)) 503 (b (current-buffer))
504 (wf (and w (vm-window-frame w))))
505 (and w (eq (vm-selected-frame) wf) (vm-created-this-frame-p wf)
506 (vm-error-free-call 'vm-delete-frame wf))
507 (and w (let ((vm-mutable-frames t))
508 (vm-delete-windows-or-frames-on b)))))))
509
510 (defun vm-register-frame (frame)
511 (setq vm-frame-list (cons frame vm-frame-list)))
491 512
492 (defun vm-goto-new-frame (&rest types) 513 (defun vm-goto-new-frame (&rest types)
493 (let ((params nil)) 514 (let ((params nil))
494 (while (and types (null params)) 515 (while (and types (null params))
495 (setq params (car (cdr (assq (car types) vm-frame-parameter-alist))) 516 (setq params (car (cdr (assq (car types) vm-frame-parameter-alist)))
501 (select-frame (make-frame params))) 522 (select-frame (make-frame params)))
502 ((fboundp 'make-screen) 523 ((fboundp 'make-screen)
503 (select-screen (make-screen params))) 524 (select-screen (make-screen params)))
504 ((fboundp 'new-screen) 525 ((fboundp 'new-screen)
505 (select-screen (new-screen params)))) 526 (select-screen (new-screen params))))
527 (vm-register-frame (vm-selected-frame))
506 (and vm-warp-mouse-to-new-frame 528 (and vm-warp-mouse-to-new-frame
507 (vm-warp-mouse-to-frame-maybe (vm-selected-frame))))) 529 (vm-warp-mouse-to-frame-maybe (vm-selected-frame)))))
530
531 (defun vm-goto-new-summary-frame-maybe ()
532 (if (and vm-frame-per-summary (vm-multiple-frames-possible-p))
533 (let ((w (vm-get-buffer-window vm-summary-buffer)))
534 (if (null w)
535 (progn
536 (vm-goto-new-frame 'summary)
537 (vm-set-hooks-for-frame-deletion))
538 (save-excursion
539 (select-window w)
540 (and vm-warp-mouse-to-new-frame
541 (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))))
542
543 (defun vm-goto-new-folder-frame-maybe (&rest types)
544 (if (and vm-frame-per-folder (vm-multiple-frames-possible-p))
545 (let ((w (or (vm-get-buffer-window (current-buffer))
546 ;; summary == folder for the purpose
547 ;; of frame reuse.
548 (and vm-summary-buffer
549 (vm-get-buffer-window vm-summary-buffer))
550 ;; presentation == folder for the purpose
551 ;; of frame reuse.
552 (and vm-presentation-buffer
553 (vm-get-buffer-window vm-presentation-buffer)))))
554 (if (null w)
555 (progn
556 (apply 'vm-goto-new-frame types)
557 (vm-set-hooks-for-frame-deletion))
558 (save-excursion
559 (select-window w)
560 (and vm-warp-mouse-to-new-frame
561 (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))))
508 562
509 (defun vm-warp-mouse-to-frame-maybe (&optional frame) 563 (defun vm-warp-mouse-to-frame-maybe (&optional frame)
510 (or frame (setq frame (vm-selected-frame))) 564 (or frame (setq frame (vm-selected-frame)))
511 (if (vm-mouse-support-possible-p) 565 (if (vm-mouse-support-possible-p)
512 (cond ((vm-mouse-xemacs-mouse-p) 566 (cond ((vm-mouse-xemacs-mouse-p)
575 (symbol-function 629 (symbol-function
576 (cond ((fboundp 'frame-visible-p) 'frame-visible-p) 630 (cond ((fboundp 'frame-visible-p) 'frame-visible-p)
577 ((fboundp 'screen-visible-p) 'screen-visible-p) 631 ((fboundp 'screen-visible-p) 'screen-visible-p)
578 (t 'ignore)))) 632 (t 'ignore))))
579 633
634 (if (fboundp 'frame-iconified-p)
635 (fset 'vm-frame-iconified-p 'frame-iconified-p)
636 (defun vm-frame-iconified-p (&optional frame)
637 (eq (vm-frame-visible-p frame) 'icon)))
638
639 ;; frame-totally-visible-p is broken under XEmacs 19.14 and is
640 ;; absent under Emacs 19.34. So vm-frame-per-summary won't work
641 ;; quite right under these Emacs versions. XEmacs 19.15 should
642 ;; have a working version of this function.
643 (if (and (fboundp 'frame-totally-visible-p)
644 (vm-xemacs-p)
645 (or (>= emacs-major-version 20)
646 (>= emacs-minor-version 15)))
647 (fset 'vm-frame-totally-visible-p 'frame-totally-visible-p)
648 (fset 'vm-frame-totally-visible-p 'vm-frame-visible-p))
649
580 (fset 'vm-window-frame 650 (fset 'vm-window-frame
581 (symbol-function 651 (symbol-function
582 (cond ((fboundp 'window-frame) 'window-frame) 652 (cond ((fboundp 'window-frame) 'window-frame)
583 ((fboundp 'window-screen) 'window-screen) 653 ((fboundp 'window-screen) 'window-screen)
584 (t 'ignore)))) 654 (t 'ignore))))