階層表示した場合の親フォルダ名部分を消してみた

フォルダを階層表示すると普通↓になる。

   [-]:gmail::0/83353/84447
     :gmail:INBOX:0/9/117
     [-]:gmail:ml:0/26841/24794
       :gmail:ml/wanderlust:0/27/195
       :gmail:ml/gnu-emacs-sources:0/217/322
       :gmail:ml/emacs-mime:0/0/6
       :gmail:ml/emacs-devel:0/21714/19327
       :gmail:ml/bug-gnu-emacs:0/4883/4938
       :gmail:ml/apel:0/0/6

これを↓な風になるようにしてみた

   [-]:gmail::0/83353/84447
     INBOX:0/9/117
     [-]ml:0/26841/24794
       wanderlust:0/27/195
       gnu-emacs-sources:0/217/322
       emacs-mime:0/0/6
       emacs-devel:0/21714/19327
       bug-gnu-emacs:0/4883/4938
       apel:0/0/6

長いフォルダ名のときに嬉しい。グループの箇所もやろうとすると面倒そうだからやってない。

追記

• [2008-10-28] imap フォルダとかの接続方法付きのフォルダ名に対応。複雑になっちゃった。
• [2008-10-27] アイコンでなくなってたのを修正。
• [2008-10-27] wl-folder-buffer-search-group でこけてたから、overlayつかうように修正。
• [2008-10-27] 起動時にDesktopを書くとこでエラーになってたのを修正。
• [2008-10-26] 以外と簡単にグループ対応できたから修正。

ソース

(require 'cl)
(defvar wl-folder-same-name-entity-string "[---]")
(defvar wl-folder-parent-name-regexp-alist
  '((?% . "^\\([%-][^/@:!]*\\)")
    (t . "\\(.+\\)")))

(defun wl-folder-setup-inhibit-parent-name-overlay (start end same-name-p)
  (let ((overlay (find-if (lambda (x) (overlay-get x 'wl-inhibit-parent-name))
                          (overlays-in start end))))
    (unless overlay
      (setq overlay (make-overlay (point) (point)))
      (overlay-put overlay name t)
      (overlay-put overlay 'evaporate t))
    (overlay-put overlay 'invisible t)
    (overlay-put overlay 'before-string
                 (and same-name-p
                      wl-folder-same-name-entity-string))
    (move-overlay overlay start end (current-buffer))))

(defadvice wl-folder-insert-entity (around inhibit-parent-name activate)
  "inhibit parent folder name of current entity."
  (let ((orig-pos (point)))
    ad-do-it
    (let ((inhibit-read-only t)
          (indent (ad-get-arg 0))
          (entity (ad-get-arg 1))
          parent submatch same-name-p)
      (save-excursion
        (goto-char orig-pos)
        (back-to-indentation)
        (when (>= (- (length indent) 2) 0)
          (save-excursion
            (setq parent (and (re-search-backward
                               (concat "^" (make-string (- (length indent) 2) ? ) "[^ ]")
                               nil t)
                              (wl-folder-get-entity-from-buffer)))))
        (when (consp entity)
          (setq entity (car entity)))
        (when (and parent
                   (string= entity (wl-folder-get-petname entity)))
          (setq same-name-p (string= parent entity))
          (setq submatch
                (and (string-match
                      (or (cdr (assq (aref parent 0) wl-folder-parent-name-regexp-alist))
                          "\\(.+\\)")
                      parent)
                     (match-string 0 parent)))
          (when (and submatch
                     (re-search-forward (concat (regexp-quote submatch) "[./]?")
                                        (line-end-position) t))
            (wl-folder-setup-inhibit-parent-name-overlay
             (match-beginning 0) (match-end 0) same-name-p)
            (when (and (re-search-forward
                        (concat
                         "\\("
                         "\\(:[^@:/!]+\\(/[^@:/!]+\\)?\\)?"
                         "\\(@[^@:/!]+\\)?\\(:[0-9]+\\)?\\(!.*\\)?"
                         "\\)"
                         ":\\([0-9*]+/?\\)+$")
                        (line-end-position) t)
                       (not (= (match-beginning 0) (match-end 0))))
              (wl-folder-setup-inhibit-parent-name-overlay
               (match-beginning 1) (match-end 1) same-name-p))
            (back-to-indentation)
            (let ((icon-overlay (find-if (lambda (x) (overlay-get x 'wl-e21-icon))
                                         (overlays-in (point) (line-end-position)))))
              (while (find-if (lambda (x) (overlay-get x 'invisible))
                              (overlays-at (point)))
                (goto-char (next-overlay-change (point))))
              (move-overlay icon-overlay (point) (overlay-end icon-overlay)))))))))