; -*-Emacs-Lisp-*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; File:         mh-refile.el
; RCS:          $Header: /users/darrylo/.repository/mh-e/mh-refile.el,v 1.2 1998/07/23 22:31:53 darrylo Exp $
; Description:  Folder refile support routines
; Author:       Darryl Okahata
; Created:      Tue Sep 24 18:33:11 1991
; Modified:     Thu Jun 25 14:09:22 1998 (Darryl Okahata) darrylo@sr.hp.com
; Language:     Emacs-Lisp
; Package:      N/A
; Status:       Experimental
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; auto refile/Fcc folder support.
;; (From: Andy Norman <ange@hplb.hpl.hp.com>, enhanced by Darryl Okahata
;;  <darrylo@sr.hp.com>)
;;
;; If y-mh-auto-folder-alist is `nil', y-mh-refile-msg will act as it has
;; always acted.  If y-mh-auto-folder-alist is set, auto-refile support
;; will be used (see docs for y-mh-auto-folder-alist for more info).
;;
;; To get quickly started using these routines, add the following lines
;; to your .emacs file:
;;
;;	(setq y-mh-auto-folder-alist '(
;;				     (t
;;					(y-mh-get-default-folder . "")
;;				     ))
;;
;; This will cause a "reasonable" default refile/Fcc folder name to be
;; presented to you.  Later, you can change this to something more
;; complex, like:
;;
;;	(setq y-mh-auto-folder-alist
;;	  '(
;;	     ("From:"
;;	       ("ug8767ea" . "+cretins")
;;	       ("joe blow" . "+joey")
;;	       ("Erik the Viking" . "+cretins")
;;	       ("Erik the Red" . "+cretins")
;;	       ("Erik the Cretin" . "+cretins")
;;	     )
;;	     ("Cc:"
;;	       ("gnu-emacs" . "+gnu")
;;	       ("g\\+\\+" . "+gcc")
;;	       ("gcc" . "+gcc")
;;	       ("gwm" . "+gwm")
;;	     )
;;	     (t
;;	       (y-mh-get-default-folder . "")
;;	     )
;;	   )
;;	)
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(require 'mh-e)			;; mh-e.el must be loaded before this one.
(require 'mh-db)
(require 'mh-comp)
(provide 'mh-refile)


(defvar y-mh-auto-folder-alist nil
  "*Non-nil value should be an alist that will be used to choose a default
folder name when messages are refiled.  The alist should contain elements of
the form:

\(HEADER-NAME
   (REGEXP . FOLDER-NAME) ...
  ...)

or of the form:

\(t
   (FUNCTION . FOLDER-NAME) ...
  ...)

where HEADER-NAME, REGEXP and FOLDER-NAME are strings.

If any part of the contents of the message header named by HEADER-NAME
is matched by the regular expression REGEXP, the corresponding
FOLDER-NAME will be used as the default when prompting for a folder to
refile the message in.  Note that any FOLDER-NAME must have a `+'
prepended to it.


FUNCTION is a name of a function to call (no arguments are passed to
it), with the current buffer being the mh-show-buffer.  If the function
result is not a string and is non-nil (e.g., `t'), the corresponding
FOLDER-NAME will be used.  If the result is a string, the FOLDER-NAME
will be ignored, and the result will instead be used as the folder name.
Note that any string result must have a `+' prepended to it.

Matching is case sensitive.")


(defun y-mh-get-from-field ()
  "Return the contents of the From: field."
  (let ()
    (save-window-excursion
      (save-excursion
	(mh-show (mh-get-msg-num t))
	(set-buffer mh-show-buffer)
	(mh-get-header-field "From:")
	))))
  

(defun y-mh-get-folder-sender-field ()
  "Get the contents of the field to use to determine the default folder.
The following fields are searched, in the order given:

	Reply-To:
	From:
	To:

The first non-empty field found is the one whose contents are returned.
NIL is returned if a non-empty field could not be found."
  (let (field)
    (cond
     ( (and (not (string= (setq field (mh-get-header-field "Reply-To:")) ""))
	    (not (string-match (concat "^" (user-login-name) "@") field))
	    )
       field)
     ( (not (string= (setq field (mh-get-header-field "From:")) ""))
       field)
     ( (not (string= (setq field (mh-get-header-field "To:")) ""))
       field)
     (t nil)
     )))


(defun y-mh-get-default-folder ()
  "Scan the current MH message and return a default folder name for it.
This function assumes that the current buffer contains an MH message.

It also doesn't conform to RFC822 standards, but it'll do for most
cases.
"
  ;;
  ;; Regarding RFC822 non-comformance:
  ;;
  ;; Properly parsing the Reply-To: header is a real pain and may not be
  ;; possible.  What do you do in the following case?  What should the
  ;; default folder name be?
  ;;
  ;;	   From:     George Jones <Jones@Host.Net>
  ;;	   Sender:   Jones@Host
  ;;	   Reply-To: The Committee: Jones@Host.Net,
  ;;				    Smith@Other.Org,
  ;;				    Doe@Somewhere-Else;
  ;;
  ;; Perhaps, in this case, we should just fall back to the "From:"
  ;; header?
  ;;
  ;; Also, parsing the following address is another pain:
  ;;
  ;;	   Wilt . (the	Stilt) Chamberlain@NBA.US
  ;;
  ;; (The default folder name should be parsed into "Wilt.Chamberlain".)
  ;;
  ;; (All above examples were taken from RFC822.)
  ;;
  (let (from result)
    (if (setq from (y-mh-get-folder-sender-field))
	(setq result
	      (cond
	       ;; The following is ORDER-DEPENDENT!
	       ( (or (string-match "[ \t]*[^<]+<\\([^/!%@> \t,]+\\)" from)
		     (string-match "[ \t]*\\([^/!%@< \t,]+\\)" from)
		     )
		 (if (not (string= (setq from (substring from
							 (match-beginning 1)
							 (match-end 1)))
				   ""))
		     (concat "+" from)
		   )
		 )
	       ;; We can add more conditionals here to make the scanning more
	       ;; intelligent.
	       ( t
		 ())
	       )))
    (if (not result)
	(if (and mh-last-destination
		 (eq (car mh-last-destination) 'refile))
	    (setq result (cdr mh-last-destination))))
    result
    ))


(defun y-mh-auto-select-folder (alist operation)
  "Return the name of a folder to refile the current message in.
The current buffer is scanned for this information."
  (let ((mh-current-folder mh-current-folder)
	(mh-showing (and (boundp 'mh-showing) mh-showing))
	case-fold-search
	header
	result)
    (save-window-excursion
      (save-excursion
	(catch 'match
	  (mapcar
	   (function (lambda (entry)
		       (if (stringp (car entry))
			   (progn
			     (setq header (mh-get-header-field (car entry)))
			     (if (zerop (length header))
				 ()
			       (mapcar
				(function (lambda (tuple)
					    (if (string-match (car tuple)
							      header)
						(throw 'match (cdr tuple)))))
				(cdr entry))))
			 (progn
			   (mapcar
			    ;; Here, we don't use "(let (result) ..." because
			    ;; we don't want the extra overhead.  Instead, we
			    ;; declare `result' in an outer `let' ....
			    (function (lambda (tuple)
					(if (setq result
						  (funcall (car tuple)))
					    (progn
					      (if (stringp result)
						  (throw 'match result)
						(throw 'match (cdr tuple)))))))
			    (cdr entry)))
			 )))
	   alist)
	  (if (eq operation (car mh-last-destination))
	      (symbol-name (cdr mh-last-destination))
	    ""))))))


(defun y-mh-get-default-refile-folder ()
  "Get a default name for refiling a message."
  (let ( (mh-current-folder mh-current-folder) )
    (if y-mh-auto-folder-alist
	(save-window-excursion
	  (save-excursion
;	    (mh-show (mh-get-msg-num t))
;	    (set-buffer mh-show-buffer)
	    (y-mh-auto-select-folder y-mh-auto-folder-alist 'refile)
	    ))
      (if (eq 'refile (car mh-last-destination))
	  (symbol-name (cdr mh-last-destination))
	"")
      )
    ))


(defun y-mh-get-the-from-entry ()
  "From y-mh-auto-folder-alist, get the list corresponding to the \"From:\" entry.
If there is none, return nil."
  (let (folders)
    (catch 'exit
      (setq folders y-mh-auto-folder-alist)
      (while folders
	(if (string= (car (car folders)) "From:")
	    (throw 'exit (cdr (car folders))))
	(setq folders (cdr folders))
	)
      (throw 'exit nil)
      )))


(defun y-mh-set-default-refile-folder (new-folder)
  "Set the default folder for the MH message under the cursor in the current
folder buffer."
  (interactive (list
		(mh-prompt-for-folder
		 "Set default refile"
		 (y-mh-get-default-refile-folder) t)))
  (let ( (from (y-mh-get-from-field))
	 folder-list new-folder-list new-from new-from-entry)
    (if (not from)
	(error "Unable to extract \"From:\" field"))
    (catch 'exit
      (progn
	(setq new-from (concat "^" (regexp-quote from) "$"))
	(if (setq folder-list (y-mh-get-the-from-entry))
	    (progn
	      ;; A "From:" entry exists
	      (while folder-list
		(if (string= (car (car folder-list)) new-from)
		    (progn
		      (setcdr (car folder-list) new-folder)
		      (throw 'exit nil)
		      ))
		(setq folder-list (cdr folder-list))
		)
	      ;; However, the "From:" entry does not already have a default
	      ;; entry for the new "from" address.  We must now add a new
	      ;; entry to be beginning of the list, and so we must rebuild
	      ;; the y-mh-auto-folder-alist variable.
	      (setq folder-list y-mh-auto-folder-alist)
	      (setq new-folder-list nil)
	      (while folder-list
		(if (string= (car (car folder-list)) "From:")
		    (progn
		      (setq new-from-entry
			    (list (cons "From:"
					(append (list (cons
						       new-from new-folder))
						(cdr (car folder-list))))))
		      (setq new-folder-list (append new-folder-list
						    new-from-entry))
		      )
		  (progn
		    (setq new-folder-list (append new-folder-list
						  (list (car folder-list))))
		    ))
		(setq folder-list (cdr folder-list))
		)
	      (setq y-mh-auto-folder-alist new-folder-list)
	      )
	  (progn
	    ;; A "From:" entry does not exist, so make one.
	    (setq y-mh-auto-folder-alist (cons (cons "From:"
						     (cons (cons new-from
								 new-folder)
							   nil))
					       y-mh-auto-folder-alist))
	    ))
	))
    (if (interactive-p)
	(message (format "Folder \"%s\" is now the default folder for \"%s\""
			 new-folder from)))
    ))


;; y-mh-e-vars-to-save is defined in mh-db.el
(if (not (memq 'y-mh-auto-folder-alist y-mh-e-vars-to-save))
    (setq y-mh-e-vars-to-save (cons 'y-mh-auto-folder-alist y-mh-e-vars-to-save)))

(setq mh-default-folder-for-message-function 'y-mh-get-default-refile-folder)
