2008-09-09

※以下は古い情報です。最新の情報は 2008-10-01 - プログラム番長のヲボエガキ

mvc.el を自分仕様にカスタマイズ。

after-save-hookの挙動がおかしかったので修正
windows.elを使って、frameのpush-pop
同じソースをsubversion と mercurial で管理しているので、明示的に使い分けできるようにコマンド追加 (これが今回のメイン)

mercurialとsubversionのダブル管理は意外と便利。
公共のリポジトリにコミットするのはどうかと思うけど、安全地帯は確保したいなんて時に効果を発揮する。
因みに、自分ローカルは mercurial管理。
プロジェクトは subversion管理。

追記 2008/09/26

自分用の mercurial リポジトリにコミットしようとして、プロジェクト用のsvnにコミットするというポカをやってしまったので、対策。
svnの時にフッタの色を変える処理を入れてみた。
　→smc毎にテーマが決められると面白いかも。

(defface mvc-face-status-footer-for-svn
  '((((type x w32 mac) (class color)) (:foreground "black" :background "#FA6CC847FFFF")))
  "status footer for svn"
  :group 'mvc-faces)

;; 上書き
(defun mvc-insert-with-face (string face)
  (if mvc-default-use-color
      (let ((start (point)))
	(insert string)
        (if (and (equal face 'mvc-face-status-footer)
		 (equal mvc-my-scm 'subversion))
            (setq face 'mvc-face-status-footer-for-svn))
	(set-text-properties start
			     (+ start (length string))
			     (list 'face face)))
    (insert string)))

設定

(require 'mvc)

(custom-set-variables
'(mvc-default-status-display-unmodified nil)
'(mvc-default-commit-message '((mercurial . "")
                               (git . "")
                               (bazaar . "")
                               (subversion . "")
                               (cvs . ""))))

(define-key mvc-log-mode-map "q" 'bury-buffer)


;;
;; 新しいバージョンの mvc-after-save-hookがバグってる(?)ので
;; 旧バージョンのものに置き換え
(defun mvc-after-save-hook ()
  (when mvc-status-buffer-list
    (mapcar #'(lambda (a)
		(when (string-match "^\\*mvc-[^-]+-status\\*" (buffer-name a))
		  (let ((check-file-name buffer-file-name))
		    (with-current-buffer a
		      (when (and (string= (mvc-get-buffer-name 'status) (buffer-name a))
				 (gethash check-file-name mvc-local-after-save-hook-hash))
			(puthash check-file-name "m" mvc-local-after-save-hook-hash)
			(mvc-status-draw-with-save-load-point))))))
	    (buffer-list))))


(defvar mvc-my-scm 'mercurial)

;; scm を mercurialに強制切り替え
(defun mvc-change-to-mercurial ()
  (interactive)
  (setq mvc-my-scm 'mercurial))

;; scm を subversionに強制切り替え
(defun mvc-change-to-svn ()
  (interactive)
  (setq mvc-my-scm 'subversion))

;; scmを自動認識に戻す
(defun mvc-clear-scm ()
  (interactive)
  (setq mvc-my-scm nil))

;; scmタイプをコントロールするための乗っ取り
(unless (fboundp 'mvc-get-current-program-org)
  (fset 'mvc-get-current-program-org (symbol-function 'mvc-get-current-program))

  (defun mvc-get-current-program ()
    (if mvc-my-scm
        (puthash (expand-file-name default-directory) mvc-my-scm mvc-program-cache-hash)
      (mvc-get-current-program-org))))


;; windows.el で frameの状態を記憶
;;   →win-load-window-buffer で戻る
(unless (fboundp 'mvc-status-org)
  (fset 'mvc-status-org (symbol-function 'mvc-status))
  
  (defun mvc-status ()
    (interactive)
    (win-update-window-buffer) ; windows.el
    (mvc-status-org)
    ))


;;  status バッファ "q" で frameの状態を戻す
(define-key mvc-status-mode-map "q"
  '(lambda ()
     (interactive)
     
     ;; subversionモードになっている時は、mercurialに戻す
     ;;  →mercurial をメインで使っているため、混乱防止
     (if (equal mvc-my-scm 'subversion)
         (mvc-change-to-mercurial))
     
     (bury-buffer)
     (win-load-window-buffer)))


;; "o" で find-file-other-window
(defun mvc-status-mode-find-file-other-window ()
  "find-file"
  (interactive)

  (let ((cursor-filename (mvc-status-get-current-line-filename)))
    (if cursor-filename
        (find-file-other-window cursor-filename)
      (message "unknown line!"))))

(define-key mvc-status-mode-map "o" 'mvc-status-mode-find-file-other-window)


(defface mvc-face-status-footer-for-svn
  '((((type x w32 mac) (class color)) (:foreground "black" :background "#FA6CC847FFFF")))
  "status footer for svn"
  :group 'mvc-faces)

;; 上書き
(defun mvc-insert-with-face (string face)
  (if mvc-default-use-color
      (let ((start (point)))
	(insert string)
        (if (and (equal face 'mvc-face-status-footer)
		 (equal mvc-my-scm 'subversion))
            (setq face 'mvc-face-status-footer-for-svn))
	(set-text-properties start
			     (+ start (length string))
			     (list 'face face)))
    (insert string)))