25. ディレクトリ表示 ― dired など (2009/03/30)

(load "dired-x")

(autoload 'find-dired-lisp
  "find-dired-lisp" "findr" t nil)
(autoload 'find-grep-dired-lisp
  "find-dired-lisp" "findr" t nil)

;; スペースでマークする (FD like)
(define-key dired-mode-map " " 'dired-toggle-mark)
(defun dired-toggle-mark (arg)
  "Toggle the current (or next ARG) files."
  ;; S.Namba Sat Aug 10 12:20:36 1996
  (interactive "P")
  (let ((dired-marker-char
         (if (save-excursion (beginning-of-line)
                             (looking-at " "))
             dired-marker-char ?\040)))
    (dired-mark arg)
    (dired-previous-line 1)))

(require 'dired-x)

;; Cygwin 利用時
(setq dired-guess-shell-gnutar "tar")
;; 以下，各ファイル別の設定
(setq dired-guess-shell-alist-user
      '(("\\.tar\\.gz\\'"  "tar ztvf")
        ("\\.taz\\'" "tar ztvf")
        ("\\.tar\\.bz2\\'" "tar Itvf")
        ("\\.zip\\'" "unzip -l")
        ("\\.\\(g\\|\\) z\\'" "zcat")
        ("\\.\\(jpg\\|JPG\\|gif\\|GIF\\)\\'"
         (if (eq system-type 'windows-nt)
             "fiber" "xv"))
        ("\\.ps\\'"
         (if (eq system-type 'windows-nt)
             "fiber" "ghostview"))
        ))

;;; dired を使って、一気にファイルの coding system (漢字) を変換する
(require 'dired-aux)
(add-hook 'dired-mode-hook
          (lambda ()
            (define-key (current-local-map) "T"
              'dired-do-convert-coding-system)))

(defvar dired-default-file-coding-system nil
  "*Default coding system for converting file (s).")

(defvar dired-file-coding-system 'no-conversion)

(defun dired-convert-coding-system ()
  (let ((file (dired-get-filename))
        (coding-system-for-write dired-file-coding-system)
        failure)
    (condition-case err
        (with-temp-buffer
          (insert-file file)
          (write-region (point-min) (point-max) file))
      (error (setq failure err)))
    (if (not failure)
        nil
      (dired-log "convert coding system error for %s:\n%s\n" file failure)
      (dired-make-relative file))))

(defun dired-do-convert-coding-system (coding-system &optional arg)
  "Convert file (s) in specified coding system."
  (interactive
   (list (let ((default (or dired-default-file-coding-system
                            buffer-file-coding-system)))
           (read-coding-system
            (format "Coding system for converting file (s) (default, %s): "
                    default)
            default))
         current-prefix-arg))
  (check-coding-system coding-system)
  (setq dired-file-coding-system coding-system)
  (dired-map-over-marks-check
   (function dired-convert-coding-system) arg 'convert-coding-system t))

(setq dired-default-file-coding-system 'euc-jp-unix)

(setq dired-recursive-copies 'always)
(setq dired-recursive-deletes 'always)

(require 'dired-aux)
(load "dired-dia")

(defun dired-my-advertised-find-file ()
  (interactive)
  (let ((kill-target (current-buffer))
        (check-file (dired-get-filename)))
    (funcall 'dired-advertised-find-file)
    (if (file-directory-p check-file)
        (kill-buffer kill-target))))

(defun dired-my-up-directory (&optional other-window)
  "Run dired on parent directory of current directory.
Find the parent directory either in this buffer or another buffer.
Creates a buffer if necessary."
  (interactive "P")
  (let* ((dir (dired-current-directory))
         (up (file-name-directory (directory-file-name dir))))
    (or (dired-goto-file (directory-file-name dir))
        ;; Only try dired-goto-subdir if buffer has more than one dir.
        (and (cdr dired-subdir-alist)
             (dired-goto-subdir up))
        (progn
          (if other-window
              (dired-other-window up)
            (progn
              (kill-buffer (current-buffer))
              (dired up))
          (dired-goto-file dir))))))

(define-key dired-mode-map "\C-m" 'dired-my-advertised-find-file)
(define-key dired-mode-map "^" 'dired-my-up-directory)

(defvar my-dired-before-buffer nil)
(defadvice dired-advertised-find-file
  (before kill-dired-buffer activate)
  (setq my-dired-before-buffer (current-buffer)))

(defadvice dired-advertised-find-file
  (after kill-dired-buffer-after activate)
  (if (eq major-mode 'dired-mode)
      (kill-buffer my-dired-before-buffer)))

(defadvice dired-up-directory
  (before kill-up-dired-buffer activate)
  (setq my-dired-before-buffer (current-buffer)))

(defadvice dired-up-directory
  (after kill-up-dired-buffer-after activate)
  (if (eq major-mode 'dired-mode)
      (kill-buffer my-dired-before-buffer)))

(autoload 'netdir "mmemo-drive" "My computer" t)
(autoload 'netcomp "mmemo-drive" "My network" t)

(defadvice dired-up-directory
  (around list-drive activate)
  (if (string-match "^[a-zA-Z]:[/]*$" default-directory)
      (netdir)
    ad-do-it))

(add-hook 'dired-mode-hook
          (lambda ()
            (define-key dired-mode-map
              "z" 'dired-fiber-find)))

(defun dired-fiber-find ()
  (interactive)
  (let ((file (dired-get-filename)))
    (if (file-directory-p file)
        (start-process "explorer" "diredfiber" "explorer.exe"
                       (unix-to-dos-filename file))
      (start-process "fiber" "diredfiber" "fiber.exe" file))))

  (let ((file (dired-get-filename)))
    (if (file-directory-p file)
        (if arg
            (start-process "explorer" "filer" "E:/soft/file/Dyna/DYNA.EXE"
                           (unix-to-dos-filename file))
          (start-process "explorer" "diredfiber" "explorer.exe"
                         (unix-to-dos-filename file))
          )
      (if arg
          (start-process "explorer" "diredfiber" "explorer.exe"
                         (unix-to-dos-filename (directory-file-name
                                                dired-directory)))
        (start-process "fiber" "diredfiber" "fiber.exe" file)
        )
      )))

;;--------------------------------------------------------
;;; Dired で Windows に関連付けられたファイルを起動する。
;;;http://uenox.infoseek.livedoor.com/meadow/
;;--------------------------------------------------------
(defun uenox-dired-winstart ()
  "Type '\\[uenox-dired-winstart]': win-start the current line's file."
  (interactive)
  (if (eq major-mode 'dired-mode)
      (let ((fname (dired-get-filename)))
        (w32-shell-execute "open" fname)
        (message "win-started %s" fname))))
;;; dired のキー割り当て追加
(add-hook 'dired-mode-hook
          (lambda ()
            (define-key dired-mode-map "z" 'uenox-dired-winstart))) ;;; 関連付け

;;----------------------------------------
;; Win32: dierd からエクスプローラを開く
;;----------------------------------------
;; dired で "E" で開く。
(add-hook 'dired-mode-hook
          (lambda ()
            (local-set-key "E" 'dired-exec-explorer)))
;;
(defun dired-exec-explorer ()
  "In dired, execute Explorer"
  (interactive)
  (explorer (dired-current-directory)))
;;
;; M-x explorer で現在のカレントディレクトリをもとにエクスプローラ
;; を立ち上げる設定。
;;
(define-process-argument-editing "/explorer\\.exe$"
  (lambda (x)
    (general-process-argument-editing-function x nil nil nil)))
(defun explorer (&optional dir)
  (interactive)
  (setq dir (expand-file-name (or dir default-directory)))
  (if (or (not (file-exists-p dir))
          (and (file-exists-p dir)
               (not (file-directory-p dir))))
      (message "%s can't open." dir)
    (setq dir (unix-to-dos-filename dir))
    (let ((w32-start-process-show-window t))
      (apply (function start-process)
             "explorer" nil "explorer.exe" (list (concat "/e,/root," dir))))))

(require 'w32-symlinks)

(setq w32-symlinks-make-using 'wsh)
(setq w32-symlinks-ln-script
      (expand-file-name "~/w32-symlinks-ln-s.js"))

(defadvice w32-symlinks-make-using-wsh
  (around make-shortcut activate)
  (w32-symlinks-check-ln-script)
  (if (not (string= (substring newname -4) ".lnk"))
      (setq newname (concat newname ".lnk")))
  (start-process "makelink" "makelink" w32-symlinks-ln-script
                 (unix-to-dos-filename (expand-file-name file))
                 (unix-to-dos-filename (expand-file-name newname)))
  )

(defun dired-make-symbolic-link (newname)
  (interactive "\FName for link to : \n")
  (if (string= "" (file-name-nondirectory newname))
      (error "Input filename for link"))
  (if (not (string= (substring newname -4) ".lnk"))
      (setq newname (concat newname ".lnk")))
  (let ((file (dired-get-filename)))
    (make-symbolic-link file newname)))

(add-hook 'dired-mode-hook
          '(lambda ()
             (define-key dired-mode-map "S" (function dired-make-symbolic-link))
             ))

(defadvice minibuffer-complete
  (before expand-symlinks activate)
  (let ((file (expand-file-name
               (buffer-substring-no-properties
                (line-beginning-position)
                (line-end-position)))))
    (when (string-match ".lnk$" file)
      (delete-region
       (line-beginning-position)
       (line-end-position))
      (if (file-directory-p
           (ls-lisp-parse-symlink file))
          (insert
           (concat
            (ls-lisp-parse-symlink file) "/"))
        (insert (ls-lisp-parse-symlink file))))))

(defun dired-do-tar-zvtf (arg)
  "Only one file line can be processed. If ARG, execute vzxf"
  (interactive "P")
  (let ((files (dired-get-marked-files t current-prefix-arg)))
    (if arg
        (dired-do-shell-command "tar zvxf * &" nil files)
      (dired-do-shell-command "tar zvtf * &" nil files))))

(defun dired-do-lha-v (arg)
  "Only one file line can be processed. If ARG, execute lha x"
  (interactive "P")
  (let ((files (dired-get-marked-files t current-prefix-arg)))
    (if arg
        (dired-do-shell-command "lha x * &" nil files)
      (dired-do-shell-command "lha v * &" nil files))))

(defun dired-do-mandoc (arg)
  "man source is formatted with col -xbf. If ARG, executes without col -xbf."
  (interactive "P")
  (let ((files (dired-get-marked-files t current-prefix-arg)))
    (if arg
        (dired-do-shell-command "groff -Tnippon -mandoc * &" nil files)
      (dired-do-shell-command "groff -Tnippon -mandoc * | col -xbf &" nil files))))

(define-key dired-mode-map "t" 'dired-do-tar-zvtf)
(define-key dired-mode-map "\eT" 'dired-do-lha-v)

(defun dired-do-tar-zvtf (arg)
  "Only one file line can be processed. If ARG, execute vzxf"
  (interactive "P")
  (let ((files (dired-get-marked-files t current-prefix-arg)))
    (if arg
        (dired-do-shell-command
         "for file in *; do echo $file;tar zvxf $file; done"
         nil files)
      (dired-do-shell-command
       "for file in *; do echo $file; tar zvtf $file; done"
       nil files))))

(defvar my-ex-isearch-next      "\C-r")
(defvar my-ex-isearch-prev      "\C-e")
(defvar my-ex-isearch-backspace "\C-h")
(defvar my-ex-isearch-return    "\C-g")
(defun my-ex-isearch (REGEX1 REGEX2 FUNC1 FUNC2 RPT)
  (interactive)
  (let ((input last-command-char)
        (inhibit-quit t)
        (oldpoint (point)) regx str)
    (save-match-data
      (catch 'END
        (while t
          (funcall FUNC1)
          (cond
           ;; character
           ((and (integerp input) (>= input ?!) (<= input ?~)
                 (not (and (>= input ?A) (<= input ?Z))))
            (setq str (concat str (char-to-string input)))
            (setq regx (concat REGEX1 str REGEX2))
            (re-search-forward regx nil t nil))
           ;; backspace
           ((and (integerp input)
                 (or (eq 'backspace input)
                     (= input (string-to-char my-ex-isearch-backspace))))
            (setq str (if (eq 0 (length str)) str (substring str 0 -1)))
            (setq regx (concat REGEX1 str REGEX2))
            (goto-char oldpoint)
            (re-search-forward regx nil t nil))
           ;; next
           ((and (integerp input)
                 (= input (string-to-char my-ex-isearch-next)))
            (re-search-forward regx nil t RPT))
           ;; previous
           ((and (integerp input)
                 (= input (string-to-char my-ex-isearch-prev)))
            (re-search-backward regx nil t nil))
           ;; return
           ((and (integerp input)
                 (= input (string-to-char my-ex-isearch-return)))
            (goto-char oldpoint)
            (message "return")
            (throw 'END nil))
           ;; other command
           (t
            (setq unread-command-events
                  (append (list input) unread-command-events))
            (throw 'END nil)))
          (funcall FUNC2)
          (highline-highlight-current-line)
          (message str)
          (setq input (read-event)))))))
(defun my-dired-isearch()
  (interactive)
  (my-ex-isearch "[0-9] " "[^ \n]+$" (lambda() (backward-char 3))
                 'dired-move-to-filename 2))
(defun my-dired-isearch-define-key (str)
  (let ((i 0))
    (while (< i (length str))
      (define-key dired-mode-map (substring str i (1+ i)) 'my-dired-isearch)
      (setq i (1+ i)))))
(add-hook 'dired-mode-hook
          '(lambda ()
             (my-dired-isearch-define-key
              "abcdefghijklmnopqrstuvwxyz_.-+~#")
             ))

(load "my-dired-mode")

(defun dired-ps-print-files ()
  (interactive)
  (let ((files-to-print (dired-get-marked-files)))
    (while (setq file (car files-to-print))
      (setq files-to-print (cdr files-to-print))
      (find-file file)
      (ps-print-buffer-with-faces)
      (kill-buffer nil))))

      (ps-print-buffer-with-faces)

(defface face-file-edited-today
  '((((class color)
      (background dark))
     (:foreground "GreenYellow"))
    (((class color)
      (background light))
     (:foreground "magenta"))
    (t
     ())) nil)
(defvar face-file-edited-today
  'face-file-edited-today)
(defun my-dired-today-search (arg)
  "Fontlock search function for dired."
  (search-forward-regexp
   (concat "\\(" (format-time-string
                  "%b %e" (current-time))
           "\\|"(format-time-string
                 "%m-%d" (current-time))
           "\\)"
           " [0-9]....") arg t))
(font-lock-add-keywords
 major-mode
 (list
  '(my-dired-today-search . face-file-edited-today)
  ))

(defface face-file-edited-today
  '((((class color)
      (background dark))
     (:foreground "GreenYellow"))
    (((class color)
      (background light))
     (:foreground "magenta"))
    (t
     ())) nil)
(defface face-file-edited-this-week
  '((((class color)
      (background dark))
     (:foreground "LimeGreen"))
    (((class color)
      (background light))
     (:foreground "violet red"))
    (t
     ())) nil)
(defface face-file-edited-last-week
  '((((class color)
      (background dark))
     (:foreground "saddle brown"))
    (((class color)
      (background light))
     (:foreground "maroon"))
    (t
     ())) nil)
(defvar face-file-edited-today
  'face-file-edited-today)
(defvar face-file-edited-this-week
  'face-file-edited-this-week)
(defvar face-file-edited-last-week
  'face-file-edited-last-week)
(defun my-dired-today-search (arg)
  "Fontlock search function for dired."
  (search-forward-regexp
   (concat "\\(" (format-time-string "%b %e" (current-time))
           "\\|"(format-time-string "%m-%d" (current-time))
           "\\)"
           " [0-9]....") arg t))
(defun my-dired-date (time)
  "Fontlock search function for dired."
  (let ((now (current-time))
        (days (* -1 time))
        dateh datel daysec daysh daysl dir
        (offset 0))
    (setq daysec (* -1.0 days 60 60 24))
    (setq daysh (floor (/ daysec 65536.0)))
    (setq daysl (round (- daysec (* daysh 65536.0))))
    (setq dateh (- (nth 0 now) daysh))
    (setq datel (- (nth 1 now) (* offset 3600) daysl))
    (if (< datel 0)
        (progn
          (setq datel (+ datel 65536))
          (setq dateh (- dateh 1))))
    ;;(floor (/ offset 24))))))
    (if (< dateh 0)
        (setq dateh 0))
    ;;(insert (concat (int-to-string dateh) ":"))
    (list dateh datel)))
(defun my-dired-this-week-search (arg)
  "Fontlock search function for dired."
  (let ((youbi
         (string-to-int
          (format-time-string "%w" (current-time))))
        this-week-start this-week-end day ;;regexp
        (flg nil))
    (setq youbi (+ youbi 1))
    (setq regexp
          (concat "\\("))
    (while (not (= youbi 0))
      (setq regexp
            (concat
             regexp
             (if flg
                 "\\|")
             (format-time-string
              "%b %e"
              (my-dired-date youbi))
             "\\|"
             (format-time-string
              "%m-%d"
              (my-dired-date youbi))
             ))
      ;;(insert (concat (int-to-string youbi) "\n"))
      (setq flg t)
      (setq youbi (- youbi 1))))
  (setq regexp
        (concat regexp "\\)"))
  (search-forward-regexp
   (concat regexp " [0-9]....") arg t))
(defun my-dired-last-week-search (arg)
  "Fontlock search function for dired."
  (let ((youbi
         (string-to-int
          (format-time-string "%w" (current-time))))
        this-week-start this-week-end day ;;regexp
        lyoubi
        (flg nil))
    (setq youbi (+ youbi 0))
    (setq lyoubi (+ youbi 7))
    (setq regexp
          (concat "\\("))
    (while (not (= lyoubi youbi))
      (setq regexp
            (concat
             regexp
             (if flg
                 "\\|")
             (format-time-string
              "%b %e"
              (my-dired-date lyoubi))
             "\\|"
             (format-time-string
              "%m-%d"
              (my-dired-date lyoubi))
             ))
      ;;(insert (concat (int-to-string youbi) "\n"))
      (setq flg t)
      (setq lyoubi (- lyoubi 1))))
  (setq regexp
        (concat regexp "\\)"))
  (search-forward-regexp
   (concat regexp " [0-9]....") arg t))

(font-lock-add-keywords
 major-mode
 (list
  '(my-dired-today-search . face-file-edited-today)
  '(my-dired-this-week-search . face-file-edited-this-week)
  '(my-dired-last-week-search . face-file-edited-last-week)
  ))

(defadvice dired-advertised-find-file
  (around dired-sort activate)
  (let ((sw dired-actual-switches))
    ad-do-it
    (if (string= major-mode 'dired-mode)
        (progn
          (setq dired-actual-switches sw)
          (dired-sort-other dired-actual-switches)))
    ))

(defadvice dired-my-up-directory
  (around dired-sort activate)
  (let ((sw dired-actual-switches))
    ad-do-it
    (if (string= major-mode 'dired-mode)
        (progn
          (setq dired-actual-switches sw)
          (dired-sort-other dired-actual-switches)))
    ))

(load "sorter")

(add-hook 'dired-load-hook
          (lambda ()
            (require 'sorter)))

(add-hook 'dired-mode-hook
          (lambda () (require 'dired-sort-menu)))

(setq ls-lisp-dirs-first t)

(defun ls-lisp-handle-switches (file-alist switches)
  ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
  ;; Return new alist sorted according to SWITCHES which is a list of
  ;; characters.  Default sorting is alphabetically.
  (let (index)
    (setq file-alist
          (sort file-alist
                (cond
                 ((memq ?S switches)    ; sorted on size
                  (function
                   (lambda (x y)
                     ;; 7th file attribute is file size
                     ;; Make largest file come first
                     (if (equal (nth 0 (cdr y))
                                (nth 0 (cdr x)))
                         (< (nth 7 (cdr y))
                            (nth 7 (cdr x)))
                       (nth 0 (cdr x))))))
                 ((memq ?t switches)    ; sorted on time
                  (setq index (ls-lisp-time-index switches))
                  (function
                   (lambda (x y)
                     (if (equal (nth 0 (cdr y))
                                (nth 0 (cdr x)))
                         (ls-lisp-time-lessp (nth index (cdr y))
                                             (nth index (cdr x)))
                       (nth 0 (cdr x))
                       ))))
                 ((memq ?X switches)    ; sorted on ext
                  (function
                   (lambda (x y)
                     (if (equal (nth 0 (cdr y))
                                (nth 0 (cdr x)))
                         (string-lessp (file-name-extension (upcase (car x)))
                                       (file-name-extension (upcase (car y))))
                       (nth 0 (cdr x))))))
                 (t                     ; sorted alphabetically
                  (if ls-lisp-dired-ignore-case
                      (function
                       (lambda (x y)
                         (if (equal (nth 0 (cdr y))
                                    (nth 0 (cdr x)))
                             (string-lessp (upcase (car x))
                                           (upcase (car y)))
                           (nth 0 (cdr x)))))
                    (function
                     (lambda (x y)
                       (if (equal (nth 0 (cdr y))
                                  (nth 0 (cdr x)))
                           (string-lessp (car x)
                                         (car y))
                         (nth 0 (cdr x)))))
                    )))))
    )

  (if (memq ?r switches)                ; reverse sort order
      (setq file-alist (nreverse file-alist)))
  file-alist)

(require 'dired-efap)
(define-key dired-mode-map [f2] 'dired-efap)

(require 'wdired)
(define-key dired-mode-map "r" 'wdired-change-to-wdired-mode)

(defadvice wdired-finish-edit
  (after skk-no-use activate)
  (skk-auto-fill-mode -1))

(require 'bf-mode)

;; 別ウィンドウに表示するサイズの上限
(setq bf-mode-browsing-size 10)
;; 別ウィンドウに表示しないファイルの拡張子
(setq bf-mode-except-ext '("\\.exe$" "\\.com$"))
;; 容量がいくつであっても表示して欲しいもの
(setq bf-mode-force-browse-exts
      (append '("\\.texi$" "\\.el$")
              bf-mode-force-browse-exts))

;; html は w3m で表示する
(setq bf-mode-html-with-w3m t)
;; 圧縮されたファイルを表示
(setq bf-mode-archive-list-verbose t)
;; ディレクトリ内のファイル一覧を表示
(setq bf-mode-directory-list-verbose t)

(defun wholenump (num)
  (if (and
       (integerp num)
       (> num 0))
      t
    nil))

(require 'master)

(load "dired-master")

(load "my-dired-master")

(autoload 'dispicon "dispicon")
;; Semi を使用したメールソフトでアイコンを表示
;; ここから
(eval-after-load "mime-view"
  '(defun mime-view-entity-title (entity)
     (or (mime-entity-read-field
          entity 'Content-Description)
         (mime-entity-read-field entity 'Subject)
         (let ((file (mime-entity-filename entity)))
           (when file
             (concat (dispicon file) file)))
         "")))
;; ここまで

;; dired でアイコンを表示
(eval-after-load "dired"
  '(progn
     (defadvice dired-revert
       (before dired-revert-remove-overlays activate)
       "Remove overlays."
       (save-excursion
         (let ((pos (point-min)))
           (while (not
                   (eq (setq pos (next-overlay-change pos))
                       (point-max)))
             (dolist (overlay (overlays-at pos))
               (delete-overlay overlay))))))
     (defun dired-insert-set-properties (beg end)
       (save-excursion
         (goto-char beg)
         (while (< (point) end)
           (condition-case nil
               (when (dired-move-to-filename)
                 (let ((beg (point))
                       end file)
                   (add-text-properties
                    beg
                    (setq end
                          (save-excursion
                            (dired-move-to-end-of-filename)
                            (point)))
                    '(mouse-face
                      highlight
                      help-echo
                      "mouse-2: visit this file in other window"))
                   (setq file (buffer-substring beg end))
                   (overlay-put (make-overlay beg end)
                                'before-string
                                (dispicon
                                 (with-temp-buffer
                                   (insert (expand-file-name
                                            file
                                            dired-directory))
                                   (goto-char (point-min))
                                   (while (search-forward "/" nil t)
                                     (replace-match "\\" nil t))
                                   (buffer-string))
                                 'small 16))))
             (error nil))
           (forward-line 1))))))

(require 'dirtree)