Higepon’s blog - Mona OS and Mosh

defadvice楽しい

Emacs, Lisp, 勝手make

勝手 make で

(compile "make")

を連続で2回走らせると yes/no を聞かれてうれしくない現象に対して、compile.el に直接手を入れるという方法を先日紹介(d:id:higepon:20060911:1157988263)しました。

この方法はとても汚いやり方だと感じつつも

• compile.elに適切なhookが用意されてない
• compile.elに適切なカスタマイズ用変数が用意されていない

という理由から諦めていました。

ところがodzさんから defadvice という機能をコード例と共に紹介(id:odz:20060911:1157995745)頂き、目から鱗でした。

defadvice を利用すれば

• 任意の関数の呼び出し前・後に hookする
• 任意の関数の中身をまるごと書き換える
• 上記の hook を簡単に有効化・無効化する

などが可能になります。

例えば yes/no を尋ねる関数 yes-or-no-p が常に t を返すような advice を作成するには以下のように書きます。

この時点では定義しただけで有効にはなっていません。

(defadvice yes-or-no-p (around yes-or-no-p-always-yes)
  "Return always yes."
  (setq ad-return-value t))

ポイントは

• ad-return-value という特別な変数に t を入れて常に t が返るようにしていること
• class指定を around (包囲アドバイス)にして関数の中身を setq で置き換えている

の2点です。

2点目が分かりづらいので補足をすると、例えば around を after (呼出し後 hook)にした場合、戻り値は t となりますが元の yes-or-no-p の中身が直前に呼ばれてしまいます。

これだと、yes/no を尋ねられてどちらを選んでも t が返るという関数になってしまうというわけです。

定義した advice は

(ad-activate-regexp "yes-or-no-p-always-yes")
(ad-deactivate-regexp "yes-or-no-p-always-yes")

のように、有効化・無効化できます。

つまり (compile "make")を呼び出すまえに有効化し、実行が終わったら無効化することで、(compile "make")中のみ、yes-or-no-pが動作を変えることが可能なのです。（すごい！）

僕は Emacs Lisp がここまで柔軟な機能を備えているとは知らずとても感動しました。

そして自分の .emacs を見返すといたるところで defadvice が使われていてびっくりしました。

というわけで、既存の関数が細かい点で期待どおりの動作をしないときは defadvice を使うことも考慮した方が良さそうです。

最後に現時点での勝手 make のソースを貼りつけておきます。

defadvice も利用しているので参考になれば幸いです。

(defun mona-build-cleanup ()
  "Clean up add-hooks for mona-build.el."
  (remove-hook 'after-save-hook 'mona-build-auto-make)
  (setq compilation-finish-function nil))

;; we need clean up.
(mona-build-cleanup)

(defun mona-build-contrib-makefile-path (filename)
  "Return contrib/Makefile."
  (string-match "\\(.+contrib[^\/]*\\)" filename)
  (format "%s/Makefile" (match-string 0 filename)))


(defun mona-build-silent-compile (command)
  "Compile with minimum window height."
  (let ((save-height compilation-window-height))
    (setq compilation-window-height 1)
    (ad-activate-regexp "yes-or-no-p-always-yes")
    (compile command)
    (ad-deactivate-regexp "yes-or-no-p-always-yes")
    (setq compilation-window-height save-height)))

(defun mona-build-remove-newline (str)
  "Remove \n from string."
  (replace-regexp-in-string "\n" "" str))

(defun mona-build-top-make (buffer, result)
  "This function called by previous make of the application."
  (if (string-match "abnormally" result)
      (progn
        (setq compilation-finish-function nil)
        (message "%s result %s" (buffer-file-name) (mona-build-remove-newline result)))
    (progn
      (setq compilation-finish-function
            (lambda (b r)
              (message "mona.iso result %s" (mona-build-remove-newline r))))
      (message "%s result %s" (current-buffer) (mona-build-remove-newline result)))
      (save-current-buffer
        (progn
          (set-buffer (find-file-noselect (mona-build-contrib-makefile-path
                                           (expand-file-name (buffer-name (current-buffer))))))
          (mona-build-silent-compile "make")))))

(defun mona-build-parent-makefile-path ()
  "Path of ../Makefile."
  (expand-file-name "Makefile" ".."))

(defun mona-build-current-makefile-path ()
  "Path of Makefile."
  (expand-file-name "Makefile"))

(defun mona-build-auto-make ()
  "Run make for application and after that, run make for mona.iso."
  (let ((current-makefile-exist-p (file-exists-p (mona-build-current-makefile-path)))
        (parent-makefile-exist-p (file-exists-p (mona-build-parent-makefile-path))))
    (cond
     (current-makefile-exist-p (progn
                                 (setq compilation-finish-function 'mona-build-top-make)
                                 (mona-build-silent-compile "make install")))
     (parent-makefile-exist-p (save-current-buffer
                                 (setq compilation-finish-function 'mona-build-top-make)
                                 (set-buffer (find-file-noselect (mona-build-parent-makefile-path)))
                                 (mona-build-silent-compile "make install"))))))

(defadvice yes-or-no-p (around yes-or-no-p-always-yes)
  "Return always yes."
  (setq ad-return-value t))

(add-hook 'after-save-hook 'mona-build-auto-make)

ツイートする

Permalink | コメント(4) | トラックバック(0) | 19:41