;;;
;;;  cmail-reply.el - Mailing, forwarding, and replying functions
;;;
;;;  $Author: tmp $
;;;  created at: Mon Jul 12 11:01:47 JST 1993
;;;
;;;  Copyright (C) 1992-1996 Yukihiro Matsumoto

;; This file is not part of GNU Emacs but obeys its copyright notice.

;; 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 'cmail-reply)
(require 'sendmail)
;(require 'rfc822)
(require 'mail-utils)
(eval-when-compile (require 'cl))
;(require 'cmail)

;; !!!! メイルを出す !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
(defun cmail-mail (&optional user subject reply cc replybuffer action
			     noerase)
  "cmail-mail2のwrapper関数. interactiveな呼出しかどうかの判定を行う.
渡された user (TO) と cc (CC) アドレスはリストに変換する。"
  (interactive)
  (if (stringp user)
      (if (string-match "^[ \t\n]*$" user)
	  (setq user "")
	(setq user (cmail-address-list user)))
    (setq user nil))
  (setq cc (cmail-address-list cc))
  (cmail-mail2 (interactive-p)
	       user subject reply cc replybuffer action noerase
	       (cmail-cc-me-p 'when-new-compose)))

(defun cmail-mail2 (intr-p &optional user subject reply cc replybuffer action
			   noerase cc-me-p)
  "USERに表題SUBJECTでメイルを出す.
宛先を入力する際に, ユーザの.mailrcファイルからコマンドgroup(alias)
の別名定義を拾ってきて補完する."
  (let* ((self (cmail-derive-self-address))
	 (self-addr-regexp (cmail-concat-addr-match-string
			    (if (eq cmail-self-addresses 'auto)
				(list self) cmail-self-addresses)))
	 (dont-cc-me-regexp
	  (cmail-concat-addr-match-string cmail-dont-cc-me-destinations))
	 (alst cmail-select-from-alist)
	 query actions last-message to addr trgt pttn full)

    (and (if (get-buffer "*mail*") t
	   (setq noerase nil))
	 (set-buffer "*mail*")
	 (buffer-modified-p)
	 (not noerase)
	 (setq query
	       (if reply
		   (cmail-read-char-from-minibuffer
		    (cmail-get-resource 'mail2-1) "ari")
		 (cmail-read-char-from-minibuffer
		  (cmail-get-resource 'mail2-2) "ar")))
	 (cond
	  ((eq query ?r)		; rename
	   (let ((bufname (rename-buffer "*mail*renamed*" t)))
	     (setq last-message
		   (cmail-format-resource1 'mail2-3 bufname))))
	  ((eq query ?i)		; include
	   (setq noerase t)
	   (setq last-message (cmail-get-resource 'mail2-4))
	   ;; when noerase replybuffer will not be copied, and as a result
	   ;; mail-yank-original will not be called.
	   (setq mail-reply-action replybuffer))
	  (t
	   (set-buffer-modified-p nil)
	   (setq mail-send-actions nil)
	   (setq last-message (cmail-get-resource 'mail2-5)))))
    (when (not noerase)
      (if (null user)
	  (setq user (cmail-address-list (cmail-complete-field-to))))
      (or subject (setq subject
			(read-string (cmail-get-resource 'mail2-6)))))
    (and cmail-mail-query-cc
	 intr-p
	 (null cc)
	 (progn
	   (setq cc (cmail-complete-field-to "CC: "))
	   (setq cc (and (null (string= cc "")) (cmail-address-list cc)))))

    (if (and cmail-select-from-alist
	     (null cmail-default-from))
	(save-excursion
	  (if (not (get-buffer-window *cmail-mail-buffer))
	      (pop-to-buffer "*mail*")
	    (select-window (get-buffer-window *cmail-mail-buffer))
	    (switch-to-buffer "*mail*"))
	  (let ((case-fold-search t))
	    (while alst
	      (setq addr (car (car alst)))
	      (setq trgt (car (cdr (car alst))))
	      (setq full (car (cdr (cdr (car alst)))))
	      (setq alst (cdr alst))
	      (if (null trgt)
		  (setq alst nil)
		(while trgt
		  (setq pttn (car trgt))
		  (setq trgt (cdr trgt))
		  (if (null (string= pttn "DEFAULT"))
		      (mapcar '(lambda (usr)
				 (setq to (car usr))
				 (if (null (string-match pttn to))
				     nil
				   (setq alst nil)
				   (setq trgt nil)))
			      user)
		    (setq alst nil)
		    (setq trgt nil)))))
	    (make-local-variable 'user-mail-address)
	    (setq user-mail-address addr)
	    (setq self (cmail-derive-self-address)))))

    ;; CC-me 処理
    (if (and user (not (stringp user)) cc-me-p
	     (null (cmail-address-match self-addr-regexp user))
	     (null (cmail-address-match self-addr-regexp cc))
	     (null (and cmail-dont-cc-me-destinations
			(or (cmail-address-match dont-cc-me-regexp user)
			    (cmail-address-match dont-cc-me-regexp cc)))))
	(setq cc (append (cmail-address-list self) cc)))

    ;; 文字列に戻す. Quoted name かどうかを考慮する.
    (let ((func (if cmail-replyaddress-without-quoted-name 'car 'cdr)))
      (if (not (stringp user))
	  (setq user (apply 'cmail-string-concat ", " (mapcar func user))))
      (setq cc (apply 'cmail-string-concat ", " (mapcar func cc)))
      (if (string= user "") (setq user nil))
      (if (string= cc "") (setq cc nil)))

    (if (not (get-buffer-window *cmail-mail-buffer))
	(pop-to-buffer "*mail*")
      (select-window (get-buffer-window *cmail-mail-buffer))
      (switch-to-buffer "*mail*"))
    (setq actions mail-send-actions)

    (flet ((mail-mode () (cmail-mail-mode)))
      (let (*cmail-mime-mail-setup-decode-header-p)
	(if reply
	    (setq *cmail-mime-mail-setup-decode-header-p t))
	(if (eq reply 'forward)
	    ;; 'forward is set in cmail-forward for query ?i
	    (setq reply nil))
	(mail noerase user subject reply cc replybuffer nil)))

    (setq mail-send-actions (append actions action))
    (if cmail-default-from
	(save-excursion
	  (goto-char (point-min))
	  (if (cmail-get-field-values-in-mail-buffer "From")
	      nil
	    (insert "From: " cmail-default-from "\n")))
      (if cmail-select-from-alist           
	  (save-excursion
	    (if (null full)
		nil
	      (make-local-variable 'user-full-name)
	      (setq user-full-name full))
	    (make-local-variable 'user-mail-address)
	    (setq user-mail-address addr)
	    (goto-char (point-min))
	    (cond
	     ((cmail-get-field-values-in-mail-buffer "From")
	      nil)
	     ((and (boundp 'mail-from-style) user-full-name)
	      (cond
	       ((eq mail-from-style 'angles)
		(insert (format "From: %s <%s>\n" (user-full-name) user-mail-address)))
	       ((eq mail-from-style 'parens)
		(insert (format "From: %s (%s)\n" user-mail-address (user-full-name))))
	       (t
		(insert (format "From: %s\n" user-mail-address)))))
	     (t
	      (insert (format "From: %s\n" user-mail-address)))))))
    (setq mail-reply-buffer replybuffer)
    (message last-message)
    (cmail-mail-overload-functions)
    (make-local-variable 'truncate-partial-width-windows)
    (setq truncate-partial-width-windows nil)
    (run-hooks 'cmail-mail-hook)))

(defun cmail-mail-overload-functions ()
  (setq mode-line-buffer-identification
	"cmail: *mail*		"))

(defun cmail-mail-from-summary (&optional user subj)
  "サマリ中からメイルを出す."
  (interactive)
  (cmail-select-buffer *cmail-mail-buffer)
  (cmail-select-buffer *cmail-summary-buffer)
  (cmail-mail user subj))

(defun cmail-mail-from-summary-noquery ()
  "サマリ中からメイルを出す. minibufなし"
  (interactive)
  (cmail-mail-from-summary "" ""))

(defun cmail-reply ()
  "メイルに返事を出す."
  (interactive)
  (cmail-reply-1 nil nil nil nil))

(defun cmail-reply-include-text ()
  "メイルに返事を出す. メイルを最初に引用する."
  (interactive)
  (cmail-reply-1 nil t nil nil))

(defun cmail-reply-ignore-reply-to ()
  "メイルに返事を出す."
  (interactive)
  (cmail-reply-1 nil nil nil 'ignore-reply-to))

(defun cmail-reply-include-text-ignore-reply-to ()
  "メイルに返事を出す. メイルを最初に引用する."
  (interactive)
  (cmail-reply-1 nil t nil 'ignore-reply-to))

(defun cmail-followup ()
  "関係者全員にメイルの返事を出す."
  (interactive)
  (cmail-reply-1 t nil nil nil))

(defun cmail-followup-include-text ()
  "関係者全員にメイルの返事を出す. メイルを最初に引用する."
  (interactive)
  (cmail-reply-1 t t nil nil))

(defun cmail-followup-ignore-reply-to ()
  "関係者全員にメイルの返事を出す."
  (interactive)
  (cmail-reply-1 t nil nil 'ignore-reply-to))

(defun cmail-followup-include-text-ignore-reply-to ()
  "関係者全員にメイルの返事を出す. メイルを最初に引用する."
  (interactive)
  (cmail-reply-1 t t nil 'ignore-reply-to))

(defun cmail-split-message-id (mid-string)
  "複数のMessage-IDを含む文字列をMessage-IDのリストに分割する."
  (if (stringp mid-string)
      (save-excursion
	(let ((offset 0) mid-list)
	  (while (string-match "<[^>]*>" mid-string offset)
	    (push (match-string 0 mid-string) mid-list)
	    (setq offset (match-end 0)))
	  (nreverse mid-list)))))

(defun cmail-remove-duplicate-message-id (ref oref)
  "refからorefに含まれるMessage-IDを取り除いたものを返す."
  (let ((ref-list (cmail-split-message-id ref))
	(oref-list (cmail-split-message-id oref))
	result-list mid)
    (while (setq mid (pop ref-list))
      (or (member mid result-list)
	  (member mid oref-list)
	  (push mid result-list)))
    (mapconcat 'identity (nreverse result-list) "\n\t")))

(defun cmail-reply-1 (to-all yankorigin nocmail ignore-reply-to-p)
  "FUP がnon-nil の場合, Cc にも返事を出す.
2番目の引数 YANKORIGIN がnon-nil の場合, はじめから記事を読み込む.
3番目の引数 NOCMAIL が non-nil の場合, mail-user-agent として起動する.
4番目の引数 ignore-reply-to-p が non-nil の場合，REPLY-TO: フィールド
を無視して (FROM: フィールドを優先して) メールアドレスを作成する．"
  (let ((case-fold-search t)
	page sbj xnsbj dat from usr nam ref mid rpl ccc buf action
	lognm rplto frm cc-me-p	status-mark)

    ;; You are expected to be on the buffer which contains a message
    ;; you are replying to.
    (if nocmail
	(run-hooks 'cmail-get-headers-hook)
      ;; From here on,
      ;; current buffer is a work buffer which cotains only headers of
      ;; a mail you are replying to.
      (setq page (cmail-get-page-number-from-summary))
      (cmail-get-folder)
      (cmail-n-page page)
      (copy-to-buffer *cmail-user-mail-agent-buffer (point) (cmail-head-max))
      (set-buffer *cmail-user-mail-agent-buffer))

    (setq dat (cmail-get-field-values-in-mail-buffer "Date"))
    (setq sbj (cmail-get-field-values-in-mail-buffer "Subject"))
    (if cmail-use-X-Nsubject
	(setq xnsbj (cmail-get-field-values-in-mail-buffer "X-Nsubject")))

    (setq ref (cmail-get-field-values-in-mail-buffer "References"))
    (setq mid (cmail-get-field-values-in-mail-buffer "Message-Id"))
    (setq from (cmail-get-field-values-in-mail-buffer "From"))
    (if (and (not nocmail) cmail-mail-callback)
	(setq action
	      (list
	       (cons 'cmail-reply-callback
		     (list cmail-current-folder
			   page mid '("Replied"))))))
    (if from
	(setq lognm (cmail-trans-name-form from 'address)
	      from (cmail-trans-name-form from 'name))
      (setq from "somebody@somewhere" lognm "somebody@somewhere"))
    (setq rpl (cmail-format-resource 'reply-1
				     from dat
				     (if mid (format "\n\t     %s" mid) "")))

    ;; 返信のTo(→usr)とCC(→ccc)を作る。
    (let* ((self (cmail-derive-self-address))
	   (self-list (if (eq cmail-self-addresses 'auto)
			  (list self) cmail-self-addresses))
	   (self-addr-regexp (cmail-concat-addr-match-string self-list))
	   (dont-reply-to-list (if (eq cmail-dont-reply-to-addresses 'self)
				   self-list cmail-dont-reply-to-addresses))
	   (dont-cc-list (if (eq cmail-dont-cc-addresses 'self)
			     self-list cmail-dont-cc-addresses)))
      (setq self-list
	    (mapcar (function (lambda (addr) (list addr))) self-list))
      (setq dont-reply-to-list
	    (mapcar (function (lambda (addr) (list addr))) dont-reply-to-list))
      (setq dont-cc-list
	    (mapcar (function (lambda (addr) (list addr))) dont-cc-list))

      ;; アドレス文字列をリストにしてからルール適用
      (setq frm (cmail-get-field-values-in-mail-buffer "From" ", ")
	    rplto (cmail-get-field-values-in-mail-buffer "Reply-To" ", "))
      (if (or to-all
	      (cmail-address-match self-addr-regexp (cmail-address-list frm)))
	  (progn
	    (setq usr (cmail-address-list (or rplto frm)))
	    (setq usr (cmail-dont-reply-to usr self-list))
	    (setq usr (append usr (cmail-address-list
				   (cmail-get-field-values-in-mail-buffer
				    "To" ", "))))
	    (setq usr (cmail-unify-dup-addresses usr))
	    (setq ccc (cmail-address-list
		       (cmail-get-field-values-in-mail-buffer "CC" ", ")))
	    (if (and ignore-reply-to-p rplto)
		(setq ccc (append (cmail-address-list frm) ccc)))
	    (setq ccc (cmail-unify-dup-addresses ccc))
	    (setq ccc (cmail-dont-reply-to ccc usr))
	    (setq usr (cmail-dont-reply-to usr dont-reply-to-list))
	    (if (null usr)
		(if (and (null ignore-reply-to-p) rplto)
		    (setq usr (cmail-address-list rplto))
		  (setq usr (cmail-address-list frm))))
	    (setq ccc (cmail-dont-reply-to ccc dont-cc-list)))
	(if ignore-reply-to-p
	    (setq usr (cmail-address-list frm))
	  (setq usr (cmail-address-list
		     (or rplto frm))))))

    ;; Mark the original message as Replied
    (if (and (not nocmail) (not cmail-mail-callback))
	(progn
	  ;; Here, you are on a folder buffer(raw buffer).
	  (cmail-get-folder)
	  (cmail-n-page page)
	  (setq status-mark
		(cmail-set-mail-status '("Replied")))))

    ;;override global var
    (if (not nocmail)
	(let ((*cmail-have-all-headers *cmail-have-all-headers))
	  (cmail-show-contents page 'all-headers)))
    (if (and (not nocmail) (not cmail-mail-callback))
	(save-excursion
	  (cmail-select-buffer *cmail-summary-buffer)
	  (apply 'cmail-put-mark page status-mark)))
    (if (or (null sbj) (string= sbj ""))
	(setq sbj (cmail-get-resource 'reply-2))
      (setq cmail-unify-multi-re-in-subject t))
    (and xnsbj
	 (if (not (or cmail-remove-re
		      cmail-unify-multi-re
		      (string-match cmail-re-regexp sbj)))
	     (setq sbj (concat "Re: " sbj))
	   (if (string-match cmail-re-regexp xnsbj)
	       (setq xnsbj (substring xnsbj (match-end 0))))
	   (or cmail-remove-re
	       (setq xnsbj (concat "Re: " xnsbj)))))

    (if nocmail
	(setq buf (cmail-setup-reply-buffer page sbj from lognm dat))
      ;; You might think I am confuesed here, but it cannot be helped
      ;; for now.
      (setq buf (cmail-setup-reply-buffer page)))

    (save-excursion
      (set-buffer *cmail-mail-buffer)
      (or *cmail-have-all-headers
	  (let ((buffer-read-only nil))
	    (cmail-ignore-headers))))
    (if nocmail
	;; When rpl is set eword-decode-header is invoked in mail-setup-hook
	;; and that do harms to mime encoded headers.
	;; It seems rpl makes any difference as far as you are using cmail.
	(cmail-mail2 nil usr sbj nil ccc buf action nil
		     (cmail-cc-me-p 'when-used-as-agent))
      (cmail-mail2 nil usr sbj rpl ccc buf action nil
		   (if to-all (cmail-cc-me-p 'when-follow-up)
		     (cmail-cc-me-p 'when-reply))))
    (set-buffer "*mail*")
    (if yankorigin
	(progn
	  (cmail-yank-original nil)
	  (if (and (featurep 'cmail-use-multi-highlight)
		   cmail-use-multi-highlight)
	      (cmail-modify-keywords-highlight-citation t))))
    (save-excursion
      (if xnsbj
	  (progn
	    (goto-char (point-min))
	    (insert (format "X-Nsubject: %s\n" xnsbj))))
      (if (and cmail-make-References-header mid)
	  (let (oref)
	    (goto-char (point-min))
	    (setq oref (cmail-get-field-values-in-mail-buffer "References"))
	    (setq ref (cmail-remove-duplicate-message-id
		       (if ref (concat ref " " mid) mid) oref))
	    (if (string= ref "")
		nil
	      (if (null oref)
		  (insert "References: ")
		(re-search-forward "^References: *" nil t))
	      (insert ref "\n" (if oref "\t" ""))))))
    (set-buffer buf)))

(defun cmail-cc-me-p (compose-type)
  (or (eq cmail-always-cc-me t)
      (and (listp cmail-always-cc-me)
	   (member compose-type cmail-always-cc-me))))

(defun cmail-derive-self-address ()
  "Returns a possible sender fully qualified address derived from
cmail-default-from, user-mail-address, and user-login-name and system name."
  (if (and (boundp 'cmail-default-from)
	   (stringp cmail-default-from)
	   (string-match "@" cmail-default-from))
      cmail-default-from
    (if (and (boundp 'user-mail-address)
	     (stringp user-mail-address)
	     (string-match "@" user-mail-address))
	user-mail-address
      (concat (user-login-name) "@"
	      (or mail-host-address (system-name))))))

(defun cmail-unify-dup-addresses (addr-list)
  (let (result addr)
    (while addr-list
      (setq addr (car addr-list))
      (setq result (cons addr result))
      (setq addr-list (cmail-dont-reply-to addr-list (list addr))))
    (reverse result)))

(defun cmail-string-concat (separator &rest str-list)
  "concat str-list inserting separator inbetween them. ignore string
that contains nothing or only spaces."
  (let ((result ""))
    (while (and str-list (string= result ""))
      (or (string-match "^[ \t\n]*$" (car str-list))
	  (setq result (car str-list)))
      (setq str-list (cdr str-list)))
    (while str-list
      (or (string-match "^[ \t\n]*$" (car str-list))
	  (setq result (concat result separator (car str-list))))
      (setq str-list (cdr str-list)))
    result))

(defun cmail-concat-addr-match-string (match-string-list)
  (apply
   'cmail-string-concat "\\|"
   (mapcar (function
	    (lambda (string)
	      (if (string-match "^regexp:[ \t]*\\(.*\\)$" string)
		  (match-string 1 string)
		(regexp-quote (mail-strip-quoted-names string)))))
	   match-string-list)))

(defun cmail-address-match (regexp addr-list)
  (while (and addr-list
	      (null (string-match regexp (car (car addr-list)))))
    (setq addr-list (cdr addr-list)))
  addr-list)

(defun cmail-dont-reply-to (addr-list excl-list)
  "Delete addresses match with EXCLUDE-LIST in ADDR-LIST and return
the list."
  ;; BUG: アドレスグループで削除が行われると phrase: ... ; のバランス
  ;; が崩れる可能性がある。
  (let* ((case-fold-search t)
	 (match (cmail-concat-addr-match-string
		 (mapcar (function (lambda (addr) (car addr))) excl-list))))
    (if (string= match "")
	addr-list
      (delq nil (mapcar (function
			 (lambda (addr)
			   (and addr
				(if (string-match match (car addr))
				    nil
				  addr))))
			addr-list)))))

(defun cmail-address-list-1 (address-string)
  "extract addresses including comments and quoted names from comma
separated address string ADDRESS-STRING, and return a list of these
addresses. Be aware the returned address order is reversed"
  (if (not (stringp address-string))
      nil
    (let ((buf (get-buffer-create " cmail-addr-list-tmp")) pos addr-list)
      (save-excursion
	(set-buffer buf)
	(delete-region (point-min) (point-max))
	(insert address-string)
	(goto-char (point-min))
	(while (search-forward ":" nil t) (replace-match "-:" nil t))
	(goto-char (point-min))
	(while (re-search-forward "\"\\|\(" nil t)
	  (setq pos (1- (point)))
	  (goto-char (scan-sexps pos 1))
	  (narrow-to-region pos (point))
	  (goto-char (point-min))
	  (while (search-forward "," nil t) (replace-match ":" nil t))
	  (goto-char (point-max))
	  (widen)
	  (if (not (= (point) (point-max))) (forward-char 1)))
	(goto-char (point-min))
	(setq pos 1)
	(while (search-forward "," nil t)
	  (setq addr-list
		(cons (buffer-substring pos (1- (point))) addr-list))
	  (setq pos (point)))
	(if (not (= pos (point-max)))
	    (setq addr-list
		  (cons (buffer-substring pos (point-max)) addr-list))))
      (kill-buffer buf)
      (mapcar (function
	       (lambda (addr)
		 (while (string-match ":" addr)
		   (setq addr (replace-match "," nil t addr)))
		 (while (string-match "-," addr)
		   (setq addr (replace-match ":" nil t addr)))
		 (cmail-remove-surrounding-whitespace addr)))
	      addr-list))))

(defun cmail-address-list-2 (stripped-address-string)
  "STRIPPED-ADDRESS-STRING is a comma separated strings of stripped
addresses. It returns a list of addresses. Be aware the order is
reversed."
  (let (addr-list (pos 0) (len (length stripped-address-string)))
    (while (< pos len)
      (string-match "\\([^,]*\\)\\(,\\|$\\)" stripped-address-string pos)
      (setq addr-list
	    (cons (match-string 1 stripped-address-string)
		  addr-list))
      (setq pos (match-end 0)))
    (mapcar 'cmail-remove-surrounding-whitespace addr-list)))

(defun cmail-remove-surrounding-whitespace (addr)
  (string-match "\\`[ \t\n]*" addr)
  (substring addr (match-end 0)
	     (string-match "[ \t\n]*\\'" addr (match-end 0))))

(defun cmail-address-list (address-string)
  "extract addresses including comments and quoted names from comma
separated address string ADDRESS-STRING, and return a list of cons of
car part as cannonical mail address and cdr part as entire mail
address string extracted."
  (if (stringp address-string)
      (let* ((addr-list-w-comment (cmail-address-list-1 address-string))
	     (addr-list-wo-comment (cmail-address-list-2
				    (mail-strip-quoted-names address-string)))
	     addr-list)
	(if (= (length addr-list-w-comment) (length addr-list-wo-comment))
	    (progn
	      (while addr-list-w-comment
		(if (not (= (length (car addr-list-wo-comment)) 0))
		    (setq addr-list (cons (cons (car addr-list-wo-comment)
						(car addr-list-w-comment))
					  addr-list)))
		(setq addr-list-w-comment (cdr addr-list-w-comment))
		(setq addr-list-wo-comment (cdr addr-list-wo-comment)))
	      addr-list)
	  ;; in case both does not match. should never hit this case.
	  (reverse
	   (mapcar (function
		    (lambda (addr-w-comment)
		      (cons (mail-strip-quoted-names addr-w-comment)
			    addr-w-comment)))
		   addr-list-w-comment))))))

(defun cmail-setup-reply-buffer (page &optional sbj name lognm date)
  ;; When page is non-nil, it is called from within the cmail package
  (if page
      (let ((*cmail-have-all-headers *cmail-have-all-headers))
	(cmail-show-contents page 'all-headers)))
  (if sbj nil
    (cmail-get-header cmail-current-folder)
    (goto-char (point-min))
    (if (re-search-forward (format "^%d " page) nil t)
	nil
      (cmail-error-resource 'setup-reply-buffer-1))
    (beginning-of-line)
    (re-search-forward cmail-summary-regexp nil t)
    (setq name	(buffer-substring (match-beginning 4) (match-end 4)))
    (setq lognm (buffer-substring (match-beginning 5) (match-end 5)))
    (setq sbj	(buffer-substring (match-beginning 7) (match-end 7)))
    (cmail-get-folder)
    (cmail-n-page page)
    (setq msgid (cmail-get-field-values "Message-Id"))
    (setq date  (cmail-get-field-values "Date")))

  (setq *cmail-reply-info
	(if cmail-reply-heading-format
	    (if (functionp cmail-reply-heading-format)
		(funcall cmail-reply-heading-format)
	      (cmail-format-parser cmail-reply-heading-format
				   'cmail-make-reply-headings))))
  (save-excursion
    (setq buf (get-buffer-create *cmail-reply-mail-buffer))
    (set-buffer *cmail-mail-buffer)
    (save-restriction
      (widen)
      (set-buffer buf)
      (erase-buffer)
      (insert-buffer *cmail-mail-buffer)))
  buf)

(defun cmail-make-reply-headings (ctl)
  (cond
   ((= ctl ?S)
    (if (string= *cmail-unknown-field-value sbj)
	(cmail-get-resource 'make-reply-headings-1) sbj))
   ((= ctl ?s)
    (substring sbj (string-match "\\(Re:\\s *\\)*" sbj)))
   ((= ctl ?d) date)
   ((= ctl ?D) (cmail-trans-date-form date cmail-reply-long-date-format))
   ((= ctl ?m) msgid)
   ((= ctl ?n) name)
   ((= ctl ?l) (substring lognm 0 (string-match "[@%]" lognm)))
   ((= ctl ?a) lognm)))

(autoload 'cmail-rfc934-char-stuff-region "cmail-digest" nil t)

(defun cmail-insert-forward-message ()
  (let (pt)
    (insert (car cmail-forwarded-mail-border-cons))
    (setq pt (point))
    (save-restriction
      (save-excursion
	(set-buffer *cmail-mail-buffer)
	(widen))
      (insert-buffer *cmail-mail-buffer))
    (exchange-point-and-mark)
    (if cmail-rfc934-forwarding
	(cmail-rfc934-char-stuff-region pt (point)))
    (insert (cdr cmail-forwarded-mail-border-cons))
    (exchange-point-and-mark)))

(defun cmail-forward (&optional user)
  "カレント記事をフォワードする."
  (interactive)
  (let ((page (cmail-get-page-number-from-summary))
	from subject action mid)
    (beginning-of-line)
    (if (looking-at "^[ +]*[0-9]+\\^")
	(progn
	  (cmail-fixcp)
	  (cmail-send-digest user))
      (with-temp-buffer
	(let ((*cmail-mail-buffer (buffer-name)))
	  (cmail-fixcp)
	  (cmail-get-folder)
	  (cmail-n-page page)
	  (setq from (cmail-get-field-values "From"))
	  (setq subject (cmail-get-field-values "Subject"))
	  (setq subject (format (cmail-get-resource 'forward-1)
				(if (or (null subject) (string= subject ""))
				    (cmail-get-resource 'forward-2)
				  subject)))
	  (setq mid
		(cmail-get-field-values-in-mail-buffer "Message-Id"))
	  (let ((cmail-mime-automatic-preview cmail-mime-forwarding)
		(*cmail-show-content-reason 'forward))
	    (save-excursion
	      (cmail-show-contents page cmail-mime-forwarding)))
	  (if cmail-mail-callback
	      (setq action
		    (list
		     (cons 'cmail-reply-callback
			   (list cmail-current-folder page
				 mid '("Forwarded")))))
	    (save-excursion
	      (let (status-mark)
		(cmail-get-folder)
		(cmail-n-page page)
		(setq status-mark (cmail-set-mail-status '("Forwarded")))
		(cmail-select-buffer *cmail-summary-buffer)
		(apply 'cmail-put-mark page status-mark))))
	  (cmail-mail user subject 'forward nil nil action)
	  (set-buffer "*mail*")
	  (save-excursion
	    (let ((point (save-excursion
			   (beginning-of-line)
			   (re-search-forward mail-header-separator nil t))))
	      (if (not point)
		  (beginning-of-line)
		(goto-char point)
		(while (and (search-forward "\n" nil 1)
			    (invisible-p (point)))
		  (next-visible-point (point)))))
	    (if (and cmail-use-mime cmail-mime-forwarding)
		(cmail-mime-insert-forward-message)
	      (cmail-insert-forward-message))))))))

(defun cmail-alt-forward (arg)
  "カレント記事をcmail-mime-forwardingの指定ではない方法でフォワードする."
  (interactive "P")
  (let ((cmail-mime-forwarding (or arg (not cmail-mime-forwarding))))
    (cmail-forward)))

(defun cmail-toggle-mime-forwarding (arg)
  "mimeによるフォワードを行うかどうかをトグルする."
  (interactive "P")
  (setq cmail-mime-forwarding
	(or arg (not cmail-mime-forwarding))))

(defun cmail-mail-this-line (user subject)
  "USERにSUBJECTでメイルを出す.
interactiveの場合は, USERにはカーソル行の記事の発信者が入る."
  (interactive
   (list (cmail-name-and-address cmail-current-folder
				 (cmail-get-page-number-from-summary) t)
	 (read-string (cmail-get-resource 'mail-this-line-1))))
  (let (page buf)
    (setq page (cmail-get-page-number-from-summary))
    (cmail-show-contents page)
    (setq buf (cmail-setup-reply-buffer page))
    (cmail-mail user subject nil nil buf)))

(defun cmail-mail-x-nsubject ()
  "カーソルをX-Nsubjectフィールドに移動させる. なければ作る."
  (interactive)
  (expand-abbrev)
  (or (mail-position-on-field "X-Nsubject" t)
      (progn (mail-position-on-field "Subject")
	     (insert "\nX-Nsubject: "))))

(defun cmail-yank-original (arg)
  "元メイルを引用する."
  (interactive "P")
  (if (not mail-reply-buffer)
      nil
    (save-excursion
      (if *cmail-reply-info (insert *cmail-reply-info))
      (mail-yank-original arg))))

(defun cmail-send (&optional confirm)
  "メイルを送る. exitしない."
  (interactive "p")
  (run-hooks 'cmail-mail-send-hook)
  (and cmail-mail-insert-x-mailer
       (save-excursion
	 (goto-char (point-min))
	 (re-search-forward
	  (concat "^" (regexp-quote mail-header-separator) "\n"))
	 (if (re-search-backward "^X-Mailer:.*\n" (point-min) t)
	     (let ((beg (point)))
	       (forward-char 1)
	       (if (re-search-forward "^[^ \t]" nil t)
		   (beginning-of-line)
		 (forward-line 1))
	       (delete-region beg (point))))
	 (goto-char (point-min))
	 (insert-string
	  (format "X-Mailer: cmail %s on %s\n"
		  (cmail-version)
		  (if (featurep 'xemacs)
		      (format "XEmacs %s.%s%s"
			      (number-to-string emacs-major-version)
			      (number-to-string emacs-minor-version)
			      (if (featurep 'mule) " with Mule" ""))
		    (format "GNU Emacs %s%s"
			    emacs-version
			    (if (or (boundp 'NEMACS)
				    (boundp 'MULE)
				    (featurep 'mule))
				(format " / %s %s"
					(if (boundp 'NEMACS) "NEmacs" "Mule")
					(if (boundp 'NEMACS)
					    nemacs-version
					  mule-version)
					""))))))))
  (if (and cmail-use-send-mail-archive
	   (if confirm
	       (y-or-n-p (cmail-get-resource 'send-1)) t))
      (cmail-archive))
  (mail-send)
  (if cmail-rename-sent-mail-buffer
      (let ((bufname (buffer-name (current-buffer))))
	(string-match "^\\**" bufname)
	(setq bufname (replace-match "*sent*" t nil bufname))
	(rename-buffer bufname t))))

(defun cmail-send-and-exit (arg)
  "cmail用メイル発信コマンド. sendmail.elから引用・変更.
Send message like mail-send, then, if no errors, exit from mail buffer.
Prefix arg means don't delete this window."
  (interactive "P")
  (cmail-send)
  (bury-buffer (current-buffer))
  (setq *cmail-reply-info nil)
  (setq mail-reply-buffer nil)
  (cond ((and (not arg)
	      (not (one-window-p))
	      (not (get-buffer *cmail-summary-buffer)))
	 (delete-window))
	((get-buffer-window *cmail-mail-buffer)
	 (switch-to-buffer (other-buffer))
	 (cmail-select-buffer *cmail-summary-buffer))
	((get-buffer-window *cmail-summary-buffer)
	 (switch-to-buffer *cmail-mail-buffer)
	 (cmail-select-buffer *cmail-summary-buffer))
	((get-buffer *cmail-summary-buffer)
	 (and (get-buffer *cmail-mail-buffer)
	      (switch-to-buffer *cmail-mail-buffer))
	 (cmail-select-buffer *cmail-summary-buffer))
	(t
	 (switch-to-buffer (other-buffer (current-buffer))))))

(defvar *cmail-mailrc-age nil)
(defvar *cmail-addresses-age nil)
(defvar *cmail-addresses-data (list nil))
(defvar *cmail-addresses nil)

(defun cmail-address-complete-list ()
  "宛先の補完用リストを返す."
  (let ((rc (expand-file-name "~/.mailrc"))
	(ad (expand-file-name cmail-addresses))
	cl tl ta beg)
    (let (envrc)
      (setq envrc (getenv "MAILRC"))
      (and envrc (setq rc envrc)))
    (and (file-exists-p rc)
	 (or (eq mail-aliases t)
	     (null *cmail-mailrc-age)
	     (cmail-older *cmail-mailrc-age (nth 5 (file-attributes rc))))
	 (progn
	   (setq *cmail-mailrc-age (nth 5 (file-attributes rc)))
	   (setq mail-aliases nil)
	   (build-mail-aliases)
	   (cond ((featurep 'xemacs)
		  (setq cl (mapcar
			    (lambda (sym)
			      (list (symbol-name sym)))
			    (delq 0 (append mail-aliases ())))))
		 (t
		  (setq tl mail-aliases)
		  (while tl
		    (setq ta (car tl))
		    (setq tl (cdr tl))
		    (setq cl (cons (list (car ta)) cl)))))
	   (setcar *cmail-addresses-data cl)))
    (and (file-exists-p ad)
	 (or (null *cmail-addresses-age)
	     (cmail-older *cmail-addresses-age (nth 5 (file-attributes ad))))
	 (save-excursion
	   (setq *cmail-addresses-age (nth 5 (file-attributes ad)))
	   (setq tl nil)
	   (set-buffer (get-buffer-create
			*cmail-complete-address-buffer))
	   (erase-buffer)
	   (insert-file-contents cmail-addresses)
	   (goto-char (point-min))
	   (while (re-search-forward "^\\([^ \t\n#]+\\)" nil t)
	     (setq tl (cons (list (buffer-substring (match-beginning 1)
						    (match-end 1))) tl))
	     (forward-line 1))
	   (setcdr *cmail-addresses-data tl)))
    (if (or cl tl)
	(setq *cmail-addresses
	      (append (car *cmail-addresses-data)
		      (cdr *cmail-addresses-data)))))
  *cmail-addresses)

(defun cmail-complete-field-to (&optional field)
  "メイルで, 宛名を入力する.
cmail-mailrcから, グループを拾ってきて補完を行なう.
cmail-addressesからも, アドレスを拾ってくる. さらに, cmail-bbdb がフィーチャ
されている状態なら, BBDBからもアドレスを拾ってきて補完リストに追加する. "
  (or field
      (setq field "To: "))
  (let ((cl (cmail-address-complete-list)))
    (if (featurep 'cmail-bbdb)
	(setq cl (append cl (bbdb/cmail-get-address-list))))
    (if cl
	(completing-read field cl)
      (read-string field)) ))

(defun cmail-complete-address ()
  "mailモードにおいてaddressを補完する."
  (interactive)
  (let* ((end (point))
	 (start (save-excursion
					;		  (skip-chars-backward "_a-zA-Z0-9+@%.!\\-")
		  (skip-chars-backward "^ \t\n,")
		  (point)))
	 (completion)

	 (pattern (buffer-substring-no-properties start end))
	 (cl (cmail-address-complete-list)))
    (if (null cl)
	nil
      (setq completion (try-completion pattern cl))
      (cond ((eq completion t)
	     (let ((alias
		    (if (featurep 'xemacs)
			(cons
			 pattern
			 (abbrev-expansion pattern mail-aliases))
		      (assoc pattern mail-aliases))))
	       (if alias
		   (progn
		     (delete-region start end)
		     (insert (cdr alias))))))
	    ((null completion)
	     (cmail-message-resource1 'complete-address-1 pattern)
	     (ding))
	    ((not (string= pattern completion))
	     (delete-region start end)
	     (insert completion))
	    (t
	     (cmail-message-resource 'complete-address-2)
	     (let ((list (all-completions pattern cl)))
	       (with-output-to-temp-buffer "*Completion*"
		 (display-completion-list list)))
	     (cmail-message-resource 'complete-address-3))))))

(defun cmail-complete-address-or-tab (force)
  (interactive "P")
  (let ((case-fold-search t))
    (if (or
	 force
	 (and
	  ;; カーソルがヘッダにあるかどうか.
	  (< (point)
	     (save-excursion
	       (goto-char (point-min))
	       (search-forward (concat "\n" mail-header-separator "\n") nil 0)
	       (point)))
	  ;; フィールドが適切かどうか.
	  (save-excursion
	    (beginning-of-line)
	    ;; 継続行なら後ろに戻る
	    (while (and (looking-at "^[ \t]")
			(not (= (point) (point-min))))
	      (forward-line -1))
	    ;; 行頭が適切なヘッダか.
	    (looking-at cmail-complete-header-regexp))))
	(cmail-complete-address)
      (indent-for-tab-command))))

(defun cmail-add-new-address (address)
  "アドレスを .aliasses に追加する。"
  (save-excursion
    (let ((inhibit-local-variables t)
	  (enable-local-variables nil))
      (set-buffer (find-file-noselect (expand-file-name cmail-addresses))))
    (goto-char (point-max))
    (insert (concat address "\n"))
    (save-buffer)
    (kill-buffer (current-buffer))))

(defun cmail-add-new-address-from-mail (user)
  "userで指定されたmail-address を .addresses に追加する."
  (interactive (list (cmail-name-and-address cmail-current-folder
					     (cmail-get-page-number-from-summary) t)))
  (let ((cl (cmail-address-complete-list)))
    (if (try-completion user cl)
	(setq user (read-string (cmail-get-resource 'add-new-address-from-mail-1))))
    (if (y-or-n-p
	 (cmail-format-resource1 'add-new-address-from-mail-2 user))
	(cmail-add-new-address user)))
  (message ""))

(defun cmail-resend-bounced-mail ()
  "エラーメイルから元のメイルの内容を取り出し再送する.
*mail*バッファに元のメイルが抽出されるので, 再送前にアドレスなどを
修正することができる."
  (interactive)
  (let ((page (cmail-get-page-number-from-summary))
	b start lim)
    (cmail-show-contents page)
    (set-buffer *cmail-mail-buffer)
    (setq b *cmail-mail-buffer)
    (setq lim (point-max))
    (save-restriction
      (widen)
      (goto-char (point-min))
      (let ((case-fold-search nil))
	;; What a wonderful world it would be if mailers used the
	;; message encapsulation standard instead the following
	;; ad hockeries.
	(or
	 ;; sendmail
	 (search-forward "----- Unsent message follows" lim t)
	 ;; smail 2.x
	 (search-forward "======= text of message follows" lim t)
	 ;; smail 3.x (?)
	 (search-forward "- Message text follows:" lim t)
	 ;; MMDF
	 (search-forward "Your message follows:\n" lim t)
	 (search-forward "    Your message begins as follows:\n" lim t)
	 ;; zmailer (?)
	 (search-forward "---  Original Message	 ---" lim t)
	 ;; Grapevine
	 (search-forward "The text of your message was\n---" lim t)
	 ;; some mailer reports like this.
	 (search-forward "----- Original message follows -----" lim t)
	 (cmail-error-resource 'resend-bounced-mail-1))
	;; move to the first header line
	(or (re-search-forward "^[^ \t][^ \t]*:" lim t)
	    (cmail-error-resource 'resend-bounced-mail-2))
	(beginning-of-line)
	(setq start (point))))
    (cmail-mail "" (cmail-format-resource 'resend-bounced-mail-2
					  cmail-current-folder page))
    (set-buffer "*mail*")
    (erase-buffer)
    (cmail-insert-buffer-substring b start lim)
    (cmail-ignore-headers)
    (let ((cmail-ignored-headers "^Date:"))
      (cmail-ignore-headers))
    (goto-char (point-min))
    (re-search-forward "^$" nil nil)
    (insert mail-header-separator)
    (if (= (following-char) ?\n)
	(forward-char 1)
      (insert "\n"))
    (goto-char (point-min))
    (search-forward "To: ")))

(defun cmail-mail-kill-buffer (buf)
  "メイルの送信を中止してバッファをKILLした場合に,
サマリバッファにカーソルを戻す."
  (interactive "bKill buffer: ")
  (kill-buffer buf)
  (let ((sbuf (get-buffer *cmail-summary-buffer)))
    (if (and sbuf (buffer-live-p sbuf))
	(cmail-go-summary))))

;;;
;;;
;;;
(defun cmail-reply-callback (folder page message-id status)
  ;; A callback function should preserve the current buffer
  ;; status, so the save-excursion function is needed here.
  (save-excursion
    (if (cmail-get-folder folder)
	(progn
	  ;; insert status field in the message in the folder buffer
	  (cmail-n-page page)
	  (if (string= (cmail-get-field-values "Message-Id") message-id)
	      (let ((status-mark
		     (cmail-set-mail-status status)))
		;; mark the corresponding line in the header buffer
		(cmail-get-header folder)
		(goto-char (point-min))
		(re-search-forward (format "^%d " page) nil t)
		(delete-char 1)
		(insert-string (car status-mark))
		;; if the folder is currently viewed, updates the summary
		(if (eq (cmail-get-folder cmail-current-folder)
			(current-buffer))
		    (progn
		      (set-buffer *cmail-summary-buffer)
		      (save-excursion
			(goto-char (point-min))
			(if (re-search-forward (format "^[ +]*%d" page) nil t)
			    (apply 'cmail-put-mark page status-mark)))))))))))

(defun cmail-insert-message (msgseq)
  "現在のバッファのポイント位置に現在選択されているのフォルダの MSGSEQ 
で指定されたメッセージを挿入する。実行後のポイントは挿入したテキストの
最後に移動する。"
  (let ((*cmail-show-content-reason 'forward))
    (save-window-excursion
      (cmail-get-folder)
      (cmail-show-contents msgseq t)))
  (save-restriction
    (narrow-to-region (point) (point))
    (cmail-insert-last-shown-message-raw)
    (goto-char (point-min))
    (if (looking-at "^$") (forward-line 1))
    (while (not (looking-at "^$"))
      (if (looking-at "^X-cmail-.*:[ \t]*")
	  (let ((beg (match-beginning 0)))
	    (forward-line 1)
	    (while (looking-at "^[ \t]+") (forward-line 1))
	    (delete-region beg (point)))
	(forward-line 1)))
    (goto-char (point-max))))

;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

;;;
;;; mail-user-agent by cmail
;;;
(defun cmail-mail-compose (&optional to subject other-headers continue
				     switch-function yank-action
				     send-actions)
  (let ((cur (current-buffer))
	(query (if (and continue
			(listp continue)
			(> (car continue) 4))
		   ;; C-u C-u C-x m  とした時だけにする。
		   (cmail-read-char-from-minibuffer
		    (cmail-get-resource 'mail-compose-1) "rfRF")
		 nil))
	to-all yankorigin top bottom)
    ;; derived sendmail-user-agent-compose
    (if switch-function
	(let ((special-display-buffer-names nil)
	      (special-display-regexps nil)
	      (same-window-buffer-names nil)
	      (same-window-regexps nil))
	  (unless (get-buffer "*mail*")
	    (setq continue nil))
	  (funcall switch-function "*mail*")))
    ;; ask for reply when in mail buffer
    (if (or (null query)
	    (save-excursion
	      ;; Postion at the start of a mail to reply
	      (set-buffer cur)
	      (if (or (and cmail-original-message-start
			   (setq top
				 (and (re-search-backward
				       cmail-original-message-start nil t)
				      (match-beginning 0))))
		      (and (setq top (goto-char (point-min)))
			   (re-search-forward "^Subject:" nil t)))
		  nil t)))
	(let ((cc (cdr (assoc-ignore-case "cc" other-headers)))
	      (in-reply-to (cdr (assoc-ignore-case "in-reply-to"
						   other-headers))))
	  (cmail-mail to subject in-reply-to cc yank-action
		      send-actions continue)
	  (save-excursion
	    (goto-char (point-min))
	    (search-forward mail-header-separator)
	    (beginning-of-line)
	    (while other-headers
	      (if (not (member (car (car other-headers))
			       '("in-reply-to" "cc")))
		  (insert (car (car other-headers)) ": "
			  (cdr (car other-headers)) "\n"))
	      (setq other-headers (cdr other-headers)))
	    t))
	(if (or (eq query ?f) (eq query ?F))
		(setq to-all t))
	(if (or (eq query ?R) (eq query ?F))
		(setq yankorigin t))
	(save-excursion
	(set-buffer cur)
	(or (and cmail-original-message-end
		 (setq bottom
		       (and (re-search-forward
			     cmail-original-message-end nil (point-max))
			    (match-beginning 0))))
		(setq bottom (point-max)))
	(save-restriction
	  (narrow-to-region top bottom)
	  (copy-to-buffer (get-buffer-create *cmail-user-mail-agent-buffer)
					  (point-min) (point-max))
	  (run-hooks 'cmail-mail-agent-setup-buffer-hook))
	(set-buffer *cmail-user-mail-agent-buffer)
	(goto-char (point-min))
	(let ((*cmail-mail-buffer *cmail-user-mail-agent-buffer))
	  ;; Contents of *cmail-mail-buffer will be copied to
	  ;; *cmail-reply-mail-buffer in cmail-setup-reply-buffer.
	  (cmail-reply-1 to-all yankorigin t nil))))))

(cmail-funcall-if-defined 'define-mail-user-agent
			  'cmail-user-agent
			  'cmail-mail-compose
			  'cmail-send-and-exit
			  'kill-buffer
			  'cmail-mail-send-hook)

(defvar cmail-original-message-start "^Received: ")
(defvar cmail-original-message-end (concat "^\\(From \\|" *cmail-border "\\)"))
(defvar cmail-as-user-mail-agent nil)
(defvar *cmail-user-mail-agent-buffer " *cmail-user-mail-agent")

;; -->
;; should be added before cmail-mime add its hook functions.
(defvar cmail-unify-multi-re-in-subject nil)
(add-hook
 'cmail-mail-hook
 '(lambda ()
    (when cmail-unify-multi-re-in-subject
      (save-excursion
	(setq cmail-unify-multi-re-in-subject nil)
	(goto-char (point-min))
	(when (re-search-forward "^Subject:\\s *\\(.+\\)$" nil t)
	  (let ((sbj (buffer-substring (match-beginning 1) (match-end 1))))
	    ;; ユーザが明示的に変更した可能性があれば Re を付けない。
	    (unless noerase
	      (delete-region (match-beginning 1) (match-end 1))
	      (if (not (or cmail-remove-re
			   cmail-unify-multi-re ; unify しないときや Re: がない場合は
			   (string-match cmail-re-regexp sbj)))
		  (setq sbj (concat "Re: " sbj)) ; 単純に Re: を付ける
		(if (string-match cmail-re-regexp sbj) ; Re: がすでにある場合は
		    (setq sbj (substring sbj (match-end 0)))) ; それを削ってから
		(or cmail-remove-re
		    (setq sbj (concat "Re: " sbj)))) ; Re: を付ける
	      (insert sbj))))))))
;; <--

;;;
;;; cmail-draft-list
;;;   - an interactive draft message selector for cmail
;;;

;;;
;;; mode definitions
;;;
(defvar cmail-draft-list-mode-hook nil
  "Hook for cmail draft list mode")
(defvar cmail-draft-list-mode-map nil
  "Mode map for cmail draft list mode")
(defvar cmail-get-draft-message-listing-func
  '(cmail-draft-list-buffers))
(defvar cmail-draft-message-list nil)

(cond
 ((null cmail-draft-list-mode-map)
  (setq cmail-draft-list-mode-map (make-sparse-keymap))

  (define-key cmail-draft-list-mode-map "s" 'cmail-go-summary)
  (define-key cmail-draft-list-mode-map "\C-cf" 'cmail-folders)

  (define-key cmail-draft-list-mode-map "h" 'backward-char)
  (define-key cmail-draft-list-mode-map "j" 'next-line)
  (define-key cmail-draft-list-mode-map "k" 'previous-line)
  (define-key cmail-draft-list-mode-map "l" 'forward-char)

  (define-key cmail-draft-list-mode-map "g" 'cmail-draft-list-mode)
  (define-key cmail-draft-list-mode-map "f" 'cmail-draft-list-open)
  (define-key cmail-draft-list-mode-map " " 'cmail-draft-list-open)
  (define-key cmail-draft-list-mode-map "d" 'cmail-draft-list-delete)
  (define-key cmail-draft-list-mode-map "q" 'cmail-draft-list-quit)))

(defun cmail-draft-list ()
  "cmail メッセージ作成バッファのリストを表示する"
  (interactive)
  (switch-to-buffer-other-window
   (get-buffer-create "*cmail-draft-list*"))
  (cmail-draft-list-mode))

(defun cmail-draft-list-mode ()
  "cmail メッセージ作成バッファのリストを表示して選択することができます。

\\{cmail-draft-list-mode-map}"
  (interactive)
  (kill-all-local-variables)
  (setq major-mode 'cmail-draft-list-mode)
  (setq mode-name "cmail draft list")
  (use-local-map cmail-draft-list-mode-map)
  (setq buffer-read-only nil)
  (make-local-variable 'cmail-draft-message-list)
  (setq cmail-draft-message-list (cmail-get-draft-message-list))
  (cmail-draft-format-buffer (current-buffer) cmail-draft-message-list)
  (setq truncate-lines t)
  (setq buffer-read-only t)
  (goto-char (point-min))
  (forward-line 2)
  (run-hooks 'cmail-draft-list-mode-hook))

(defun cmail-get-draft-message-list ()
  (let ((list-funcs cmail-get-draft-message-listing-func)
	(msgnum 1) res1 res)
    (while list-funcs
      (setq res1 (apply (car list-funcs) (list msgnum)))
      (setq list-funcs (cdr list-funcs))
      (if res1
	  (progn
	    (setq msgnum (car res1))
	    (setq res (append res (list (cdr res1)))))))
    res))

(defun cmail-draft-format-buffer (buffer draft-list)
  "Format cmail draft list buffer including header."
  (let (msg-list)
    (save-excursion
      (set-buffer buffer)
      (delete-region (point-min) (point-max))
      (cmail-draft-insert-line "MsgID" "To" "Subject")
      (cmail-draft-insert-line "-----" "--" "-------")
      (cmail-draft-insert-line "[new]" "" "")
      (while draft-list
	(setq msg-list (cdr (car draft-list)))
	(if msg-list
	    (progn
	      (insert (concat ": ===== " (car (car draft-list)) " =====\n"))
	      (while msg-list
		(apply 'cmail-draft-insert-line
		       (list (nth 0 (car msg-list))
			     (nth 1 (car msg-list))
			     (nth 2 (car msg-list))))
		(setq msg-list (cdr msg-list)))))
	(setq draft-list (cdr draft-list))))))

(defun cmail-draft-insert-line (index to subject)
  "Insert a formated entry of a line in cmail draft list mode buffer."
  (insert (format "  %s %s %s\n"
		  (cmail-fill 5 (if (stringp index)
				    index
				  (int-to-string index)))
		  (cmail-fill -24 to)
		  subject)))

;;; draft mode commands
(defun cmail-draft-list-quit ()
  "メール作成バッファリストモードを終了します。"
  (interactive)
  (kill-buffer (current-buffer))
  (cmail-go-summary))

(defun cmail-draft-list-open ()
  "現在のカーソルのある行に対応するメール作成バッファを呼び出します。"
  (interactive)
  (let ((message (cmail-draft-list-get-draft-message)))
    (cond ((and message (listp message))
	   (apply (nth 3 message) (list 'open message))
	   (goto-char (mail-text-start)))
	  ((eq message 'new)
	   (cmail-mail "" ""))
	  (t (message "No valid draft message.")))))

(defun cmail-draft-list-delete ()
  "現在のカーソルのある行に対応するメール作成バッファを削除します。"
  (interactive)
  (let ((message (cmail-draft-list-get-draft-message)))
    (cond ((and message (listp message))
	   (apply (nth 3 message) (list 'delete message)))
	  (t (message "No valid draft message.")))))

(defun cmail-draft-list-get-draft-message ()
  "Return buffer name corresponding to the current cursor line. This
function should be used in a cmail draft list mode buffer. If the line
does not contain a valid buffer name at the proper position in the
line, then checks if a special contorl line. ex. if it finds [new],
return a symbol ' new. Otherwise, it returns nil."
  (save-excursion
    (beginning-of-line)
    (if (looking-at " *\\([0-9]+\\)")
	(let ((id (string-to-int (buffer-substring (match-beginning 1)
						   (match-end 1)))))
	  (if (> id 0)
	      (assoc id (apply 'append
			       (mapcar 'cdr cmail-draft-message-list)))))
      (if (looking-at "  \\[new\\]") 'new))))

;;;
;;; draft list for mail mode buffers
;;;
(defun cmail-draft-list-buffers (msgnum)
  "
Create a cmail draft message list by going through the list of
buffers. It looks for buffers in cmail-mail-mode or mail-mode. The
cmail draft buffers list returned from this function is a list of
mail mode buffer information list, which includes a buffer object,
buffer filename, 'to' field content, and 'subject' field content."
  (save-excursion
    (let ((bl (buffer-list)) res1 res)
      (while bl
	(set-buffer (car bl))
	(if (or (eq major-mode 'mail-mode)
		(eq major-mode 'cmail-mail-mode))
	    (progn
	      (goto-char (point-min))
	      (setq res1
		    (append
		     res1
		     (list (list
			    msgnum
			    (or (cmail-get-field-values-in-mail-buffer "To" ", ") "")
			    (or (cmail-get-field-values-in-mail-buffer "Subject") "")
			    'cmail-draft-list-buffer-commands
			    (current-buffer)
			    (or (buffer-file-name) "")))))
	      (setq msgnum (1+ msgnum))))
	(setq bl (cdr bl)))
      (setq res (cons "Mail Mode Buffers" res1))
      (cons msgnum res))))

(defconst cmail-draft-list-buffer-commands
  '((open . cmail-draft-list-buffer-open)
    (delete . cmail-draft-list-buffer-delete) ))
    
(defun cmail-draft-list-buffer-commands (operation message)
  (let ((func (cdr (assoc operation cmail-draft-list-buffer-commands))))
    (if func (apply func (list message)))))

(defun cmail-draft-list-buffer-open (message)
  (bury-buffer)
  (switch-to-buffer (nth 4 message)))

(defun cmail-draft-list-buffer-delete (message)
  (kill-buffer (nth 4 message))
  (cmail-draft-list-mode)
  (beginning-of-line))

;;;
;;;
