[mew-dist 20996] 全文引用対策

[KOIE Hidetaka ( 鯉江英隆 )]

仕事のメイルで全文引用してくる人が多いので
なんとかするプログラムを書きました。

サマリバッファでHをたたくと、すっきりします。
メッセージバッファでHをたたくと、もとにもどります。

> うだうだ
> うだうだ

みじかい引用には手をつけません

> うだうだ
> うだうだ
> うだうだ
> うだうだ
> うだうだ
> うだうだ
> うだうだ
> うだうだ
> うだうだ
> うだうだ
> うだうだ

--
KOIE Hidetaka 鯉江英隆 <hide at example.com>
-------------- next part --------------
;; clearup.el -- 全文引用をすっきりさせる

;; 使用法:
;; バッファで
;; M-x clearup-do-buffer
;; これで5行を越える引用がすっきりする。
;;
;; -snip- がふくまれている引用のところで `H' を押すと
;; 見えなくなっていた部分が復元する。
;;
;; 再度 `H' を押すとまた見えなくなる。
;;
;; おしまいは
;; M-x clearup-undo-buffer
;;
;; mewから:
;; サマリバッファで `H' を押すとすっきりする。
;; `G' を押すともとにもどる。
;; メッセージバッファで引用部分で `H' を押すと復元する。

(defvar clearup-snip-string
  "- - - s n i p - - - press H key to restore - - -\n")

(defun clearup-undo ()
  "この不可視になっている引用ブロックを見えるようにする"
  (interactive)
  (mapcar (lambda (ov)
            (when (and (overlay-get ov 'clearup)
                       (not (overlay-get ov 'invisible)))
              (define-key (overlay-get ov 'local-map) "H" 'clearup-do)
              (mapcar (lambda (ov2)
                        (when (and (overlay-get ov2 'clearup)
                                   (overlay-get ov2 'invisible))
                          (delete-overlay ov2)))
                      (overlays-in (overlay-start ov) (overlay-end ov)))))
          (overlays-at (point))))

(defun clearup-do1 (ov)
  "この引用ブロックを不可視にする"
  (let* ((beg (overlay-start ov))
        (end (overlay-end ov))
        (beg2 (save-excursion (goto-char beg)
                               (forward-line +1) (point)))
         (end2 (save-excursion (goto-char end)
                               (forward-line -3) (point)))
         (ov2 (make-overlay beg2 end2)))
        (overlay-put ov2 'clearup t)
        (overlay-put ov2 'evaporate t)
        (overlay-put ov2 'intangible t)
        (overlay-put ov2 'invisible t)
        (overlay-put ov2 'after-string clearup-snip-string)))

(defun clearup-do ()
  "この引用ブロックを不可視にする
ただし一度clearup-do-bufferを実行しておくのが前提"
  (interactive)
  (mapcar (lambda (ov)
            (when (and (overlay-get ov 'clearup)
                       (not (overlay-get ov 'invisible)))
              (define-key (overlay-get ov 'local-map) "H" 'clearup-undo)
              (clearup-do1 ov)))
          (overlays-at (point))))

(defun clearup-do-buffer-pass1 ()
  "引用ブロックの抽出"
  (let ((re mew-highlight-body-regex-cite))
    (while (re-search-forward re nil t)
      (beginning-of-line)
      (let ((brandnew t)
            (beg (point))
            (end (save-excursion (end-of-line) (1+ (point)))))
        (mapcar (lambda (ov)
                  (when (overlay-get ov 'clearup)
                    (move-overlay ov (overlay-start ov) end)
                    (setq brandnew nil)))
                (overlays-at (1- (point))))
        (when brandnew
          (let ((ov (make-overlay beg end))
                (map (make-sparse-keymap)))
            (set-keymap-parent map (current-local-map))
            (define-key map "H" 'clearup-undo)
            (overlay-put ov 'clearup t)
            (overlay-put ov 'evaporate t)
            (overlay-put ov 'local-map map)
            (overlay-put ov 'mouse-face 'highlight)))
        (goto-char end)))))
      
(defun clearup-do-buffer-pass2 ()
  "5行を越える引用ブロックを不可視にする
clearup-do-buffer-pass1()で検出した引用で5行以下のは忘れる"
  (mapcar (lambda (ov)
              (when (overlay-get ov 'clearup)
                (let ((beg (overlay-start ov))
                      (end (overlay-end ov)))
                  (if (> (count-lines beg end) 5)
                      (clearup-do1 ov)
                    (delete-overlay ov)))))
            (overlays-in (point-min) (point-max))))

(defun clearup-do-buffer ()
  "バッファ中の引用で5行を越えるものを不可視にする"
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (clearup-do-buffer-pass1))
  (clearup-do-buffer-pass2))

(defun clearup-undo-buffer ()
  "バッファ中の引用の不可視化をやめる"
  (interactive)
  (progn
    (mapcar (lambda (ov)
              (when (overlay-get ov 'clearup)
                (delete-overlay ov)))
            (overlays-in (point-min) (point-max)))))

;;mewからの利用
(when (boundp 'mew-version)
  (defun mew-clearup-do ()
    (interactive)
    (let ((buf (get-buffer (mew-buffer-message))))
      (when buf
        (set-buffer buf)
        (clearup-do-buffer))))
  (defun mew-clearup-undo ()
    (interactive)
    (let ((buf (get-buffer (mew-buffer-message))))
      (when buf
        (set-buffer buf)
        (clearup-undo-buffer))))
  (define-key mew-summary-mode-map "H" 'mew-clearup-do)
  (define-key mew-summary-mode-map "G" 'mew-clearup-undo)
  (define-key mew-message-mode-map "H" 'mew-clearup-do)
  (define-key mew-message-mode-map "G" 'mew-clearup-undo))