;;;
;;;  cmail-misc.el - utility functions for cmail
;;;
;;;  $Author: tmp $
;;;  created at: Mon Jul 12 10:44:23 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.

(require 'rfc822)
(require 'emu)

(eval-when-compile
  (require 'cmail))

;;; Emacs 20.3以降
(defvar running-emacs-20_3-or-later
  (and (not (featurep 'xemacs))
       (or (> emacs-major-version 20)
	   (and (= emacs-major-version 20) (>= emacs-minor-version 3)))))

;;
;; ==== ツール類 ====================================================
(defun cmail-get-page-number-from-summary (&optional no-err)
  "サマリからカーソル位置のmailのページ番号を拾う."
  (cmail-fixcp)
  (save-excursion
    (beginning-of-line)
    (if (looking-at "^[ +]*\\([0-9]+\\)")
	(string-to-int
	 (buffer-substring (match-beginning 1) (match-end 1)))
      (if no-err
	  nil
	(cmail-error-resource 'get-page-number-from-summary)))))

(defun cmail-narrow-to-page ()
  (interactive)
  (save-excursion
    (let (beg end)
      (backward-page)
      (setq beg (point))
      (if (eq (char-after beg) ?\n)
	  (setq beg (1+ beg)))
      (forward-page)
      (setq end (point))
      (narrow-to-region beg end))))

(defvar *cmail-re-head-bdr "\n\n")
(defun cmail-head-max ()
  "カレントページのヘッダの最大ポイント(ボーダ行の始め)を返す."
  (save-excursion
    (let ((max (cmail-page-max)))
    (if (not (re-search-forward *cmail-re-head-bdr max 1))
	max
      (forward-line -1)
      (point)))))

(defun cmail-page-max ()
  "カレントページの最大ポイント(ボーダ行の始め)を返す."
  (save-excursion
    (if (not (re-search-forward *cmail-re-bdr nil t))
	(point-max)
      (beginning-of-line)
      (point))))

(defun cmail-n-page (nth)
  "NTH番目のメイルの先頭のポインタの値を返す. ポインタも移動する."
  (cmail-rebuild-index)
  (goto-char (nth nth *cmail-pagelist)))

(defun cmail-rebuild-index ()
  "カレントバッファの各メイルへのマーカのリストを用意する."
  (if (eq (current-buffer) *cmail-summary-buffer)
      (cmail-error-resource 'rebuild-index-1))
  (if *cmail-pagelist
      nil
    (cmail-message-resource1 'rebuild-index-2 *cmail-last-opened-folder)
    (save-excursion
      (goto-char (point-min))
      (setq *cmail-pagelist (list (point-marker)))
      (while (re-search-forward *cmail-re-bln nil t)
	(nconc *cmail-pagelist (list (point-marker)))))
    (message "")))

(defun cmail-show-index ()
  (interactive)
  (cmail-get-folder)
  (message "%s" *cmail-pagelist)
  (sit-for 1))

(defun cmail-reset-index ()
  (interactive)
  (cmail-get-folder)
  (setq *cmail-pagelist nil))

(defun cmail-mail-counter ()
  "カレントフォルダのメイル数をカウントする.
返り値は新しく追加されるべきメイルの番号."
  (cmail-rebuild-index)
  (1- (length *cmail-pagelist)))

(defun cmail-num-of-mails ()
  "カレントフォルダのメイル数をカウントする.
返り値はフォルダ内のメイルの数(すき間を数えない)."
  (save-excursion
    (cmail-get-header)
    (save-restriction
      (widen)
      (count-lines (point-min) (point-max)))))

(defun cmail-ignore-headers ()
  "カレントバッファのメイルからいらないヘッダを削除する."
  (if (stringp cmail-ignored-headers)
      (save-excursion
	(save-restriction
	  (goto-char (point-min))
	  (narrow-to-region (point) (cmail-head-max))
	  (goto-char (point-min))
	  (while (re-search-forward "^[^ \t]+" nil t)
	    (beginning-of-line)
	    (if (and (or (not cmail-always-shown-headers)
			 (not (looking-at cmail-always-shown-headers)))
		     (not (looking-at "^$"))
		     (looking-at cmail-ignored-headers))
		(let ((beg (point)))
		  (forward-line 1)
		  ;; Be sure to get multi-line headers...
		  (re-search-forward "^[^ \t\n]+" nil 1)
		  (beginning-of-line)
		  (delete-region beg (point))
		  (goto-char beg))
	      (forward-line 1)))))))

(defun cmail-skip-From_ ()
  (while (looking-at "^From ") (forward-line)))
  
(defconst *cmail-mail-status-mark-assoc
  '(("^Active\\(,.*\\|$\\)" " " "A")
    ("^Unread\\(,.*\\|$\\)" "U" "U")
    ("^Edited\\(,.*\\|$\\)" "E" "E")
    ("^Deleted\\(,.*\\|$\\)" "D" "D")
    ("^Hold\\(,.*\\|$\\)" "H" "H")
    ("^Replied$" "R" "R")
    ("^Forwarded$" "F" "F")
    ("^Bookmarked$" "B" "B")
    ("^Replied,Forwarded$" ">" ">")
    ("^Replied,Bookmarked$" "b" "b")
    ("^Replied,Forwarded,Bookmarked$" "b" "b")))

(defun cmail-get-mark-symbol (status-string)
  (let ((markstr-db *cmail-mail-status-mark-assoc))
    (catch 'cmail-get-mark-symbol-return
      (while markstr-db
	(if (string-match (car (car markstr-db)) status-string)
	    (throw 'cmail-get-mark-symbol-return
		   (cdr (car markstr-db))))
	(setq markstr-db (cdr markstr-db)))
      '("!" "!"))))

(defun cmail-set-mail-status (add-status &optional del-status)
  (cmail-skip-From_)
  ;; For backward compatibility, allow string for add-status
  (let (status status-string new-status mod-p)
    (if (stringp add-status) (setq add-status (list add-status)))
    (if (re-search-forward "^X-cmail-status:[ \t]*\\(.*$\\)"
			   (cmail-head-max) t)
	(progn
	  (setq status-string (match-string 1))
	  (setq status (cmail-set-mail-status1 status-string
					       add-status del-status))
	  ;; nil is returned if no change.
	  (if status
	      (progn
		(setq new-status (mapconcat '(lambda (x) x) status ","))
		(if (not (string= new-status status-string))
		    (progn
		      (setq mod-p t)
		      (replace-match
		       (format "X-cmail-status: %s" new-status t t)))))
	    (setq new-status status-string)))
      (setq status (cmail-sort-mail-status add-status))
      (setq new-status (mapconcat '(lambda (x) x) status ","))
      (insert-string (format "X-cmail-status: %s\n" new-status))
      (setq mod-p t))
    ;; imap4 update, only when status is updated
    (if (and mod-p (boundp 'cmail-message-status-function)
	     (functionp cmail-message-status-function))
	(funcall cmail-message-status-function new-status))
    (cmail-get-mark-symbol new-status)))

(defun cmail-set-mail-status-if-missing (add-status)
  (cmail-skip-From_)
  (let ((beg (point)) status-string)
    ;; if status is already present, do nothing.
    (if (re-search-forward "^X-cmail-status:[ \t]*\\(.*$\\)"
			   (cmail-head-max) t)
	nil
      ;; otherwise, insert status string.
      (setq status-string
	    (mapconcat
	     '(lambda (x) x) (cmail-sort-mail-status add-status) ","))
      (goto-char beg)
      (insert-string (format "X-cmail-status: %s\n" status-string)))))

(defun cmail-set-mail-status1 (status-string add-status del-status)
  (let ((cur-status status-string) status-list status mod-p)
    (save-match-data
      (while (string-match "\\([^,]+\\)\\(,.*\\|\\)$" cur-status)
	(setq status (match-string 1 cur-status))
	(if (member status del-status)
	    (setq mod-p t)
	  (setq status-list (cons status status-list)))
	(setq cur-status (match-string 2 cur-status))))
    (while add-status
      (if (not (member (car add-status) status-list))
	  (progn
	    (setq mod-p t)
	    (setq status-list (cons (car add-status) status-list))))
      (setq add-status (cdr add-status)))
    (and mod-p (cmail-sort-mail-status status-list))))

(defconst *cmail-sort-mail-status-order
  '("Active" "Deleted" "Hold" "Unread"
    "Edited" "Replied" "Forwarded" "Bookmarked"))

(defun cmail-sort-mail-status (status-list)
  (let ((order *cmail-sort-mail-status-order) res)
    (while order
      (if (member (car order) status-list)
	  (progn
	    (setq res (cons (car order) res))
	    (setq status-list (delete (car order) status-list))))
      (setq order (cdr order)))
    ;; unknown status will be discarded for now.
    (setq res (nreverse res))
    (if (and res (equal (car res) "Active"))
	(or (cdr res) res)
      res)))

(defun cmail-mail-status-p (status)
  (let ((status-string (cmail-get-field-values "X-cmail-status")))
    (string-match (concat "\\(,\\|^\\)" (regexp-quote status)
			  "\\(,\\|$\\)") status-string)))

(defun cmail-delete-field (field-regexp)
  "FIELD-REGEXPに当てはまるヘッダのフィールドを削除する. "
  (let ((case-fold-search t) max beg)
    (if (string= (substring field-regexp 0 1) "^")
	nil
      (setq field-regexp (concat "^" field-regexp ":[ \t]*")))
    (setq max (cmail-head-max))
    (while (re-search-forward field-regexp max t)
      (setq beg (match-beginning 0))
      (forward-line 1)
      (while (looking-at "^[ \t]+") (forward-line 1))
      (delete-region beg (point)))))

(defun cmail-get-field-values (field-regexp &optional sep sep2)
  "FIELD-REGEXPに当てはまるヘッダのフィールド値を返す."
  (or sep2 (setq sep2 " "))
  (save-excursion
    (let ((case-fold-search t) max str tmp beg found)
      (if (string= (substring field-regexp 0 1) "^")
	  nil
	(setq field-regexp (concat "^" field-regexp ":[ \t]*")))
      (setq max (cmail-head-max))
      (while (and (null found)
		  (re-search-forward field-regexp max t))
	(setq beg (point))
	(end-of-line)
	(skip-chars-backward " \t")
	(if (> beg (point)) (goto-char beg))
	(setq tmp (buffer-substring-no-properties beg (point)))
	(setq str
	      (if str 
		  (concat str sep tmp)
		tmp))
	(forward-line 1)
	(while (looking-at "^[ \t]+")
	  (skip-chars-forward " \t")
	  (setq beg (point))
	  (end-of-line)
	  (skip-chars-backward " \t")
	  (setq tmp (buffer-substring-no-properties beg (point)))
	  (if tmp (setq str (concat str (or sep2 " ") tmp)))
	  (forward-line 1))
	(if (null sep) (setq found t)))
      str)))

(defun cmail-get-field-values-in-mail-buffer
  (field-regexp &optional sep sep2 header page)
  "FIELD-REGEXPに当てはまるヘッダのフィールド値を返す。メールバッファ用。
もとのはフォルダバッファ用。"
  (let ((*cmail-re-head-bdr (if header header
			      (concat "^" mail-header-separator "$")))
	(*cmail-re-bdr (if page page *cmail-re-bdr)))
    (cmail-get-field-values field-regexp sep sep2)))
(defalias 'cmail-get-field-values2 'cmail-get-field-values-in-mail-buffer)

(defun cmail-set-field-value (field-str value-str &optional appendp)
  "FIELD-STR ヘッダのフィールドを VALUE-STR にセットする. APPENDP が 
nil であれば現在のヘッダを置換する. 複数のヘッダがある場合は一つになる.
APPENDP が non-nil のときはフィールドが追加される."
  (if appendp
      (let ((case-fold-search t)
	    (field-regexp (concat "^" (regexp-quote field-str) ":"))
	    (beg (point)))
	(goto (cmail-head-max))
	(if (re-search-backward field-regexp beg t)
	    (progn
	      (forward-line 1)
	      (while (looking-at "^[ \t]+") (forward-line 1)))))
    (cmail-delete-field field-str))
  (insert (concat field-str ": " value-str "\n")))

(defun cmail-trans-date-form (date &optional long-date-format)
  "'Tue, 30 Jun 92 ...'または, '3 Mar 92 ...'といったDATEの日付から,
'92/06/30'という形に変換する."
  (if (null date)
      (setq date (current-time-string)))
  (let (year month day (case-fold-search t))
    (cond
     ((string-match
;; The date format recognized here is the one specified in RFC 822.
;; Some slop is allowed e.g. dashes between the monthday, month and year
;; because such malformed headers have been observed.
"\\(\\([a-z][a-z][a-z]+\\),\\)?[ \t\n]*\\([0-9][0-9]?\\)[ \t\n---]*\\([a-z][a-z][a-z]+\\)[ \t\n---]*\\([0-9]*[0-9][0-9]\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|[---+][0-9][0-9][0-9][0-9]\\)?"
        date)
      (setq year  (substring date (match-beginning 5) (match-end 5)))
      (setq month (substring date (match-beginning 4) (match-end 4)))
      (setq day   (substring date (match-beginning 3) (match-end 3))))
     ((string-match
;; UNIX ctime(3) format, with slop allowed in the whitespace, and we allow for
;; the possibility of a timezone at the end.
"\\([a-z][a-z][a-z]+\\),?[ \t\n]*\\([a-z][a-z][a-z]+\\)[ \t\n]*\\([0-9][0-9]?\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*[0-9][0-9]\\([0-9][0-9]\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|[---+][0-9][0-9][0-9][0-9]\\)?"
       date)
      (setq year  (substring date (match-beginning 5) (match-end 5)))
      (setq month (substring date (match-beginning 2) (match-end 2)))
      (setq day   (substring date (match-beginning 3) (match-end 3))))
     (t
      (setq year  "00")
      (setq month "00")
      (setq day  "00")))
    (if (< (length day) 2)
	(setq day (concat "0" day)))
    (if (and (> (length year) 2)
	     (not long-date-format))
	(setq year (substring year -2)))
    (if (> (length month) 3)
	(setq month (substring month 0 3)))
    (setq month (downcase month))
    (setq month (cond
		 ((string= month "jan") "01")
		 ((string= month "feb") "02")
		 ((string= month "mar") "03")
		 ((string= month "apr") "04")
		 ((string= month "may") "05")
		 ((string= month "jun") "06")
		 ((string= month "jul") "07")
		 ((string= month "aug") "08")
		 ((string= month "sep") "09")
		 ((string= month "oct") "10")
		 ((string= month "nov") "11")
		 ((string= month "dec") "12")
		 (t "00")))
    (format "%s/%s/%s" year month day)))

(defun cmail-days-between (date1 date2)
  ;; Return the number of days between date1 and date2.
  (- (cmail-day-number date1) (cmail-day-number date2)))

(defun cmail-day-number (date)
  (let ((dat (mapcar '(lambda (s) (and s (string-to-int s)) )
		     ;; before parse date, make timezone normalize.
                     (timezone-parse-date 
		      (timezone-make-date-arpa-standard date)))))
    (timezone-absolute-from-gregorian 
     (nth 1 dat) (nth 2 dat) (car dat))))

(defun cmail-older (t1 t2)
  (cond 
   ((= (car t1) (car t2))
    (< (nth 1 t1) (nth 1 t2)))
   ((< (car t1) (car t2)) t)
   (t nil)))

(defun cmail-current-time ()
  (let (today today-time)
    ;; compatibility check by 719163
    (if (= 0 (car (timezone-time-from-absolute 719163 0)))
        (setq today (cmail-day-number (current-time-string)))
      (setq today (1- (cmail-day-number (current-time-string)))))
    (setq today (timezone-time-from-absolute today 0))
    (setq today (list (car today) (cdr today)))
    today))
    
(defvar *cmail-expired-time-alist nil)

(defun cmail-expirable-folder (folder)
  (let (result file attr)
    (cond
     ((null cmail-auto-expirable-folders)
      (setq result nil))
     ((stringp cmail-auto-expirable-folders)
      (setq result (string-match cmail-auto-expirable-folders folder)))
     ((listp cmail-auto-expirable-folders)
      (setq result (equal-member folder cmail-auto-expirable-folders))))
    (if result
	(let ((prev-time (assoc folder *cmail-expired-time-alist))
	      (now (cmail-current-time)))
	  (if prev-time
	      (if (not (cmail-older (cdr prev-time) now))
		  nil
		(setcdr prev-time now)
		t)
	    (setq *cmail-expired-time-alist
		  (cons (cons folder now) *cmail-expired-time-alist))
	    t)))))

(defun cmail-expiry-days (folder)
  (let ((fldr (assoc folder cmail-expiry-days-alist)))
    (if fldr
	(cdr fldr)
      cmail-default-expiry-days)))

(defun cmail-nuke-space (str)
  (save-excursion
    (let ((buf (generate-new-buffer " nuke-space")))
      (set-buffer buf)
      (insert str)
      (goto-char (point-min))
      (while (re-search-forward "\\s +" nil t)
	(replace-match " "))
      (goto-char (point-min))
      (while (search-forward "( " nil t)
	(replace-match "("))
      (goto-char (point-min))
      (while (search-forward " )" nil t)
	(replace-match ")"))
      (let (beg end)
	(goto-char (point-min))
	(skip-chars-forward " \t")
	(setq beg (point))
	(goto-char (point-max))
	(skip-chars-backward " \t")
	(setq end (point))
	(setq str (buffer-substring beg end)))
      (kill-buffer buf)))
  str)

(defun cmail-rfc822-address-for-nemacs (name)
  (if (string-match "[\200-\377]" name)
      (let ((buf (generate-new-buffer " nemacs-address")))
	(save-excursion
	  (set-buffer buf)
	  (insert name)
	  (goto-char (point-min))
	  (while (re-search-forward "[\200-\377]" nil t)
	    (replace-match "AA"))
	  (setq name (buffer-substring (point-min) (point-max)))
	  (kill-buffer buf))))
  (car (rfc822-addresses name)))

(defun cmail-trans-name-form (name &optional mode)
  "名前NAMEの表示形式を変更する.
変更後は \"Macot Hayashi <hayasima@opal.esi.yamanashi.ac.jp>\"になる.
付加引数MODEが'nameであれば名前だけ, 'addressであればアドレスだけ,
'consであれば(name . address)のコンスペアを返す."
  (if name
      (let* (fn ln)
	(setq ln (if (boundp 'NEMACS)
		     (cmail-rfc822-address-for-nemacs name)
		   (car (rfc822-addresses name))))
	(if (or (null ln) (string-match "(Unparsable address --" ln))
	    (setq ln "unparsable-address"
		  fn name)
	  (if (eq mode 'address)
	      ln
	    (setq fn (regexp-quote ln))
	    (cond
	     ((string-match (concat "<" fn ">") name)
	      (setq fn (concat (substring name 0 (match-beginning 0))
			       (substring name (match-end 0)))))
	     ((string-match (concat fn "\\s *(\\(.*\\))") name)
	      (setq fn (concat (substring name (match-beginning 1)
					  (match-end 1)))))
	     (t (setq fn ln)))
	    (if (equal fn "") (setq fn ln))
	    (setq fn (cmail-nuke-space fn))))
	(cond
	 ((eq mode 'name) fn)
	 ((eq mode 'address) ln)
	 ((eq mode 'cons) (cons fn ln))
	 (t
	  (format "%s <%s>" fn ln))))))

(defun cmail-format-parser (form function)
  "コントロール文字列FORM を変換則の関数FUNCTION で変換した文字列を返す."
  (let (str mb1 mb2 me0)
    (while form
      (store-match-data nil)
      (if (string-match "%\\(:?\\)\\(-?[0-9]+\\)?\\(.\\)" form)
          (let ((me0 (match-end 0))
                (mb2 (match-beginning 2))
                (me2 (match-end 2))
                (mb3 (match-beginning 3))
                val lgt lim)
            (setq str (concat str (substring form 0 (match-beginning 0))))
            (setq val (funcall function (aref form mb3)))
            (setq lgt (length val))
            (setq str
                  (concat str
                          (if (null mb2)
                              val
                            (setq lim (string-to-int (substring form mb2 me2)))
                            (cmail-fill lim val))))
            (setq form (substring form me0)))
        (setq str (concat str form))
        (setq form nil)))
    str))

(cond ((boundp 'NEMACS)
       (if (fboundp 'sref)
	   nil
	 (fset 'sref (symbol-function 'aref)))
       (if (fboundp 'string-width)
	   nil
	 (fset 'string-width (symbol-function 'length)))
       (if (fboundp 'char-bytes)
	   nil
	 (defun char-bytes (chr) (if (< chr 128) 1 2)))
       (if (fboundp 'char-width)
	   nil
	 (defun char-width (chr)
	   (if (< chr 128) 1 2)))))

;;; str, idx, and width are set by caller
(if running-emacs-20_3-or-later
    (defun cmail-skip-column (column)
      (let (cw)
	(while (<= (+ width (setq cw (char-width (aref str idx))))
		   column)
	  (setq width (+ width cw))
	  (setq idx (1+ idx)))))
  (defun cmail-skip-column (column)
    (let (cw)
      (while (<= (+ width (setq cw (char-width (sref str idx))))
		 column)
	(setq width (+ width cw))
	(setq idx (+ idx (char-bytes (sref str idx))))))))

(defun cmail-substring (str from &optional to)
  (let ((idx 0)
	(width 0)
	(length (string-width str)))
    (if (< from 0)
	(setq from (- length from)))
    (cmail-skip-column from)
    (setq from idx)
    (when to
      (if (< to 0)
	  (setq to (- length to)))
      (cmail-skip-column to)
      (setq to idx))
    (substring str from to)))

(defun cmail-fill (fmt str)
  (let ((lgt (string-width str))
	(lim (if (< fmt 0) (- 0 fmt) fmt))
	val diff)
    (cond ((> lgt lim)
	   (setq val (cmail-substring str 0 lim)))
	  ((< fmt 0)
	   (setq val (format (format "%%s%%%ds" (- lim lgt)) str "")))
	  (t
	   (setq val (format (format "%%%ds" lim) str))))
    (setq diff (- lim (string-width val)))
    (if (= diff 0)
	nil
      (if (< fmt 0)
	  (setq val (format (format "%%s%%%ds" diff) val ""))
	(setq val (format (format "%%%ds" lim) val))))
    val))

(defun cmail-spaces (num)
  (let ((sp ""))
    (while (> num 0)
      (setq sp (concat sp " "))
      (setq num (1- num)))
    sp))

(defun cmail-command-line-p ()
  "cmailがコマンドラインから呼ばれていたら t, そうじゃなかったらnilを返す."
  (let* ((flist (equal-member "-f" command-line-args))
	 (funct (car (cdr flist))))
    (if (string= funct "cmail") 't)))

(defun cmail-select-buffer (buffer)
  "バッファBUFFERが表示されていたらそのバッファに飛ぶ.
表示されていない場合や, 生成されていない場合には，
そのウィンドウを生成する."
  (let ((gbw (get-buffer-window buffer))
	(sum (car cmail-window-size))
	(rml (cdr cmail-window-size))
	(fol (car cmail-window-horizontal-size))
	(smr (cdr cmail-window-horizontal-size))
	whi wwi adf)
    (if gbw
	(select-window gbw)
      (if (or (null rml) (null smr) cmail-use-full-window)
	  (delete-other-windows)
	(or cmail-use-full-window
	    (set-window-configuration *cmail-window-conf)))
      (switch-to-buffer *cmail-mail-buffer)
      (setq whi (window-height))
      (if rml
	  (let ((total (+ sum rml)))
	    (setq sum (max window-min-height (/ (* whi sum) total)))
	    (setq rml (max window-min-height (/ (* whi rml) total)))
	    (if (< whi rml)
		(enlarge-window (- rml whi)))))
      (setq wwi (window-width))
      (and cmail-always-display-folders
	   (get-buffer *cmail-folders-buffer)
	   (if (eq cmail-always-display-folders 'auto)
	       (if (< wwi cmail-always-display-folders-threshold)
		   (setq adf nil)
		 (setq adf t))
	     (setq adf t)))
      (if adf
	  (progn
	    (if fol
		(let ((total (+ fol smr)))
		  (setq fol (max window-min-width (/ (* wwi fol) total)))
		  (setq smr (max window-min-width (/ (* wwi smr) total)))
		  (if (< wwi smr)
		      (enlarge-window (- smr wwi))))
	      (if (< (- wwi window-min-width) smr)
		  (setq smr (- wwi window-min-width)))
	      (setq fol (- wwi smr)))
	    (save-excursion
	      (split-window nil fol t)
	      (switch-to-buffer *cmail-folders-buffer)
	      (other-window 1))))
;;      (split-window (get-buffer-window (current-buffer)) sum)
      (and (string= buffer *cmail-mail-buffer)
	   (split-window (get-buffer-window (current-buffer)) sum))
      (switch-to-buffer *cmail-summary-buffer)
      (setq gbw (get-buffer-window buffer))
      (and gbw (select-window gbw)))))

(defvar *cmail-virtual-folders nil "仮想フォルダのリスト")

(defun cmail-virtual-folder-p (folder)
  "FOLDERが仮想フォルダであればtを返す."
  (if folder
      (or (eq (aref folder 0) ?/)
	  (if (and
	       (boundp 'cmail-virtual-folder-check-function)
	       (functionp cmail-virtual-folder-check-function))
	      (funcall
	       cmail-virtual-folder-check-function folder)))))

(defun cmail-clean-virtual-folders (&optional force)
  "仮想フォルダを削除する. ユーザに確認を取った場合tを返す."
  (let (confirm)
    (if (and (null force) cmail-check-virtual-folder-on-clean)
	(mapcar (function (lambda (folder)
			    (if (not (cmail-volatile-folder-p folder))
				(setq confirm t))))
		*cmail-virtual-folders))
    (and confirm
	 (not (y-or-n-p (cmail-get-resource 'clean-virtual-folders-1)))
	 (cmail-error-resource 'clean-virtual-folders-2))
    (message "")
    (mapcar 'cmail-dismiss-folder *cmail-virtual-folders)
    (setq *cmail-virtual-folders nil)
    confirm))

(defun cmail-volatile-folder-p (&optional folder)
  "Return t if FOLDER is a virtual folder, and is marked volatile. A
virtual folder is by definition a folder loaded in a on-memory
buffer."
  (if (cmail-virtual-folder-p folder)
      (save-excursion
	(cmail-get-folder folder)
	(or (and (assq '*cmail-volatile-folder-p (buffer-local-variables))
		 *cmail-volatile-folder-p)
	    (= (cmail-mail-counter) 0)))))

(defun cmail-set-folder-to-volatile (&optional folder)
  "Set FOLDER to be volatile, if it's a virtual folder. If FOLDER is
not passed in current folder is used."
  (if (cmail-virtual-folder-p folder)
      (save-excursion
	(cmail-get-folder folder)
	(setq *cmail-volatile-folder-p t))))

(defun cmail-set-folder-to-nonvolatile (&optional folder)
  "Set FOLDER to be nonvolatile, if it's a virtual folder. If FOLDER
is not passed in current folder is used."
  (if (cmail-virtual-folder-p folder)
      (save-excursion
	(cmail-get-folder folder)
	(setq *cmail-volatile-folder-p t))))

(defvar *cmail-prev-folder nil)
(defvar *cmail-folder-list nil)

(autoload 'cmail-folders-get-folders-list "cmail-folders" nil t)

(defun cmail-make-folder-list ()
  "フォルダの一覧を作成する."
  (if *cmail-folder-list
      *cmail-folder-list
    (setq *cmail-folder-list (cmail-folders-get-folders-list))))

(defun cmail-complete-foldername (prompt &optional initialfolder req initstr)
  "フォルダ名を補完する.
PROMPTに続いて入力待ちを行ない, 付加引数のINITIALFOLDERがnon-nilの場合，
先行入力としてINITIALFOLDERを挿入する.
付加引数のREQUIRE-MATCHがnon-nilの場合, フォルダは存在しなくてはならない."
  (let* ((folderlist (cmail-make-folder-list))
	 (initial (if initialfolder initialfolder *cmail-prev-folder))
	 (pmt (cond
	       (initial
		(format (cmail-get-resource 'complete-foldername-1) prompt initial))
	       (t
		(format "%s: " prompt))))
	 (match (append (mapcar 'list *cmail-virtual-folders) folderlist))
	 (fld (completing-read pmt match nil req initstr))
	 done result)
    (setq result (if (string= "" fld) initial fld))
    (if (eq (aref result 0) ?/)
	nil
      (if (or (file-directory-p (expand-file-name result cmail-path))
	      (string= (file-name-as-directory fld) fld))
	  (cmail-error-resource1 'complete-foldername-2 result)))
    result))

(defun cmail-complete-filename (prompt &optional initialname)
  "ファイル名を補完する. PROMPTに続いて入力を行なう.
付加引数としてINITIALNAMEがnon-nilの場合, それをデフォルトとして扱う.
*cmail-save-to-dirと*cmail-save-to-nameをそれぞれ参照・更新する."
  (let* ((dir (file-name-as-directory
	       (or *cmail-save-to-dir cmail-save-to)))
	 (name (or initialname
		   *cmail-save-to-name
		   "file_created_by_cmail"))
	 (pmt (format (cmail-get-resource 'complete-filename-1) prompt name))
	 (mfl (save-window-excursion
		(read-file-name pmt dir (concat dir name) nil)))
	 (stm (string-match "[^/]+$" mfl))
	 (stm (if stm stm (cmail-error-resource 'complete-filename-2)))
	 (dir (substring mfl 0 stm))
	 (name (substring mfl stm))
	 (exfl (expand-file-name mfl)))
    (setq *cmail-save-to-dir dir)
    (setq *cmail-save-to-name name)
    exfl))

(defun cmail-make-directory (directory)
  "再帰的にディレクトリを作る(なければ)."
  (let ((directory (expand-file-name directory default-directory)))
    (or (file-exists-p directory)
	(let (head tail)
	  (if (and (eq system-type 'windows-nt)
		   (string-match "^[A-Za-z]:/" directory))
	      (setq head (substring directory 0 3)
		    tail (substring directory 2))
	    (setq head "/"
		  tail directory))
	  (cmail-make-directory-1 head tail)))
    ))

(defun cmail-make-directory-1 (head tail)
  (cond ((string-match "^/\\([^/]+\\)" tail)
	 (setq head
	       (concat (file-name-as-directory head)
		       (substring tail (match-beginning 1) (match-end 1))))
	 (or (file-exists-p head)
	     (make-directory head))
	 (cmail-make-directory-1 head (substring tail (match-end 1))))
	((string= tail "") t)
	))

(defvar *cmail-deleted nil)
(defvar *cmail-disp-thread cmail-display-thread)
(defvar *cmail-thread-data nil)
(defvar *cmail-mid-data nil)
(defvar *cmail-confirm-new-folder t)

(defun cmail-find-buffer (folder)
  (or (get-buffer (cmail-folder-buffer folder))
      (find-buffer-visiting (expand-file-name folder cmail-path))
      (get-buffer-create (cmail-folder-buffer folder))))

(defun cmail-set-buffer-multibyte (flag)
  (if (functionp 'set-buffer-multibyte)
      (set-buffer-multibyte flag)
    (setq mc-flag flag kanji-fileio-code flag)))

(defun cmail-open-folder (folder)
  "フォルダFOLDERをバッファに展開する. 展開したフォルダはリストに保持される."
  (setq *cmail-last-opened-folder folder)
  (if (get-buffer (cmail-folder-buffer folder))
      nil
    (let ((fn (cmail-folder-buffer folder))
	  (file (expand-file-name folder cmail-path))
	  new)
      (if (and (boundp 'cmail-mailbox-open-function)
	       (functionp cmail-mailbox-open-function))
	  ;; imap4 - if error happens it stops with error.
	  (progn
	    (funcall cmail-mailbox-open-function folder
		     *cmail-confirm-new-folder)
	    ;; if folder is new, unconditionally create it.  Note:
	    ;; if a folder is created on the server, it will be
	    ;; prompted in the imap4 routine. This case is only for
	    ;; local synchronization.
	    (if (not (file-exists-p file)) (setq new t)))
	;; otherwise check the user if we want to create.
	(and *cmail-confirm-new-folder
	     (not (file-exists-p file))
	     (if (yes-or-no-p (cmail-format-resource1 'open-folder-1 folder))
		 (setq new t)
	       (cmail-error-resource1 'open-folder-2 folder))))
      (if (cmail-virtual-folder-p folder)
	  (progn
	    (set-buffer (get-buffer-create fn))
	    (setq *cmail-virtual-folders
		  (cons folder *cmail-virtual-folders)))
        (cmail-make-directory (file-name-directory file))
        ;; if this is a new folder, commit the creation anyway, don't
	;; wait for final save, make it zero length folder. This is to
	;; make the folders mode happy to show the created folders.
	(if new
	    (with-temp-buffer
	      (erase-buffer)
	      (insert *cmail-borderline)
	      (as-binary-output-file
	       (write-region (point-min) (point-max) file))))
	(set-buffer
	 (let ((jam-code-guess-input-coding-system *cmail-file-coding-system)
	       mc-flag
	       kanji-fileio-code ; NEmacs 用
	       (inhibit-local-variables t)
	       (enable-local-variables nil))
	   (as-binary-input-file
	    (find-file-noselect file))))
	(if (>= (string-to-int emacs-version) 20)
	    (set-buffer-file-coding-system *cmail-file-coding-system)
	  (setq file-coding-system *cmail-file-coding-system))
	(cmail-set-buffer-multibyte nil)
	(if (string= (buffer-name) fn)
	    nil
	  (rename-buffer fn)))
      (or (equal-member folder *cmail-opened-folders-list)
	  (setq *cmail-opened-folders-list
		(cons folder *cmail-opened-folders-list)))
      (if (/= (buffer-size) 0)
	  nil
	(insert-string *cmail-borderline)
	(goto-char (point-min)))
      (or (cmail-virtual-folder-p folder)
	  (equal-member (list folder) *cmail-folder-list)
	  (nconc *cmail-folder-list (list (list folder))))
      (cmail-folder-mode)
      (make-local-variable 'make-backup-files)
      (setq make-backup-files nil)
      (make-local-variable '*cmail-backuped)
      (setq *cmail-backuped nil)
      (make-local-variable '*cmail-pagelist)
      (setq *cmail-pagelist nil)
      (cmail-rebuild-index)
      (make-local-variable '*cmail-deleted)
      (setq *cmail-deleted nil)
      (make-local-variable '*cmail-thread-data)
      (setq *cmail-thread-data nil)
      (make-local-variable '*cmail-mid-data)
      (setq *cmail-mid-data nil)
      (make-local-variable '*cmail-disp-thread)
      (setq *cmail-disp-thread (cmail-check-display-thread folder))
      (make-local-variable '*cmail-folders-modified)
      (setq *cmail-folders-modified new)
      (setq buffer-auto-save-file-name nil)
      (set (make-local-variable '*cmail-folder-name) folder)
      (set (make-local-variable '*cmail-volatile-folder-p) nil)
      (widen)
      (cmail-make-header-buffer folder)
      (set-buffer-modified-p nil)
      (run-hooks 'cmail-open-folder-hook))))

(defun cmail-get-folder (&optional folder)
  "フォルダFOLDERのバッファを返す."
  (if (null folder) (setq folder cmail-current-folder))
  (cmail-open-folder folder)
  (set-buffer (cmail-folder-buffer folder))
  (widen)
  (current-buffer))

(defun cmail-get-header (&optional folder nomovecursor)
  "フォルダのヘッダ部分をカレントバッファにする."
  (if (null folder) (setq folder cmail-current-folder))
  (setq *cmail-last-opened-folder folder)
  (let ((hbuf (cmail-header-buffer folder)))
    (if (not (get-buffer hbuf))
	(cmail-open-folder folder))
    (if (get-buffer hbuf)
	nil
      (cmail-get-folder folder)
      (cmail-make-header-buffer folder))
    (set-buffer hbuf))
  (if (not nomovecursor)
      (goto-char (point-min)))
  (current-buffer))

(defvar cmail-make-header-buffer-hook nil)

(defun cmail-make-header-buffer (folder)
  "retrieve header info"
  (let (hbuf min max)
    (save-excursion
      (setq hbuf (get-buffer-create (cmail-header-buffer folder)))
      (set-buffer hbuf)
      (erase-buffer))
    (goto-char (point-min))
    (setq min (point))
    (setq max (cmail-page-max))
    (copy-to-buffer hbuf min max)
    (save-excursion
      (set-buffer hbuf)
      (decode-coding-region (point-min) (point-max) *cmail-primary-coding-system)
	(run-hooks 'cmail-make-header-buffer-hook)
      (set-buffer-modified-p nil))))

(defun cmail-modified-p (folder)
  "フォルダが更新されていなければnilを返す."
  (let ((bbuf (get-buffer (cmail-folder-buffer folder)))
	(hbuf (get-buffer (cmail-header-buffer folder))))
    (or (buffer-modified-p bbuf)
	(buffer-modified-p hbuf))))

(defun cmail-folder-buffer (folder)
  "フォルダ名FOLDERからそのフォルダのバッファ名を返す.
そのバッファは存在していなくても何ら影響はない."
  (concat *cmail-folder-buffer-prefix folder "*"))

(defun cmail-header-buffer (folder)
  "フォルダ名FOLDERからそのフォルダのバッファ名を返す.
そのバッファは存在していなくても何ら影響はない."
  (concat *cmail-header-buffer-prefix folder "*"))

(defun cmail-backup-folder (&optional folder)
  "FOLDERのバックアップを作成する."
  (if (null folder) (setq folder cmail-current-folder))
  (let ((file (expand-file-name folder cmail-path)))
    (if (and (not (cmail-virtual-folder-p folder))
	     (null (string-match "^%" folder))
	     (file-exists-p file)
	     (progn (cmail-folder-buffer folder)
		    (null *cmail-backuped)))
	(let ((bkfile (cmail-backup-file folder)))
	  (save-excursion
	    (cmail-get-folder folder)
	    (setq *cmail-backuped t)
	    (copy-file file bkfile t t)
	    (set-file-modes bkfile cmail-folder-modes))))))

(defun cmail-backup-file (folder)
  "フォルダ名FOLDERからそのバックアップファイル名を返す."
  (let ((file (expand-file-name folder cmail-path)))
    (concat (file-name-directory file)
	    *cmail-backup-prefix
	    (file-name-nondirectory file))))

(defun cmail-save-buffer ()
  "カレントバッファをセーブし, モードをセットする"
  (if (buffer-modified-p)
      (setq *cmail-folders-modified t))
  (save-buffer cmail-backup-version)
  (set-file-modes (buffer-file-name) cmail-folder-modes)
  (run-hooks 'cmail-save-buffer-hook))

(defun cmail-flush-folder (folder)
  (if (cmail-virtual-folder-p folder)
      nil
    (cmail-sync-header folder)
    (cmail-get-folder folder)
    (if (buffer-modified-p)
	(progn
	  (cmail-save-buffer)
	  (rename-buffer (cmail-folder-buffer folder))))))

(defun cmail-flush-folders ()
  (save-excursion
    (mapcar 'cmail-flush-folder
	    *cmail-opened-folders-list))
  )

(if (fboundp 'equal-member)
    nil
  (defun equal-member (x list)
    "Returns non-nil if ELT is an element of LIST.  Comparison done with EQUAL.
The value is actually the tail of LIST whose car is ELT."
    (while (and list (not (equal x (car list))))
      (setq list (cdr list)))
    list))

(if (fboundp 'delete-if)
    nil
  ;;copied from epoch-util.el (a little changed)
  (defun delete-if (test lst)
    "Destructively remove all items that satisfy TEST from LIST"
    (while (and lst (listp lst) (funcall test (car lst)))
      (setq lst (cdr lst)))
    (let ((prev lst))
      (while (cdr prev)
	(if (funcall test (car (cdr prev)))	;;(cadr X) to (car (cdr X))
	    (setcdr prev (cdr (cdr prev)))	;;(cddr X) to (cdr (cdr X))
	  (setq prev (cdr prev))))
      lst)))

(if (fboundp 'buffer-substring-no-properties)
    nil
  (fset 'buffer-substring-no-properties (symbol-function 'buffer-substring)))

(if (fboundp 'functionp)
    nil
  ;;copied from epoch-util.el (a little changed)
  (defun functionp (thing)
    "Returns t if the argument is a function, nil otherwise"
    (cond
     ((symbolp thing) (fboundp thing))
     ((consp thing)
      (and (eq (car thing) 'lambda) (listp (car (cdr thing))))
      )
     (t nil)
     )
    ))

(defun cmail-delete-line (n)
  "kill-lineと同じだがkill-ringに追加しない."
  (let ((beg (point))
	(end (save-excursion
	       (forward-line n)
	       (point))))
    (delete-region beg end)))

(defun cmail-delete-mail (page &optional noecho)
  "PAGE番号のメイルを削除する.
付加引数NOECHOがnon-nilの場合, 削除時の聞き返しは行なわない．"
  (let ((cnt 0) (beg 0) (end 0)
	(yon t) buf)
    (cmail-get-folder)
    (goto-char (point-min))
    (while (< cnt page)
      (re-search-forward *cmail-re-bln nil t)
      (setq cnt (1+ cnt)))
    (setq beg (point))
    (setq end (cmail-page-max))
    (setq buf (current-buffer))
    (and cmail-query-delete
	 (not noecho)
	 (save-window-excursion
	   (pop-to-buffer " **DELETING MAIL**")
	   (erase-buffer)
	   (cmail-insert-buffer-substring buf beg end)
	   (goto-char (point-min))
	   (cmail-ignore-headers)
	   (setq yon (y-or-n-p (cmail-get-resource 'delete-mail-1)))))
    (if (not yon)
	nil
      ;; imap deletion
      (if (and (boundp 'cmail-message-delete-function)
	       (functionp cmail-message-delete-function))
	  (save-restriction
	    (narrow-to-region beg end)
	    (funcall cmail-message-delete-function)))
      (cmail-th-remove page)
      (setq *cmail-deleted t)
      (delete-region beg end)
      (cmail-get-header)
      (if (not (re-search-forward (format "^%d " page) (cmail-head-max) t))
	  nil
	(beginning-of-line)
	(cmail-delete-line 1)))))

(defun cmail-exec (func &optional ntimes)
  (let ((cnt 0) page)
    ;; removes confirmation buffer
    (let ((buf (get-buffer " *Confirm*")))
      (and buf (kill-buffer buf)))
    (cmail-fixcp)
    (beginning-of-line)
    (cond
     ((looking-at "^+? *[0-9]+\\^")
      (goto-char (point-min))
      (while (re-search-forward "^+? *[0-9]+\\^" nil t)
	(cmail-fixcp)
	(setq page (cmail-get-page-number-from-summary))
	(save-excursion (funcall func page))
	(if (or (eobp) (= page (cmail-get-page-number-from-summary)))
	    (forward-line 1))
	(beginning-of-line)
	(setq cnt (1+ cnt))))
     (ntimes
      (while (> ntimes 0)
	(save-excursion
	  (funcall func (cmail-get-page-number-from-summary)))
	(cmail-go-down 1)
	(setq ntimes (1- ntimes))
	(setq cnt (1+ cnt))))
     (t
      (save-excursion
	(funcall func (cmail-get-page-number-from-summary)))
      (setq cnt 1)))
    (cmail-fixcp)
    cnt))

(defun cmail-sync-header (&optional folder)
  (if (null folder) (setq folder cmail-current-folder))
  (save-excursion
    (let (fmod hmod fbuf hbuf)
      (cmail-get-folder folder)
      (setq fbuf (current-buffer))
      (setq fmod (buffer-modified-p))
      (cmail-get-header folder)
      (setq hbuf (current-buffer))
      (setq hmod (buffer-modified-p))
      (save-restriction
	(widen)
	(set-buffer-modified-p nil)
	(cmail-get-folder folder)
	;; delete obsolete header info
	(goto-char (point-min))
	(delete-region (point) (cmail-page-max))
	;; insert current header info
	(cmail-insert-buffer-substring hbuf)
	(encode-coding-region (point-min) (cmail-page-max)
			      *cmail-primary-coding-system)
	(set-buffer-modified-p (or fmod hmod))
	(set-buffer hbuf))))
  (run-hooks 'cmail-sync-header-hook))

(defun cmail-update-mark (page mark &optional folder)
  (save-excursion
    (let ((regexp (concat "[^" mark "]")))
      (cmail-get-header folder)
      (goto-char (point-min))
      (if (and (re-search-forward (format "^%d " page) nil t)
	       (looking-at regexp))
	  (replace-match mark)))))

(defun cmail-retrieve-mark (page &optional folder)
  (save-excursion
    (cmail-get-header folder)
    (goto-char (point-min))
    (if (re-search-forward (format "^%d " page) nil t)
	(buffer-substring (point) (1+ (point))))))

(defun cmail-sync-headers ()
  (save-excursion
    (mapcar 'cmail-sync-header
	    *cmail-opened-folders-list))
  )

(defun cmail-funcall-if-defined (symbol &rest args)
  (if (fboundp symbol)
      (apply symbol args)))

(defun cmail-read-char-from-minibuffer (prompt chars)
  (let ((cursor-in-echo-area t) char)
    (setq chars (append chars nil))
    (while (progn
	     (message prompt)
	     (setq char (read-char))
	     (if (memq char chars)
		 nil
	       (beep) t)))
    char))

(if running-emacs-20_3-or-later
    (defun cmail-insert-buffer-substring (buf &optional start end)
      (let ((dst-emc enable-multibyte-characters)
	    (src-emc (save-excursion
		       (set-buffer buf)
		       enable-multibyte-characters)))
	(if (eq dst-emc src-emc)
	    (insert-buffer-substring buf start end)
	  (let ((str (save-excursion
		       (set-buffer buf)
		       (buffer-substring (or start (point-min))
					 (or end (point-max))))))
	    (insert (if dst-emc
			(string-as-multibyte str)
		      (string-as-unibyte str)))))))
  (fset 'cmail-insert-buffer-substring
	(symbol-function 'insert-buffer-substring)))

(defun cmail-safe-read (string)
  (condition-case nil (read (or string "")) (error nil)))

(defun cmail-bufstr-p (bufstr)
  (and (vectorp bufstr)
       (buffer-live-p (get-buffer (aref bufstr 0)))
       (>= (save-excursion
	     (set-buffer (aref bufstr 0))
	     (buffer-size))
	   (max (aref bufstr 1) (aref bufstr 2)))))

(provide 'cmail-misc)
;; =========================================================================
