755 lines
34 KiB
EmacsLisp
755 lines
34 KiB
EmacsLisp
;;; dirvish-widgets.el --- Core widgets in dirvish -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2021-2025 Alex Lu
|
|
;; Author : Alex Lu <https://github.com/alexluigit>
|
|
;; Keywords: files, convenience
|
|
;; Homepage: https://github.com/alexluigit/dirvish
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
;;; Commentary:
|
|
|
|
;; This library provides core attributes / mode-line segments / preview
|
|
;; dispatchers (fast and non-blocking media files preview) for dirvish.
|
|
;;
|
|
;; Attributes:
|
|
;; `file-size', `file-time', `file-modes'
|
|
;;
|
|
;; Mode-line segments:
|
|
;;
|
|
;; `path', `symlink', `omit', `sort', `index', `free-space', `file-link-number',
|
|
;; `file-user', `file-group', `file-time', `file-size', `file-modes',
|
|
;; `file-inode-number', `file-device-number'
|
|
;;
|
|
;; Preview dispatchers:
|
|
;;
|
|
;; - `image': preview image files, requires `vipsthumbnail'
|
|
;; - `gif': preview GIF image files with animation
|
|
;; - `video': preview videos files with thumbnail image
|
|
;; - requires `ffmpegthumbnailer' on Linux/macOS
|
|
;; - requires `mtn' on Windows (special thanks to @samb233!)
|
|
;; - `audio': preview audio files with metadata, requires `mediainfo'
|
|
;; - `epub': preview epub documents, requires `epub-thumbnail'
|
|
;; - `font': preview font files, requires `magick'
|
|
;; - `pdf': preview pdf documents with thumbnail image, require `pdftoppm'
|
|
;; - `pdf-tools': preview pdf documents via `pdf-tools'
|
|
;; - `archive': preview archive files, requires `tar' and `unzip'
|
|
;; - `image-dired' NOT implemented yet | TODO
|
|
|
|
;;; Code:
|
|
|
|
(require 'dirvish)
|
|
|
|
(defcustom dirvish-time-format-string "%y-%m-%d %R"
|
|
"FORMAT-STRING for `file-time' mode line segment.
|
|
This value is passed to function `format-time-string'."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defcustom dirvish-file-count-overflow 15000
|
|
"Up limit for counting directory files, to improve performance."
|
|
:group 'dirvish :type 'natnum)
|
|
|
|
(defcustom dirvish-path-separators '(" ⌂" " ∀" " ⋗ ")
|
|
"Separators in path mode line segment.
|
|
The value is a list with 3 elements:
|
|
- icon for home directory [~]
|
|
- icon for root directory [/]
|
|
- icon for path separators [/]"
|
|
:group 'dirvish :type '(repeat (string :tag "path separator")))
|
|
|
|
(defcustom dirvish-vipsthumbnail-program "vipsthumbnail"
|
|
"Absolute or reletive name of the `vipsthumbnail' program.
|
|
This is used to generate image thumbnails."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defcustom dirvish-ffmpegthumbnailer-program "ffmpegthumbnailer"
|
|
"Absolute or reletive name of the `ffmpegthumbnailer' program.
|
|
This is used to generate video thumbnails on macOS/Linux."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defcustom dirvish-mtn-program "mtn"
|
|
"Absolute or reletive name of the `mtn' program.
|
|
This is used to generate video thumbnails on Windows."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defcustom dirvish-epub-thumbnailer-program "epub-thumbnailer"
|
|
"Absolute or reletive name of the `epub-thumbnailer' program.
|
|
This is used to generate thumbnail for epub files."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defcustom dirvish-mediainfo-program "mediainfo"
|
|
"Absolute or reletive name of the `mediainfo' program.
|
|
This is used to retrieve metadata for multiple types of media files."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defcustom dirvish-magick-program "magick"
|
|
"Absolute or reletive name of the `magick' program.
|
|
This is used to generate thumbnail for font files."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defcustom dirvish-pdfinfo-program "pdfinfo"
|
|
"Absolute or reletive name of the `pdfinfo' program.
|
|
This is used to retrieve pdf metadata."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defcustom dirvish-pdftoppm-program "pdftoppm"
|
|
"Absolute or reletive name of the `pdftoppm' program.
|
|
This is used to generate thumbnails for pdf files."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defcustom dirvish-7z-program (or (executable-find "7zz") (executable-find "7z"))
|
|
"Absolute or reletive name of the `7z' | `7zz' (7-zip) program.
|
|
This is used to list files and their attributes for .zip archives."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defcustom dirvish-fc-query-program "fc-query"
|
|
"Absolute or reletive name of the `fc-query' program.
|
|
This is used to generate metadata for font files."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defcustom dirvish-show-media-properties
|
|
(and (executable-find dirvish-mediainfo-program) t)
|
|
"Show media properties automatically in preview window."
|
|
:group 'dirvish :type 'boolean)
|
|
|
|
(defcustom dirvish-font-preview-sample-text
|
|
"\nABCDEFGHIJKLMNOPQRSTUVWXYZ\nabcdefghijklmnopqrstuvwxyz\nThe quick
|
|
brown fox jumps over the lazy dog\n\n 枕上轻寒窗外雨 眼前春色梦中人
|
|
\n1234567890\n!@$%^&*-_+=|\\\\<>(){}[]\nالسلام عليكم"
|
|
"Sample text for font preview."
|
|
:group 'dirvish :type 'string)
|
|
|
|
(defconst dirvish-media--img-max-width 2400)
|
|
(defconst dirvish-media--img-scale-h 0.75)
|
|
(defconst dirvish-media--img-scale-w 0.92)
|
|
(defconst dirvish-media--info
|
|
"General;(Full-name . \"\"%FileName%\"\")(Format . \"\"%Format%\"\")(File-size . \"\"%FileSize/String1%\"\")(Duration . \"\"%Duration/String3%\"\")
|
|
Image;(Width . \"\"%Width/String%\"\")(Height . \"\"%Height/String%\"\")(Bit-depth . \"\"%BitDepth/String%\"\")(Color-space . \"\"%ColorSpace%\"\")(Chroma-subsampling . \"\"%ChromaSubsampling%\"\")(Compression-mode . \"\"%Compression_Mode/String%\"\")
|
|
Video;(Resolution . \"\"%Width% x %Height%\"\")(Video-codec . \"\"%CodecID%\"\")(Framerate . \"\"%FrameRate%\"\")(Video-bitrate . \"\"%BitRate/String%\"\")
|
|
Audio;(Audio-codec . \"\"%CodecID%\"\")(Audio-bitrate . \"\"%BitRate/String%\"\")(Audio-sampling-rate . \"\"%SamplingRate/String%\"\")(Audio-channels . \"\"%ChannelLayout%\"\")")
|
|
(defconst dirvish--fc-query-format
|
|
"(Family . \"%{family}\")(Family-lang . \"%{familylang}\")(Style . \"%{style}\")(Style-lang . \"%{stylelang}\")(Full-name . \"%{fullname}\")
|
|
(Slant . \"%{slant}\")(Weight . \"%{weight}\")(Width . \"%{width}\")(Spacing . \"%{spacing}\")
|
|
(Foundry . \"%{foundry}\")(Capability . \"%{capability}\")(Font-format . \"%{fontformat}\")(Decorative . \"%{decorative}\")")
|
|
|
|
(defface dirvish-free-space
|
|
'((t (:inherit font-lock-constant-face)))
|
|
"Face used for `free-space' mode-line segment."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-file-link-number
|
|
'((t (:inherit font-lock-constant-face)))
|
|
"Face used for file link number mode-line segment."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-file-user-id
|
|
'((t (:inherit font-lock-preprocessor-face)))
|
|
"Face used for file size attributes / mode-line segment."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-file-group-id
|
|
'((t (:inherit dirvish-file-user-id)))
|
|
"Face used for file group id mode-line segment."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-file-time
|
|
'((((background dark)) (:foreground "#5699AF")) ; a light cyan
|
|
(t (:foreground "#979797")))
|
|
"Face used for `file-time' attribute and mode line segment."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-file-size
|
|
'((t (:inherit completions-annotations :underline nil :italic nil)))
|
|
"Face used for `file-size' attribute and mode-line segment."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-file-modes
|
|
'((((background dark)) (:foreground "#a9a1e1")) ; magenta
|
|
(t (:foreground "#6b6b6b")))
|
|
"Face used for `file-modes' attribute and mode line segment."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-file-inode-number
|
|
'((t (:inherit dirvish-file-link-number)))
|
|
"Face used for file inode number mode-line segment."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-file-device-number
|
|
'((t (:inherit dirvish-file-link-number)))
|
|
"Face used for filesystem device number mode-line segment."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-media-info-heading
|
|
'((t :inherit (dired-header bold)))
|
|
"Face used for heading of media property groups."
|
|
:group 'dirvish)
|
|
|
|
(defface dirvish-media-info-property-key
|
|
'((t :inherit (italic)))
|
|
"Face used for emerge group title."
|
|
:group 'dirvish)
|
|
|
|
;;;; Helpers
|
|
|
|
(defun dirvish--attr-size-human-readable (file-size kilo)
|
|
"Produce a string showing FILE-SIZE in human-readable form.
|
|
KILO is 1024.0 / 1000 for file size / counts respectively."
|
|
(if (and (eq kilo 1000) (> file-size (- dirvish-file-count-overflow 3)))
|
|
" MANY "
|
|
(let ((prefixes '("" "k" "M" "G" "T" "P" "E" "Z" "Y")))
|
|
(while (and (>= file-size kilo) (cdr prefixes))
|
|
(setq file-size (/ file-size kilo)
|
|
prefixes (cdr prefixes)))
|
|
(substring (format (if (and (< file-size 10)
|
|
(>= (mod file-size 1.0) 0.05)
|
|
(< (mod file-size 1.0) 0.95))
|
|
" %.1f%s%s"
|
|
" %.0f%s%s")
|
|
file-size (car prefixes)
|
|
(if (dirvish-prop :gui) " " ""))
|
|
-6))))
|
|
|
|
(defun dirvish--file-attr-size (name attrs)
|
|
"Get file size of file NAME from ATTRS."
|
|
(cond ((and (dirvish-prop :remote) (not (dirvish-prop :sudo)))
|
|
(substring (format " %s%s"
|
|
(or (file-attribute-size attrs) "?")
|
|
(if (dirvish-prop :gui) " " ""))
|
|
-6))
|
|
((stringp (file-attribute-type attrs))
|
|
(let* ((ovfl dirvish-file-count-overflow)
|
|
(ct (dirvish-attribute-cache name :f-count
|
|
(condition-case nil
|
|
(let ((files (directory-files name nil nil t ovfl)))
|
|
(dirvish--attr-size-human-readable
|
|
(- (length files) 2) 1000))
|
|
(file-error 'file)))))
|
|
(if (not (eq ct 'file)) ct
|
|
(dirvish-attribute-cache name :f-size
|
|
(dirvish--attr-size-human-readable
|
|
(file-attribute-size (file-attributes name)) 1024.0)))))
|
|
((file-attribute-type attrs)
|
|
(let* ((ovfl dirvish-file-count-overflow)
|
|
(ct (dirvish-attribute-cache name :f-count
|
|
(condition-case nil
|
|
(let ((files (directory-files name nil nil t ovfl)))
|
|
(dirvish--attr-size-human-readable
|
|
(- (length files) 2) 1000))
|
|
(file-error 'no-permission)))))
|
|
(if (eq ct 'no-permission) " ---- " ct)))
|
|
(t (dirvish-attribute-cache name :f-size
|
|
(dirvish--attr-size-human-readable
|
|
(or (file-attribute-size attrs) 0) 1024.0)))))
|
|
|
|
(defun dirvish--file-attr-time (name attrs)
|
|
"File NAME's modified time from ATTRS."
|
|
(if (and (dirvish-prop :remote) (not (dirvish-prop :sudo)))
|
|
(format " %s " (or (file-attribute-modification-time attrs) "?"))
|
|
(format " %s " (dirvish-attribute-cache name :f-time
|
|
(format-time-string
|
|
dirvish-time-format-string
|
|
(file-attribute-modification-time attrs))))))
|
|
|
|
(defun dirvish--format-file-attr (name &optional suffix)
|
|
"Return a (ATTR . FACE) cons of index's attribute NAME.
|
|
Use optional SUFFIX or NAME to intern the face symbol."
|
|
(when-let* ((fname (dirvish-prop :index))
|
|
(attrs (dirvish-attribute-cache fname :builtin))
|
|
(attr-getter (intern (format "file-attribute-%s" name)))
|
|
(a-face (intern (format "dirvish-file-%s" (or suffix name))))
|
|
(face (if (dirvish--selected-p) a-face 'dirvish-inactive))
|
|
(attr (and attrs (funcall attr-getter attrs))))
|
|
(cons attr face)))
|
|
|
|
;; TODO: support Thumbnail Managing Standard (#269)
|
|
(defun dirvish--img-thumb-name (file prefix &optional ext)
|
|
"Get FILE's image cache path.
|
|
PREFIX is a string indicating the subdir of `dirvish-cache-dir' to use.
|
|
EXT is a suffix such as \".jpg\" that is attached to FILE's md5 hash."
|
|
(let* ((md5 (secure-hash 'md5 (concat "file://" file)))
|
|
(dir (expand-file-name
|
|
(format "thumbnails/%s" prefix) dirvish-cache-dir)))
|
|
(unless (file-exists-p dir) (make-directory dir t))
|
|
(expand-file-name (concat md5 ext) dir)))
|
|
|
|
(defun dirvish-media--cache-sentinel (proc _exitcode)
|
|
"Sentinel for image cache process PROC."
|
|
(when-let* ((dv (dirvish-curr))
|
|
(path (dirvish-prop :index)))
|
|
(and (equal path (process-get proc 'path))
|
|
(dirvish--preview-update dv path))))
|
|
|
|
(defun dirvish-media--group-heading (group-titles)
|
|
"Format media group heading in Dirvish preview buffer.
|
|
GROUP-TITLES is a list of group titles."
|
|
(let ((prefix (propertize " " 'face
|
|
'(:inherit dirvish-media-info-heading
|
|
:strike-through t)))
|
|
(title (propertize
|
|
(format " %s " (mapconcat #'concat group-titles " & "))
|
|
'face 'dirvish-media-info-heading))
|
|
(suffix (propertize " " 'display '(space :align-to right)
|
|
'face '(:inherit dirvish-media-info-heading
|
|
:strike-through t))))
|
|
(format "%s%s%s\n\n" prefix title suffix)))
|
|
|
|
(defun dirvish-media--metadata-from-mediainfo (file)
|
|
"Return result string from command `mediainfo' for FILE."
|
|
(read (format "(%s)" (shell-command-to-string
|
|
(format "%s --Output='%s' %s"
|
|
dirvish-mediainfo-program
|
|
dirvish-media--info
|
|
(shell-quote-argument file))))))
|
|
|
|
(defun dirvish-media--metadata-from-pdfinfo (file)
|
|
"Return result string from command `pdfinfo' for FILE."
|
|
(cl-loop with out = (shell-command-to-string
|
|
(format "%s %s" dirvish-pdfinfo-program (shell-quote-argument file)))
|
|
with lines = (remove "" (split-string out "\n"))
|
|
for line in lines
|
|
for (title content) = (split-string line ":\s+")
|
|
concat (format " %s:\t%s\n"
|
|
(propertize title 'face 'dirvish-media-info-property-key)
|
|
content)))
|
|
|
|
(defun dirvish-media--format-metadata (mediainfo properties)
|
|
"Return a formatted string of PROPERTIES from MEDIAINFO."
|
|
(cl-loop for prop in properties
|
|
for p-name = (replace-regexp-in-string
|
|
"-" " " (format "%s" prop))
|
|
for info = (alist-get prop mediainfo)
|
|
concat (format " %s:\t%s\n"
|
|
(propertize p-name 'face 'dirvish-media-info-property-key)
|
|
info)))
|
|
|
|
;;;; Attributes
|
|
|
|
(dirvish-define-attribute file-size
|
|
"File size or directories file count."
|
|
:right 6
|
|
:when (and dired-hide-details-mode (>= win-width 20))
|
|
(let* ((str (concat (dirvish--file-attr-size f-name f-attrs)))
|
|
(face (or hl-face 'dirvish-file-size)))
|
|
(add-face-text-property 0 (length str) face t str)
|
|
`(right . ,str)))
|
|
|
|
(dirvish-define-attribute file-time
|
|
"File's modified time reported by `file-attribute-modification-time'."
|
|
:right (+ 2 (string-width
|
|
(format-time-string
|
|
dirvish-time-format-string (current-time))))
|
|
:when (and dired-hide-details-mode (>= win-width 25))
|
|
(let* ((raw (dirvish--file-attr-time f-name f-attrs))
|
|
(face (or hl-face 'dirvish-file-time)) str str-len)
|
|
(cond ((or (not raw) (< w-width 40)) (setq str (propertize " … ")))
|
|
(t (setq str (format " %s " raw))))
|
|
(add-face-text-property 0 (setq str-len (length str)) face t str)
|
|
(add-text-properties 0 str-len `(help-echo ,raw) str)
|
|
`(right . ,str)))
|
|
|
|
(dirvish-define-attribute file-modes
|
|
"File's modes reported by `file-attribute-modes'."
|
|
:right 12
|
|
:when (and dired-hide-details-mode (>= win-width 30))
|
|
(let* ((raw (file-attribute-modes
|
|
(dirvish-attribute-cache f-name :builtin)))
|
|
(face (or hl-face 'dirvish-file-modes)) str str-len)
|
|
(cond ((or (not raw) (< w-width 48)) (setq str (propertize " … ")))
|
|
(t (setq str (format " %s " raw))))
|
|
(add-face-text-property 0 (setq str-len (length str)) face t str)
|
|
(add-text-properties 0 str-len `(help-echo ,raw) str)
|
|
`(right . ,str)))
|
|
|
|
;;;; Mode line segments
|
|
|
|
(defun dirvish--register-path-seg (segment path face)
|
|
"Register mode line path SEGMENT with target PATH and FACE."
|
|
(propertize
|
|
segment 'face face 'mouse-face 'highlight
|
|
'help-echo "mouse-1: visit this directory"
|
|
'keymap `(header-line keymap
|
|
(mouse-1 . (lambda (_ev)
|
|
(interactive "e")
|
|
(dirvish--find-entry 'find-file ,path))))))
|
|
|
|
(dirvish-define-mode-line path
|
|
"Path of file under the cursor."
|
|
(let* ((directory-abbrev-alist nil) ; TODO: support custom `directory-abbrev-alist'
|
|
(index (dired-current-directory))
|
|
(face (if (dirvish--selected-p) 'dired-header 'dirvish-inactive))
|
|
(rmt (dirvish-prop :remote))
|
|
(abvname (if rmt (file-local-name index) (abbreviate-file-name index)))
|
|
(host (propertize (if rmt (concat " " (substring rmt 1)) "")
|
|
'face 'font-lock-builtin-face))
|
|
(segs (nbutlast (split-string abvname "/")))
|
|
(scope (pcase (car segs)
|
|
("~" (dirvish--register-path-seg
|
|
(nth 0 dirvish-path-separators)
|
|
(concat rmt "~/") face))
|
|
("" (dirvish--register-path-seg
|
|
(nth 1 dirvish-path-separators)
|
|
(concat rmt "/") face))))
|
|
(path (cl-loop for idx from 2
|
|
for sp = (format
|
|
"%s%s" (or rmt "")
|
|
(mapconcat #'concat (seq-take segs idx) "/"))
|
|
for s in (cdr segs) concat
|
|
(format "%s%s" (nth 2 dirvish-path-separators)
|
|
(dirvish--register-path-seg s sp face)))))
|
|
(replace-regexp-in-string "%" "%%%%" (format "%s%s%s " host scope path))))
|
|
|
|
(dirvish-define-mode-line sort
|
|
"Current sort criteria."
|
|
(let* ((switches (split-string dired-actual-switches))
|
|
(unfocused (unless (dirvish--selected-p) 'dirvish-inactive))
|
|
(crit (cond (dired-sort-inhibit "DISABLED")
|
|
((member "--sort=none" switches) "none")
|
|
((member "--sort=time" switches) "time")
|
|
((member "--sort=version" switches) "version")
|
|
((member "--sort=size" switches) "size")
|
|
((member "--sort=extension" switches) "extension")
|
|
((member "--sort=width" switches) "width")
|
|
(t "name")))
|
|
(time (cond ((member "--time=use" switches) "use")
|
|
((member "--time=ctime" switches) "ctime")
|
|
((member "--time=birth" switches) "birth")
|
|
(t "mtime")))
|
|
(rev (if (member "--reverse" switches) "↓" "↑")))
|
|
(format " %s %s|%s "
|
|
(propertize rev 'face (or unfocused 'font-lock-constant-face))
|
|
(propertize crit 'face (or unfocused 'font-lock-type-face))
|
|
(propertize time 'face (or unfocused 'font-lock-doc-face)))))
|
|
|
|
(dirvish-define-mode-line omit
|
|
"A `dired-omit-mode' indicator."
|
|
(and (bound-and-true-p dired-omit-mode)
|
|
(propertize "Omit" 'face 'font-lock-negation-char-face)))
|
|
|
|
(dirvish-define-mode-line symlink
|
|
"Show the truename of symlink file under the cursor."
|
|
(when-let* ((name (dirvish-prop :index))
|
|
(truename (cdr (dirvish-attribute-cache name :type))))
|
|
(format "%s %s"
|
|
(propertize "→ " 'face 'font-lock-comment-delimiter-face)
|
|
(propertize truename 'face 'dired-symlink))))
|
|
|
|
(dirvish-define-mode-line index
|
|
"Cursor file's index and total files count within current subdir."
|
|
(let* ((count (if (cdr dired-subdir-alist)
|
|
(format "[ %s subdirs ] " (length dired-subdir-alist)) ""))
|
|
(smin (line-number-at-pos (dired-subdir-min)))
|
|
(cpos (- (line-number-at-pos (point)) smin))
|
|
(fpos (- (line-number-at-pos (dired-subdir-max)) smin 1))
|
|
(cur (format "%3d " cpos)) (end (format "/%3d " fpos)))
|
|
(if (dirvish--selected-p)
|
|
(put-text-property 0 (length end) 'face 'bold end)
|
|
(put-text-property 0 (length count) 'face 'dirvish-inactive count)
|
|
(put-text-property 0 (length cur) 'face 'dirvish-inactive cur)
|
|
(put-text-property 0 (length end) 'face 'dirvish-inactive end))
|
|
(format "%s%s%s" cur end count)))
|
|
|
|
(dirvish-define-mode-line free-space
|
|
"Amount of free space on `default-directory''s file system."
|
|
(let ((free-space (or (dirvish-prop :free-space)
|
|
(get-free-disk-space default-directory) "")))
|
|
(dirvish-prop :free-space free-space)
|
|
(format " %s %s " (propertize free-space 'face 'dirvish-free-space)
|
|
(propertize "free" 'face 'font-lock-doc-face))))
|
|
|
|
(dirvish-define-mode-line file-link-number
|
|
"Number of links to file."
|
|
(pcase-let ((`(,lk . ,face) (dirvish--format-file-attr 'link-number)))
|
|
(propertize (format "%s" lk) 'face face)))
|
|
|
|
(dirvish-define-mode-line file-user
|
|
"User name of file."
|
|
(pcase-let ((`(,uid . ,face) (dirvish--format-file-attr 'user-id)))
|
|
(unless (dirvish-prop :remote) (setq uid (user-login-name uid)))
|
|
(propertize (format "%s" uid) 'face face)))
|
|
|
|
(dirvish-define-mode-line file-group
|
|
"Group name of file."
|
|
(pcase-let ((`(,gid . ,face) (dirvish--format-file-attr 'group-id)))
|
|
(unless (dirvish-prop :remote) (setq gid (group-name gid)))
|
|
(propertize (format "%s" gid) 'face face)))
|
|
|
|
(dirvish-define-mode-line file-time
|
|
"Last modification time of file."
|
|
(pcase-let ((`(,time . ,face)
|
|
(dirvish--format-file-attr 'modification-time 'time)))
|
|
(unless (and (dirvish-prop :remote) (not (dirvish-prop :sudo)))
|
|
(setq time (format-time-string dirvish-time-format-string time)))
|
|
(propertize (format "%s" time) 'face face)))
|
|
|
|
(dirvish-define-mode-line file-size
|
|
"File size of files or file count of directories."
|
|
(when-let* ((name (dirvish-prop :index))
|
|
(attrs (dirvish-attribute-cache name :builtin))
|
|
(size (dirvish--file-attr-size name attrs)))
|
|
(format "%s" (propertize size 'face 'dirvish-file-size))))
|
|
|
|
(dirvish-define-mode-line file-modes
|
|
"File modes, as a string of ten letters or dashes as in ls -l."
|
|
(pcase-let ((`(,modes . ,face) (dirvish--format-file-attr 'modes)))
|
|
(propertize (format "%s" modes) 'face face)))
|
|
|
|
(dirvish-define-mode-line file-inode-number
|
|
"File's inode number, as a nonnegative integer."
|
|
(pcase-let ((`(,attr . ,face) (dirvish--format-file-attr 'inode-number)))
|
|
(propertize (format "%s" attr) 'face face)))
|
|
|
|
(dirvish-define-mode-line file-device-number
|
|
"Filesystem device number, as an integer."
|
|
(pcase-let ((`(,attr . ,face) (dirvish--format-file-attr 'device-number)))
|
|
(propertize (format "%s" attr) 'face face)))
|
|
|
|
(dirvish-define-mode-line project
|
|
"Return a string showing current project."
|
|
(let ((project (dirvish--vc-root-dir))
|
|
(face (if (dirvish--selected-p) 'dired-header 'dirvish-inactive)))
|
|
(if project
|
|
(setq project (file-name-base (directory-file-name project)))
|
|
(setq project "-"))
|
|
(format " %s %s"
|
|
(propertize "Project:" 'face face)
|
|
(propertize project 'face 'font-lock-string-face))))
|
|
|
|
;;;; Preview dispatchers
|
|
|
|
(cl-defmethod dirvish-clean-cache (&context ((display-graphic-p) (eql t)))
|
|
"Clean cache images for marked files when `DISPLAY-GRAPHIC-P'."
|
|
(when-let* ((win (dv-preview-window (dirvish-curr)))
|
|
(size (and (window-live-p win) (dirvish-media--img-size win))))
|
|
(clear-image-cache)
|
|
(setq size (dirvish-media--img-size win))
|
|
(dolist (file (dired-get-marked-files))
|
|
(mapc #'delete-file
|
|
(file-expand-wildcards
|
|
(dirvish--img-thumb-name file size ".*") t )))))
|
|
|
|
(cl-defgeneric dirvish-media-metadata (file)
|
|
"Get media file FILE's metadata.")
|
|
|
|
(cl-defmethod dirvish-media-metadata ((file (head image)))
|
|
"Get metadata for image FILE."
|
|
(let ((minfo (dirvish-media--metadata-from-mediainfo (cdr file))))
|
|
(format "%s%s\n%s%s"
|
|
(dirvish-media--group-heading '("Image"))
|
|
(dirvish-media--format-metadata
|
|
minfo '(Width Height Color-space Chroma-subsampling Bit-depth Compression-mode))
|
|
(dirvish-media--group-heading '("General"))
|
|
(dirvish-media--format-metadata minfo '(Full-name Format File-size)))))
|
|
|
|
(cl-defmethod dirvish-media-metadata ((file (head video)))
|
|
"Get metadata for video FILE."
|
|
(let ((minfo (dirvish-media--metadata-from-mediainfo (cdr file))))
|
|
(format "%s%s\n%s%s\n%s%s"
|
|
(dirvish-media--group-heading '("General"))
|
|
(dirvish-media--format-metadata
|
|
minfo '(Full-name Format File-size Duration))
|
|
(dirvish-media--group-heading '("Video"))
|
|
(dirvish-media--format-metadata
|
|
minfo '(Resolution Video-codec Framerate Video-bitrate))
|
|
(dirvish-media--group-heading '("Audio"))
|
|
(dirvish-media--format-metadata
|
|
minfo '(Audio-codec Audio-bitrate Audio-sampling-rate Audio-channels)))))
|
|
|
|
(cl-defmethod dirvish-media-metadata ((file (head pdf)))
|
|
"Get metadata for pdf FILE."
|
|
(format "%s%s" (dirvish-media--group-heading '("PDF info"))
|
|
(dirvish-media--metadata-from-pdfinfo (cdr file))))
|
|
|
|
(cl-defmethod dirvish-media-metadata ((file (head font)))
|
|
"Get metadata for font FILE."
|
|
(let ((finfo
|
|
(read (format "(%s)" (shell-command-to-string
|
|
(format "%s -f '%s' %s"
|
|
dirvish-fc-query-program
|
|
dirvish--fc-query-format
|
|
(shell-quote-argument (cdr file))))))))
|
|
(format "%s%s\n%s%s\n%s%s"
|
|
(dirvish-media--group-heading '("Family" "Style"))
|
|
(dirvish-media--format-metadata
|
|
finfo '(Family Family-lang Style Style-lang Full-name))
|
|
(dirvish-media--group-heading '("Characteristics"))
|
|
(dirvish-media--format-metadata
|
|
finfo '(Slant Weight Width Spacing))
|
|
(dirvish-media--group-heading '("Others"))
|
|
(dirvish-media--format-metadata
|
|
finfo '(Foundry Capability Font-format Decorative)))))
|
|
|
|
(cl-defmethod dirvish-preview-dispatch ((recipe (head img)) dv)
|
|
"Insert RECIPE as an image at preview window of DV."
|
|
(with-current-buffer (dirvish--special-buffer 'preview dv t)
|
|
(let ((img (cdr recipe)) buffer-read-only)
|
|
(erase-buffer) (remove-overlays) (insert " ")
|
|
(add-text-properties 1 2 `(display ,img rear-nonsticky t keymap ,image-map))
|
|
(pcase-let ((`(,iw . ,ih) (image-size img)))
|
|
(let* ((p-window (dv-preview-window dv))
|
|
(w-pad (max (round (/ (- (window-width p-window) iw) 2)) 0))
|
|
(h-pad (max (round (/ (- (window-height p-window) ih) 2)) 0)))
|
|
(goto-char 1)
|
|
(insert (make-string (if dirvish-show-media-properties 2 h-pad) ?\n)
|
|
(make-string w-pad ?\s))
|
|
(when dirvish-show-media-properties
|
|
(let* ((beg (progn (goto-char (point-max)) (point)))
|
|
(file (with-current-buffer (cdr (dv-index dv))
|
|
(dirvish-prop :index)))
|
|
(ext (downcase (or (file-name-extension file) "")))
|
|
(type (cond ((member ext dirvish-image-exts) 'image)
|
|
((member ext dirvish-video-exts) 'video)
|
|
((member ext dirvish-font-exts) 'font)
|
|
((equal ext "pdf") 'pdf)
|
|
(t (user-error "Not a media file")))))
|
|
;; ensure the content is higher than the window height to avoid
|
|
;; unexpected auto scrolling
|
|
(insert "\n\n\n" (dirvish-media-metadata (cons type file))
|
|
(make-string (* h-pad 2) ?\n))
|
|
(align-regexp beg (point) "\\(\\\t\\)[^\\\t\\\n]+" 1 4 t)
|
|
(goto-char 1)))))
|
|
(current-buffer))))
|
|
|
|
(cl-defmethod dirvish-preview-dispatch ((recipe (head cache)) dv)
|
|
"Generate cache image according to RECIPE and session DV."
|
|
(let* ((path (dirvish-prop :index))
|
|
(buf (dirvish--special-buffer 'preview dv t))
|
|
(name (format "%s-%s-img-cache" path
|
|
(window-width (dv-preview-window dv)))))
|
|
(unless (get-process name)
|
|
(let ((proc (apply #'start-process
|
|
name (get-buffer-create "*img-cache*")
|
|
(cadr recipe) (cddr recipe))))
|
|
(process-put proc 'path path)
|
|
(set-process-sentinel proc #'dirvish-media--cache-sentinel)))
|
|
(with-current-buffer buf
|
|
(let (buffer-read-only) (erase-buffer) (remove-overlays)) buf)))
|
|
|
|
(defun dirvish-media--img-size (window &optional height)
|
|
"Get corresponding image width or HEIGHT in WINDOW."
|
|
(let ((size (if height (* dirvish-media--img-scale-h (window-pixel-height window))
|
|
(min (* dirvish-media--img-scale-w (window-pixel-width window))
|
|
dirvish-media--img-max-width))))
|
|
(floor size)))
|
|
|
|
(dirvish-define-preview audio (file ext)
|
|
"Preview audio files by printing its metadata.
|
|
Require: `mediainfo' (executable)"
|
|
:require (dirvish-mediainfo-program)
|
|
(when (member ext dirvish-audio-exts)
|
|
`(shell . (,dirvish-mediainfo-program ,file))))
|
|
|
|
(dirvish-define-preview image (file ext preview-window)
|
|
"Preview image files.
|
|
Require: `vipsthumbnail'"
|
|
:require (dirvish-vipsthumbnail-program)
|
|
(when (member ext dirvish-image-exts)
|
|
(let* ((w (dirvish-media--img-size preview-window))
|
|
(h (dirvish-media--img-size preview-window 'height))
|
|
(cache (dirvish--img-thumb-name file w ".jpg")))
|
|
(cond
|
|
((file-exists-p cache)
|
|
`(img . ,(create-image cache nil nil :max-width w :max-height h)))
|
|
((member ext '("ico" "svg")) ; do not convert them, will get blank images
|
|
`(img . ,(create-image file nil nil :max-width w :max-height h)))
|
|
(t `(cache . (,dirvish-vipsthumbnail-program
|
|
,file "--size" ,(format "%sx" w) "--output" ,cache)))))))
|
|
|
|
;; TODO: switch to `libvips' after its text rendering issues get solved
|
|
(dirvish-define-preview font (file ext preview-window)
|
|
"Preview font files.
|
|
Require: `magick' (from `imagemagick' suite)"
|
|
:require (dirvish-magick-program)
|
|
(when (member ext dirvish-font-exts)
|
|
(let* ((w (dirvish-media--img-size preview-window))
|
|
(h (dirvish-media--img-size preview-window 'height))
|
|
(cache (dirvish--img-thumb-name file w ".jpg")))
|
|
(if (file-exists-p cache)
|
|
`(img . ,(create-image cache nil nil :max-width w :max-height h))
|
|
`(cache . (,dirvish-magick-program
|
|
"-size" "1000x500" "xc:#ffffff" "-gravity" "center"
|
|
"-pointsize" "40" "-font" ,file "-fill" "#000000"
|
|
"-annotate" "+0+20" ,dirvish-font-preview-sample-text
|
|
"-flatten" ,cache))))))
|
|
|
|
(dirvish-define-preview gif (file ext)
|
|
"Preview gif images with animations."
|
|
(when (equal ext "gif")
|
|
(let ((gif (dirvish--find-file-temporarily file))
|
|
(callback (lambda (rcp)
|
|
(when-let* ((buf (cdr rcp)) ((buffer-live-p buf)))
|
|
(with-current-buffer buf
|
|
(image-animate (get-char-property 1 'display)))))))
|
|
(run-with-idle-timer 1 nil callback gif) gif)))
|
|
|
|
(dirvish-define-preview video (file ext preview-window)
|
|
"Preview video files.
|
|
Require: `ffmpegthumbnailer' (executable)"
|
|
:require (dirvish-ffmpegthumbnailer-program)
|
|
(when (member ext dirvish-video-exts)
|
|
(let* ((width (dirvish-media--img-size preview-window))
|
|
(height (dirvish-media--img-size preview-window 'height))
|
|
(cache (dirvish--img-thumb-name file width ".jpg")))
|
|
(if (file-exists-p cache)
|
|
`(img . ,(create-image cache nil nil :max-width width :max-height height))
|
|
`(cache . (,dirvish-ffmpegthumbnailer-program "-i" ,file "-o" ,cache "-s"
|
|
,(number-to-string width) "-m"))))))
|
|
|
|
(dirvish-define-preview video-mtn (file ext preview-window)
|
|
"Preview video files on MS-Windows.
|
|
Require: `mtn' (executable)"
|
|
:require (dirvish-mtn-program)
|
|
(when (member ext dirvish-video-exts)
|
|
(let* ((width (dirvish-media--img-size preview-window))
|
|
(height (dirvish-media--img-size preview-window 'height))
|
|
(cache (dirvish--img-thumb-name file width ".jpg"))
|
|
(path (dirvish--get-parent-path cache)))
|
|
(if (file-exists-p cache)
|
|
`(img . ,(create-image cache nil nil :max-width width :max-height height))
|
|
`(cache . (,dirvish-mtn-program "-P" "-i" "-c" "1" "-r" "1" "-O" ,path ,file "-o"
|
|
,(format ".%s.jpg" ext) "-w"
|
|
,(number-to-string width)))))))
|
|
|
|
(dirvish-define-preview epub (file preview-window)
|
|
"Preview epub files.
|
|
Require: `epub-thumbnailer' (executable)"
|
|
:require (dirvish-epub-thumbnailer-program)
|
|
(when (equal ext "epub")
|
|
(let* ((width (dirvish-media--img-size preview-window))
|
|
(height (dirvish-media--img-size preview-window 'height))
|
|
(cache (dirvish--img-thumb-name file width ".jpg")))
|
|
(if (file-exists-p cache)
|
|
`(img . ,(create-image cache nil nil :max-width width :max-height height))
|
|
`(cache . (,dirvish-epub-thumbnailer-program ,file ,cache ,(number-to-string width)))))))
|
|
|
|
(dirvish-define-preview pdf-tools (file ext)
|
|
"Preview pdf files.
|
|
Require: `pdf-tools' (Emacs package)"
|
|
(when (equal ext "pdf")
|
|
(if (and (require 'pdf-tools nil t)
|
|
(bound-and-true-p pdf-info-epdfinfo-program)
|
|
(file-exists-p pdf-info-epdfinfo-program))
|
|
(dirvish--find-file-temporarily file)
|
|
'(info . "`epdfinfo' program required to preview pdfs; run `M-x pdf-tools-install'"))))
|
|
|
|
(dirvish-define-preview pdf (file ext preview-window)
|
|
"Display thumbnail for pdf files."
|
|
:require (dirvish-pdftoppm-program)
|
|
(when (equal ext "pdf")
|
|
(let* ((width (dirvish-media--img-size preview-window))
|
|
(height (dirvish-media--img-size preview-window 'height))
|
|
(cache (dirvish--img-thumb-name file width))
|
|
(cache-jpg (concat cache ".jpg")))
|
|
(if (file-exists-p cache-jpg)
|
|
`(img . ,(create-image cache-jpg nil nil :max-width width :max-height height))
|
|
`(cache . (,dirvish-pdftoppm-program "-jpeg" "-f" "1" "-singlefile" ,file ,cache))))))
|
|
|
|
(dirvish-define-preview archive (file ext)
|
|
"Preview archive files.
|
|
Require: `7z' executable (`7zz' on macOS)"
|
|
:require (dirvish-7z-program)
|
|
(when (member ext dirvish-archive-exts)
|
|
;; TODO: parse output from (dirvish-7z-program "l" "-ba" "-slt" "-sccUTF-8")
|
|
`(shell . (,dirvish-7z-program "l" "-ba" ,file))))
|
|
|
|
(provide 'dirvish-widgets)
|
|
;;; dirvish-widgets.el ends here
|