[mew-dist 25926] mew-summary-exchange-marks again (was: mknmz)

[Hideyuki SHIRAI ( 白井秀行 )]

From: Kazu Yamamoto (山本和彦) <kazu at example.com> さん曰く
Subject: [mew-dist 25911] Re: mknmz
Message-ID: <20050108.112649.48202336.kazu at example.com>
Date: Sat, 08 Jan 2005 11:26:49 +0900 (JST)

> > それにしてもハードコーディングは嫌なので、後でコードを書いてみます。
> 
> やりました。

どうもありがとうございます。
ところで『ハードコーディング』で思い出したのだけど、やっぱり 'o'
も扱いたいので、

From: Kazu Yamamoto (山本和彦) <kazu at example.com> さん曰く
Subject: [mew-dist 25674] Re: マーク変換
Date: Fri, 19 Nov 2004 12:02:30 +0900 (JST)
Message-ID: <20041119.120230.137561106.kazu at example.com>
               ↑ここいら辺りにカーソルをおいて、"kp" と打ってみよう

> refile の部分はハードコーディングなので、マージしていません。
> 
> --かず＠結局ハードコーティングしか方法はなさそうだけれど

の再挑戦です。そのフォルダでつけられないマークかどうかの判定をし
ていないけど、やっぱり必要かな。

# ソフトコーディング(？)かどうかは不明。

(defvar mew-summary-exchange-marks-alist
  `((,mew-mark-refile (mew-summary-undo-one 'nomsg)
		      (mew-summary-refile-body checkresult nil 'nomsg)
		      mew-summary-exchange-get-refile-folders)
    (t (mew-summary-undo-one 'nomsg) (mew-mark-put-mark to-mark 'nomsg) nil))
  "*A list of lists which consists of
  1st: mark or 't' ('t' means no specified mark)
  2nd: function or form to undo the mark
  3rd: function or form to put the mark
  4th: function or form to check the putting mark.
If you assign the form in this a list, you can use special variable as 'from-mark'
, 'to-mark' and 'checkresult'.")

(defun mew-summary-input-exchangeable-mark (msg)
  (let (mark)
    (catch 'loop
      (while t
	(setq mark (mew-input-mark msg))
	(if mark
	    (throw 'loop mark)
	  (message "That is not a mark")
	  (mew-let-user-read))))))

(defun mew-summary-mark-exchange-get-function (mark nth)
  (let ((alist (or (assq mark mew-summary-exchange-marks-alist)
		   (assq t mew-summary-exchange-marks-alist))))
    (nth nth alist)))

(defmacro mew-summary-mark-exchange-call-function (func)
  `(cond ((functionp ,func) (funcall ,func))
	 ((consp ,func) (eval ,func))))

(defun mew-summary-exchange-marks (&optional arg)
  "Exchange the first input mark to the second one."
  (interactive "P")
  (let* ((from-mark (mew-summary-input-exchangeable-mark "Input mark from: "))
	 (to-mark (mew-summary-input-exchangeable-mark "Input mark to: "))
	 (regex (mew-mark-regex from-mark))
	 (func-unmark (mew-summary-mark-exchange-get-function from-mark 1))
	 (func-putmark (mew-summary-mark-exchange-get-function to-mark 2))
	 (func-check (mew-summary-mark-exchange-get-function to-mark 3))
	 (i 0)
	 (end (make-marker))
	 checkresult begend)
    (if (or arg (mew-mark-active-p))
	(setq begend (mew-summary-get-region))
      (setq begend (cons (point-min) (point-max))))
    ;; marker for the modification of buffer.
    (set-marker end (cdr begend))
    (message "Exchange marks from '%c' to '%c'..." from-mark to-mark)
    (save-excursion
      (goto-char (car begend))
      (while (re-search-forward regex end t)
	(when (and (zerop i) func-check)
	  (setq checkresult (mew-summary-mark-exchange-call-function func-check)))
	(mew-summary-mark-exchange-call-function func-unmark)
	(mew-summary-mark-exchange-call-function func-putmark)
	(forward-line 1)
	(setq i (1+ i))))
    (message "Exchange %s mark%s from '%c' to '%c'...done"
	     (if (= i 0) "no" (number-to-string i))
	     (if (= i 1) "" "s")
	     from-mark to-mark)))

(defun mew-summary-exchange-get-refile-folders ()
  (let (fld msg folders tmp buf killbuf
	    mew-inherit-refile-case mew-inherit-refile-proto)
    (mew-summary-goto-message)
    (when (mew-sumsyn-match mew-regex-sumsyn-short)
      (setq fld (mew-sumsyn-folder-name))
      (setq msg (mew-sumsyn-message-number))
      (setq mew-inherit-refile-case  (mew-case:folder-case fld))
      (setq mew-inherit-refile-proto (mew-case:folder-folder fld))
      (unless (setq buf (mew-cache-hit fld msg))
	(setq killbuf t)
	(setq buf (generate-new-buffer mew-buffer-prefix))
	(save-excursion
	  (set-buffer buf)
	  (mew-insert-message
	   fld msg mew-cs-text-for-read mew-header-reasonable-size)
	  (mew-refile-decode-subject)))
      (while (null folders)
	(setq tmp (car (mew-refile-decide-folders buf msg nil)))
	(while tmp
	  (setq fld (car tmp))
	  (setq tmp (cdr tmp))
	  (unless (or (mew-folder-draftp fld)
		      (mew-folder-queuep fld))
	    (setq folders (cons fld folders)))))
      (if killbuf (mew-kill-buffer buf))
      (nreverse folders))))

-- 
白井秀行 (mailto:shirai at example.com)