;;!emacs
;; $Id:
;;
;; FILE:         hvm.el
;; SUMMARY:      Support Hyperbole buttons in mail reader: Vm.
;; USAGE:        GNU Emacs Lisp Library
;;
;; AUTHOR:       Bob Weiner
;; ORG:          Brown U.
;;
;; ORIG-DATE:    10-Oct-91 at 01:51:12
;; LAST-MOD:     28-Jan-93 at 13:48:03 by Bob Weiner
;;
;; This file is part of Hyperbole.
;;
;; Copyright (C) 1991, Brown University and the Free Software Foundation, Inc.
;; Available for use and distribution under the same terms as GNU Emacs.
;;
;; DESCRIPTION:  
;;
;;   Automatically configured for use in "hsite.el".
;;   If hsite loading fails prior to initializing Hyperbole Vm support,
;;
;;       {M-x Vm-init RTN}
;;
;;   will do it.
;;
;; DESCRIP-END.

;;; ************************************************************************
;;; Other required Elisp libraries
;;; ************************************************************************

(require 'hmail)
(load "hsmail")
(require 'vm)
(or (and (fboundp 'vm-edit-message) (fboundp 'vm-edit-message-end))
    (load "vm-edit"))
(vm-session-initialization)

;;; ************************************************************************
;;; Public variables
;;; ************************************************************************

;;; This is necessary since VM is not kind enough to provide an edit
;;; mode of its own.  "hmail.el" procedures will branch improperly if a
;;; regular mode, like VM's default 'text-mode', is used for editing.
(defvar vm-edit-message-mode nil
  "*Major mode to use when editing messages in VM.")
(setq vm-edit-message-mode 'vm-edit-mode)

(defun vm-edit-mode ()
  "Major mode for editing vm mail messages.
  Special commands:\\{vm-edit-message-mode-map}
Turning on vm-edit-mode calls the value of the variable vm-edit-mode-hook,
if that value is non-nil."
  (interactive)
  (kill-all-local-variables)
  (use-local-map vm-edit-message-mode-map)
  (setq mode-name "VM Edit")
  (setq major-mode 'vm-edit-mode)
  (setq local-abbrev-table text-mode-abbrev-table)
  (set-syntax-table text-mode-syntax-table)
  (run-hooks 'vm-edit-mode-hook))

;;; ************************************************************************
;;; Public functions
;;; ************************************************************************

(defun Vm-init ()
  "Initializes Hyperbole support for Vm mail reading."
  (interactive)
  (setq hmail:composer  'mail-mode
	hmail:lister    'vm-summary-mode
	hmail:modifier  'vm-edit-mode
	hmail:reader    'vm-mode)
  ;;
  ;; Setup public abstract interface to Hyperbole defined mail
  ;; reader-specific functions used in "hmail.el".
  ;;
  (rmail:init)
  ;;
  ;; Setup private abstract interface to mail reader-specific functions
  ;; used in "hmail.el".
  ;;
  (fset 'rmail:get-new       'vm-get-new-mail)
  (fset 'rmail:msg-forward   'vm-forward-message)
  (fset 'rmail:summ-msg-to   'vm-follow-summary-cursor)
  (fset 'rmail:summ-new      'vm-summarize)
  (if (interactive-p)
      (message "Hyperbole VM mail reader support initialized."))
  )

(defun Vm-msg-hdrs-full (toggled)
  "If TOGGLED is non-nil, toggle full/hidden headers, else show full headers."
  (save-excursion
    (if (or toggled
	    (let ((exposed (= (point-min)
			      (vm-start-of (car vm-message-pointer)))))
	      (not exposed)))
	(progn (vm-expose-hidden-headers)
	       (setq toggled t)))
    toggled))

(defun Vm-msg-narrow ()
  "Narrows mail reader buffer to current message.
This includes Hyperbole button data."
  (vm-within-current-message-buffer
   (narrow-to-region (point-min) (Vm-msg-end))))

(defun Vm-msg-next ()           (vm-next-message 1))

(defun Vm-msg-num ()
  "Returns number of vm mail message that point is within."
  (interactive)
  (let ((count 1)
	(case-fold-search))
    (save-excursion
      (save-restriction
	(widen)
	(while (search-backward Vm-msg-start-string nil t)
	  (setq count (1+ count)))))
    count))

(defun Vm-msg-prev ()           (vm-previous-message 1))

(defun Vm-msg-to-p (mail-msg-id mail-file)
  "Sets current buffer to start of msg with MAIL-MSG-ID in MAIL-FILE.
Returns t if successful, else nil or signals error."
  (if (not (file-readable-p mail-file))
      nil
    (vm-visit-folder mail-file)
    (widen)
    (goto-char 1)
      (if (let ((case-fold-search))
	    (re-search-forward (concat rmail:msg-hdr-prefix
				       (regexp-quote mail-msg-id)) nil t))
	  ;; Found matching msg
	  (progn
	    (setq buffer-read-only t)
	    (vm-goto-message (Vm-msg-num))
	    t))))

(defun Vm-msg-widen ()
  "Widens buffer to full current message including Hyperbole button data."
  (vm-within-current-message-buffer
   (narrow-to-region (point-min) (Vm-msg-end))))

(defun Vm-to ()
  "Sets current buffer to a mail reader buffer."
  (and (eq major-mode 'vm-summary-mode) (set-buffer vm-mail-buffer)))

(defun Vm-Summ-delete ()        (vm-delete-message 1))

(fset 'Vm-Summ-expunge          'vm-expunge-folder)

(defun Vm-Summ-goto ()          'vm-follow-summary-cursor)

(defun Vm-Summ-to ()
  "Sets current buffer to a mail listing buffer."
  (and (eq major-mode 'vm-mode) (set-buffer vm-summary-buffer)))

(defun Vm-Summ-undelete-all ()
  (message
   "(Vm-Summ-undelete-all: Vm doesn't have an undelete all msgs function."))

;;; ************************************************************************
;;; Private functions
;;; ************************************************************************

(defun Vm-msg-end ()
  "Returns end point for current Vm message, including Hyperbole button data.
Has side-effect of widening buffer."
  (save-excursion
    (goto-char (point-min))
    (widen)
    (if (let ((case-fold-search))
	  (search-forward Vm-msg-start-string nil t))
	(match-beginning 0)
      (point-max))))

;;; Overlay version of this function from "vm-page.el" to hide any
;;; Hyperbole button data whenever a message is displayed in its entirety.
(defun vm-show-current-message ()
  (setq vm-system-state 'showing)
  (let ((vmp vm-message-pointer))
    (vm-within-current-message-buffer
     (let ((vm-message-pointer vmp))
       (hmail:msg-narrow (point-min) (Vm-msg-end))
       (goto-char (vm-text-of (car vm-message-pointer))))
     (and vm-honor-page-delimiters
	  (save-excursion
	    (if (search-forward page-delimiter nil t)
		(progn
		  (goto-char (match-beginning 0))
		  (not (looking-at (regexp-quote hmail:hbdata-sep))))))
	  (progn
	    (if (looking-at page-delimiter)
		(forward-page 1))
	    (vm-narrow-to-page)))))
  (cond ((vm-new-flag (car vm-message-pointer))
	 (vm-set-new-flag (car vm-message-pointer) nil))
	((vm-unread-flag (car vm-message-pointer))
	 (vm-set-unread-flag (car vm-message-pointer) nil)))
  (if (fboundp 'ep:but-create) (ep:but-create))
  (vm-update-summary-and-mode-line))

;;;  
;;; Overlay version of this function from "vm-page.el" to treat end of
;;; text (excluding Hyperbole button data) as end of message.
(defun vm-scroll-forward (&optional arg)
  "Scroll forward a screenful of text.
If the current message is being previewed, the message body is revealed.
If at the end of the current message, moves to the next message iff the
value of vm-auto-next-message is non-nil.
Prefix N scrolls forward N lines."
  (interactive "P")
  (let ((mp-changed (vm-follow-summary-cursor)) was-invisible do-next-message)
    (vm-select-folder-buffer)
    (vm-sanity-check-modification-flag)
    (vm-check-for-killed-summary)
    (vm-error-if-folder-empty)
    (if (vm-within-current-message-buffer
	 (null (get-buffer-window (current-buffer))))
	(progn
	  (vm-display-current-message-buffer)
	  (setq was-invisible t)))
    (if (eq vm-system-state 'previewing)
	(vm-show-current-message)
      (if (or mp-changed was-invisible)
	  ()
	(setq vm-system-state 'reading)
	(let ((w (get-buffer-window (vm-current-message-buffer)))
	      (vmp vm-message-pointer)
	      (old-w (selected-window))
	      (direction (prefix-numeric-value arg))
	      error-data)
	  (vm-within-current-message-buffer
	   (unwind-protect
	       (progn
		 (select-window w)
		 (let ((vm-message-pointer vmp))
		   (while
		     (catch 'tryagain
		       (if (not
			    (eq
			     (condition-case error-data
				 (scroll-up arg)
			       (error
				(if (or (and (< direction 0)
					     (> (point-min)
						(vm-text-of
						 (car vm-message-pointer))))
					(and (>= direction 0)
					     (/= (point-max)
						 (save-restriction
						   (hmail:hbdata-start
						    (point-min)
						    (vm-text-end-of
						     (car vm-message-pointer)
						     )))
						 )))
				    (progn
				      (vm-widen-page)
				      (if (>= direction 0)
					  (progn
					    (forward-page 1)
					    (set-window-start w (point))
					    nil )
					(if (or
					     (bolp)
					     (not
					      (save-excursion
						(beginning-of-line)
						(looking-at page-delimiter))))
					    (forward-page -1))
					(beginning-of-line)
					(set-window-start w (point))
					(throw 'tryagain t)))
				  (if (eq (car error-data) 'end-of-buffer)
				      (if vm-auto-next-message
					  (progn (setq do-next-message t)
						 'next-message)
					(message "End of message %s from %s"
						 (vm-number-of
						  (car vm-message-pointer))
						 (vm-su-full-name
						  (car vm-message-pointer)))
					nil )))))
			     'next-message))
			   (progn
			     (if vm-honor-page-delimiters
				 (progn
				   (vm-narrow-to-page)
				   ;; This voodoo is required!  For some
				   ;; reason the 18.52 emacs display
				   ;; doesn't immediately reflect the
				   ;; clip region change that occurs
				   ;; above without this mantra. 
				   (scroll-up 0)))))
		       nil ))))
	     (select-window old-w))))))
    (if do-next-message
	(vm-next-message)))
  (if (not (or vm-startup-message-displayed vm-inhibit-startup-message))
      (vm-display-startup-message)))

;;; Overlay version of this function from "vm-page.el" (called by
;;; vm-scroll-* functions).  Make it keep Hyperbole button data hidden.
(defun vm-widen-page ()
  (if (or (> (point-min) (vm-text-of (car vm-message-pointer)))
	  (/= (point-max) (vm-text-end-of (car vm-message-pointer))))
      (hmail:msg-narrow (vm-vheaders-of (car vm-message-pointer))
			(if (or (vm-new-flag (car vm-message-pointer))
				(vm-unread-flag (car vm-message-pointer)))
			    (vm-text-of (car vm-message-pointer))
			  (vm-text-end-of (car vm-message-pointer))))))

;;; Overlay version of this function from "vm-edit.el" to hide
;;; Hyperbole button data when insert edited message from temporary buffer.
(fset 'vm-edit-message (append (symbol-function 'vm-edit-message)
			       '((hmail:msg-narrow))))

;;; Overlay version of this function from "vm-edit.el" to hide
;;; Hyperbole button data when insert edited message from temporary buffer.
(defun vm-edit-message-end ()
  "End the edit of a VM mail message and copy the new version
to the message's folder."
  (interactive)
  (if (null vm-message-pointer)
      (error "This is not a VM message edit buffer."))
  (if (null (buffer-name (marker-buffer (vm-end-of (car vm-message-pointer)))))
      (error "The folder buffer for this message has been killed."))
  (let ((edit-buf (current-buffer))
	(mp vm-message-pointer))
    (if (buffer-modified-p)
	(let ((inhibit-quit t))
	  (widen)
	  (save-excursion
	    (set-buffer (marker-buffer (vm-start-of (car mp))))
	    (if (not (memq (car mp) vm-message-list))
		(error "The original copy of this message has been expunged."))
	    (vm-save-restriction
	     (widen)
	     (goto-char (vm-start-of (car mp)))
	     (forward-line 1)
	     (let ((vm-message-pointer mp)
		   vm-next-command-uses-marks
		   buffer-read-only)
	       (insert-buffer-substring edit-buf)
	       (and (/= (preceding-char) ?\n) (insert ?\n))
	       (delete-region (point) (vm-text-end-of (car mp)))
	       (vm-discard-cached-data)
	       (hmail:msg-narrow))
	     (vm-set-edited-flag (car mp) t)
	     (vm-mark-for-display-update (car mp))
	     (if (eq vm-flush-interval t)
		 (vm-stuff-virtual-attributes (car mp))
	       (vm-set-modflag-of (car mp) t))
	     (vm-set-buffer-modified-p t)
	     (vm-clear-modification-flag-undos)
	     (vm-set-edit-buffer-of (car mp) nil))
	    (if (eq mp vm-message-pointer)
		(vm-preview-current-message)
	      (vm-update-summary-and-mode-line))))
      (message "No change."))
    (set-buffer-modified-p nil)
    (kill-buffer edit-buf)))

;;; Overlay version of this function from "vm-reply.el" to hide any
;;; Hyperbole button data.
(fset 'vm-forward-message
      (append (symbol-function 'vm-forward-message)
	      '((hmail:msg-narrow))))

;;; Overlay this function from "vm.el" called whenever new mail is
;;; incorporated so that it will highlight Hyperbole buttons when possible.
;;  Returns non-nil if there were any new messages.
(defun vm-assimilate-new-messages ()
  (let ((tail-cons (vm-last vm-message-list))
	(new-messages-p (null vm-message-list)))
    (save-excursion
      (vm-save-restriction
       (widen)
       (if (fboundp 'ep:but-create)
	   (ep:but-create))
       (vm-build-message-list)
       (vm-read-attributes)
       (setq new-messages-p (or new-messages-p (cdr tail-cons))
	     vm-numbering-redo-start-point new-messages-p
	     vm-summary-redo-start-point new-messages-p)
       (cond ((and vm-current-grouping new-messages-p)
	      (condition-case data
		  (vm-group-messages vm-current-grouping)
		;; presumably an unsupported grouping
		(error (message (car (cdr data)))
		       (sleep-for 2))))))
      (setq vm-need-summary-pointer-update t)
      new-messages-p)))

;;; Overlay version of 'vm-force-mode-line-update' from "vm.el"
;;; to highlight Hyperbole buttons in summary buffers.
;;;
(defun vm-force-mode-line-update ()
  (save-excursion
    (if vm-summary-buffer
	(progn (set-buffer vm-summary-buffer)
	       (if (fboundp 'ep:but-create) (ep:but-create)))
      (set-buffer (other-buffer)))
    (set-buffer-modified-p (buffer-modified-p))))

;;; ************************************************************************
;;; Private variables
;;; ************************************************************************

(defvar Vm-msg-start-string "\n\nFrom "
  "String that begins a Vm mail message.")

(provide 'hvm)