btree.el --- For tree-view-mode add-in

btree.el

;;; btree.el --- For tree-view-mode add-in -*- lexical-binding:t -*-

;; Copyright (C) 2025 fubuki

;; Author:   fubuki at frill.org
;; Created:  Apr 2025
;; Keywords: Files
;; Version:  @(#)$Revision: 1.6 $
;; URL: 

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; 音楽ファイル(*1)のタイムやコーデック情報を追加した
;; ファイルツリーを新規バッファに表示します.
;; 実行するとツリーを取るディレクトリ名を聞いてきます.
;; スキャンを終えるとツリーバッファが開きます.
;;
;;   M-x btree
;;
;; 遅く行ったきり雀になるので
;; その間も Emacs が使えるよう新しいスレッドを切って実行します.
;; 進捗状況は mode line の右端に表示します.
;; 結構引っぱられるので カスタム変数 `btree-sleep' で
;; 妥協できる塩梅(があるのなら)に待機時間(フォアに戻っている時間)を調整してください.
;; デフォルトは 0.0005 秒です.
;; 実行中はタイマーを利用している `show-paren-mode' 等は動きません.

;; *1 wtag で対応しているもの(mp3 m4a flac 等).

;;; Installation:

;; Use `tree-view-mode' and `wtag' package.
;;
;;  github.com/s-fubuki/tree-view-mode
;;  github.com/s-fubuki/wtag
;;
;;   (require 'btree)

;;; Code:
(require 'tree-view-mode)

(defconst btree-version "$Revision: 1.6 $")

(defcustom btree-sleep 0.0005
  "Thread wait time."
  :type 'number
  :group 'tree)

;; Work Variables.
(defvar btree-thread nil)
(defvar btree-count nil)
(defvar btree-now nil)
(defvar btree-mode-string nil)
(put 'btree-mode-string 'risky-local-variable t)

(eval-and-compile
  (mapc #'require '(wtag mf-lib-wav mf-lib-mp3v1 mf-lib-wma mf-lib-ogg mf-lib-aiff))
  (defvar btree-suffix-regexp
    (rx "." (eval (cons '| (mapcar #'symbol-name mf-lib-suffix-all))) eos)))

(defvar btree-font-lock
  '(("\\(?1:\\[[ [:digit:]]+'[[:digit:]].+ \\(?2:`.+'\\)\\]\\)$"
     (1 'wtag-time) (2 'wtag-title t))
    ("\\[ERROR\\]$" . 'error)
    ("\\[[ [:digit:]]+'[[:digit:]].+\\]$" . 'wtag-time)))

(defvar btree-regexp
  (rx bos
      (group-n 1 (+? not-newline))
      (? (| (seq " [" (+ (any digit space)) "'" digit (+ not-newline)
                 (? (seq " `" (+ not-newline) "'")) "]")
            " [ERROR]"))
      eos))

(defun btree-progress ()
  (setq btree-now (1+ (or btree-now 0)))
  (setq btree-mode-string (format "BT:%d/%d " btree-now btree-count))
  (and btree-sleep (sleep-for btree-sleep)))

(defun btree-file-make-data-base (file)
  "tree FILE text をソートされたフラットなデータベースリストにする.
list 各要素は (PATH . MUSICINFO).
list は PATH 文字列でソートされている."
  (interactive "fTree Text: ")
  (with-temp-buffer
    (tree-directory-insert
     (with-temp-buffer
       (insert-file-contents file)
       (tree-text-make-list))
     nil 'flat)
    (btree--file-make-data-base)))

(defun btree--file-make-data-base ()
  (let (pre result)
    (goto-char (point-min))
    (looking-at "\\(?1:[a-zA-z]:\\)\\(?2:.+\\)$")
    (setq pre (match-string 2))
    (while (re-search-forward
            "^\\(?1:\\[.+?] \\)\\(?2:.+?\\) ?\\(?3:\\[[ 0-9]+'[0-9]+\" .+]\\)$"
            nil t)
      (push (cons (concat pre (match-string 2))
                  (match-string 3))
            result))
    (sort result (lambda (a b) (string-lessp (car a) (car b))))))

(defvar btree-cache nil)

;; binary search しているが、今なら通常の assoc でも変わらない気もする.
(defun btree-assoc (key alst)
  "KEY に CAR がマッチするコンスセルを ALST から戻す.
マッチが無ければ nil を戻す."
  (let* ((beg 0)
         (end (1- (length alst)))
         mid pnt)
    (while (and (<= beg end) (not (equal key (car pnt))))
      (setq mid (/ (+ beg end) 2)
            pnt (nth mid alst))
      (if (string-lessp (car pnt) key)
          (setq beg (1+ mid))
        (setq end (1- mid))))
    (and (equal key (car pnt)) pnt)))

(defun btree-strip-drive (filename)
  "FILENAME からドライブレターを削る.
Windows の仕様バグで Cache と実ドライブが違う可能性がある為."
  (if (string-match-p "\\`[a-zA-Z]:" filename)
      (substring filename 2)
    filename))

(defun btree-add-bitrate (file dir)
  "tree.el 変数 `tree-file-name-deco' 用ビットレート表示関数."
  (let (cache)
    (btree-progress)
    (cond
     ((not (string-match btree-suffix-regexp file))
      (tree-quote-file-name file))
     ((and btree-cache
           (setq cache
                 (btree-assoc (concat (btree-strip-drive dir) "/" file) btree-cache)))
      (format "%s %s" (tree-quote-file-name file) (cdr cache)))
     (t
      (condition-case nil
          (let ((mf-mp4-reload-margin 0.5)
                tag full title wtag-current-mode message-log-max)
            (setq tag (mf-tag-read-plist
                       (setq full (expand-file-name file dir))
                       (mf-read-size full) t)
                  title (plist-get tag 'title)
                  wtag-current-mode (plist-get tag '*type))
            (format "%s [%s%s]"
                    (tree-quote-file-name file)
                    (wtag-format
                     (wtag-form-select wtag-time-form 'full)
                     (plist-get tag '*time))
                    (or (btree-string-almost-match file title) "")))
        (t (format "%s [ERROR]" file)))))))

(defun btree-string-almost-match (a b)
  "A B がほぼマッチすれば nil, さもなくば B を戻す.
戻される B はクォートされアタマにはブランクが追加される"
  (let ((a (file-name-base a)))
    (setq a (and (string-match "\\`[- [:digit:]]*\\(?1:.+\\)\\'" a)
                 (match-string 1 a)))
    (if (not (string-match (japanese-hankaku (regexp-quote a) 'ascii)
                           (japanese-hankaku b 'ascii)))
        (format " `%s'" b))))

(defun btree-count (lst)
  "`tree-directory-make-list' が戻す LST 内のファイル数を得る."
  (let ((files lst)
        leaf (result 0))
    (while files
      (setq leaf  (car files)
	    files (cdr files))
      (if (and (consp leaf) (tree-obj-p (car leaf))) ; directory
          (setq result (+ 1 result (btree-count (cdr leaf))))
        (setq result (1+ result))))
    result))

(defun btree-open-directory ()
  "Override on `tree-open-directory'.
`btree' で付け加える部分をはしょって正しいファイル名にして処理する版."
  (interactive)
  (let* ((tmp (tree-point-filename 'full))
         (file (progn (string-match btree-regexp tmp) (match-string 1 tmp)))
         (dir (file-name-directory file)))
    (dired-other-window dir)
    (dired-goto-file file)))

(define-minor-mode btree-mode
  "tree view mode extension.
Add font-lock highlight."
  :group  'tree
  :keymap '(([remap tree-open-directory] . btree-open-directory))
  (if btree-mode
      (font-lock-add-keywords nil btree-font-lock)
    (font-lock-remove-keywords nil btree-font-lock)))

(add-hook 'tree-view-mode-hook #'btree-mode)
(add-hook 'easy-tree-view-mode-hook #'btree-mode)

;;;###autoload
(defun btree (dir &optional cache-file)
  "`ftree' を新たなスレッドで実行し、音楽ファイルの情報も追加する.
このコマンドの出力する形式の CACHE-FILE を指定すると
そこにあるデータはそちらを使い高速化する."
  (interactive
   ;; `read-directory-name' だと名前末尾にスラッシュをつけると
   ;; そのディレクトリにはならず `default-directory' になってしまう. BUG?
   (let ((dir (read-file-name "Directory: " nil nil nil nil #'file-directory-p))
         (cache (and current-prefix-arg (read-file-name "Cache file: "))))
     (list dir cache)))
  (advice-add 'tree-directory-make-list :around #'btree-directory-make-list)
  (add-hook 'tree-buffer-display-hook #'btree-buffer-display-after)
  (when cache-file
    (message "Make cache data base...")
    (setq btree-cache (btree-file-make-data-base cache-file)))
  ;; `tree-file-name-deco' のセットは btree-cache をセットした後にする
  ;; そうしないとそちらでも `btree-add-bitrate' で動いてしまうため.
  (setq tree-file-name-deco #'btree-add-bitrate)
  (with-mutex (make-mutex "*btree*")
    (message "Start tree scan `%s' BG process..." dir)
    (setq btree-thread (make-thread
                        (lambda ()
                          (let ((inhibit-message 'silence))
                            (ftree (expand-file-name dir))))
                        "*btree*"))))

(defun btree-directory-make-list (org dir)
  (let ((lst (funcall org dir)))
    (setq btree-count (btree-count lst)
          global-mode-string (append global-mode-string '(btree-mode-string)))
    lst))

(defun btree-buffer-display-after ()
  (advice-remove 'tree-directory-make-list #'btree-directory-make-list)
  (remove-hook 'tree-buffer-display-hook #'btree-buffer-display-after)
  (setq tree-file-name-deco nil btree-thread nil btree-mode-string nil
        btree-now nil btree-count nil btree-cache nil)
  (setq global-mode-string (delq 'btree-mode-string global-mode-string)))

(provide 'btree)
;; END HERE.

CHANGES

-*- mode: outline -*-
* 1.6
** new: 追加差分のツリーが欲しいとき前回取ったツリーテキストを PREFIX 起動で指定すると
 それをキャッシュにして大幅に高速化できる.

** fix: `read-directory-name' (interactive "D" も等価) からディレクトリを指定したとき
 末尾にスラッシュがあると戻値が `default-directory' になってしまう.
 スラッシュ末尾でなければ渡した名前がそのまま戻る
 (スラッシュがあってもなくても常にこちらであってほしい).
 これが BUG なのか知らないが、
 `read-directory-name' に代えて `read-file-name' を使い
 PREDICATE を `file-directory-p' にすることにより回避.

** change: `btree-buffer-display-after'
 引数を使わないのでバイトコンパイルでワーニングが出るため
 アドバイスではなくフックで実行するよう変更.

* 1.4
** fix: btree 実行前に btree 生成の text で `tree-view-mode' を使うと
 `btree-font-lock' が反映されないため、
 `tree-view-mode-hook' と `easy-tree-view-mode-hook' での
 `'btree-mode' の実行を `btree' の外に出す.