;;;
;;;  cmail-digest.el -
;;;
;;;  $Author: tmp $
;;;  created at: Wed Oct 20 14:23:24 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.

(defvar cmail-delete-after-bursting t
  "*non nilの時digestを展開した後, 元メイルを削除する.
展開先が仮想フォルダであれば削除しない.")
(defvar cmail-burst-folder "/digest"
  "*展開したdigestを追加するフォルダ(デフォルトは仮想フォルダ`/digest')")

;; 上記の変数を
;;   (setq cmail-burst-folder cmail-inbox-folder)
;; とするのも一つの手である. 運用によって使い分けて欲しい.

(defvar cmail-burst-border "^-$\\|^-----"
  "digestの区切りを示す正規表現. これで良いのだろうか?")

(defun cmail-rfc934-char-stuff-region (start end)
  (save-excursion
    (goto-char start)
    (while (and (< (point) end) (re-search-forward "^-" end t))
      (replace-match "- -" t t))))

(defun cmail-rfc934-char-unstuff-region (start end)
  (save-excursion
    (goto-char start)
    (while (and (< (point) end) (re-search-forward "^- "  end t))
      (replace-match "" t t)
      (forward-char))))

(defun cmail-burst-digest (fp)
  "digestされたメイルを個別のメイルに分割する.
\\[universal-argument]が与えられた場合, 追加するフォルダを入力できる.
デフォルトは変数cmail-burst-folderで指定されたフォルダ."
  (interactive "P")
  (let (burst-folder)
    (setq burst-folder
	  (if fp
	      (cmail-complete-foldername "Append bursted mails to")
	    cmail-burst-folder))
    (cmail-message-resource 'burst-digest-1)
    (if (cmail-virtual-folder-p burst-folder)
	(save-excursion
	  (cmail-kill-folder burst-folder t)))
    (cmail-exec '(lambda (page) (cmail-burst-internal page burst-folder)))
    (if (not (cmail-virtual-folder-p burst-folder))
	(cmail-save-folder burst-folder))
    (cmail-save-curpos)
    (cmail-visit-folder burst-folder t)
    (sit-for 0)
    (cmail-message-resource 'burst-digest-2)))

(defun cmail-burst-internal (page folder)
  "PAGEのメイルをFOLDERにアペンドする."
  (let (inbuf beg end max next buf)
    (setq inbuf (get-buffer-create *cmail-new-arrivals-buffer))
    (set-buffer inbuf)
    (erase-buffer)
    (cmail-insert-message page)
    ;; ヘッダ部分をskip
    (goto-char (point-min))
    (setq max (point-max))
    (if (and cmail-use-mime (featurep 'mmbuffer)
	     (= 0 (cmail-mime-burst-internal nil folder)))
	(if (not (re-search-forward cmail-burst-border max t))
	    (cmail-error-resource 'burst-internal-1)
	  (forward-line 1)
	  (skip-chars-forward "\n")
	  (setq buf (get-buffer-create *cmail-arrived-mail-buffer))
	  (cmail-skip-From_)
	  (setq beg (point))
	  (while (re-search-forward cmail-burst-border max t)
	    (goto-char (match-beginning 0))
	    (setq next (point))
	    (skip-chars-backward "\n")	; skip back blank lines
	    (forward-char 1)			; save last newline
	    (setq end (point))
	    (set-buffer buf)
	    (widen)
	    (erase-buffer)
	    (cmail-insert-buffer-substring inbuf beg end)
	    (cmail-rfc934-char-unstuff-region (point-min) (point-max))
	    (goto-char (point-min))
	    (cmail-set-mail-status '("Unread") '("Active"))
	    (goto-char (point-max))
	    (insert *cmail-borderline)
	    (cmail-append-mail-to-folder buf folder)
	    (set-buffer inbuf)
	    (goto-char next)
	    (forward-line 1)
	    (skip-chars-forward "\n")
	    (setq beg (point)))))
    (set-buffer *cmail-summary-buffer)
    (and cmail-delete-after-bursting
	 (null (cmail-virtual-folder-p folder))
	 (save-excursion
	   (cmail-get-folder)
	   (setq *cmail-deleted t))
	 (cmail-put-mark page "D" "D"))))

(defun cmail-send-digest (&optional user)
  "メイルのdigestを送る.
カーソル行のメイルにマークがついていれば, マークのついたメイル全てを,
ついていなければフォルダ内の全てのメイルをdigestする."
  (interactive)
  (let ((subject (cmail-format-resource1 'send-digest-1 cmail-current-folder))
	(only-marked-p (save-excursion
			 (set-buffer *cmail-summary-buffer)
			 (beginning-of-line)
			 (looking-at "^[ +]*[0-9]+\\^")))
	msgs mbuf obuf)
    (set-buffer *cmail-summary-buffer)
    (goto-char (point-max))
    (while (re-search-backward (if only-marked-p
				   "^[ +]*[0-9]+\\^"
				 "^[ +]*[0-9]+")
			       (point-min) t)
      (setq msgs
	    (cons (save-excursion (cmail-get-page-number-from-summary))
		  msgs)))
    
    (cmail-mail user subject 'forward)
    (setq mbuf (get-buffer "*mail*"))
    (cmail-message-resource 'send-digest-2)
    (set-buffer mbuf)
    (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-send-mime-digest-internal msgs mbuf)
      (cmail-send-digest-internal msgs mbuf))
    (cmail-select-buffer *cmail-mail-buffer)
    (switch-to-buffer "*mail*")
    (cmail-message-resource 'send-digest-3)))

(defun cmail-send-digest-internal (msgs mbuf)
  (let (beg end last)
    (if (null msgs)
	(error "cmail-send-digest-internal: no messages to digest"))
    (setq beg (point))
    (while msgs
      (set-buffer mbuf)
      (setq last (point))
      (cmail-insert-message (car msgs))
      (cmail-rfc934-char-stuff-region last (point))
      (let ((code (detect-coding-region last (point))))
	(if (listp code) (setq code (car code)))
	(decode-coding-region last (point) code))
      (save-restriction
	(narrow-to-region last (point))
	(run-hooks 'cmail-digest-prepare-hook))
      (insert "\n------------------------------\n\n")
      (setq msgs (cdr msgs)))
    ;; 最後のセパレータを消す.
    (forward-line 1)
    (setq end (point))
    (forward-line -3)
    (delete-region (point) end)
    (insert "------- End of digest -------\n")
    (goto-char beg)
    (insert "------- Start of digest -------\n")
    (goto-char beg)))
