cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-window.el

   1 ;;; vm-window.el --- Window management code for VM
   2 ;;
   3 ;; Copyright (C) 1989-1997 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21 (defun vm-display (buffer display commands configs
  22                    &optional do-not-raise)
  23 ;; the clearinghouse VM display function.
  24 ;;
  25 ;; First arg BUFFER non-nil is a buffer to display or undisplay.
  26 ;; nil means there is no request to display or undisplay a
  27 ;; buffer.
  28 ;;
  29 ;; Second arg DISPLAY non-nil means to display the buffer, nil means
  30 ;; to undisplay it.  This function guarantees to display the
  31 ;; buffer if requested.  Undisplay is not guaranteed.
  32 ;;
  33 ;; Third arg COMMANDS is a list of symbols.  this-command must
  34 ;; match one of these symbols for a window configuration to be
  35 ;; applied.
  36 ;;
  37 ;; Fourth arg CONFIGS is a list of window configurations to try.
  38 ;; vm-set-window-configuration will step through the list looking
  39 ;; for an existing configuration, and apply the one it finds.
  40 ;;
  41 ;; Display is done this way:
  42 ;;  1. if the buffer is visible in an invisible frame, make that frame visible
  43 ;;  2. if the buffer is already displayed, quit
  44 ;;  3. if vm-display-buffer-hook in non-nil
  45 ;;        run the hooks
  46 ;;        use the selected window/frame to display the buffer
  47 ;;        quit
  48 ;;  4. apply a window configuration
  49 ;;        if the buffer is displayed now, quit
  50 ;;  5. call vm-display-buffer which will display the buffer.
  51 ;;
  52 ;; Undisplay is done this way:
  53 ;;  1. if the buffer is not displayed, quit
  54 ;;  2. if vm-undisplay-buffer-hook is non-nil
  55 ;;        run the hooks
  56 ;;        quit
  57 ;;  3. apply a window configuration
  58 ;;  4, if a window configuration was applied
  59 ;;        quit
  60 ;;  5. call vm-undisplay-buffer which will make the buffer
  61 ;;     disappear from at least one window/frame.
  62 ;;
  63 ;; If display/undisplay is not requested, only window
  64 ;; configuration is done, and only then if the value of
  65 ;; this-command is found in the COMMANDS list.
  66   (and (stringp buffer) (setq buffer (get-buffer buffer)))
  67   (vm-save-buffer-excursion
  68    (let* ((w (and buffer (vm-get-buffer-window buffer)))
  69           (wf (and w (vm-window-frame w))))
  70      (if (and w display (not do-not-raise))
  71          (vm-raise-frame wf))
  72      (if (and w display (not (eq (vm-selected-frame) wf)))
  73          (vm-select-frame wf))
  74      (cond ((and buffer display)
  75             (if (and vm-display-buffer-hook
  76                      (null (vm-get-visible-buffer-window buffer)))
  77                 (progn (save-excursion
  78                          (set-buffer buffer)
  79                          (run-hooks 'vm-display-buffer-hook))
  80                        (switch-to-buffer buffer))
  81               (if (not (and (memq this-command commands)
  82                             (apply 'vm-set-window-configuration configs)
  83                             (vm-get-visible-buffer-window buffer)))
  84                   (vm-display-buffer buffer))))
  85            ((and buffer (not display))
  86             (if (and vm-undisplay-buffer-hook
  87                      (vm-get-visible-buffer-window buffer))
  88                 (progn (save-excursion
  89                          (set-buffer buffer)
  90                          (run-hooks 'vm-undisplay-buffer-hook)))
  91               (if (not (and (memq this-command commands)
  92                             (apply 'vm-set-window-configuration configs)))
  93                   (vm-undisplay-buffer buffer))))
  94            ((memq this-command commands)
  95             (apply 'vm-set-window-configuration configs))))))
  96
  97 (defun vm-display-buffer (buffer)
  98   (let ((pop-up-windows (eq vm-mutable-windows t))
  99         (pop-up-frames (and pop-up-frames vm-mutable-frames)))
 100     (if (or pop-up-frames
 101             (and (eq vm-mutable-windows t)
 102                  (symbolp
 103                   (vm-buffer-to-label
 104                    (window-buffer
 105                     (selected-window))))))
 106         (select-window (display-buffer buffer))
 107       (switch-to-buffer buffer))))
 108
 109 (defun vm-undisplay-buffer (buffer)
 110   (vm-save-buffer-excursion
 111    (let ((vm-mutable-frames (and vm-mutable-frames pop-up-frames)))
 112      (vm-maybe-delete-windows-or-frames-on buffer))
 113    (let (w)
 114      (while (setq w (vm-get-buffer-window buffer))
 115        (set-window-buffer w (other-buffer buffer))))))
 116
 117 (defun vm-load-window-configurations (file)
 118   (save-excursion
 119     (let ((work-buffer nil))
 120       (unwind-protect
 121           (progn
 122             (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*")))
 123             (if vm-fsfemacs-mule-p
 124                 (set-buffer-multibyte nil))
 125             (erase-buffer)
 126             (setq vm-window-configurations
 127                   (condition-case ()
 128                       (progn
 129                         (let ((coding-system-for-read
 130                                   (vm-line-ending-coding-system)))
 131                           (insert-file-contents file))
 132                         (read (current-buffer)))
 133                     (error nil))))
 134         (and work-buffer (kill-buffer work-buffer))))))
 135
 136 (defun vm-store-window-configurations (file)
 137   (save-excursion
 138     (let ((work-buffer nil))
 139       (unwind-protect
 140           (progn
 141             (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*")))
 142             (if vm-fsfemacs-mule-p
 143                 (set-buffer-multibyte nil))
 144             ;; for MULE
 145             (if (fboundp 'set-buffer-file-coding-system)
 146                 (set-buffer-file-coding-system (vm-line-ending-coding-system)))
 147             (erase-buffer)
 148             (print vm-window-configurations (current-buffer))
 149             (let ((coding-system-for-write (vm-line-ending-coding-system))
 150                   (selective-display nil))
 151               (write-region (point-min) (point-max) file nil 0)))
 152         (and work-buffer (kill-buffer work-buffer))))))
 153
 154 (defun vm-set-window-configuration (&rest tags)
 155   (catch 'done
 156     (if (not vm-mutable-windows)
 157         (throw 'done nil))
 158     (let ((nonexistent " *vm-nonexistent*")
 159           (nonexistent-summary " *vm-nonexistent-summary*")
 160           (selected-frame (vm-selected-frame))
 161           folders-summary summary message composition edit config)
 162       (while (and tags (null config))
 163         (setq config (assq (car tags) vm-window-configurations)
 164               tags (cdr tags)))
 165       (or config (setq config (assq 'default vm-window-configurations)))
 166       (or config (throw 'done nil))
 167       (setq config (vm-copy config))
 168       (setq composition (vm-find-composition-buffer t))
 169       (cond ((eq major-mode 'vm-summary-mode)
 170              (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer)))
 171                  (throw 'done nil)
 172                (setq summary (current-buffer))
 173                (setq message vm-mail-buffer)))
 174             ((eq major-mode 'vm-folders-summary-mode)
 175              (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer)))
 176                  (throw 'done nil)
 177                (setq folders-summary (current-buffer))
 178                (setq message vm-mail-buffer)))
 179             ((eq major-mode 'vm-mode)
 180              (setq message (current-buffer)))
 181             ((eq major-mode 'vm-presentation-mode)
 182              (setq message vm-mail-buffer))
 183             ((eq major-mode 'vm-virtual-mode)
 184              (setq message (current-buffer)))
 185             ((eq major-mode 'mail-mode)
 186              (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer)))
 187                  (throw 'done nil)
 188                (setq message vm-mail-buffer
 189                      ;; assume that the proximity implies affinity
 190                      composition (current-buffer))))
 191             ((eq vm-system-state 'editing)
 192              (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer)))
 193                  (throw 'done nil)
 194                (setq edit (current-buffer))
 195                (setq message vm-mail-buffer)))
 196             ;; not in a VM related buffer, bail...
 197             (t (throw 'done nil)))
 198       (set-buffer message)
 199       (vm-check-for-killed-presentation)
 200       (if vm-presentation-buffer
 201           (setq message vm-presentation-buffer))
 202       (vm-check-for-killed-summary)
 203       (or folders-summary (setq folders-summary (or vm-folders-summary-buffer
 204                                                     nonexistent)))
 205       (or summary (setq summary (or vm-summary-buffer nonexistent-summary)))
 206       (or composition (setq composition nonexistent))
 207       (or edit (setq edit nonexistent))
 208       (tapestry-replace-tapestry-element (nth 1 config) 'buffer-name
 209                                          (function
 210                                           (lambda (x)
 211                                             (if (symbolp x)
 212                                                 (symbol-value x)
 213                                               (if (and (stringp x)
 214                                                        (get-buffer x)
 215                                                        (zerop
 216                                                         (save-excursion
 217                                                           (set-buffer x)
 218                                                           (buffer-size))))
 219                                                   nonexistent
 220                                                 x )))))
 221       (set-tapestry (nth 1 config) 1)
 222       (and (get-buffer nonexistent)
 223            (vm-maybe-delete-windows-or-frames-on nonexistent))
 224       (if (and (vm-get-buffer-window nonexistent-summary)
 225                (not (vm-get-buffer-window message)))
 226           ;; user asked for summary to be displayed but doesn't
 227           ;; have one, nor is the folder buffer displayed.  Help
 228           ;; the user not to lose here.
 229           (vm-replace-buffer-in-windows nonexistent-summary message)
 230         (and (get-buffer nonexistent-summary)
 231              (vm-maybe-delete-windows-or-frames-on nonexistent-summary)))
 232       config )))
 233
 234 ;;;###autoload
 235 (defun vm-save-window-configuration (tag)
 236   "Name and save the current window configuration.
 237 With this command you associate the current window setup with an
 238 action.  Each time you perform this action VM will duplicate this
 239 window setup.
 240
 241 Nearly every VM command can have a window configuration
 242 associated with it.  VM also allows some category configurations,
 243 `startup', `reading-message', `composing-message', `editing-message',
 244 `marking-message' and `searching-message' for the commands that
 245 do these things.  There is also a `default' configuration that VM
 246 will use if no other configuration is applicable.  Command
 247 specific configurations are searched for first, then the category
 248 configurations and then the default configuration.  The first
 249 configuration found is the one that is applied.
 250
 251 The value of vm-mutable-windows must be non-nil for VM to use
 252 window configurations."
 253   (interactive
 254    (let ((last-command last-command)
 255          (this-command this-command))
 256      (if (null vm-window-configuration-file)
 257          (error "Configurable windows not enabled.  Set vm-window-configuration-file to enable."))
 258      (list
 259       (intern
 260        (completing-read "Name this window configuration: "
 261                         vm-supported-window-configurations
 262                         'identity t)))))
 263   (if (null vm-window-configuration-file)
 264       (error "Configurable windows not enabled.  Set vm-window-configuration-file to enable."))
 265   (let (map p)
 266     (setq map (tapestry (list (vm-selected-frame))))
 267     ;; set frame map to nil since we don't use it.  this prevents
 268     ;; cursor objects and any other objects that have an
 269     ;; "unreadable" read syntax appearing in the window
 270     ;; configuration file by way of frame-parameters.
 271     (setcar map nil)
 272     (tapestry-replace-tapestry-element map 'buffer-name 'vm-buffer-to-label)
 273     (tapestry-nullify-tapestry-elements map t nil t t t nil)
 274     (setq p (assq tag vm-window-configurations))
 275     (if p
 276         (setcar (cdr p) map)
 277       (setq vm-window-configurations
 278             (cons (list tag map) vm-window-configurations)))
 279     (vm-store-window-configurations vm-window-configuration-file)
 280     (message "%s configuration recorded" tag)))
 281
 282 (defun vm-buffer-to-label (buf)
 283   (save-excursion
 284     (set-buffer buf)
 285     (cond ((eq major-mode 'vm-summary-mode)
 286            'summary)
 287           ((eq major-mode 'vm-folders-summary-mode)
 288            'folders-summary)
 289           ((eq major-mode 'mail-mode)
 290            'composition)
 291           ((eq major-mode 'vm-mode)
 292            'message)
 293           ((eq major-mode 'vm-presentation-mode)
 294            'message)
 295           ((eq major-mode 'vm-virtual-mode)
 296            'message)
 297           ((eq vm-system-state 'editing)
 298            'edit)
 299           (t buf))))
 300
 301 ;;;###autoload
 302 (defun vm-delete-window-configuration (tag)
 303   "Delete the configuration saved for a particular action.
 304 This action will no longer have an associated window configuration.
 305 The action will be read from the minibuffer."
 306   (interactive
 307    (let ((last-command last-command)
 308          (this-command this-command))
 309      (if (null vm-window-configuration-file)
 310          (error "Configurable windows not enabled.  Set vm-window-configuration-file to enable."))
 311      (list
 312       (intern
 313        (completing-read "Delete window configuration: "
 314                         (mapcar (function
 315                                  (lambda (x)
 316                                    (list (symbol-name (car x)))))
 317                                 vm-window-configurations)
 318                         'identity t)))))
 319   (if (null vm-window-configuration-file)
 320       (error "Configurable windows not enabled.  Set vm-window-configuration-file to enable."))
 321   (let (p)
 322     (setq p (assq tag vm-window-configurations))
 323     (if p
 324         (if (eq p (car vm-window-configurations))
 325             (setq vm-window-configurations (cdr vm-window-configurations))
 326           (setq vm-window-configurations (delq p vm-window-configurations)))
 327       (error "No window configuration set for %s" tag)))
 328   (vm-store-window-configurations vm-window-configuration-file)
 329   (message "%s configuration deleted" tag))
 330
 331 ;;;###autoload
 332 (defun vm-apply-window-configuration (tag)
 333   "Change the current window configuration to be one
 334 associated with a particular action.  The action will be read
 335 from the minibuffer."
 336   (interactive
 337    (let ((last-command last-command)
 338          (this-command this-command))
 339      (list
 340       (intern
 341        (completing-read "Apply window configuration: "
 342                         (mapcar (function
 343                                  (lambda (x)
 344                                    (list (symbol-name (car x)))))
 345                                 vm-window-configurations)
 346                         'identity t)))))
 347   (vm-set-window-configuration tag))
 348
 349 (defun vm-window-help ()
 350   (interactive)
 351   (message "WS = save configuration, WD = delete configuration, WW = apply configuration"))
 352
 353 (defun vm-iconify-frame ()
 354   "Iconify the current frame.
 355 Run the hooks in vm-iconify-frame-hook before doing so."
 356   (interactive)
 357   (vm-check-for-killed-summary)
 358   (vm-select-folder-buffer)
 359   (if (vm-multiple-frames-possible-p)
 360       (progn
 361         (run-hooks 'vm-iconify-frame-hook)
 362         (vm-iconify-frame-xxx))))
 363
 364 (defun vm-window-loop (action obj-1 &optional obj-2)
 365   (let ((delete-me nil)
 366         (done nil)
 367         (all-frames (if vm-search-other-frames t nil))
 368         start w)
 369     (setq start (next-window (selected-window) 'nomini all-frames)
 370           w start)
 371     (and obj-1 (setq obj-1 (get-buffer obj-1)))
 372     (while (not done)
 373       (if (and delete-me (not (eq delete-me (next-window delete-me 'nomini))))
 374           (progn
 375             (delete-window delete-me)
 376             (if (eq delete-me start)
 377                 (setq start nil))
 378             (setq delete-me nil)))
 379       (cond ((and (eq action 'delete) (eq obj-1 (window-buffer w)))
 380              ;; a deleted window has no next window, so we
 381              ;; defer the deletion until after we've moved
 382              ;; to the next window.
 383              (setq delete-me w))
 384             ((and (eq action 'replace) (eq obj-1 (window-buffer w)))
 385              (set-window-buffer w obj-2)))
 386       (setq done (eq start
 387                      (setq w
 388                           (condition-case nil
 389                               (next-window w 'nomini all-frames)
 390                             (wrong-number-of-arguments
 391                              (next-window w 'nomini))))))
 392       (if (null start)
 393           (setq start w)))
 394     (if (and delete-me (not (eq delete-me (next-window delete-me 'nomini))))
 395         (delete-window delete-me))))
 396
 397 (defun vm-frame-loop (action obj-1)
 398   (if (fboundp 'vm-next-frame)
 399       (let ((start (vm-next-frame (vm-selected-frame)))
 400             (delete-me nil)
 401             (done nil)
 402             f)
 403         (setq f start)
 404         (and obj-1 (setq obj-1 (get-buffer obj-1)))
 405         (while (not done)
 406           (if delete-me
 407               (progn
 408                 (condition-case nil
 409                     (progn
 410                       (if (vm-created-this-frame-p delete-me)
 411                           (progn
 412                             (vm-delete-frame delete-me)
 413                             (if (eq delete-me start)
 414                                 (setq start nil)))))
 415                   (error nil))
 416                 (setq delete-me nil)))
 417           (cond ((and (eq action 'delete)
 418                       ;; one-window-p doesn't take a frame argument
 419                       (eq (next-window (vm-frame-selected-window f) 'nomini)
 420                           (previous-window (vm-frame-selected-window f)
 421                                            'nomini))
 422                       ;; the next-window call is to avoid looking
 423                       ;; at the minibuffer window
 424                       (eq obj-1 (window-buffer
 425                                  (next-window
 426                                   (vm-frame-selected-window f)
 427                                   'nomini))))
 428                  ;; a deleted frame has no next frame, so we
 429                  ;; defer the deletion until after we've moved
 430                  ;; to the next frame.
 431                  (setq delete-me f))
 432                 ((eq action 'bury)
 433                  (bury-buffer obj-1)))
 434           (setq done (eq start (setq f (vm-next-frame f))))
 435           (if (null start)
 436               (setq start f)))
 437         (if (and delete-me (vm-created-this-frame-p delete-me))
 438             (progn
 439               (vm-error-free-call 'vm-delete-frame delete-me)
 440               (setq delete-me nil))))))
 441
 442 (defun vm-maybe-delete-windows-or-frames-on (buffer)
 443   (and (eq vm-mutable-windows t) (vm-window-loop 'delete buffer))
 444   (and vm-mutable-frames (vm-frame-loop 'delete buffer)))
 445
 446 (defun vm-replace-buffer-in-windows (old new)
 447   (vm-window-loop 'replace old new))
 448
 449 (defun vm-bury-buffer (&optional buffer)
 450   (or buffer (setq buffer (current-buffer)))
 451   (if vm-xemacs-p
 452       (if (vm-multiple-frames-possible-p)
 453           (vm-frame-loop 'bury buffer)
 454         (bury-buffer buffer))
 455     (bury-buffer buffer)))
 456
 457 (defun vm-unbury-buffer (buffer)
 458   (save-excursion
 459     (save-window-excursion
 460       ;; catch errors--- the selected window might be a dedicated
 461       ;; window or a minibuffer window.  We don't care and we
 462       ;; don't want to crash because of it.
 463       (condition-case data
 464           (switch-to-buffer buffer)
 465         (error nil)))))
 466
 467 (defun vm-get-buffer-window (buffer)
 468   (condition-case nil
 469       (or (get-buffer-window buffer nil nil)
 470           (and vm-search-other-frames
 471                (get-buffer-window buffer t t)))
 472     (wrong-number-of-arguments
 473      (condition-case nil
 474          (or (get-buffer-window buffer nil)
 475              (and vm-search-other-frames
 476                   (get-buffer-window buffer t)))
 477        (wrong-number-of-arguments
 478         (get-buffer-window buffer))))))
 479
 480 (defun vm-get-visible-buffer-window (buffer)
 481   (condition-case nil
 482       (or (get-buffer-window buffer nil nil)
 483           (and vm-search-other-frames
 484                (get-buffer-window buffer t nil)))
 485     (wrong-number-of-arguments
 486      (condition-case nil
 487          (or (get-buffer-window buffer nil)
 488              (and vm-search-other-frames
 489                   (get-buffer-window buffer 'visible)))
 490        (wrong-number-of-arguments
 491         (get-buffer-window buffer))))))
 492
 493 (defun vm-set-hooks-for-frame-deletion ()
 494   (make-local-variable 'vm-undisplay-buffer-hook)
 495   (add-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame)
 496   (add-hook 'kill-buffer-hook 'vm-delete-buffer-frame))
 497
 498 (defun vm-created-this-frame-p (&optional frame)
 499   (memq (or frame (vm-selected-frame)) vm-frame-list))
 500
 501 (defun vm-delete-buffer-frame ()
 502   ;; kludge.  we only want to this to run on VM related buffers
 503   ;; but this function is generally on a global hook.  Check for
 504   ;; vm-undisplay-buffer-hook set; this is a good sign that this
 505   ;; is a VM buffer.
 506   (if vm-undisplay-buffer-hook
 507       (save-excursion
 508         ;; run once only per buffer.
 509         (remove-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame)
 510         (let* ((w (vm-get-visible-buffer-window (current-buffer)))
 511                (b (current-buffer))
 512                (wf (and w (vm-window-frame w))))
 513           (and w (eq (vm-selected-frame) wf) (vm-created-this-frame-p wf)
 514                (vm-error-free-call 'vm-delete-frame wf))
 515           (and w (let ((vm-mutable-frames t))
 516                    (vm-maybe-delete-windows-or-frames-on b)))))))
 517
 518 (defun vm-register-frame (frame)
 519   (setq vm-frame-list (cons frame vm-frame-list)))
 520
 521 (defun vm-goto-new-frame (&rest types)
 522   (let ((params nil))
 523     (while (and types (null params))
 524       (setq params (car (cdr (assq (car types) vm-frame-parameter-alist)))
 525             types (cdr types)))
 526     ;; these functions might be defined in an Emacs that isn't
 527     ;; running under a window system, but VM always checks for
 528     ;; multi-frame support before calling this function.
 529     (cond ((fboundp 'make-frame)
 530            (select-frame (make-frame params)))
 531           ((fboundp 'make-screen)
 532            (select-screen (make-screen params)))
 533           ((fboundp 'new-screen)
 534            (select-screen (new-screen params))))
 535     (vm-register-frame (vm-selected-frame))
 536     (and vm-warp-mouse-to-new-frame
 537          (vm-warp-mouse-to-frame-maybe (vm-selected-frame)))))
 538
 539 (defun vm-goto-new-summary-frame-maybe ()
 540   (if (and vm-mutable-frames vm-frame-per-summary
 541            (vm-multiple-frames-possible-p))
 542       (let ((w (vm-get-buffer-window vm-summary-buffer)))
 543         (if (null w)
 544             (progn
 545               (vm-goto-new-frame 'summary)
 546               (vm-set-hooks-for-frame-deletion))
 547           (save-excursion
 548             (select-window w)
 549             (and vm-warp-mouse-to-new-frame
 550                  (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))))
 551
 552 (defun vm-goto-new-folders-summary-frame-maybe ()
 553   (if (and vm-mutable-frames vm-frame-per-folders-summary
 554            (vm-multiple-frames-possible-p))
 555       (let ((w (vm-get-buffer-window vm-folders-summary-buffer)))
 556         (if (null w)
 557             (progn
 558               (vm-goto-new-frame 'folders-summary)
 559               (vm-set-hooks-for-frame-deletion))
 560           (save-excursion
 561             (select-window w)
 562             (and vm-warp-mouse-to-new-frame
 563                  (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))))
 564
 565 (defun vm-goto-new-folder-frame-maybe (&rest types)
 566   (if (and vm-mutable-frames vm-frame-per-folder
 567            (vm-multiple-frames-possible-p))
 568       (let ((w (or (vm-get-buffer-window (current-buffer))
 569                    ;; summary == folder for the purpose
 570                    ;; of frame reuse.
 571                    (and vm-summary-buffer
 572                         (vm-get-buffer-window vm-summary-buffer))
 573                    ;; presentation == folder for the purpose
 574                    ;; of frame reuse.
 575                    (and vm-presentation-buffer
 576                         (vm-get-buffer-window vm-presentation-buffer)))))
 577         (if (null w)
 578             (progn
 579               (apply 'vm-goto-new-frame types)
 580               (vm-set-hooks-for-frame-deletion))
 581           (save-excursion
 582             (select-window w)
 583             (and vm-warp-mouse-to-new-frame
 584                  (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))))
 585
 586 (defun vm-warp-mouse-to-frame-maybe (&optional frame)
 587   (or frame (setq frame (vm-selected-frame)))
 588   (if (vm-mouse-support-possible-here-p)
 589       (cond ((vm-mouse-xemacs-mouse-p)
 590              (cond ((fboundp 'mouse-position);; XEmacs 19.12
 591                     (let ((mp (mouse-position)))
 592                       (if (and (car mp)
 593                                (eq (window-frame (car mp)) (selected-frame)))
 594                           nil
 595                         (set-mouse-position (frame-highest-window frame)
 596                                             (/ (frame-width frame) 2)
 597                                             (/ (frame-height frame) 2)))))
 598                    (t ;; XEmacs 19.11
 599                     ;; use (apply 'screen-...) instead of
 600                     ;; (screen-...) to avoid stimulating a
 601                     ;; byte-compiler bug in Emacs 19.29 that
 602                     ;; happens when it encounters 'obsolete'
 603                     ;; functions.  puke, puke, puke.
 604                     (let ((mp (read-mouse-position frame)))
 605                       (if (and (>= (car mp) 0)
 606                                (<= (car mp) (apply 'screen-width frame))
 607                                (>= (cdr mp) 0)
 608                                (<= (cdr mp) (apply 'screen-height frame)))
 609                           nil
 610                         (set-mouse-position frame
 611                                             (/ (apply 'screen-width frame) 2)
 612                                             (/ (apply 'screen-height frame) 2)))))))
 613             ((vm-fsfemacs-p)
 614              (let ((mp (mouse-position)))
 615                (if (and (eq (car mp) frame)
 616                         ;; nil coordinates mean that the mouse
 617                         ;; pointer isn't really within the frame
 618                         (car (cdr mp)))
 619                    nil
 620                  (set-mouse-position frame
 621                                      (/ (frame-width frame) 2)
 622                                      (/ (frame-height frame) 2))
 623                  ;; doc for set-mouse-position says to do this
 624                  (unfocus-frame)))))))
 625
 626 (fset 'vm-selected-frame
 627       (symbol-function
 628        (cond ((fboundp 'selected-frame) 'selected-frame)
 629              ((fboundp 'selected-screen) 'selected-screen)
 630              (t 'ignore))))
 631
 632 (fset 'vm-delete-frame
 633       (symbol-function
 634        (cond ((fboundp 'delete-frame) 'delete-frame)
 635              ((fboundp 'delete-screen) 'delete-screen)
 636              (t 'ignore))))
 637
 638 ;; xxx because vm-iconify-frame is a command
 639 (defun vm-iconify-frame-xxx (&optional frame)
 640   (cond ((fboundp 'iconify-frame)
 641          (iconify-frame frame))
 642         ((fboundp 'iconify-screen)
 643          (iconify-screen (or frame (selected-screen))))))
 644
 645 (fset 'vm-raise-frame
 646       (symbol-function
 647        (cond ((fboundp 'raise-frame) 'raise-frame)
 648              ((fboundp 'raise-screen) 'raise-screen)
 649              (t 'ignore))))
 650
 651 (fset 'vm-frame-visible-p
 652       (symbol-function
 653        (cond ((fboundp 'frame-visible-p) 'frame-visible-p)
 654              ((fboundp 'screen-visible-p) 'screen-visible-p)
 655              (t 'ignore))))
 656
 657 (if (fboundp 'frame-iconified-p)
 658     (fset 'vm-frame-iconified-p 'frame-iconified-p)
 659   (defun vm-frame-iconified-p (&optional frame)
 660     (eq (vm-frame-visible-p frame) 'icon)))
 661
 662 ;; frame-totally-visible-p is broken under XEmacs 19.14 and is
 663 ;; absent under Emacs 19.34.  So vm-frame-per-summary won't work
 664 ;; quite right under these Emacs versions.  XEmacs 19.15 should
 665 ;; have a working version of this function.
 666 ;; 2 April 1997, frame-totally-visible-p apparently still broken
 667 ;; under 19.15.  I give up for now.
 668 ;;(if (and (fboundp 'frame-totally-visible-p)
 669 ;;       vm-xemacs-p
 670 ;;       (or (>= emacs-major-version 20)
 671 ;;           (>= emacs-minor-version 15)))
 672 ;;    (fset 'vm-frame-totally-visible-p 'frame-totally-visible-p)
 673 ;;  (fset 'vm-frame-totally-visible-p 'vm-frame-visible-p))
 674 ;; 2 April 1998, frame-visible-p returns 'hidden for tty frames
 675 ;; that are visible but not the topmost frame.  Use that info.
 676 (defun vm-frame-totally-visible-p (&optional frame)
 677   (or frame (setq frame (selected-frame)))
 678   (not (memq (frame-visible-p frame) '(nil hidden))))
 679
 680 (fset 'vm-window-frame
 681       (symbol-function
 682        (cond ((fboundp 'window-frame) 'window-frame)
 683              ((fboundp 'window-screen) 'window-screen)
 684              (t 'ignore))))
 685
 686 (cond ((fboundp 'next-frame)
 687        (fset 'vm-next-frame (symbol-function 'next-frame))
 688        (fset 'vm-select-frame (symbol-function 'select-frame))
 689        (fset 'vm-frame-selected-window
 690              (symbol-function 'frame-selected-window)))
 691       ((fboundp 'next-screen)
 692        (fset 'vm-next-frame (symbol-function 'next-screen))
 693        (fset 'vm-select-frame (symbol-function 'select-screen))
 694        (fset 'vm-frame-selected-window
 695              (if (fboundp 'epoch::selected-window)
 696                  (symbol-function 'epoch::selected-window)
 697                (symbol-function 'screen-selected-window))))
 698       (t
 699        ;; it is useful for this to be a no-op, but don't bind the
 700        ;; others.
 701        (fset 'vm-select-frame 'ignore)))
 702
 703 (provide 'vm-window)
 704
 705 ;;; vm-window.el ends here