;;;
;;;  cmail-thread.el - thread related functions
;;;
;;;  $Author: tmp $
;;;  created at: Fri Jul 14 10:21:00 JST 1995
;;;  $Modified: Toshihiko Ueki <toshi@he.kobelcosys.co.jp>
;;;  modified at: Sat Nov 23 23:23:23 JST 1997
;;;
;;;  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-thread)
(eval-when-compile (require 'cl))

(defun cmail-build-thread ()
  "カレントフォルダのスレッドデータを作成する. 
既にスレッドデータが存在していればそれを返す."
  (save-excursion
    (cmail-get-folder)
    (if (null *cmail-thread-data)
	(let (data)
	  (save-excursion
	    (cmail-get-header nil t)
	    (while (not (eobp))
	      (setq data
		    (cmail-th-add data
				  (string-to-int
				   (buffer-substring (point)
						     (progn
						       (forward-line 1)
						       (point))))))))
	  (setq *cmail-thread-data data)))
    *cmail-thread-data))

(defun cmail-th-message-id (page)
  "指定したページ番号のメイルのメッセージIDを返す."
  (save-excursion
    (cmail-get-folder)
    (cmail-n-page page)
    (let ((str (cmail-get-field-values "Message-ID")))
      (and str
           (string-match "<[^\033 >]+>" str)
           (substring str (match-beginning 0) (match-end 0))))))

(defun cmail-th-parent (page)
  "In-Reply-To:があれば、そこから元メイルのメッセージIDを得, また,
In-Reply-To:がなくReferences:があれば, その最後のメッセージIDを
元メイルのメッセージIDとして返す."
  (save-excursion
    (let (str res)
      (cmail-get-folder)
      (cmail-n-page page)
      (setq str (cmail-get-field-values "In-Reply-To"))
      (and str
	   (string-match "<[^\033 >]+>" str)
	   (setq res (substring str (match-beginning 0)
				(match-end 0))))
      (if res
	  nil
	(setq str (cmail-get-field-values "References"))
	(if str
	    (let ((buf (get-buffer-create " *cmail-th-parent*")))
	      (unwind-protect
		  (progn
		    (set-buffer buf)
		    (erase-buffer)
		    (insert str)
		    (goto-char (point-max))
		    (if (search-backward "<" nil t)
		      (and
		       (looking-at "<[^\033 >]+>")
		       (setq res (buffer-substring (match-beginning 0)
						   (match-end 0))))))
		(kill-buffer buf)))))
      res)))

(defun cmail-th-find (mid)
  "指定されたメッセージIDを持つメイルのページ番号を返す."
  (save-excursion
    (cmail-get-header)
    (cmail-build-thread)
    (cmail-get-folder)
    (nth 1 (assoc mid *cmail-thread-data))))

(defun cmail-th-level (page)
  "スレッドの深さを返す."
  (save-excursion
    (cmail-get-folder)
    (if (null *cmail-thread-data)
	0
      (let ((mid (cmail-th-message-id page)))
	(nth 2 (assoc mid *cmail-thread-data))))))

(defun cmail-th-add (data page)
  "スレッドデータに指定したページ番号のメイルを追加."
  (let ((mid (cmail-th-message-id page)))
    (if (> page 0)
	(let* ((pmid (cmail-th-parent page))
	       (newlevel 0)
	       (p (member (assoc pmid data) data))
	       ptr level)
	  (if (and pmid p)
	      (progn
		(setq newlevel (1+ (nth 2 (car p))))
		(while p
		  (setq ptr (cdr p))
		  (setq level (nth 2 (car ptr)))
		  (if (and ptr (>= level newlevel))
		      (setq p ptr)
		    (setcdr p nil)
		    (setq p nil)))))
	  (append data (list (list mid page newlevel)) ptr))
      data)))

(defun cmail-th-append (folder page)
  "指定したフォルダのスレッドデータに指定したページ番号のメイルを追加."
  (save-excursion
    (let ((cmail-current-folder folder))
      (cmail-get-folder folder)
      (if *cmail-thread-data
	  (setq *cmail-thread-data (cmail-th-add *cmail-thread-data page)))
      )))

(defun cmail-th-insert-summary ()
  "カレントフォルダのスレッド化されたサマリを作成する."
  (let (p page (data (cmail-build-thread)) done)
    (goto-char (point-min))
    (while data
      (setq done nil)
      (setq p (car data))
      (setq page (format "^%d " (nth 1 p)))
      (while (null done)
	(cond
	 ((or (re-search-forward page nil t) 
	      (re-search-backward page nil t))
	  (setq done t))
	 (t 
	  (save-excursion		;rebuild thread-data
	    (cmail-get-folder)
	    (setq *cmail-thread-data nil))
	  (setq page (format "^%d " (cmail-th-find (nth 0 p)))))))
      (cmail-insert-summary (nth 2 p))
      (setq data (cdr data))))
  )

(defun cmail-toggle-thread ()
  "スレッド表示を行うかどうかをトグルさせる."
  (interactive)
  (cmail-get-folder)
  (setq *cmail-disp-thread (not *cmail-disp-thread))
  (cmail-make-summary))

(defun cmail-toggle-thread-ignore-limit ()
  "スレッド表示でlimitを使用するかどうかをトグルさせる."
  (interactive)
  (setq cmail-thread-ignore-limit (not cmail-thread-ignore-limit)))

(defun cmail-thread-p ()
  "スレッド表示を行うかどうかを調べる."
  (save-excursion
    (cmail-get-folder)
    *cmail-disp-thread))

;;; page to mid ryouhou no check
(defun cmail-th-remove (page)
  "指定したページ番号のメイルをスレッドデータから削除する."
  (save-excursion
    (cmail-get-folder)
    (if *cmail-thread-data
	(let ((mid (cmail-th-message-id page)))
	  (setq *cmail-thread-data
		(delete-if '(lambda (data) (= page (nth 1 data)))
			   *cmail-thread-data))))))

(defun cmail-refer-article ()
  "Read article specified by message-id around point."
  (interactive)
  (search-forward ">" nil t)    ;Move point to end of "<....>".
  (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
      (let ((mid (buffer-substring (match-beginning 1) (match-end 1))))
	(cmail-refer-article-mid mid))
    (cmail-error-resource 'refer-article-1)))

(defun cmail-refer-article-mid (mid)
  "Show parent article which has specific message-id."
  (let (page)
    (setq page (cmail-th-find mid))
    (cmail-select-buffer *cmail-summary-buffer)
    (cond
     ((null mid)
      (cmail-error-resource 'refer-article-1))
     ((null page)
      (error (cmail-format-resource 'refer-article-mid-2 cmail-current-folder mid)))
     ((null (cmail-goto-index page))
      (cmail-error-resource1 'refer-article-3 page))
     (t
      (cmail-show-contents page)))))

(defun cmail-refer-parent-article ()
  "Refer parent article."
  (interactive)
  (let* ((page (cmail-get-page-number-from-summary))
	 (mid (cmail-th-parent page)))
    (cmail-refer-article-mid mid)))

(defun cmail-check-display-thread (folder)
  "Check if display as threaded summary when specified folder is opened."
  (if (and (stringp cmail-thread-ignored-folder-regexp)
	   (string-match cmail-thread-ignored-folder-regexp folder))
      nil
    (or (and (stringp cmail-thread-folder-regexp)
	     (string-match cmail-thread-folder-regexp folder))
	cmail-display-thread)))

(defun cmail-mark-thread (&optional arg)
  "カーソル位置のメールが含まれるスレッド全体をマークする.
\\[universal-argument] を付けると, カーソル位置のメールをスレッドのトップとみなす.
\\[universal-argument] \\[universal-argument] を付けるとHOLDにする."
  (interactive "p")
  (if (not (cmail-thread-p))
      (cmail-mark-mail 1)
    (save-excursion
      (set-buffer *cmail-summary-buffer)
      (let ((buffer-read-only nil)		; バッファを書き換え可能に
	    (page (cmail-get-page-number-from-summary))
	    (loop (not (or (= arg 4) (= arg 256))))
	    msgid family)
	(while loop
	  (setq msgid (cmail-th-parent page))
	  (and (setq loop (cmail-th-find msgid))
	       (setq family (cons msgid family)
		     page loop)))
	(or family
	    ;; いきなりスレッドの頭だった
	    (save-excursion
	      (cmail-get-folder)
	      (cmail-n-page page)
	      (setq family (cons
			    (let ((str (cmail-get-field-values "Message-ID")))
			      (and str
				   (string-match "<[^\033 >]+>" str)
				   (substring str (match-beginning 0) (match-end 0))))
			    nil))))
	(cmail-goto-index page)
	(setq loop t)
	(while loop
	  (cond
	   ((= arg 16)
	    (cmail-put-mark page "H" "H"))
	   ((or (= arg 64) (= arg 256))
	    (cmail-put-mark page "D" "D"))
	   (t
	    (cmail-fixcp)		; カーソルをマーク位置に
	    (forward-char -1)		; 980525-SNAP 以降
	    (delete-char 1)		; 一旦マークを消して...
	    (insert-string "^")))	; マークを付ける。
	  (forward-line 1)
	  (save-excursion
	    (if (eq (save-excursion (point-max)) (point))
		(setq loop nil)			; もうメールがない
	      (setq page (cmail-get-page-number-from-summary))
	      (cmail-get-folder)
	      (cmail-n-page page)
	      (setq msgid (cmail-get-field-values "In-Reply-To"))
	      (and msgid
		   ;; In-Reply-To には、余計な文字列が付いていることがある
		   (string-match "<[^\033 >]+>" msgid)
		   (setq msgid (substring
				msgid (match-beginning 0) (match-end 0))))
	      (or (member msgid family)
		  (let (family-p)
		    ;; In-Reply-To で見つからないので、References を調べる
		    (setq family-p
			  (catch 'found
			    (dolist (msgid (cmail-get-references-list))
			      (and (member msgid family)
				   (throw 'found t)))))	; 一族だった
		    (or family-p (setq loop nil))))	; 一族ではなかった
	      (and loop
		   (setq msgid (cmail-get-field-values "Message-ID"))
		   (or (member msgid family)
		       ;; まだ family に登録していなかったので、登録する
		       (setq family (cons msgid family)))))
	    ) ; save-excursion (*cmail-summary-buffer に戻る)
	  ) ; while-loop
	))
    (cmail-fixcp)))

(defun cmail-th-mark-delete (&optional topstart)
  "カーソル位置のメールが含まれるスレッド全体に消印を押す.
\\[universal-argument] を付けると, カーソル位置のメールをスレッドのトップとみなす."
  (interactive "P")
  (if (cmail-thread-p)
      (cmail-mark-thread (if topstart 256 64))
    (save-excursion
      (cmail-mark-delete 1))
    (cmail-fixcp)))

(defun cmail-get-references-list ()
  "References:で示されるメッセージID群をリストにして返す."
  ;; あらかじめ、(cmail-get-folder) (cmail-n-page n) を実行しておく必要あり
  (let ((str (cmail-get-field-values "References")) alist)
    (and str
	 (string-match "" "")			; match-end をクリア
	 (while (string-match "<[^\033 >]+>" str (match-end 0))
	   (setq alist
		 (cons (substring str (match-beginning 0) (match-end 0))
		       alist))))
    alist))					; References: がなかったら nil
