LISPUSER

Windows 上の Emacs では多彩な色が使えるので， Dired のバッファで拡張子 に応じた色をつける（端末ベースの Emacs でも少しだけ再現できます）．

標準の dired では通常のファイルには色がついていません．

そこで，拡張子に応じた色をつけてみます．まず，設定用関数を用意します． そして，例のように拡張子とフェイスを指定すると色がつきます．この例では .orgi や .el に色をつけています．

(defvar *original-dired-font-lock-keywords* dired-font-lock-keywords)
(defun dired-highlight-by-extensions (highlight-list)
  "highlight-list accept list of (regexp [regexp] ... face)."
  (let ((lst nil))
    (dolist (highlight highlight-list)
      (push `(,(concat "\\.\\(" (regexp-opt (butlast highlight)) "\\)$")
              (".+" (dired-move-to-filename)
               nil (0 ,(car (last highlight)))))
            lst))
    (setq dired-font-lock-keywords
          (append *original-dired-font-lock-keywords* lst))))

(dired-highlight-by-extensions
  '(("txt" font-lock-variable-name-face)
    ("lisp" "el" "pl" "c" "h" "cc" font-lock-constant-face)))

(defun directory-walker (fn dir)
  (dolist (file (directory-files dir t nil))
    (cond ((and (file-directory-p file) (string-match "\\.\\.?$" file)))
          ((file-directory-p file)
           (directory-walker fn file))
          ((file-regular-p file)
           (funcall fn file))
          (t))))

(defun take-around ()
  (let ((lst nil)
        (n 3))
    (save-excursion
      (ignore-errors (previous-line))
      (while (> n 0)
        (push (cons (line-number-at-pos) (buffer-substring-no-properties (point-at-bol) (point-at-eol))) lst)
        (ignore-errors (next-line))
        (if (= (point) (point-max))
            (setq n 0)
          (decf n))))
    (apply #'concat (nreverse (mapcar #'(lambda (s) (concat (format "%5d: %s\n" (car s) (cdr s)))) lst)))))

(defun file-convert-to-utf8 (file)
  (find-file file)
  (set-buffer-file-coding-system 'utf-8-dos t)
  (write-file file)
  (kill-buffer (current-buffer)))

(defun howm-convert-to-utf8 ()
  (interactive)
  (directory-walker #'file-convert-to-utf8 howm-directory))

(defvar *defclass-list* nil)
(defun scan-defclass-lines (file)
  (when (string= (file-name-extension file) "lisp")
    (with-temp-buffer
      (insert-file-contents file)
      (goto-char (point-min))
      (while (re-search-forward "defclass" nil t)
        (push (list file (line-number-at-pos) (take-around))
              *defclass-list*)))))

(defun search-defclass-lines ()
  (interactive)
  (setq *defclass-list* nil)
  (directory-walker #'scan-defclass-lines "~/lisp")
  ;; display results
  (switch-to-buffer "*output*")
  (erase-buffer)
  (dolist (e (nreverse *defclass-list*))
    (let ((filename (car e))
          (line     (cadr e))
          (text     (caddr e)))
      (insert (format "%s:%s:\n%s" filename line text)))))

(defmacro with-force-override (&rest form)
  (destructuring-bind ((file &optional mode) &rest body)
      form
    (let (($mode (gensym "mode"))
          (mode  (or mode "600")))
      `(let ((,$mode (file-modes ,file))) ; モードを保存
         (unwind-protect
           (progn
             (set-file-modes ,file (string-to-int ,mode 8)) ; 書き込み可能なモードへ
             ,@body)
           (set-file-modes ,file ,$mode)))))) ; 保存しておいたモードに戻す

(defun svn-override (file)
  (let ((from "/repos/")
        (to   "/"))
    (when (string-match "\\.svn/entries$" file)
      (with-force-override (file)
        (find-file file) ; ファイルを開く
        (replace-regexp from to nil (point-min) (point-max)) ; 置換する
        (when (buffer-modified-p)
          (save-buffer))  ; 変更があったら保存
        (kill-buffer (current-buffer)))))) ; バッファを消す

(defun change-svn-repos ()
  (interactive)
  (directory-walker #'svn-override "./"))