;; Last edited: Fri Nov  2 10:26:24 1990
;; extra widgets for rmail and rmailsum
;; Copyright (C) 1990 Henry S. Thompson

;; This file is part of GNU Emacs.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

(provide 'mail-extras)
(require 'rmail)
(require 'sendmail)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; mods and fixes for reading mail ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar ht-last-file (expand-file-name "~/XMAIL")
  "default for moving mail to")
(make-variable-buffer-local 'ht-last-file)

(defvar rmht-always-recompress t
  "If non-nil, when saving into compressed babyl file,
always recompress and save immediately")

(defvar rmht-allow-autosave t
  "if non-nil, leaves autosave alone for compressed babyl files,
otherwise turns it off")

(add-hook 'rmail-mode-hook 'rmail-mode-fun1)
(add-hook 'rmail-mode-hook 'rmail-mode-fun2)

;; run the first time in to RMAIL
(defun rmail-mode-fun1 ()
  "add ht's mods to RMAIL"
  (define-key rmail-mode-map "R" 'reply-w/o-cc)
  (define-key rmail-mode-map "M" 'rmht-output)
  (define-key rmail-mode-map "H" 'print-buffer)
  (define-key rmail-mode-map "W" 'edit-and-move-to-diary)
  (define-key rmail-mode-map "D" 'update-default-diary)
  (define-key rmail-mode-map "F" 're-post-failed-mail)
  (define-key rmail-mode-map "B" 'ht-write-body-to-file)
  (define-key rmail-mode-map "E" 'extract-attachment)
  ;; fix the doc string
  (repl-comment 'rmail-mode
	"Rmail Mode is used by \\[rmail] for editing Rmail files.
All normal editing commands are turned off.
Instead, these commands are available (additions from ht's mail-extras.el
indicated by *:

.	Move point to front of this message (same as \\[beginning-of-buffer]).
SPC	Scroll to next screen of this message.
DEL	Scroll to previous screen of this message.
n	Move to Next non-deleted message.
p	Move to Previous non-deleted message.
M-n	Move to Next message whether deleted or not.
M-p	Move to Previous message whether deleted or not.
>	Move to the last message in Rmail file.
j	Jump to message specified by numeric position in file.
M-s	Search for string and show message it is found in.
d	Delete this message, move to next nondeleted.
C-d	Delete this message, move to previous nondeleted.
u	Undelete message.  Tries current message, then earlier messages
	till a deleted message is found.
e	Expunge deleted messages.
s	Expunge and save the file.
q       Quit Rmail: expunge, save, then switch to another buffer.
C-x C-s Save without expunging.
g	Move new mail from system spool directory or mbox into this file.
m	Mail a message (same as \\[mail-other-window]).
c	Continue composing outgoing message started before.
r	Reply to this message.  Like m but initializes some fields.
R	* Like r, but reply to originator only.
f	Forward this message to another user.
F	* like f, but assumes message is \"failed mail\" for re-sending
o       Output this message to an Rmail file (append it).
C-o	Output this message to a Unix-format mail file (append it).
M	* Output this message to a file,
	  in format determined by extension (babyl for RMAIL/msg for Unix).
B	* Write the body of the message to a file, leaving a pointer
H	* Print the message (same as \\<global-map>\\[print-buffer]).\\<rmail-mode-map>
i	Input Rmail file.  Run Rmail on that file.
a	Add label to message.  It will be displayed in the mode line.
k	Kill label.  Remove a label from current message.
C-M-n   Move to Next message with specified label
          (label defaults to last one specified).
          Standard labels: filed, unseen, answered, forwarded, deleted.
          Any other label is present only if you add it with `a'.
C-M-p   Move to Previous message with specified label
h, C-M-h Show headers buffer, with a one line summary of each message.
l, C-M-l Like h only just messages with particular label(s) are summarized.
C-M-r   Like h only just messages with particular recipient(s) are summarized.
t	Toggle header, show Rmail header if unformatted or vice versa.
w	Edit the current message.  C-c C-c to return to Rmail.
W	* Edit the subject field.  C-c C-c to move the message to the Diary.
D	* Update the Diary.

Messages for the diary (see also \\[describe-mode] in rmail-summary mode
or \\[describe-function] rmail-summary-mode) should have a subject field
which begins with the date and optional time of the event described therein.
These must be in the form
     d m y t
where d is one or two digits for the day,
m is either the full month name or the first three letters thereof,
y is two digits for the year,
and t, if present, is 4 digits for the time,
thus for example
     31 Jun 91 1530
")
  (remove-hook 'rmail-mode-hook 'rmail-mode-fun1))

(defun rmail-mode-fun2 ()
  "always run in RMAIL mode"
  (setq case-fold-search t))

(defun reply-w/o-cc ()
  "Reply as r, but without sending to other recipients"
  (interactive)
  (rmail-reply t))

(defun rmht-output (&optional file-name gnus)
  "Move to a file, determining format by extension (babyl/msg)"
  (interactive)
  (if (not file-name)
      (setq file-name (car (get-move-file-name))))
  (if (string-match "\\.g?[zZ]$" file-name)
      (let ((clean-file-name (substring file-name 0 (match-beginning 0)))
	    there)
	(if (setq there (get-file-buffer clean-file-name))
	    nil
	  (save-window-excursion (rmail clean-file-name)
				 (setq there
				       (get-file-buffer clean-file-name))))
	(rmht-output clean-file-name gnus)
	(if rmht-always-recompress
	    (save-excursion
	      (set-buffer there)
	      (save-buffer))
	  (if (not rmht-allow-autosave)
	      (save-excursion
		(set-buffer there)
		(auto-save-mode -1)))))
    (setq file-name (expand-file-name file-name))
    (save-excursion
      (if (string-match "\\.babyl$" file-name)
	  (if gnus
	      (gnus-output-to-rmail file-name)
	    (rmail-output-to-rmail-file file-name 1))
	(if (string-match "\\.msg$" file-name)
	    (if (or (get-file-buffer file-name)
		    (file-exists-p file-name)
		    (yes-or-no-p
		     (concat "\"" file-name "\" does not exist, create it? ")))
		(rmail-output file-name 1)
	      (error "Output file does not exist"))
	  (error "not a valid mail file: %s" file-name))))
    (setq ht-last-file file-name)
    (if (not gnus) (ht-rmail-delete-forward))))

(defun get-move-file-name ()
  "get a file name for moving a message to"
  (list (read-file-name
	 (concat "Output message to file: (default "
		 (file-name-nondirectory ht-last-file)
		 ") ")
	 (file-name-directory ht-last-file)
	 ht-last-file)))

(defun re-post-failed-mail ()
  "try to salvage the original from failed mail and prepare to resend it"
  (interactive)
  (rmail-forward nil)
  (let ((top (point))
	subjp textp)
    (re-search-forward "^Subject: ")
    (kill-line nil)
    (setq subjp (point))
    (re-search-forward "^From: ") ; the bouncer
    (re-search-forward "^From: ") ; should be us
    (re-search-forward "^Subject: ")
    (kill-line nil)
    (save-excursion (goto-char subjp)
		    (yank))
    (beginning-of-line 3)
    (setq textp (point))
    (goto-char top)
    (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
    (beginning-of-line 2)
    (delete-region (point) textp)
    (goto-char top)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; mods and fixes for mail summaries ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(add-hook 'rmail-summary-mode-hook 'rmail-summary-mode-fun1)
 
;; run the first time we make a summary window
(defun rmail-summary-mode-fun1 ()
  "install ht's mods"
  (define-key rmail-summary-mode-map "r" 'rms-reply-w-cc)
  (define-key rmail-summary-mode-map "R" 'rms-reply-w/o-cc)
  (define-key rmail-summary-mode-map "s" 'diary-save)
  (define-key rmail-summary-mode-map "m" 'rms-move)
  (define-key rmail-summary-mode-map "d" 'rms-delete)
  (define-key rmail-summary-mode-map "h" 'rms-hardcopy)
  (define-key rmail-summary-mode-map " " 'ht-rmailsum-scroll-msg-up)
  (define-key rmail-summary-mode-map "\177" 'ht-rmailsum-scroll-msg-down)
  ;; fix the doc string
  (repl-comment 'rmail-summary-mode
	"Major mode in effect in Rmail summary buffer.
A subset of the Rmail mode commands are supported in this mode. 
As commands are issued in the summary buffer the corresponding
mail message is displayed in the rmail buffer.
Modifications from ht's mail-extras.el indicated with *:

n       Move to next undeleted message, or arg messages.
p       Move to previous undeleted message, or arg messages.
C-n	Move to next, or forward arg messages.
C-p	Move to previous, or previous arg messages.
j       Jump to the message at the cursor location.
d       Delete the message at the cursor location and move to next message.
u	Undelete this or previous deleted message.
q	Quit Rmail.
x	Exit and kill the summary window.
space   * If cursor is on line of current message,
	  scroll message window forward.  Otherwise, jump to indicated message.
delete  * same as space, but scrolls backward.
r	* Same as r in rmail window.  Reply to current message.
R	* Same as R in rmail window. Reply to current message, originator only.
s	* Update and save the rmail file, and re-summarise.  Re-sorts if Diary.
m	* Same as M in rmail window.  Moves message to file.
h	* Same as H in rmail window.  Prints message on line printer.

Entering this mode calls value of hook variable rmail-summary-mode-hook.

If the file summarised is called by the name given in ht-diary-file-name,
which defaults to diary.babyl,
then the summary will be called *Diary*, sorted in date order and
formated in a special way.

Messages in the diary should have a subject field
which begins with the date and optional time of the event described therein.
These must be in the form
     d m y t
where d is one or two digits for the day,
m is either the full month name or the first three letters thereof,
y is two digits for the year,
and t, if present, is 4 digits for the time,
thus for example
Subject: 31 Jun 91 1530 Hades freezing ceremony followed by champagne reception
")
  (remove-hook 'rmail-summary-mode-hook 'rmail-summary-mode-fun1))

(defun rmht-sum-reply (sender-only)
  "reply to current message"
  (rmail-summary-goto-msg)
  (pop-to-buffer rmail-buffer)
  (rmail-reply sender-only)
  (switch-to-buffer rmail-summary-buffer)
  (switch-to-buffer "*mail*")
)

(defun rms-reply-w-cc ()
  "Do r in RMAIL - reply to everybody"
  (interactive)
  (rmht-sum-reply nil))

(defun rms-reply-w/o-cc ()
  "Do R in RMAIL - reply to sender only"
  (interactive)
  (rmht-sum-reply t))

(defun rms-save ()
  "expunge deleted messages, save RMAIL file and re-display headers"
  (interactive)
  (pop-to-buffer rmail-buffer)
  (rmail-expunge-and-save)
  (rmail-summary))

(defun rms-delete ()
  "delete current and move down to next in summary buffer"
  (interactive)
  (rmail-summary-goto-msg)
  (save-excursion
    (rmail-summary-delete-forward nil))
  (rms-del))

(defun rms-move ()
  "Move to a file, mode determined by file extension (babyl/msg)"
  (interactive)
  (rmail-summary-goto-msg)
  (save-excursion
    (set-buffer rmail-buffer)
    (rmht-output))
  (rms-del))

(defun rms-del ()
  "mark current summary line as deleted and move down"
  (let ((buffer-read-only nil))
    (skip-chars-forward " ")
    (skip-chars-forward "[0-9]")
    (delete-char 1)
    (insert "D"))
  (forward-line 1))

(defun rms-hardcopy ()
  "hardcopy the current message"
  (interactive)
  (pop-to-buffer rmail-buffer)
  (print-buffer)
  (pop-to-buffer rmail-summary-buffer))


;; fix interpretation of SPACE and DEL in summary windows to
;; 1) scroll the right window regardless of how many panes are up;
;; 2) go to the message associated with the current line if not already there,
;;    a la gnus, for instance

(defun ht-rmailsum-normalise ()
  "if not already showing message named on current line, go to it & return t"
  (beginning-of-line)
  (let ((current-msg-num (cdr (assoc 'rmail-current-message
				     (buffer-local-variables
				      (or rmail-buffer
					  (error
					   "not in a summary buffer"))))))
	(line-message-num (string-to-int
			   (buffer-substring
			    (point)
			    (min (point-max)(+ 5 (point)))))))
    (if (= current-msg-num line-message-num)
	nil
      (rmail-summary-goto-msg line-message-num)
      t)))

(defun ht-rmailsum-scroll-msg-up (&optional dist)
  "goto other message or scroll current message forward"
  (interactive "P")
  (if (ht-rmailsum-normalise)
      nil
    (pop-to-buffer rmail-buffer)
    (scroll-up dist)
    (pop-to-buffer rmail-summary-buffer)))

(defun ht-rmailsum-scroll-msg-down (&optional dist)
  "goto other message or scroll current message backward"
  (interactive "P")
  (if (ht-rmailsum-normalise)
      nil
    (pop-to-buffer rmail-buffer)
    (scroll-down dist)
    (pop-to-buffer rmail-summary-buffer)))

(autoload 'edit-and-move-to-diary "diary")
(autoload 'update-diary "diary")
(autoload 'diary-save "diary")

;; unfortunately, gnus mucks about with the buffers before calling
;; mail, so we have to intervene to make the about-to-mail-hook work right

(defun ht-Subject-mode-fun ()
  "fix the map to save window state"
;  (define-key gnus-summary-mode-map "r" 'ht-Subject-mail-reply)
;  (define-key gnus-summary-mode-map "R" 'ht-Subject-mail-reply-with-original)
;  (define-key gnus-summary-mode-map "m" 'ht-Subject-mail-other-window)
  (define-key gnus-summary-save-map "M" 'ht-Subject-move)
  (remove-hook 'gnus-summary-mode-hook 'ht-Subject-mode-fun))

(add-hook 'gnus-summary-mode-hook 'ht-Subject-mode-fun)

(defun ht-Subject-mail-reply (yank)
  "Runs about-to-mail-hook, then calls gnus-summary-mail-reply"
  (interactive "P")
  (require 'sendmail)
  (run-hooks 'about-to-mail-hook)
  (let (about-to-mail-hook)
    (gnus-summary-reply yank)))

(defun ht-Subject-mail-reply-with-original ()
  "Runs about-to-mail-hook, then calls gnus-summary-mail-reply-with-original"
  (interactive)
  (require 'sendmail)
  (run-hooks 'about-to-mail-hook)
  (let (about-to-mail-hook)
    (gnus-summary-reply-with-original)))

(defun ht-Subject-mail-other-window ()
  "Runs about-to-mail-hook, then calls gnus-summary-mail-other-window"
  (interactive)
  (require 'sendmail)
  (run-hooks 'about-to-mail-hook)
  (let (about-to-mail-hook)
    (gnus-summary-mail-other-window)))

(defun ht-Subject-move ()
  "Move article to a file, mode determined by file extension (babyl/msg)"
  (interactive)
  (gnus-summary-select-article)
  (save-excursion
    (set-buffer gnus-article-buffer)
    (rmht-output nil t)))


(defun ht-write-body-to-file (file)
  "Write the body of the message to a file and replace it with a pointer"
  (interactive "FFile to save in: ")
  (goto-char (point-min))
  (or (search-forward "\n\n" nil t)
      (error "Can't find text"))
  (write-region (point)(point-max) file)
  (rmail-edit-current-message)
  (delete-region (point)(point-max))
  (insert "\n>> " file "\n")
  (rmail-cease-edit)
  (rmht-output))

(defun extract-attachment ()
  "extract attachments from a multi-part mime message"
  (interactive)
  (rmail-toggle-header)
  (mime/viewer-mode)
  (let ((pt 0))
    (while (progn
	     (mime-viewer/next-content)
	     (and
	      (equal "*Preview-RMAIL*" (buffer-name (current-buffer)))
	      (not (= pt (point)))))
      (setq pt (point))
      (if (looking-at "^\\[[0-9]* [^ ]+ <")
	  (mime-viewer/extract-content))))
  (if (not (equal "*Preview-RMAIL*" (buffer-name (current-buffer))))
      ;; we fell off the end
      (rmail-previous-undeleted-message 1))
  (kill-buffer "*Preview-RMAIL*")
  )

;; see message-citation-line-function in message.el
(defun safe-citation ()
  (use-text-not-html)
  (when message-reply-headers
    (let ((from (mail-header-from message-reply-headers)))
      (cond ((string-match "^\"?\\([^\"]*\\)\"? <.*>$" from)
	     (insert (match-string 1 from) " writes:\n\n"))
	    ((string-match "^\\([^<@]*\\)@" from)
	     (insert (match-string 1 from) " writes:\n\n"))
	    (t
	     (insert "[anon] writes:\n\n"))))))

(defun use-text-not-html (&optional clear)
  (when (and (if clear (looking-at "<html")
	       (looking-at "> <html"))
	     (bufferp (get-buffer "*Shell Command Output*")))
    ;; replace HTML only with result of my HTML filter
    (delete-region (point)(mark t))
    (insert-buffer "*Shell Command Output*")
    (when (looking-at "piping")
      (kill-entire-line)
      (indent-rigidly (point) (mark t) -3)
      (if (not clear)
	  (submerge-region (point) (mark t)))))
  )

(setq message-citation-line-function (function safe-citation))

;(load-library "mailcrypt") ; provides "mc-setversion"
;(mc-setversion "gpg")    ; for PGP 2.6 (default); also "5.0" and "gpg"
;(autoload 'mc-install-write-mode "mailcrypt" nil t)
;(autoload 'mc-install-read-mode "mailcrypt" nil t)
;(add-hook 'mail-mode-hook 'mc-install-write-mode)
;(add-hook 'gnus-summary-mode-hook 'mc-install-read-mode)
;(add-hook 'message-mode-hook 'mc-install-write-mode)
;(add-hook 'news-reply-mode-hook 'mc-install-write-mode)
;(setq mc-passwd-timeout 6000)
;;; Key server at Cambridge University (Cambridge, England)
;(setq mc-pgp-fetch-methods      '(mc-pgp-fetch-from-keyrings
;				  mc-pgp-fetch-from-http))
;(require 'pgg)
;(add-hook 'message-send-hook 'my-sign-message)
(setq hack-yn-map (copy-keymap query-replace-map))
(define-key hack-yn-map 'return 'act)

(defun my-sign-message ()
  (goto-char (point-min))
  (unless
      (or
       (re-search-forward "<#\\(part\\|mml\\) " nil t)
					; signing attachments doesn't seem
                                        ; to work well
       (search-forward "\n-- \nHenry S. Thompson, Central Edinburgh LM" nil t)
					; Don't sign Quaker mail
       )
    (let* ((headers (mail-header-extract-no-properties))
	   (cc (mail-header 'cc))
	   (to (mail-header 'to)))
      (if (and to
	       (not (string-match "htcalendar[@]markup\.co\.uk" to))
	       (not (string-match "^ht$" to))
	       (or 
		(string-match "w3.org" to)
		(and cc (string-match "w3.org" cc))
		(let ((query-replace-map hack-yn-map))
		  (y-or-n-p "Sign message? "))))
	  (mml-secure-message-sign-pgp)))))