replace-regexp に入力する手間を省く replace-multi-pairs

Emacs で M-x replace-string や M-x replace-regexp はテキスト編集では日常的に使います。
しかし、複雑な正規表現や、同一の検索置換を何度か実行していると一つ不満が出てきました。

検索文字列と置換文字列を毎回入力せねばならない。

ミニバッファの履歴を辿ることもできますが、検索文字列と置換文字列で履歴を共有していたりと微妙な面倒くささがあります。

よく使う検索文字列と置換文字列の組み合わせを保存しておいて、一発で呼び出したい。できれば複数の検索置換を一回で済ませたい。

そこで書いたものが
replace-multi-pairs

(defgroup replace-multi-pairs nil
  "Replace multiple pairs of strings."
  :group 'editing)

(defcustom replace-multi-pairs-alist
  '( ;; default pairs
    ("default"
     ("[ \t]+$" "" t))
    ;; Text to XML, HTML.
    ;; Similar to M-x sgml-quote
    ("html-quote"
     ("&"   "&")
     ("<"   "&lt;")
     (">"   "&gt;")
     ("'"   "&apos;")
     ("\""  "&quot;"))
    ;; XML, HTML to Text.
    ;; Similar to C-u M-x sgml-quote
    ("html-unquote"
     ("&lt;"        "<")
     ("&gt;"        ">")
     ("&apos;"      "'")
     ("&quot;"      "\"")
     ("&nbsp;"      " ")
     ("&amp;"       "&"))
    ;; <br />
    ("br"
     ("\n" "<br />\n"))
    ;; Flush blank lines.
    ;; Similar to M-x delete-blank-lines (C-x C-o)
    ("no-blank"
     ("^[ \t]*\n" "" t))
    ;; Delete spaces and tabs at the end of line.
    ;; Similar to M-x delete-trailing-whitespace
    ("no-trailing"
     ("[ \t]+$" "" t))
    ;; Delete indentations.
    ;; Same as C-u 0 M-x indent-region (C-M-\)
    ("no-indent"
     ("^[ \t]+" "" t))
    ;; Delete line breaks. Like M-x join-line
    ;;     )
    ;;   )
    ;; )
    ;; -->
    ;;     )))
    ("no-break"
     ("[ \t]*\n[ \t]*" "" t))
    ;; Replace consecutive spaces and tabs with just one space.
    ;; Similar to M-x just-one-space (M-SPC)
    ("one-space"
     ("[ \t]+" " " t))
    ;; Extract URLs and delete other lines. For HTML source, etc.
    ("url"
     ("^" " " t)
     ("\\([^h]\\)ttp\\(s?\\)://" "\\1http\\2://" t)
     ("\\([^ft]\\)tp\\(s?\\)://" "\\1http\\2://" t)
     ("h?[ft]tps?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+" "\n\\&\n " t)
     ("^hftp" " " t)
     ("^ .*$" "" t)
     ("^\n" "" t)
     ("'$" "" t))                       ; not correct. for HTML source
    ;; \ -> \\ and " -> \"
    ("quote-string"
     ("\\\\\\|\"" "\\\\\\&" t))
    ;; \" -> " and \\ -> \
    ("unquote-string"
     ("\\\"" "\"")
     ("\\\\" "\\"))
    ;; a "b" \c -> "a \"b\" \\c\n"
    ("quote-lines"
     ("\\\\\\|\"" "\\\\\\&" t)
     (".*" "\"\\&\\\\n\"" t))
    ;; "0001: "
    ;; "0002: "
    ;; "0003: "
    ("number-lines"
     ("^" "\\,(format \"%04d: \" (1+ \\#))" t))
    ;; M-: (regexp-quote "")
    ("regexp-quote"
     (".+" "\\,(regexp-quote \\&)" t))
    ;; 全角英数のみ半角に
    ;; C-u C-x japanese-hankaku-region では ー が - に変換される
    ("hankaku"
     ("\\cA" "\\,(japanese-hankaku \\& t)" t)))

  "Alist of pairs of search string and replacement.
Each element looks like:

\(KEY (SEARCH-STRING REPLACEMENT REGEXP-FLAG DELIMITED-FLAG) ...)

KEY is a string which is a name of pairs.

SEARCH-STRING and REPLACEMENT are strings as described in
`replace-string' and `replace-regexp'. REPLACEMENT may contain
`\\,' followed by a Lisp expression and some other letters
that `replace-regexp' accepts in interactive calls.

When REGEXP-FLAG is non-nil, SEARCH-STRING and REPLACEMENT
are treated as regexp.
DELIMITED-FLAG is as in `replace-string' and `replace-regexp'."
  :type '(alist :key-type (string :tag "Key")
                :value-type
                (repeat :tag "Pairs of search string and replacement"
                        (group
                         (string  :tag "Search string")
                         (string  :tag "Replacement")
                         (boolean :tag "Regexp flag")
                         (boolean :tag "Delimited flag"))))
  :group 'replace-multi-pairs)

(defcustom replace-multi-pairs-require-prefix nil
  "Non-nil means prompt for key with \\[universal-argument].
If nil, always prompt unless \\[universal-argument] is given.

Without prompt, the first element of `replace-multi-pairs-alist'
is used as key."
  :type 'boolean
  :group 'replace-multi-pairs)

(defvar replace-multi-pairs-history nil
  "History list for `replace-multi-pairs'.")

(defun replace-multi-pairs-count ()
  (let ((message (current-message)))
    (if (and message
             (string-match "^Replaced \\([0-9]+\\) " message))
        (string-to-number (match-string 1 message))
      0)))

(defun replace-multi-pairs-1 (beg end key)
  "Perform replacement starting from BEG to END using KEY.
Return the total number of replaced occurrences."
  (let ((limit (copy-marker (max beg end)))
        (count 0)
        (orig-push-mark (symbol-function 'push-mark))
        (orig-undo-boundary (symbol-function 'undo-boundary))
        (orig-deactivate-mark (symbol-function 'deactivate-mark)))
    (fset 'push-mark (symbol-function 'ignore))
    (fset 'undo-boundary (symbol-function 'ignore))
    (fset 'deactivate-mark (symbol-function 'ignore))
    (unwind-protect
        (dolist (args (cdr (assoc key replace-multi-pairs-alist)) count)
          (unless args
            (error "Bad key: %s" key))
          (perform-replace (nth 0 args)
                           (query-replace-compile-replacement
                            (nth 1 args) (nth 2 args))
                           nil (nth 2 args) (nth 3 args)
                           nil nil (min beg end) limit)
          (setq count (+ count (replace-multi-pairs-count))))
      (fset 'push-mark orig-push-mark)
      (fset 'undo-boundary orig-undo-boundary)
      (fset 'deactivate-mark orig-deactivate-mark))))

(defun replace-multi-pairs-read ()
  (let ((completion-ignore-case t)
        (default (or (car replace-multi-pairs-history)
                     (caar replace-multi-pairs-alist))))
    (completing-read
     (format "Which regexp? (default %s): " default)
     replace-multi-pairs-alist nil t nil
     'replace-multi-pairs-history default)))

(defun replace-multi-pairs (beg end &optional key)
  "Replace text between BEG and END using KEY.
KEY is one of keys of `replace-multi-pairs-alist', which defines
multiple pairs of search string and replacement.

In interactive calls, when the region is active, operate on the region;
otherwise operate from the current point to the end of the buffer.

Prompt for KEY depending on the prefix argument and the value of
`replace-multi-pairs-require-prefix'.
If KEY is not specified, the first element of
`replace-multi-pairs-alist' is used."
  (interactive
   (let (beg end key)
     (barf-if-buffer-read-only)
     (when (or (and replace-multi-pairs-require-prefix
                    current-prefix-arg)
               (and (null replace-multi-pairs-require-prefix)
                    (null current-prefix-arg)))
       (setq key (replace-multi-pairs-read)))
     (if (and transient-mark-mode mark-active)
         (setq beg (region-beginning)
               end (region-end))
       (setq beg (point)
             end (point-max)))
     (list beg end key)))
  (let (count)
    (setq key (or key (caar replace-multi-pairs-alist)))
    (push-mark)
    (when (and transient-mark-mode mark-active)
      (deactivate-mark))
    (setq count (replace-multi-pairs-1 beg end key))
    (message "Replaced %d occurrence%s in total (%s)"
             count (if (= 1 count) "" "s") key)))

;; (global-set-key "\C-cr" 'replace-multi-pairs)

動作確認：GNU Emacs 22

＜使い方＞
キーに設定した文字列で置換を行うには、範囲選択して
M-x replace-multi-pairs RET キー RET

キーはタブで補完が効き、変数 replace-multi-pairs-alist で設定します。
replace-multi-pairs-alist は M-x customize の Editing からでも編集できます。
replace-multi-pairs-alist を直接編集する場合、各要素は以下のような構成になります。

("キー"
 ("検索文字列1" "置換文字列1" 正規表現フラグ ワード区切りフラグ)
 ("検索文字列2" "置換文字列2" 正規表現フラグ ワード区切りフラグ)
 ...)

・キーは任意の文字列です。
・検索文字列と置換文字列は replace-regexp, replace-string で使う書式がそのまま使えます。
・正規表現フラグは non-nil ならば、 replace-regexp と同じ動作。nil または省略されたならば、 replace-string。
・ワード区切りフラグは non-nil ならば C-u 付きで replace-regexp, replace-string を実行した時と同じ挙動に。

default と html-quote を設定した例。

(setq replace-multi-pairs-alist
      '(("default"
         ("[ \t]+$" "" t))
        ("html-quote"
         ("&"   "&")
         ("<"   "&lt;")
         (">"   "&gt;")
         ("'"   "&apos;")
         ("\""  "&quot;"))))

default は正規表現で行末のスペースとタブを削除。
M-x replace-multi-pairs RET default RET
html-quote は & 等をHTMLタグに一括置換。
M-x replace-multi-pairs RET html-quote RET

replace-multi-pairs-alist の初期値として色々設定してあるので、参考程度にはなるかと思います。






以下余談。

replace-multi-pairs では検索置換する関数として perform-replace を使っています。
perform-replace は query-replace, query-replace-regex, replace-string, replace-regexp の下請け関数です。
ヘルプにはこう書いてあります。

Subroutine of `query-replace'.  Its complexity handles interactive queries.
Don't use this in your own program unless you want to query and set the mark
just as `query-replace' does.  Instead, write a simple loop like this:

  (while (re-search-forward "foo[ \t]+bar" nil t)
    (replace-match "foobar" nil nil))

which will run faster and probably do exactly what you want.  Please
see the documentation of `replace-match' to find out how to simulate
`case-replace'.

要約すると、自作のプログラムからはこの関数を使わずに、 re-search-forward のループを書きなさい、ということ。
しかし、それを承知した上で replace-multi-pairs では perform-replace を使ってます。
理由は replace-regexp の検索文字列と置換文字列の書式がそのまま使えるからです。

例えば行末に foobar と付け加えるためこのようなコマンドを使います。
M-x replace-regexp RET $ RET foobar RET

それと同じことをしようとして、以下のようなコードを書くと無限ループになります。

(while (re-search-forward "$" nil t)
  (replace-match "foobar" nil nil))

同様に、全角英数を半角英数に変換する場合、 \, を使った Lisp の式を書けますが、
M-x replace-regexp RET \cA RET \,(japanese-hankaku \& t) RET

それと同じことをしようとしても、意図した通りには動きません。

(while (re-search-forward "\\cA" nil t)
  (replace-match "\\,(japanese-hankaku \\& t)" nil nil))

ただ perform-replace を使う注意点として、その関数から呼ばれる push-mark, undo-boundary, deactivate-mark の3つの関数は、実行されると不自然な挙動になるので、一時的に ignore に置き換えています。