;;; This file customizes rmail functionality. It:
;;; - generates a .mailrc for the UNIX mailer programs
;;; - completes the receiver's name in the TO field
;;; - automatically sets the preferred email address of the sender based on
;;;		the email destination, and
;;; - allows selection of the sender address of an email
;;; - archives a copy of all mail sent
;;; - puts deleted mail into a TRASH file rather than deleting it
;;; - allows reply or posting to a note in a digest

;;; 
;;; important variables
;;; Notice that MY-ADDRESSES and ALIAS-ADDRESSES should be defined
;;; before this is loaded in order for defaults to be set correctly

(defvar my-addresses nil
  "A list of email account descriptors. 
The first member is an ID name, the second is the account, the third is 
the text name to use. 

It should be defined *before* this file is required.")

(defvar alias-addresses nil
  "A list of aliases to use for email recipients. Should be set in calling file.
The first member is an ID name, the second is the account, the third is 
the text name to use, the fourth is an alias in MY-ADDRESSES telling which
account to use for this person (defaults to the first entry).

After any changes here you should call the command \"rmail-make-alias-file\"

It should be defined *before* this file is required.")

(defvar rmail-alias-filename "~/.mailrc" 
  "name of the file to put the generated mail aliases")

;;;
;;; this section has code for generating the .mailrc file from the 
;;; ALIAS-ADDRESSES list
;;;

(defun rmail-check-entry (x)
  (re-search-forward (rmail-make-alias-entry x) nil t))

(defun rmail-check-aliases (&optional file)
  "Checks an alias file to make sure it is in synch with the lisp definition.
Comments can be added to the file as long as they do not start with `##'
and do not come between an ## comment and the alias it refers to"
  (interactive)
  (set-buffer (find-file-noselect (setq file (or file rmail-alias-filename))))
  (goto-char 1)
  (if (and (every 'rmail-check-entry alias-addresses)
			   (> (point) (buffer-size)))
	  (message "File %s matches 'alias-addresses'" file)
	(error "File %s does not match list 'alias-addresses'" file)))

(defun rmail-make-alias-entry (x)
  "Makes a single-line entry for the generated .mailrc file"
  (let ((string (concat "alias " (car x) "\t\t")))
	(if (listp (third x)) 
		(mapcar (lambda (y) (setq string (concat string y " "))) (third x))
	  (setq string (concat string (third x))))
	(if (second x)
		(setq string (concat "## " (second x) "\n" string)))
	(setq string (concat string "\n"))
	string))

(setq rmail-alias-intro "# This file is generated from within lisp. See the 
# file \"email.el\"")

(defun rmail-make-alias-file (&optional destination)
  "used to synch the alias list defined above with the .mailrc file used by unix"
  (interactive)
  (or destination (setq destination rmail-alias-filename))
  (let* ((file (make-temp-name "/tmp/rmail-alias"))
		 (buffer (find-file-noselect file))
		 (message (concat "wrote file " destination)))
	(set-buffer buffer)
	(insert rmail-alias-intro "\n\n")
	(mapcar '(lambda (x) (insert (rmail-make-alias-entry x))) alias-addresses)
	(basic-save-buffer)
	(kill-buffer nil)
	(if (or (not (file-exists-p destination))
			(y-or-n-p (concat "Proceed? (warning: file " destination " will be overwritten) ")))
		(rename-file file destination t)
	  (beep)
	  (setq message "save cancelled")
	  (delete-file file))
	(message message)))

;;;
;;; alias expansion and completion
;;;

(defun rmail-make-addr (id &optional list)
  (let ((desc id))
	(if (stringp desc)
		(setq desc (assoc desc (or list alias-addresses))))
	(if desc
		(if (second desc)
			(concat "\"" (second desc) "\" <" (third desc) ">")
		  (third desc))
	  id)))

(defun alias-completion ()
  (interactive)
  (if (re-search-backward "[:
 	,]\\(.*\\)\\=" nil t)
	  (let* ((stub (match-string 1))
			 (start (match-beginning 1))
			 (end (match-end 0))
			 (candidates (all-completions stub alias-addresses)))
		(if (member stub candidates) (setq candidates (list stub)))
		(case (length candidates)
		  (0 (goto-char end)
			 (error "no match"))
		  (1 (delete-region start end)
			 (goto-char start)
			 (let ((desc (assoc (car candidates) alias-addresses)))
			   (mail-change-sender (or (fourth desc) (caar my-addresses)))
			   (if (stringp (third desc))
				   (insert (rmail-make-addr desc))
				 (insert (car desc)))))
		  (t (delete-region start end)
			 (goto-char start)
			 (message "candidates: %s" candidates)
			 (insert (try-completion stub alias-addresses))))
		)))


(defun my-setup-mail ()
  "Sets up the *mail* buffer"
  (local-set-key "	" 'possible-alias-expand)
  (make-local-variable 'mail-current-id)
  (mail-change-sender mail-current-id))

(add-hook  'mail-setup-hook 'my-setup-mail)

(defun possible-alias-expand ()
  "expands mail alias to address in TO:, CC:, or REPLY-TO fields.
Also sets the email account to use for this user."
  (interactive)
  (if (save-excursion
		(beginning-of-line)
		(or (looking-at "^To:") 
			(looking-at "^cc:")
			(looking-at "^Reply-to:")))
	  (alias-completion)
	(indent-relative)))


;;;
;;; The following code is used to change the sender of an email
;;; 

(defun mail-id-to-desc (id)
  "Finds the address descriptor associated with an id of an email account.
ID can be one of the IDs in the above table or an email address."
  (or (assoc id my-addresses)
	  (if (string-match " *\"\\([^\"]*\\)\" *<\\([^>]*\\)>" id)
		  (list 0 (match-string 1 id) (match-string 2 id)))
	  (if (string-match " *\\([^ ]*@[^ ]*\\) *$" id)
		  (list 0 nil (match-string 1 id)))
	  (error (concat "bad id \"" id "\""))))
 


;;; This is why alias-addresses and my-addresses should be set up earlier
(defvar mail-current-id (caar my-addresses))
(setq mail-default-reply-to (rmail-make-addr (car my-addresses)))

(defun mail-change-sender (id)
  "Changes the address of the mail sender
Includes From, Mail-from, Reply-to"
  (interactive "i")
  (or id (setq id (completing-read "account: " my-addresses nil t)))
  (save-excursion
	(let* ((sender (mail-id-to-desc id))
		   (address (third sender))
		   (full (rmail-make-addr sender))
;		   (old mail-current-id)
		   )
	  (setq user-mail-address address
			mail-current-id id
			mail-default-reply-to address)
	  (goto-char 1)
	  (when (re-search-forward "^Reply-to: " nil t)
		(kill-line)
		(insert full))
;	  old
	  )))


;;;
;;; Handles replies and posts to digests
;;;

(defvar digest-separator "			  #################"
  "Separator used in Princeton digest files")
(defvar collection-separator "^----------------------------------------------------------------------$"
  "Separator used in Princeton collected list files")

(defun is-digest ()
  "Returns the regexp used as an entry separator if the current message is a digest file"
  (save-excursion
	(goto-char 1)
	(if (re-search-forward "^Content-Type: multipart/digest;" nil t) 
		digest-separator
	  (if (re-search-forward "^List-Unsubscribe: <mailto:" nil t)
		  collection-separator))))

(defun reply-sender (separator)
  "Sets up a mail buffer to reply to the sender of the current digest email.
If the current message is not a digest then does a regular SEND"
  (let* ((point (point))
		 (start (or (re-search-backward separator nil t) 1))
		 (end (or (re-search-forward separator nil t 2)))
		 (from (progn
				 (goto-char start)
				 (or (re-search-forward "^reply-to: *\\([^\n]*\\)" end t)
					 (re-search-forward "^From: *\\([^\n]*\\)" end))
				 (match-string 1)))
		 (subject (progn
					(goto-char start)
					(re-search-forward "^Subject: *\\([^\n]*\\)" end t)
					(or (match-string 1) "(no subject)")))
		 (new-subject (if (string-match "re:" subject) subject
						(concat "Re: " subject))))
	(goto-char point)
	(rmail-start-mail nil from new-subject)))

(defun reply-list (separator)
  "Sets up a mail buffer to post to the current list.
If the current message is not a digest then does a regular SEND"
  (let* ((point (point))
		 (start (or (re-search-backward separator nil t) 1))
		 (end (or (re-search-forward separator nil t 2)))
		 (to (progn (goto-char 1)
					(or (re-search-forward "^reply-to: *\\([^\n]*\\)" nil t)
						(re-search-forward "^from: *\\([^\n]*\\)"))
					(match-string 1)))
		 (subject (progn
					(goto-char start)
					(re-search-forward "^Subject: *\\([^\n]*\\)" end t)
					(or (match-string 1) "(no subject)")))
		 (new-subject (if (string-match "re:" subject) subject
						(concat "Re: " subject))))
	(goto-char point)
	(rmail-start-mail nil to new-subject)))

(defun rmail-get-sent-candidates ()
  "Gets a list of recipients of an email, including both To: and CC:.
Handles continuation lines properly"
  (save-excursion
	(goto-char 1)
	(let (continuation list addr)
	  (while (or (re-search-forward "^\\(to\\|cc\\): *\\([^\n]*\\)" nil t)
				 (and continuation (re-search-forward "\\( +\\)\\([^\n]*\\)" nil t)))
		(let ((all (match-string 2))
			  (start 0))
		  (while (eq start (string-match "[\t ]*\\([^,\n]+\\),?" all start))
			(setq addr (match-string 1 all)
				  start (match-end 0)
				  continuation (not (= (match-end 1) (match-end 0)))
				  list (cons (if (string-match "<\\([^>]*\\)>" addr)
								 (match-string 1 addr) addr) list))
			)))
	  list)
	))


(defun rmail-get-sent-to ()
  "Tries to get the address the current email was sent to, for the reply sender"
  (let ((candidates (rmail-get-sent-candidates)))
	(some (lambda (x) (if (member (third x) candidates) (car x))) my-addresses)
   ))

(defun rmail-get-reply-sender ()
  "Checks if there is a preferred email address for the sender of the current email.
It first looks for a Reply-to field and then the From field for a sender"
  (save-excursion
	(goto-char 1)
	(if (or (re-search-forward "^reply-to: *\\([^\n]*\\)" nil t)
			(re-search-forward "^from: *\\([^\n]*\\)" nil t))
		(let ((from (match-string 1)))
		  (and (string-match "\\( *\"[^\"]*\" *<\\)?\\([^>\n]*\\)" from)
			   (some (lambda (x) (if (equal (third x) (match-string 2 from)) 
									 (fourth x))) 
					 alias-addresses)))
	  )))
		  
			   
(defun my-rmail-reply (P)
  "in mail, finds the email address to use for the sender of a Reply.
The first choice is the address associated with the original sender, second
is the address the mail was sent to, and if neither can be determined it
uses the default."
  (interactive "P")
  (let* ((case-fold-search t)
		 (sent-to (or (rmail-get-reply-sender) (rmail-get-sent-to)))
		 (separator (is-digest)))
	(if separator (reply-sender separator)
	  (rmail-reply (not P)))
	(if sent-to (mail-change-sender sent-to))))

(defun my-rmail-post ()
  "in mail, sends reply to current posting"
  (interactive)
  (let ((separator (is-digest)))
	(if separator (reply-list separator))))

(defun my-rmail-summary-reply (P)
  "in mail digest, sends reply to sender of current posting from summary buffer"
  (interactive "P")
  (set-buffer rmail-buffer)
  (my-rmail-reply P))

(defun my-rmail-summary-post ()
  "in mail digest, sends reply to current posting from summary buffer"
  (interactive)
  (set-buffer rmail-buffer)
  (my-rmail-post))

;;;
;;; hooks and setup stuff
;;;

(defun my-rmail-setup ()
  (define-key rmail-mode-map "r" 'my-rmail-reply)
  (define-key rmail-mode-map "R" 'my-rmail-post)
  (define-key rmail-mode-map "F" 'fetchmail)
  (define-key rmail-summary-mode-map "F" 'fetchmail)
  (define-key rmail-summary-mode-map "r" 'my-rmail-summary-reply)
  (define-key rmail-summary-mode-map "R" 'my-rmail-summary-post))

(add-hook 'rmail-mode-hook 'my-rmail-setup)

;;; for archiving sent mail
(defvar mail-archives 
  '(("MatthewF@regionnet.com" "sent-catharon")
	("develop@vdelta.com" "sent-catharon")
	("" "sent"))
  "list that directs mail to the proper archive account
Last entry should be \"\" to handle default case, or else default will be 
to do nothing")

(defun mail-archive ()
  "Archives a mail message in the proper file"
  (goto-char 1)
  (let ((dest (some (lambda (x) 
					  (and (re-search-forward (concat "^To: [^\n]*" (car x)) nil t)
						   (second x)))
					mail-archives)))
	(goto-char 1)
	(if (not (re-search-forward "^Subject:" nil t))
		(error "No subject line"))
	(beginning-of-line)
	(if dest (insert "BCC: " dest "
"))))

(add-hook 'mail-send-hook 'mail-archive)

;;; to insert a FROM line so sendmail doesn't prepend the login name
(defun rmail-do-from ()
"Adds a FROM: line so sendmail doesn't get it wrong later"
  (goto-char 1)
  (forward-line 2)
  (while (looking-at "[	 ]") (forward-line))
  (insert "From: " (rmail-make-addr mail-current-id my-addresses) "\n"))

(add-hook 'mail-send-hook 'rmail-do-from)

(require 'fetchmail)
(require 'mailalias)		;duh - this is in mailaliases

(provide 'my-rmail)