home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / vm / vm-page.el < prev    next >
Encoding:
Text File  |  1993-01-26  |  10.5 KB  |  309 lines
  1. ;;; Commands to move around within a VM message
  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-scroll-forward (&optional arg)
  19.   "Scroll forward a screenful of text.
  20. If the current message is being previewed, the message body is revealed.
  21. If at the end of the current message, moves to the next message iff the
  22. value of vm-auto-next-message is non-nil.
  23. Prefix N scrolls forward N lines."
  24.   (interactive "P")
  25.   (let ((mp-changed (vm-follow-summary-cursor)) was-invisible do-next-message)
  26.     (vm-select-folder-buffer)
  27.     (vm-sanity-check-modification-flag)
  28.     (vm-check-for-killed-summary)
  29.     (vm-error-if-folder-empty)
  30.     (if (vm-within-current-message-buffer
  31.      (null (get-buffer-window (current-buffer))))
  32.     (progn
  33.       (vm-display-current-message-buffer)
  34.       (setq was-invisible t)))
  35.     (if (eq vm-system-state 'previewing)
  36.     (vm-show-current-message)
  37.       (if (or mp-changed was-invisible)
  38.       (vm-howl-if-eom)
  39.     (let ((vmp vm-message-pointer)
  40.           (msg-buf (vm-current-message-buffer))
  41.           (h-diff 0)
  42.           w old-w result)
  43.     (setq vm-system-state 'reading)
  44.     (setq old-w (get-buffer-window msg-buf))
  45.     (if (not (eq vm-window-configuration 'paging-message))
  46.         (save-excursion (vm-set-window-configuration 'paging-message)))
  47.     (setq w (get-buffer-window msg-buf))
  48.     (if (null w)
  49.         (error "paging-message configuration hides the message buffer.")
  50.       (setq h-diff (- (window-height w) (window-height old-w))))
  51.     (setq old-w (selected-window))
  52.     (vm-within-current-message-buffer
  53.      (unwind-protect
  54.          (progn
  55.            (select-window w)
  56.            (let ((next-screen-context-lines
  57.               (+ next-screen-context-lines h-diff))
  58.              ;; restore
  59.              (vm-message-pointer vmp))
  60.          (while (eq (setq result (vm-scroll-forward-internal arg))
  61.                 'tryagain))
  62.          (cond ((and (not (eq result 'next-message))
  63.                  vm-honor-page-delimiters)
  64.             (vm-narrow-to-page)
  65.             ;; This voodoo is required!  For some
  66.             ;; reason the 18.52 emacs display
  67.             ;; doesn't immediately reflect the
  68.             ;; clip region change that occurs
  69.             ;; above without this mantra. 
  70.             (scroll-up 0)))))
  71.        (select-window old-w)))
  72.     (cond ((eq result 'next-message)
  73.            (vm-next-message)
  74.            (vm-set-window-configuration 'auto-next-message))
  75.           ((eq result 'end-of-message)
  76.            (vm-set-window-configuration 'end-of-message)
  77.            (let ((vm-message-pointer vmp))
  78.          (vm-emit-eom-blurb)))
  79.           (t
  80.            (and (> (prefix-numeric-value arg) 0)
  81.             (vm-howl-if-eom))))))))
  82.   (if (not (or vm-startup-message-displayed vm-inhibit-startup-message))
  83.       (vm-display-startup-message)))
  84.  
  85. (defun vm-scroll-forward-internal (arg)
  86.   (let ((direction (prefix-numeric-value arg))
  87.     (w (selected-window)))
  88.     (condition-case error-data
  89.     (progn (scroll-up arg) nil)
  90.       (error
  91.        (if (or (and (< direction 0)
  92.             (> (point-min) (vm-text-of (car vm-message-pointer))))
  93.            (and (>= direction 0)
  94.             (/= (point-max)
  95.             (vm-text-end-of (car vm-message-pointer)))))
  96.        (progn
  97.          (vm-widen-page)
  98.          (if (>= direction 0)
  99.          (progn
  100.            (forward-page 1)
  101.            (set-window-start w (point))
  102.            nil )
  103.            (if (or (bolp)
  104.                (not (save-excursion
  105.                   (beginning-of-line)
  106.                   (looking-at page-delimiter))))
  107.            (forward-page -1))
  108.            (beginning-of-line)
  109.            (set-window-start w (point))
  110.            'tryagain))
  111.      (if (eq (car error-data) 'end-of-buffer)
  112.          (if vm-auto-next-message
  113.          'next-message
  114.            (set-window-point w (point))
  115.            'end-of-message)))))))
  116.  
  117. (defun vm-howl-if-eom ()
  118.   (let ((vmp vm-message-pointer))
  119.     (vm-within-current-message-buffer
  120.      (let ((w (get-buffer-window (current-buffer)))
  121.        (vm-message-pointer vmp))
  122.        (and w
  123.         (save-excursion
  124.           (save-window-excursion
  125.         (condition-case ()
  126.             (let ((next-screen-context-lines 0))
  127.               (select-window w)
  128.               (save-excursion
  129.             (save-window-excursion
  130.               (scroll-up nil)))
  131.               nil)
  132.           (error t))))
  133.         (= (vm-text-end-of (car vm-message-pointer)) (point-max))
  134.         (vm-emit-eom-blurb))))))
  135.  
  136. (defun vm-emit-eom-blurb ()
  137.   (message "End of message %s from %s"
  138.        (vm-number-of (car vm-message-pointer))
  139.        (vm-su-full-name (car vm-message-pointer))))
  140.  
  141. (defun vm-scroll-backward (arg)
  142.   "Scroll backward a screenful of text.
  143. Prefix N scrolls backward N lines."
  144.   (interactive "P")
  145.   (vm-scroll-forward (cond ((null arg) '-)
  146.                ((symbolp arg) nil)
  147.                ((consp arg) (list (- (car arg))))
  148.                (t arg))))
  149.  
  150. (defun vm-preview-current-message ()
  151.   (setq vm-system-state 'previewing)
  152.   (if (and (null (vm-within-current-message-buffer
  153.           (get-buffer-window (current-buffer))))
  154.        (eq major-mode 'vm-virtual-mode)
  155.        (not (one-window-p t)))
  156.       (vm-display-current-message-buffer t))
  157.   (if (null vm-message-pointer) ; don't lose on empty folder -- jwz
  158.       nil
  159.   (let ((vmp vm-message-pointer))
  160.     (vm-within-current-message-buffer
  161.      (let ((vm-message-pointer vmp))
  162.        (widen)
  163.        (narrow-to-region
  164.     (vm-vheaders-of (car vm-message-pointer))
  165.     (if vm-preview-lines
  166.         (min
  167.          (vm-text-end-of (car vm-message-pointer))
  168.          (save-excursion
  169.            (goto-char (vm-text-of (car vm-message-pointer)))
  170.            (forward-line (if (natnump vm-preview-lines)
  171.                  vm-preview-lines
  172.                    0))
  173.            (point)))
  174.       (vm-text-of (car vm-message-pointer))))
  175.        (if vm-honor-page-delimiters
  176.        (vm-narrow-to-page))
  177.        (goto-char (vm-text-of (car vm-message-pointer)))
  178.        ;; If we have a window, set window start appropriately.
  179.        ;; Highlight appropriate headers if current buffer is visible.
  180.        (let ((w (get-buffer-window (current-buffer))))
  181.      (if w (set-window-start w (point-min)))
  182.      (vm-highlight-headers (car vm-message-pointer) w)))))
  183.   ;; De Morgan's Theorems could clear away most of the following negations,
  184.   ;; but the resulting code would be horribly obfuscated.
  185.   (if (or (null vm-preview-lines)
  186.       (and (not vm-preview-read-messages)
  187.            (not (vm-new-flag (car vm-message-pointer)))
  188.            (not (vm-unread-flag (car vm-message-pointer)))))
  189.       (vm-show-current-message)
  190.     (vm-update-summary-and-mode-line)
  191.     (run-hooks 'vm-preview-message-hook)    ; jwz
  192.     )))
  193.  
  194. (defun vm-show-current-message ()
  195.   (setq vm-system-state 'showing)
  196.   (let ((vmp vm-message-pointer)
  197.     (newp nil)
  198.     (unreadp nil))
  199.     (vm-within-current-message-buffer
  200.      (let ((vm-message-pointer vmp))
  201.        (save-excursion
  202.      (goto-char (point-min))
  203.      (widen)
  204.      (narrow-to-region (point) (vm-text-end-of (car vm-message-pointer))))
  205.        (if vm-honor-page-delimiters
  206.        (progn
  207.          (if (looking-at page-delimiter)
  208.          (forward-page 1))
  209.          (vm-narrow-to-page)))))
  210.   (cond ((vm-new-flag (car vm-message-pointer))
  211.      (setq newp t)        ; jwz: for vm-show-new-message-hook.
  212.      (vm-set-new-flag (car vm-message-pointer) nil))
  213.     ((vm-unread-flag (car vm-message-pointer))
  214.      (setq unreadp t)    ; jwz: for vm-show-unread-message-hook.
  215.      (vm-set-unread-flag (car vm-message-pointer) nil)))
  216.   (vm-update-summary-and-mode-line)
  217.   (cond (newp (run-hooks 'vm-show-new-message-hook))
  218.     (unreadp (run-hooks 'vm-show-unread-message-hook)))
  219.   (run-hooks 'vm-show-message-hook)
  220.   ))
  221.  
  222. (defun vm-expose-hidden-headers ()
  223.   "Toggle exposing and hiding message headers that are normally not visible."
  224.   (interactive)
  225.   (vm-follow-summary-cursor)
  226.   (vm-select-folder-buffer)
  227.   (vm-check-for-killed-summary)
  228.   (vm-error-if-folder-empty)
  229.   (let ((vmp vm-message-pointer))
  230.     (vm-within-current-message-buffer
  231.      (let* ((vm-message-pointer vmp)
  232.         (exposed (= (point-min) (vm-start-of (car vm-message-pointer)))))
  233.        (vm-widen-page)
  234.        (goto-char (point-max))
  235.        (widen)
  236.        (if exposed
  237.        (narrow-to-region (point) (vm-vheaders-of (car vm-message-pointer)))
  238.      (narrow-to-region (point) (vm-start-of (car vm-message-pointer))))
  239.        (goto-char (point-min))
  240.        (let (w)
  241.      (setq w (get-buffer-window (current-buffer)))
  242.      (and w (set-window-point w (point-min)))
  243.      (and w
  244.           (= (window-start w) (vm-vheaders-of (car vm-message-pointer)))
  245.           (not exposed)
  246.           (set-window-start w (vm-start-of (car vm-message-pointer)))))
  247.        (if vm-honor-page-delimiters
  248.        (vm-narrow-to-page))))))
  249.  
  250. (defun vm-widen-page ()
  251.   (if (or (> (point-min) (vm-text-of (car vm-message-pointer)))
  252.       (/= (point-max) (vm-text-end-of (car vm-message-pointer))))
  253.       (narrow-to-region (vm-vheaders-of (car vm-message-pointer))
  254.             (if (or (vm-new-flag (car vm-message-pointer))
  255.                 (vm-unread-flag (car vm-message-pointer)))
  256.                 (vm-text-of (car vm-message-pointer))
  257.               (vm-text-end-of (car vm-message-pointer))))))
  258.  
  259. (defun vm-narrow-to-page ()
  260.   (save-excursion
  261.     (let (min max (omin (point-min)) (omax (point-max)))
  262.       (if (or (bolp) (not (save-excursion
  263.                 (beginning-of-line)
  264.                 (looking-at page-delimiter))))
  265.       (forward-page -1))
  266.       (setq min (point))
  267.       (forward-page 1)
  268.       (beginning-of-line)
  269.       (setq max (point))
  270.       (narrow-to-region min max))))
  271.  
  272. (defun vm-beginning-of-message ()
  273.   "Moves to the beginning of the current message."
  274.   (interactive)
  275.   (vm-follow-summary-cursor)
  276.   (vm-select-folder-buffer)
  277.   (vm-check-for-killed-summary)
  278.   (vm-error-if-folder-empty)
  279.   (let ((vmp vm-message-pointer))
  280.     (vm-within-current-message-buffer
  281.      (let ((vm-message-pointer vmp))
  282.        (vm-widen-page)
  283.        (push-mark)
  284.        (goto-char (point-min))
  285.        (if vm-honor-page-delimiters
  286.        (vm-narrow-to-page)))))
  287.   (vm-display-current-message-buffer))
  288.  
  289. (defun vm-end-of-message ()
  290.   "Moves to the end of the current message, exposing and flagging it read
  291. as necessary."
  292.   (interactive)
  293.   (vm-follow-summary-cursor)
  294.   (vm-select-folder-buffer)
  295.   (vm-check-for-killed-summary)
  296.   (vm-error-if-folder-empty)
  297.   (if (eq vm-system-state 'previewing)
  298.       (vm-show-current-message))
  299.   (setq vm-system-state 'reading)
  300.   (let ((vmp vm-message-pointer))
  301.     (vm-within-current-message-buffer
  302.      (let ((vmp vm-message-pointer))
  303.        (vm-widen-page)
  304.        (push-mark)
  305.        (goto-char (point-max))
  306.        (if vm-honor-page-delimiters
  307.        (vm-narrow-to-page)))))
  308.   (vm-display-current-message-buffer t))
  309.