home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / vm / vm-5.33beta / vm-window.el < prev    next >
Encoding:
Text File  |  1991-06-03  |  7.3 KB  |  208 lines
  1. ;;; Window management code for VM
  2. ;;; Copyright (C) 1989, 1990, 1991 Kyle E. Jones
  3. ;;;
  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
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (defun vm-display-current-message-buffer (&optional no-highlighting)
  19.   (vm-select-folder-buffer)
  20.   (vm-check-for-killed-summary)
  21.   (let (point msg-buf sized)
  22.     (vm-within-current-message-buffer
  23.      (setq msg-buf (current-buffer)
  24.        point (point))
  25.      (if (null (get-buffer-window (current-buffer)))
  26.      (if (not (setq sized (vm-set-window-configuration 'showing-message)))
  27.          (if vm-mutable-windows
  28.          (let ((pop-up-windows (and pop-up-windows
  29.                         (eq vm-mutable-windows t))))
  30.            (display-buffer (current-buffer)))
  31.            (switch-to-buffer (current-buffer)))))
  32.      (set-buffer msg-buf)
  33.      (let ((w (get-buffer-window msg-buf)))
  34.        (and w
  35.         (progn (set-window-point w point)
  36.            (and (>= (window-start w) (point-max))
  37.             (set-window-start w (point-min)))))))
  38.     (if (and (not sized) vm-summary-buffer
  39.          (get-buffer-window vm-summary-buffer)
  40.          (eq vm-mutable-windows t))
  41.     (vm-proportion-windows))
  42.     (if (not no-highlighting)
  43.     (vm-within-current-message-buffer
  44.      (vm-highlight-headers (car vm-message-pointer)
  45.                    (get-buffer-window (current-buffer)))))))
  46.  
  47. (defun vm-proportion-windows ()
  48.   (vm-select-folder-buffer)
  49.   (vm-within-current-message-buffer
  50.    ;; don't attempt proportioning if there aren't exactly two windows.
  51.    (if (and (not (one-window-p t))
  52.         (eq (selected-window)
  53.         (next-window (next-window (selected-window) 0) 0)))
  54.        (if (= (window-width) (screen-width))
  55.        (let ((mail-w (get-buffer-window (current-buffer)))
  56.          (n (- (window-height (get-buffer-window (current-buffer)))
  57.                (/ (* vm-mail-window-percentage
  58.                  (- (screen-height)
  59.                 (window-height (minibuffer-window))))
  60.               100)))
  61.          (old-w (selected-window)))
  62.          (if mail-w
  63.          (save-excursion
  64.            (select-window mail-w)
  65.            (shrink-window n)
  66.            (select-window old-w)
  67.            (and (memq major-mode '(vm-summary-mode vm-virtual-mode))
  68.             (vm-auto-center-summary)))))
  69.      (let ((mail-w (get-buffer-window (current-buffer)))
  70.            (n (- (window-width (get-buffer-window (current-buffer)))
  71.              (/ (* vm-mail-window-percentage (screen-width))
  72.             100)))
  73.            (old-w (selected-window)))
  74.        (if mail-w
  75.            (save-excursion
  76.          (select-window mail-w)
  77.          (shrink-window-horizontally n)
  78.          (select-window old-w)
  79.          (and (memq major-mode '(vm-summary-mode vm-virtual-mode))
  80.               (vm-auto-center-summary)))))))))
  81.  
  82. (defun vm-load-window-configurations (file)
  83.   (save-excursion
  84.     (let (work-buffer)
  85.       (unwind-protect
  86.       (progn
  87.         (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*")))
  88.         (erase-buffer)
  89.         (setq vm-window-configurations
  90.           (condition-case ()
  91.               (progn
  92.             (insert-file-contents file)
  93.             (read (current-buffer)))
  94.             (error nil))))
  95.     (and work-buffer (kill-buffer work-buffer))))))
  96.  
  97. (defun vm-store-window-configurations (file)
  98.   (save-excursion
  99.     (let (work-buffer)
  100.       (unwind-protect
  101.       (progn
  102.         (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*")))
  103.         (erase-buffer)
  104.         (print vm-window-configurations (current-buffer))
  105.         (write-region (point-min) (point-max) file nil 0))
  106.     (and work-buffer (kill-buffer work-buffer))))))
  107.  
  108. (defun vm-set-window-configuration (&rest tags)
  109.   (catch 'done
  110.     (let ((scratch "*scratch*") summary message composition config p)
  111.       (while (and tags (null config))
  112.     (setq config (assq (car tags) vm-window-configurations)
  113.           tags (cdr tags)))
  114.       (or config (throw 'done nil))
  115.       (setq config (vm-copy config))
  116.       (setq composition (vm-find-composition-buffer t))
  117.       (cond ((memq major-mode '(vm-summary-mode mail-mode))
  118.          (and vm-mail-buffer (buffer-name vm-mail-buffer)
  119.           (set-buffer vm-mail-buffer)))
  120.         ((eq major-mode 'vm-virtual-mode)
  121.          (setq summary (current-buffer)
  122.            message (and vm-message-pointer
  123.                    (vm-current-message-buffer)))))
  124.       (vm-check-for-killed-summary)
  125.       (or message (setq message (current-buffer)))
  126.       (or summary (setq summary (or vm-summary-buffer scratch)))
  127.       (or composition (setq composition scratch))    
  128.       (screen-replace-map-element (nth 1 config) 'buffer-name 'symbol-value)
  129.       (set-screen-map (nth 1 config))
  130.       (save-excursion
  131.     (set-buffer message)
  132.     (setq vm-window-configuration (car tags)))
  133.       t )))
  134.  
  135. (defun vm-save-window-configuration (tag)
  136.   (interactive
  137.    (progn
  138.      (if (null vm-window-configuration-file)
  139.      (error "Configurable windows not enabled."))
  140.      (list
  141.       (intern
  142.        (completing-read "Name this window configuration: "
  143.             vm-supported-window-configurations
  144.             'identity t)))))
  145.   (if (null vm-window-configuration-file)
  146.       (error "Configurable windows not enabled."))
  147.   (let (map p)
  148.     (setq map (screen-map))
  149.     (screen-replace-map-element map 'buffer-name 'vm-screen-buffer-to-label)
  150.     (screen-nullify-map-elements map t nil t t t nil)
  151.     (setq p (assq tag vm-window-configurations))
  152.     (if p
  153.     (setcar (cdr p) map)
  154.       (setq vm-window-configurations
  155.         (cons (list tag map) vm-window-configurations)))
  156.     (vm-store-window-configurations vm-window-configuration-file)
  157.     (message "%s configuration recorded" tag)))
  158.  
  159. (defun vm-screen-buffer-to-label (buf)
  160.   (save-excursion
  161.     (set-buffer buf)
  162.     (cond ((memq major-mode '(vm-virtual-mode vm-summary-mode))
  163.        'summary)
  164.       ((eq major-mode 'mail-mode)
  165.        'composition)
  166.       ((eq major-mode 'vm-mode)
  167.        'message)
  168.       (t buf))))
  169.  
  170. (defun vm-delete-window-configuration (tag)
  171.   (interactive
  172.    (progn
  173.      (if (null vm-window-configuration-file)
  174.      (error "Configurable windows not enabled."))
  175.      (list
  176.       (intern
  177.        (completing-read "Delete window configuration: "
  178.             vm-window-configurations
  179.             'identity t)))))
  180.   (if (null vm-window-configuration-file)
  181.       (error "Configurable windows not enabled."))
  182.   (let (p)
  183.     (setq p (assq tag vm-window-configurations))
  184.     (if p
  185.     (if (eq p (car vm-window-configurations))
  186.         (setq vm-window-configurations (cdr vm-window-configurations))
  187.       (setq vm-window-configurations (delq p vm-window-configurations)))))
  188.   (vm-store-window-configurations vm-window-configuration-file)
  189.   (message "%s configuration deleted" tag))
  190.  
  191. (defun vm-apply-window-configuration (tag)
  192.   (interactive
  193.    (progn
  194.      (if (null vm-window-configuration-file)
  195.      (error "Configurable windows not enabled."))
  196.      (list
  197.       (intern
  198.        (completing-read "Apply window configuration: "
  199.             vm-window-configurations
  200.             'identity t)))))
  201.   (if (null vm-window-configuration-file)
  202.       (error "Configurable windows not enabled."))
  203.   (vm-set-window-configuration tag))
  204.  
  205. (defun vm-window-help ()
  206.   (interactive)
  207.   (message "WS = save configuration, WD = delete configuration, WW = apply configuration"))
  208.