Mercurial > hg > xemacs-beta
diff lisp/vm/vm-window.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
author | cvs |
---|---|
date | Mon, 13 Aug 2007 08:45:50 +0200 |
parents | |
children | 49a24b4fd526 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/vm/vm-window.el Mon Aug 13 08:45:50 2007 +0200 @@ -0,0 +1,602 @@ +;;; Window management code for VM +;;; Copyright (C) 1989, 1990, 1991, 1993, 1994, 1995 Kyle E. Jones +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 1, or (at your option) +;;; any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +(provide 'vm-window) + +(defun vm-display (buffer display commands configs) +;; the clearinghouse VM display function. +;; +;; First arg BUFFER non-nil is a buffer to display or undisplay. +;; nil means there is no request to display or undisplay a +;; buffer. +;; +;; Second arg DISPLAY non-nil means to display the buffer, nil means +;; to undisplay it. This function guarantees to display the +;; buffer if requested. Undisplay is not guaranteed. +;; +;; Third arg COMMANDS is a list of symbols. this-command must +;; match one of these symbols for a window configuration to be +;; applied. +;; +;; Fourth arg CONFIGS is a list of window configurations to try. +;; vm-set-window-configuration will step through the list looking +;; for an existing configuration, and apply the one it finds. +;; +;; Display is done this way: +;; 1. if the buffer is visible in an invisible frame, make that frame visible +;; 2. if the buffer is already displayed, quit +;; 3. if vm-display-buffer-hook in non-nil +;; run the hooks +;; use the selected window/frame to display the buffer +;; quit +;; 4. apply a window configuration +;; if the buffer is displayed now, quit +;; 5. call vm-display-buffer which will display the buffer. +;; +;; Undisplay is done this way: +;; 1. if the buffer is not displayed, quit +;; 2. if vm-undisplay-buffer-hook is non-nil +;; run the hooks +;; quit +;; 3. apply a window configuration +;; 4, if a window configuration was applied +;; quit +;; 5. call vm-undisplay-buffer which will make the buffer +;; disappear from at least one window/frame. +;; +;; If display/undisplay is not requested, only window +;; configuration is done, and only then if the value of +;; this-command is found in the COMMANDS list. + (vm-save-buffer-excursion + (let ((w (and buffer (vm-get-buffer-window buffer)))) + (and buffer (set-buffer buffer)) +; (and w display (vm-raise-frame (vm-window-frame w))) + (and w display (vm-window-frame w)) + (and w display (not (eq (vm-selected-frame) (vm-window-frame w))) + (vm-select-frame (vm-window-frame w))) + (cond ((and buffer display) + (if (and vm-display-buffer-hook + (null (vm-get-visible-buffer-window buffer))) + (progn (run-hooks 'vm-display-buffer-hook) + (switch-to-buffer buffer) + (vm-record-current-window-configuration nil)) + (if (not (and (memq this-command commands) + (apply 'vm-set-window-configuration configs) + (vm-get-visible-buffer-window buffer))) + (vm-display-buffer buffer)))) + ((and buffer (not display)) + (if (and vm-undisplay-buffer-hook + (vm-get-visible-buffer-window buffer)) + (progn (run-hooks 'vm-undisplay-buffer-hook) + (vm-record-current-window-configuration nil)) + (if (not (and (memq this-command commands) + (apply 'vm-set-window-configuration configs))) + (vm-undisplay-buffer buffer)))) + ((memq this-command commands) + (apply 'vm-set-window-configuration configs)))))) + +(defun vm-display-buffer (buffer) + (let ((pop-up-windows (eq vm-mutable-windows t)) + (pop-up-frames vm-mutable-frames)) + (vm-record-current-window-configuration nil) + (if (or pop-up-frames + (and (eq vm-mutable-windows t) + (symbolp + (vm-buffer-to-label + (window-buffer + (selected-window)))))) + (select-window (display-buffer buffer)) + (switch-to-buffer buffer)))) + +(defun vm-undisplay-buffer (buffer) + (vm-save-buffer-excursion + (vm-delete-windows-or-frames-on buffer) + (let ((w (vm-get-buffer-window buffer))) + (and w (set-window-buffer w (other-buffer)))))) + +(defun vm-load-window-configurations (file) + (save-excursion + (let ((work-buffer nil)) + (unwind-protect + (progn + (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*"))) + (erase-buffer) + (setq vm-window-configurations + (condition-case () + (progn + (insert-file-contents file) + (read (current-buffer))) + (error nil)))) + (and work-buffer (kill-buffer work-buffer)))))) + +(defun vm-store-window-configurations (file) + (save-excursion + (let ((work-buffer nil)) + (unwind-protect + (progn + (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*"))) + (erase-buffer) + (print vm-window-configurations (current-buffer)) + (write-region (point-min) (point-max) file nil 0)) + (and work-buffer (kill-buffer work-buffer)))))) + +(defun vm-set-window-configuration (&rest tags) + (catch 'done + (if (not vm-mutable-windows) + (throw 'done nil)) + (let ((nonexistent " *vm-nonexistent*") + (nonexistent-summary " *vm-nonexistent-summary*") + (selected-frame (vm-selected-frame)) + summary message composition edit config) + (while (and tags (null config)) + (setq config (assq (car tags) vm-window-configurations) + tags (cdr tags))) + (or config (setq config (assq 'default vm-window-configurations))) + (or config (throw 'done nil)) + (setq config (vm-copy config)) + (setq composition (vm-find-composition-buffer t)) + (cond ((eq major-mode 'vm-summary-mode) + (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) + (throw 'done nil) + (setq summary (current-buffer)) + (setq message vm-mail-buffer))) + ((eq major-mode 'vm-mode) + (setq message (current-buffer))) + ((eq major-mode 'vm-virtual-mode) + (setq message (current-buffer))) + ((eq major-mode 'mail-mode) + (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) + (throw 'done nil) + (setq message vm-mail-buffer))) + ((eq vm-system-state 'editing) + (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) + (throw 'done nil) + (setq edit (current-buffer)) + (setq message vm-mail-buffer))) + ;; not in a VM related buffer, bail... + (t (throw 'done nil))) + (set-buffer message) + ;; if this configuration is already the current one, don't + ;; set it up again. + (if (or (and vm-mutable-frames (eq (car config) vm-window-configuration)) + (and (not vm-mutable-frames) + (listp vm-window-configuration) + (eq (car config) + (cdr (assq selected-frame vm-window-configuration))))) + (throw 'done nil)) + (vm-check-for-killed-summary) + (or summary (setq summary (or vm-summary-buffer nonexistent-summary))) + (or composition (setq composition nonexistent)) + (or edit (setq edit nonexistent)) + (tapestry-replace-tapestry-element (nth 1 config) 'buffer-name + (function + (lambda (x) + (if (symbolp x) + (symbol-value x) + x )))) + (set-tapestry (nth 1 config) 1) + (and (get-buffer nonexistent) + (vm-delete-windows-or-frames-on nonexistent)) + (if (and (vm-get-buffer-window nonexistent-summary) + (not (vm-get-buffer-window message))) + ;; user asked for summary to be displayed but doesn't + ;; have one, nor is the folder buffer displayed. Help + ;; the user not to lose here. + (vm-replace-buffer-in-windows nonexistent-summary message) + (and (get-buffer nonexistent-summary) + (vm-delete-windows-or-frames-on nonexistent-summary))) + (vm-record-current-window-configuration config) + config ))) + +(defun vm-record-current-window-configuration (config) + ;; this function continues to be a no-op. + ;; + ;; the idea behind this function is that VM can remember what + ;; the current window configuration is and not rebuild the + ;; configuration for the next command if it matches what we + ;; have recorded. + ;; + ;; the problem with this idea is that the user can do things + ;; like C-x 0 and VM has no way of knowing. So VM thinks the + ;; right configuration is displayed when in fact it is not, + ;; which can cause incorrect displays. + '(let (cell) + (if (and (listp vm-window-configuration) + (setq cell (assq (vm-selected-frame) vm-window-configuration))) + (setcdr cell (car config)) + (setq vm-window-configuration + (cons + (cons (vm-selected-frame) (car config)) + vm-window-configuration))))) + +(defun vm-save-window-configuration (tag) + "Name and save the current window configuration. +With this command you associate the current window setup with an +action. Each time you perform this action VM will duplicate this +window setup. + +Nearly every VM command can have a window configuration +associated with it. VM also allows some category configurations, +`startup', `reading-message', `composing-message', `editing-message', +`marking-message' and `searching-message' for the commands that +do these things. There is also a `default' configuration that VM +will use if no other configuration is applicable. Command +specific configurations are searched for first, then the category +configurations and then the default configuration. The first +configuration found is the one that is applied. + +The value of vm-mutable-windows must be non-nil for VM to use +window configurations. + +If vm-mutable-frames is non-nil and Emacs is running under X +windows, then VM will use all existing frames. Otherwise VM will +restrict its changes to the frame in which it was started." + (interactive + (let ((last-command last-command) + (this-command this-command)) + (if (null vm-window-configuration-file) + (error "Configurable windows not enabled. Set vm-window-configuration-file to enable.")) + (list + (intern + (completing-read "Name this window configuration: " + vm-supported-window-configurations + 'identity t))))) + (if (null vm-window-configuration-file) + (error "Configurable windows not enabled. Set vm-window-configuration-file to enable.")) + (let (map p) + (setq map (tapestry (list (vm-selected-frame)))) + ;; set frame map to nil since we don't use it. this prevents + ;; cursor objects and any other objects that have an + ;; "unreadable" read syntax appearing in the window + ;; configuration file by way of frame-parameters. + (setcar map nil) + (tapestry-replace-tapestry-element map 'buffer-name 'vm-buffer-to-label) + (tapestry-nullify-tapestry-elements map t nil t t t nil) + (setq p (assq tag vm-window-configurations)) + (if p + (setcar (cdr p) map) + (setq vm-window-configurations + (cons (list tag map) vm-window-configurations))) + (vm-store-window-configurations vm-window-configuration-file) + (message "%s configuration recorded" tag))) + +(defun vm-buffer-to-label (buf) + (save-excursion + (set-buffer buf) + (cond ((eq major-mode 'vm-summary-mode) + 'summary) + ((eq major-mode 'mail-mode) + 'composition) + ((eq major-mode 'vm-mode) + 'message) + ((eq major-mode 'vm-virtual-mode) + 'message) + ((eq vm-system-state 'editing) + 'edit) + (t buf)))) + +(defun vm-delete-window-configuration (tag) + "Delete the configuration saved for a particular action. +This action will no longer have an associated window configuration. +The action will be read from the minibuffer." + (interactive + (let ((last-command last-command) + (this-command this-command)) + (if (null vm-window-configuration-file) + (error "Configurable windows not enabled. Set vm-window-configuration-file to enable.")) + (list + (intern + (completing-read "Delete window configuration: " + (mapcar (function + (lambda (x) + (list (symbol-name (car x))))) + vm-window-configurations) + 'identity t))))) + (if (null vm-window-configuration-file) + (error "Configurable windows not enabled. Set vm-window-configuration-file to enable.")) + (let (p) + (setq p (assq tag vm-window-configurations)) + (if p + (if (eq p (car vm-window-configurations)) + (setq vm-window-configurations (cdr vm-window-configurations)) + (setq vm-window-configurations (delq p vm-window-configurations))) + (error "No window configuration set for %s" tag))) + (vm-store-window-configurations vm-window-configuration-file) + (message "%s configuration deleted" tag)) + +(defun vm-apply-window-configuration (tag) + "Change the current window configuration to be one +associated with a particular action. The action will be read +from the minibuffer." + (interactive + (let ((last-command last-command) + (this-command this-command)) + (list + (intern + (completing-read "Apply window configuration: " + (mapcar (function + (lambda (x) + (list (symbol-name (car x))))) + vm-window-configurations) + 'identity t))))) + (vm-set-window-configuration tag)) + +(defun vm-window-help () + (interactive) + (message "WS = save configuration, WD = delete configuration, WW = apply configuration")) + +(defun vm-iconify-frame () + "Iconify the current frame. +Run the hooks in vm-iconify-frame-hook before doing so." + (interactive) + (vm-check-for-killed-summary) + (vm-select-folder-buffer) + (if (vm-multiple-frames-possible-p) + (progn + (run-hooks 'vm-iconify-frame-hook) + (vm-iconify-frame-xxx)))) + +(defun vm-window-loop (action obj-1 &optional obj-2) + (let ((delete-me nil) + (done nil) + (all-frames (if vm-mutable-frames t nil)) + start w) + (setq start (next-window (selected-window) 'nomini all-frames) + w start) + (and obj-1 (setq obj-1 (get-buffer obj-1))) + (while (not done) + (if (and delete-me (not (eq delete-me (next-window delete-me 'nomini)))) + (progn + (delete-window delete-me) + (if (eq delete-me start) + (setq start nil)) + (setq delete-me nil))) + (cond ((and (eq action 'delete) (eq obj-1 (window-buffer w))) + ;; a deleted window has no next window, so we + ;; defer the deletion until after we've moved + ;; to the next window. + (setq delete-me w)) + ((and (eq action 'replace) (eq obj-1 (window-buffer w))) + (set-window-buffer w obj-2))) + (setq done (eq start + (setq w + (condition-case nil + (next-window w 'nomini all-frames) + (wrong-number-of-arguments + (next-window w 'nomini)))))) + (if (null start) + (setq start w))) + (if (and delete-me (not (eq delete-me (next-window delete-me 'nomini)))) + (delete-window delete-me)))) + +(defun vm-frame-loop (action obj-1) + (if (fboundp 'vm-next-frame) + (let ((start (vm-next-frame (vm-selected-frame))) + (delete-me nil) + (done nil) + f) + (setq f start) + (and obj-1 (setq obj-1 (get-buffer obj-1))) + (while (not done) + (if delete-me + (progn + (condition-case nil + (progn + (vm-delete-frame delete-me) + (if (eq delete-me start) + (setq start nil))) + (error nil)) + (setq delete-me nil))) + (cond ((and (eq action 'delete) + ;; one-window-p doesn't take a frame argument + (eq (next-window (vm-frame-selected-window f) 'nomini) + (previous-window (vm-frame-selected-window f) + 'nomini)) + ;; the next-window call is to avoid looking + ;; at the minibuffer window + (eq obj-1 (window-buffer + (next-window + (vm-frame-selected-window f) + 'nomini)))) + ;; a deleted frame has no next frame, so we + ;; defer the deletion until after we've moved + ;; to the next frame. + (setq delete-me f)) + ((eq action 'bury) + (bury-buffer obj-1))) + (setq done (eq start (setq f (vm-next-frame f)))) + (if (null start) + (setq start f))) + (if delete-me + (progn + (vm-error-free-call 'vm-delete-frame delete-me) + (setq delete-me nil)))))) + +(defun vm-delete-windows-or-frames-on (buffer) + (and (eq vm-mutable-windows t) (vm-window-loop 'delete buffer)) + (and vm-mutable-frames (vm-frame-loop 'delete buffer))) + +(defun vm-replace-buffer-in-windows (old new) + (vm-window-loop 'replace old new)) + +(defun vm-bury-buffer (&optional buffer) + (or buffer (setq buffer (current-buffer))) + (if (vm-xemacs-p) + (if (vm-multiple-frames-possible-p) + (vm-frame-loop 'bury buffer) + (bury-buffer buffer)) + (bury-buffer buffer))) + +(defun vm-unbury-buffer (buffer) + (save-excursion + (save-window-excursion + (switch-to-buffer buffer)))) + +(defun vm-get-buffer-window (buffer) + (condition-case nil + (or (get-buffer-window buffer nil nil) + (and vm-search-other-frames + (get-buffer-window buffer t t))) + (wrong-number-of-arguments + (condition-case nil + (or (get-buffer-window buffer nil) + (and vm-search-other-frames + (get-buffer-window buffer t))) + (wrong-number-of-arguments + (get-buffer-window buffer)))))) + +(defun vm-get-visible-buffer-window (buffer) + (condition-case nil + (or (get-buffer-window buffer nil nil) + (and vm-search-other-frames + (get-buffer-window buffer t nil))) + (wrong-number-of-arguments + (condition-case nil + (or (get-buffer-window buffer nil) + (and vm-search-other-frames + (get-buffer-window buffer 'visible))) + (wrong-number-of-arguments + (get-buffer-window buffer)))))) + +(defun vm-set-hooks-for-frame-deletion () + (make-local-variable 'vm-undisplay-buffer-hook) + (make-local-variable 'kill-buffer-hook) + (add-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame) + (add-hook 'kill-buffer-hook 'vm-delete-buffer-frame)) + +(defun vm-delete-buffer-frame () + (save-excursion + (let ((w (vm-get-visible-buffer-window (current-buffer))) + (b (current-buffer))) + (and w (eq (vm-selected-frame) (vm-window-frame w)) + (vm-error-free-call 'vm-delete-frame (vm-window-frame w))) + (and w (let ((vm-mutable-frames t)) + (vm-delete-windows-or-frames-on b))))) + ;; do it only once + (remove-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame) + (remove-hook 'kill-buffer-hook 'vm-delete-buffer-frame)) + +(defun vm-goto-new-frame (&rest types) + (let ((params nil)) + (while (and types (null params)) + (setq params (car (cdr (assq (car types) vm-frame-parameter-alist))) + types (cdr types))) + ;; these functions might be defined in an Emacs that isn't + ;; running under a window system, but VM always checks for + ;; multi-frame support before calling this function. + (cond ((fboundp 'make-frame) + (select-frame (make-frame params))) + ((fboundp 'make-screen) + (select-screen (make-screen params))) + ((fboundp 'new-screen) + (select-screen (new-screen params)))) + (and vm-warp-mouse-to-new-frame + (vm-warp-mouse-to-frame-maybe (vm-selected-frame))))) + +(defun vm-warp-mouse-to-frame-maybe (&optional frame) + (or frame (setq frame (vm-selected-frame))) + (if (vm-mouse-support-possible-p) + (cond ((vm-mouse-xemacs-mouse-p) + (cond ((fboundp 'mouse-position);; XEmacs 19.12 + (let ((mp (mouse-position))) + (if (and (car mp) + (eq (window-frame (car mp)) (selected-frame))) + nil + (set-mouse-position (frame-highest-window frame) + (/ (frame-width frame) 2) + (/ (frame-height frame) 2))))) + (t ;; XEmacs 19.11 + ;; use (apply 'screen-...) instead of + ;; (screen-...) to avoid stimulating a + ;; byte-compiler bug in Emacs 19.29 that + ;; happens when it encounters 'obsolete' + ;; functions. puke, puke, puke. + (let ((mp (read-mouse-position frame))) + (if (and (>= (car mp) 0) + (<= (car mp) (apply 'screen-width frame)) + (>= (cdr mp) 0) + (<= (cdr mp) (apply 'screen-height frame))) + nil + (set-mouse-position frame + (/ (apply 'screen-width frame) 2) + (/ (apply 'screen-height frame) 2))))))) + ((vm-fsfemacs-19-p) + (let ((mp (mouse-position))) + (if (and (eq (car mp) frame) + ;; nil coordinates mean that the mouse + ;; pointer isn't really within the frame + (car (cdr mp))) + nil + (set-mouse-position frame + (/ (frame-width frame) 2) + (/ (frame-height frame) 2)) + ;; doc for set-mouse-position says to do this + (unfocus-frame))))))) + +(fset 'vm-selected-frame + (symbol-function + (cond ((fboundp 'selected-frame) 'selected-frame) + ((fboundp 'selected-screen) 'selected-screen) + (t 'ignore)))) + +(fset 'vm-delete-frame + (symbol-function + (cond ((fboundp 'delete-frame) 'delete-frame) + ((fboundp 'delete-screen) 'delete-screen) + (t 'ignore)))) + +;; xxx because vm-iconify-frame is a command +(defun vm-iconify-frame-xxx (&optional frame) + (cond ((fboundp 'iconify-frame) + (iconify-frame frame)) + ((fboundp 'iconify-screen) + (iconify-screen (or frame (selected-screen)))))) + +(fset 'vm-raise-frame + (symbol-function + (cond ((fboundp 'raise-frame) 'raise-frame) + ((fboundp 'raise-screen) 'raise-screen) + (t 'ignore)))) + +(fset 'vm-frame-visible-p + (symbol-function + (cond ((fboundp 'frame-visible-p) 'frame-visible-p) + ((fboundp 'screen-visible-p) 'screen-visible-p) + (t 'ignore)))) + +(fset 'vm-window-frame + (symbol-function + (cond ((fboundp 'window-frame) 'window-frame) + ((fboundp 'window-screen) 'window-screen) + (t 'ignore)))) + +(cond ((fboundp 'next-frame) + (fset 'vm-next-frame (symbol-function 'next-frame)) + (fset 'vm-select-frame (symbol-function 'select-frame)) + (fset 'vm-frame-selected-window + (symbol-function 'frame-selected-window))) + ((fboundp 'next-screen) + (fset 'vm-next-frame (symbol-function 'next-screen)) + (fset 'vm-select-frame (symbol-function 'select-screen)) + (fset 'vm-frame-selected-window + (if (fboundp 'epoch::selected-window) + (symbol-function 'epoch::selected-window) + (symbol-function 'screen-selected-window)))) + (t + ;; it is useful for this to be a no-op, but don't bind the + ;; others. + (fset 'vm-select-frame 'ignore)))