daniel/emacs
1
2
Fork 0
Code Issues 7 Pull Requests Projects Releases Wiki Activity

add package dependencies

Browse Source
This commit is contained in:
Daniel Weschke
2025-07-06 21:26:51 +02:00
parent 65dedd3df8
commit 807d0f28f6
23 changed files with 8249 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
lisp/deflate/deflate-pkg.el Normal file
View File

@@ -0,0 +1,11 @@
;; -*- no-byte-compile: t; lexical-binding: nil -*-
(define-package "deflate" "20250703.808"
"The DEFLATE compression algorithm in pure Emacs LISP."
'((dash "2.0.0")
(emacs "25.1"))
:url "https://github.com/skuro/deflate"
:commit "4896cdf0c1d031404c6705f52c03f048444ff927"
:revdesc "4896cdf0c1d0"
:keywords '("files" "tools")
:authors '(("Carlo Sciolla" . "carlo.sciolla@gmail.com"))
:maintainers '(("Carlo Sciolla" . "carlo.sciolla@gmail.com")))

1006
lisp/deflate/deflate.el Normal file
View File

File diff suppressed because it is too large Load Diff

87
lisp/dirvish/dirvish-collapse.el Normal file
View File

@@ -0,0 +1,87 @@
;;; dirvish-collapse.el --- Collapse unique nested paths -*- 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:
;; Provides `collapse' attribute to reveal unique nested paths.
;;; Code:
(require 'dirvish)
(defface dirvish-collapse-dir-face
'((t (:inherit dired-directory)))
"Face used for directories in `collapse' attribute."
:group 'dirvish)
(defface dirvish-collapse-empty-dir-face
'((t (:inherit shadow)))
"Face used for empty directories in `collapse' attribute."
:group 'dirvish)
(defface dirvish-collapse-file-face
'((t (:inherit default)))
"Face used for files in `collapse' attribute."
:group 'dirvish)
(defcustom dirvish-collapse-separator "|"
"Separator string for `collapse' attribute."
:group 'dirvish :type 'string)
(defun dirvish-collapse--cache (f-name)
"Cache collapse state for file F-NAME."
(dirvish-attribute-cache f-name :collapse
(let ((path f-name) should-collapse files dirp)
(while (and (setq dirp (file-directory-p path))
(setq files (ignore-errors (directory-files path)))
(= 3 (length files))
;; Don't collapse "." and ".."
(not (or (string-suffix-p ".." path)
(string-suffix-p "/." path))))
(setq should-collapse t
path (expand-file-name
(car (remove "." (remove ".." files)))
path)))
(cond
((and (eq (length files) 2) (not should-collapse)) (cons 'empty t))
(should-collapse
(let* ((path (substring path (1+ (length f-name))))
(segs (split-string path "/"))
(head (format "%s%s%s" dirvish-collapse-separator
(mapconcat #'concat (butlast segs)
dirvish-collapse-separator)
dirvish-collapse-separator))
(tail (car (last segs)))
(tail-face (if dirp 'dirvish-collapse-dir-face
'dirvish-collapse-file-face)))
(and (equal head (format "%s%s" dirvish-collapse-separator
dirvish-collapse-separator))
(setq head dirvish-collapse-separator))
(add-face-text-property
0 (length head) 'dirvish-collapse-dir-face nil head)
(add-face-text-property 0 (length tail) tail-face nil tail)
(cons head tail)))
(t (cons nil nil))))))
(dirvish-define-attribute collapse
"Collapse unique nested paths."
:when (and (not (dirvish-prop :fd-info))
(not (dirvish-prop :remote)))
(when-let* ((cache (dirvish-collapse--cache f-name))
(head (car cache))
(tail (cdr cache)))
(if (eq head 'empty)
(let ((ov (make-overlay f-beg f-end)))
(overlay-put ov 'face 'dirvish-collapse-empty-dir-face)
`(ov . ,ov))
(let* ((str (concat head tail)))
(add-face-text-property 0 (length str) hl-face nil str)
`(left . ,str)))))
(provide 'dirvish-collapse)
;;; dirvish-collapse.el ends here

577
lisp/dirvish/dirvish-emerge.el Normal file
View File

@@ -0,0 +1,577 @@
;;; dirvish-emerge.el --- Pin files you are interested in at top -*- 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 extension allows user to pin important files at the top of Dirvish
;; buffers. Type M-x dirvish-emerge-menu RET into a dirvish buffer to get
;; started.
;;; Code:
(declare-function dirvish-emerge--menu "dirvish-emerge")
(require 'dirvish)
(require 'transient)
(defun dirvish-emerge-safe-groups-p (groups)
"Return t if GROUPS is a list and has less than 100 items."
(and (listp groups) (< (length groups) 100)))
(defcustom dirvish-emerge-groups '()
"Default emerge groups applied to all Dirvish buffer.
The value is an alist of (NAME . (TYPE . VALUE)) where NAME is a
string to designate the name and display title of the group, TYPE
is a symbol in one of `predicate', `extensions', or `regex'. The
corresponding VALUEs (criteria) for these types are:
- `predicate': a symbol that points to a predicate
- `extensions': one or more filename extensions
- `regex': a regular expression
The predicates are defined by `dirvish-emerge-define-predicate'.
Here is a sample value for this variable.
\((\"Recent\" (predicate . `recent-files-2h'))
(\"README\" (regex . \"README\"))
(\"PDF\" (extensions \"pdf\"))
(\"LaTeX\" (extensions \"tex\" \"bib\")))
When `dirvish-emerge-mode' is enabled in the buffer, the fileset
in the buffer are separated and rearranged by the following groups:
1. files modified within 2 hours
2. files whose name can be matched by \"README\"
3. files whose extension is \"pdf\"
4. files whose extension is \"tex\" or \"bib\"
5. other files
Although you can set this variable globally, a more appropriate
way would be set it directory locally. In that case, it is
recommended to compose and save this variable to .dir-locals.el
by the help of `dirvish-emerge-menu'."
:group 'dirvish :type 'alist)
(put 'dirvish-emerge-groups 'safe-local-variable #'dirvish-emerge-safe-groups-p)
(defcustom dirvish-emerge-max-file-count 20000
"Inhibit auto grouping in big directories.
If file count of the directory is greater than this value,
automatic grouping is disabled even if `dirvish-emerge-mode' is
turned on in the buffer."
:group 'dirvish :type 'integer)
(defface dirvish-emerge-group-title
'((t :inherit dired-ignored))
"Face used for emerge group title."
:group 'dirvish)
(defclass dirvish-emerge-group (transient-infix)
((hide :initarg :hide)
(selected :initarg :selected)
(recipe :initarg :recipe))
"[Experimental] Class for Dirvish emerge groups.")
(defvar-local dirvish-emerge--group-overlays nil)
(cl-defmethod transient-format-key ((obj dirvish-emerge-group))
"Format key for OBJ."
(let ((key (oref obj key))
(sel (oref obj selected)))
(propertize key 'face (if sel 'transient-value 'transient-key))))
(cl-defmethod transient-format-description ((obj dirvish-emerge-group))
"Format description for OBJ."
(let ((desc (oref obj description))
(sel (oref obj selected)))
(propertize desc 'face (and sel 'transient-value))))
(cl-defmethod transient-format-value ((obj dirvish-emerge-group))
"Format value for OBJ."
(pcase-let* ((`(,type . ,val) (oref obj recipe))
(face (if (oref obj hide) 'font-lock-comment-face
'transient-argument)))
(pcase type
('regex (propertize (format "\"%s\"" val) 'face face))
('extensions (propertize (format "%s" (mapconcat #'concat val ","))
'face face))
('predicate (propertize "PRED" 'face face)))))
(cl-defmethod transient-infix-read ((obj dirvish-emerge-group))
"Read value from OBJ."
(oset obj value (list (oref obj description) (oref obj recipe)
(oref obj hide) (oref obj selected))))
(cl-defmethod transient-infix-set ((obj dirvish-emerge-group) _value)
"Set value for OBJ."
(if-let* ((sel (oref obj selected)))
(dirvish-emerge-read-recipe (oref obj recipe) obj)
(oset obj selected t)))
(defvar dirvish-emerge--max-pred-name-len 0)
(defvar dirvish-emerge--available-preds '())
(defmacro dirvish-emerge-define-predicate (name docstring &rest body)
"Define a group predicate NAME with BODY.
DOCSTRING is the documentation of the predicate.
The predicate takes the following arguments:
- `local-name': output from (file-name-nondirectory FILE)
- `full-name': output from (dired-get-filename)
- `type': a cons of (TYPE . SYM-TARGET). TYPE is either `dir' or
`file'. SYM-TARGET is the symlink target as a string when the
file is a symlink, otherwise nil.
- `attrs': output from (file-attributes FILE)
The predicate is consumed by `dirvish-emerge-groups'."
(declare (indent defun) (doc-string 2))
`(let* ((fn (lambda (local-name full-name type attrs)
(ignore local-name full-name type attrs) ,@body))
(pair (assq ',name dirvish-emerge--available-preds))
(val (cons ',name (cons fn ,docstring))))
(setf dirvish-emerge--max-pred-name-len
(max dirvish-emerge--max-pred-name-len
(length (format "%s" ',name))))
(if pair
(setcdr (assq ',name dirvish-emerge--available-preds) val)
(push val dirvish-emerge--available-preds))))
(dirvish-emerge-define-predicate recent-files-2h
"File modified within 2 hours."
(let ((mtime (file-attribute-modification-time attrs)))
(and (listp mtime)
(< (float-time (time-subtract (current-time) mtime)) 7200))))
(dirvish-emerge-define-predicate recent-files-today
"File modified today."
(let ((mtime (file-attribute-modification-time attrs)))
(and (listp mtime)
(< (float-time (time-subtract (current-time) mtime)) 86400))))
(dirvish-emerge-define-predicate directories
"Matches directories."
(eq 'dir (car type)))
(dirvish-emerge-define-predicate files
"Matches files."
(eq 'file (car type)))
(dirvish-emerge-define-predicate symlinks
"Matches symlimks."
(cdr type))
;; Note the behavior of this predicate doesn't exactly match `file-executable-p'.
;; It checks if the owner of the file can execute it and not if the current
;; user can.
(dirvish-emerge-define-predicate executables
"Matches executables."
(eq ?x (aref (file-attribute-modes attrs) 3)))
(cl-defgeneric dirvish-emerge-read-recipe (recipe &optional obj)
"Read RECIPE from user input and optionally save it to OBJ.")
(cl-defmethod dirvish-emerge-read-recipe ((recipe (head regex)) &optional obj)
"Read RECIPE from user input and optionally save it to OBJ."
(let* ((deft (cdr recipe))
(regex (read-regexp
(format "Change regex to (defaults to %s): " deft) deft)))
(if obj (oset obj recipe `(regex . ,regex)) regex)))
(cl-defmethod dirvish-emerge-read-recipe ((recipe (head extensions)) &optional obj)
"Read RECIPE from user input and optionally save it to OBJ."
(let* ((prompt "Input one or more extensions: ")
(cands
(cl-remove-if-not (lambda (i) (and i (> (length i) 0)))
(mapcar #'file-name-extension
(directory-files default-directory))))
(exts (completing-read-multiple
prompt cands nil nil (mapconcat #'concat (cdr recipe) ","))))
(if obj (oset obj recipe `(extensions . ,@exts)) exts)))
(cl-defmethod dirvish-emerge-read-recipe ((recipe (head predicate)) &optional obj)
"Read RECIPE from user input and optionally save it to OBJ."
(ignore recipe)
(let* ((table dirvish-emerge--available-preds)
(fn (lambda (i)
(let ((item (intern (format "%s" i))))
(concat
(make-string
(- dirvish-emerge--max-pred-name-len (length i) -8) ?\s)
(cddr (assq item table))))))
(coll (dirvish--completion-table-with-metadata
table `((annotation-function . ,fn))))
(pred (completing-read "Predicate: " coll)))
(if obj (oset obj recipe `(predicate . ,(read pred))) (read pred))))
(defsubst dirvish-emerge--make-pred (recipe)
"Make predicate function from RECIPE."
(pcase-let ((`(,type . ,val) recipe))
(pcase type
('regex
`(lambda (local-name _ _ _) (string-match ,val local-name)))
('extensions
(let ((exts (format "\\.\\(%s\\)$" (mapconcat #'concat val "\\|"))))
`(lambda (local-name _ _ _) (string-match ,exts local-name))))
('predicate
(cadr (assq (cdr recipe) dirvish-emerge--available-preds))))))
(defun dirvish-emerge--update-groups (groups)
"Update dir-local groups to GROUPS."
(setq-local dirvish-emerge-groups groups)
(setf (alist-get 'dirvish-emerge-groups
(alist-get
'dirvish-mode
(alist-get (expand-file-name default-directory)
dir-locals-class-alist nil nil #'string=)))
groups))
(defun dirvish-emerge--create-infix
(ifx description recipe &optional selected hide)
"Create an transient infix IFX of emerge group.
DESCRIPTION, RECIPE, SELECTED and HIDE are inserted into the
corresponding slots."
(eval `(transient-define-infix ,ifx ()
:class 'dirvish-emerge-group
:recipe ',recipe
:selected ,selected
:hide ,hide
:description ,description)))
(defun dirvish-emerge--create-infixes ()
"Define and collect emerge groups from `dirvish-emerge-groups'."
(cl-loop with len = (length dirvish-emerge-groups)
for idx from 0
for (desc recipe hide selected) in (seq-take dirvish-emerge-groups 99)
for ifx = (intern (format "dirvish-%s-infix"
(replace-regexp-in-string " " "-" desc)))
for key = (format (if (> len 10) "%02i" "%i") idx)
collect (progn
(dirvish-emerge--create-infix
ifx desc recipe selected hide)
(list key ifx))))
(defun dirvish-emerge--ifx-apply ()
"Apply emerge infixes in `transient-current-suffixes'."
(let* ((ifxes (cl-loop for o in transient-current-suffixes
when (eq (type-of o) 'dirvish-emerge-group)
collect o))
(groups (cl-loop for o in ifxes
collect (list (oref o description) (oref o recipe)
(oref o hide) (oref o selected)))))
(dirvish-emerge-mode 1)
(revert-buffer)
(dirvish-prop :force-emerge t)
(setq-local dirvish-emerge-groups groups)))
(defun dirvish-emerge--ifx-unselect ()
"Unselect selected emerge groups."
(cl-loop for obj in transient-current-suffixes
when (eq (type-of obj) 'dirvish-emerge-group)
do (oset obj selected nil)))
(defun dirvish-emerge--ifx-toggle-hiding ()
"Hide selected emerge groups."
(cl-loop for obj in transient-current-suffixes
when (and (eq (type-of obj) 'dirvish-emerge-group)
(oref obj selected))
do (oset obj hide (not (oref obj hide)))))
(defun dirvish-emerge--ifx-add ()
"Add a new emerge group to `transient-current-suffixes'."
(let ((type (pcase (read-char-choice
"Press e for extensions, p for predicate, r for regex: "
'(?e ?p ?r))
(101 'extensions) (112 'predicate) ('114 'regex)))
(names (mapcar #'car dirvish-emerge-groups))
(groups (buffer-local-value 'dirvish-emerge-groups (current-buffer)))
(idx 1) (default "Anon-1") recipe title)
(while (member default names)
(cl-incf idx)
(setq default (format "Anon-%s" idx)))
(setq recipe (dirvish-emerge-read-recipe (cons type nil)))
(setq title (read-string "Group title: " default))
(push (list title (cons type recipe)) groups)
(dirvish-emerge--update-groups groups)
(dirvish-emerge-menu)))
(defun dirvish-emerge--ifx-remove ()
"Remove an emerge group from `transient-current-suffixes'."
(cl-loop for obj in transient-current-suffixes
when (and (eq (type-of obj) 'dirvish-emerge-group)
(oref obj selected))
do (dirvish-emerge--update-groups
(assoc-delete-all (oref obj description)
dirvish-emerge-groups #'equal)))
(dirvish-emerge-menu))
(defun dirvish-emerge--ifx-promote (&optional demote)
"Shift selected emerge groups the highest position.
If DEMOTE, shift them to the lowest instead."
(cl-loop with sel = ()
for obj in transient-current-suffixes
when (and (eq (type-of obj) 'dirvish-emerge-group)
(oref obj selected))
do (progn (push obj sel)
(setf dirvish-emerge-groups
(assoc-delete-all
(oref obj description)
dirvish-emerge-groups #'equal)))
finally
(let* ((sel (cl-loop for o in (reverse sel) collect
(list (oref o description) (oref o recipe)
(oref o hide) (oref o selected))))
(groups (if demote (append dirvish-emerge-groups sel)
(append sel dirvish-emerge-groups))))
(dirvish-emerge--update-groups groups)))
(dirvish-emerge-menu))
(defun dirvish-emerge--ifx-read ()
"Read groups from .dir-locals.el."
(dirvish-emerge--readin-groups-1 t)
(dirvish-emerge-menu))
(defun dirvish-emerge--ifx-write ()
"Write groups to .dir-locals.el."
(add-dir-local-variable
'dired-mode 'dirvish-emerge-groups
(cl-loop for o in transient-current-suffixes
when (eq (type-of o) 'dirvish-emerge-group) collect
(list (oref o description) (oref o recipe)
(oref o hide) (oref o selected)))))
(defun dirvish-emerge--readin-groups-1 (&optional re-read)
"Helper for `dirvish-emerge--readin-groups'.
When RE-READ, read groups from .dir-locals.el regardless of cache."
(let ((dir-locals-directory-cache
(if re-read nil dir-locals-directory-cache)))
(hack-dir-local-variables))
(let* ((dir-local (cdr (assq 'dirvish-emerge-groups
file-local-variables-alist)))
(groups
(cond (re-read dir-local)
((local-variable-if-set-p 'dirvish-emerge-groups)
(buffer-local-value 'dirvish-emerge-groups (current-buffer)))
(dir-local dir-local)
(t (default-value 'dirvish-emerge-groups)))))
(hack-one-local-variable 'dirvish-emerge-groups groups)
(dirvish-prop :emerge-preds
(cl-loop for idx from 0 to (1- (length groups))
for (_desc recipe) in groups collect
(cons idx (dirvish-emerge--make-pred recipe))))))
(defun dirvish-emerge--readin-groups (&optional _dv _entry buffer)
"Readin emerge groups in BUFFER for session DV."
(with-current-buffer (or buffer (current-buffer))
(dirvish-emerge--readin-groups-1)))
(defvar dirvish-emerge-group-heading-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "TAB") 'dirvish-emerge-toggle-current-group)
map)
"Keymap used when over a group heading.")
(defun dirvish-emerge--group-heading (desc hide)
"Format emerge group heading in Dirvish buffer.
DESC and HIDE are the group title and visibility respectively."
(let ((prefix (propertize " " 'font-lock-face
'(:inherit dirvish-emerge-group-title
:strike-through t)))
(title (propertize (format " %s%s " desc (if hide " (Hidden)" ""))
'font-lock-face 'dirvish-emerge-group-title))
(suffix (propertize " " 'display '(space :align-to right)
'font-lock-face
'(:inherit dirvish-emerge-group-title
:strike-through t))))
(propertize (format "%s%s%s\n" prefix title suffix)
'keymap dirvish-emerge-group-heading-map)))
(defun dirvish-emerge--insert-group (group)
"Insert an individual GROUP to buffer."
(pcase-let* ((`(,idx ,desc ,hide ,files) group)
(beg (point)) (empty nil))
(when (listp files)
(setq empty (not files)
files (mapconcat #'concat (nreverse files) "")))
(unless empty (insert (dirvish-emerge--group-heading desc hide)))
(unless hide (insert files))
(let ((o (make-overlay beg (point))))
(overlay-put o 'evaporate t)
(overlay-put o 'dirvish-emerge
(list idx desc hide (unless empty files) empty))
(push o dirvish-emerge--group-overlays))))
(defun dirvish-emerge--insert-groups (groups &optional pos beg end)
"Insert GROUPS then resume cursor to POS.
POS can be a integer or filename.
BEG and END determine the boundary of groups."
(unless (or beg end)
(setq beg (dirvish-prop :content-begin)
end (- (dired-subdir-max) (if (cdr dired-subdir-alist) 1 0))))
(with-silent-modifications
(setq dirvish-emerge--group-overlays nil)
(delete-region beg end)
(mapc #'dirvish-emerge--insert-group groups)
(setq dirvish-emerge--group-overlays
(nreverse dirvish-emerge--group-overlays)))
(cond ((numberp pos) (goto-char pos))
((stringp pos) (dired-goto-file pos))))
(defun dirvish-emerge--apply-1 (preds)
"Helper for `dirvish-emerge--apply'.
PREDS are locally composed predicates."
(let ((old-file (dirvish-prop :index))
(groups (cl-loop
with grs = (append dirvish-emerge-groups
'(("-" nil nil)))
for i from 0
for (desc _ hide) in grs
collect (list i desc hide '())))
(beg (progn (goto-char (point-min)) (dirvish-prop :content-begin)))
(end (- (dired-subdir-max) (if (cdr dired-subdir-alist) 1 0)))
(max-idx (length preds))
(dir (file-local-name (dired-current-directory))))
(while (< (point) end)
(when-let* ((f-beg (dired-move-to-filename))
(f-end (dired-move-to-end-of-filename)))
(let* ((l-beg (line-beginning-position))
(l-end (1+ (line-end-position)))
(local (buffer-substring-no-properties f-beg f-end))
(full (concat dir local))
(type (dirvish-attribute-cache full :type))
(attrs (dirvish-attribute-cache full :builtin))
(match (cl-loop for (index . fn) in preds
for match = (funcall fn local full type attrs)
thereis (and match index))))
(push (buffer-substring-no-properties l-beg l-end)
(nth 3 (nth (or match max-idx) groups)))))
(forward-line 1))
(dirvish-emerge--insert-groups groups old-file beg end)))
(defun dirvish-emerge--apply ()
"Readin `dirvish-emerge-groups' and apply them."
(when (and (not (dirvish-prop :fd-info))
(or (dirvish-prop :force-emerge)
(< (hash-table-count dirvish--dir-data)
dirvish-emerge-max-file-count)))
(dirvish-emerge--readin-groups)
(when-let* ((preds (dirvish-prop :emerge-preds)))
(dirvish-emerge--apply-1 preds))))
;;;; Interactive commands
;;;###autoload
(defun dirvish-emerge-menu ()
"Manage pinned files in Dirvish."
(interactive)
(dirvish-emerge--readin-groups)
(eval
`(transient-define-prefix dirvish-emerge--menu ()
"Manage pinned files in Dirvish."
[:description
(lambda () (dirvish--format-menu-heading
"Manage Emerging Groups"
"Press the index (like \"1\") to select the group
Press again to set the value for the group"))
["Active groups:"
,@(if dirvish-emerge-groups
(dirvish-emerge--create-infixes)
(list '("+" " Press + to add a group"
(lambda () (interactive) (dirvish-emerge--ifx-add)))))]
["Actions:"
("RET" "Apply current setup" (lambda () (interactive) (dirvish-emerge--ifx-apply)))
("u" " Unselect all groups"
(lambda () (interactive) (dirvish-emerge--ifx-unselect)) :transient t)
("v" " Toggle visibility of selected"
(lambda () (interactive) (dirvish-emerge--ifx-toggle-hiding)) :transient t)
("a" " Add a group"
(lambda () (interactive) (dirvish-emerge--ifx-add)))
("x" " Remove selected groups"
(lambda () (interactive) (dirvish-emerge--ifx-remove)))
("t" " Promote selected groups (top)"
(lambda () (interactive) (dirvish-emerge--ifx-promote)))
("b" " Demote selected groups (bottom)"
(lambda () (interactive) (dirvish-emerge--ifx-promote 'demote)))
("n" " Jump to next group" dirvish-emerge-next-group
:transient t :if (lambda () dirvish-emerge--group-overlays))
("p" " Jump to previous group" dirvish-emerge-previous-group
:transient t :if (lambda () dirvish-emerge--group-overlays))
("r" " Read groups from .dir-locals.el"
(lambda () (interactive) (dirvish-emerge--ifx-read)))
("w" " Write groups to .dir-locals.el"
(lambda () (interactive) (dirvish-emerge--ifx-write)))]]))
(dirvish-emerge--menu))
;;;###autoload
(define-minor-mode dirvish-emerge-mode
"Toggle grouping of files in Dirvish."
:group 'dirvish
(if dirvish-emerge-mode
(progn
(add-hook 'dirvish-setup-hook #'dirvish-emerge--apply nil t)
(unless dirvish-emerge--group-overlays (dirvish-emerge--apply)))
(remove-hook 'dirvish-setup-hook #'dirvish-emerge--apply t)
(mapc #'delete-overlay dirvish-emerge--group-overlays)
(setq dirvish-emerge--group-overlays nil)
(revert-buffer)))
(defun dirvish-emerge--get-group-overlay ()
"Return overlay for the group at point."
(unless dirvish-emerge--group-overlays
(user-error "Dirvish: no groups applied here"))
(let ((pos (point)))
(cl-find-if (lambda (o) (and (overlay-start o)
(< pos (overlay-end o))
(>= pos (overlay-start o))))
dirvish-emerge--group-overlays)))
(defun dirvish-emerge-next-group (arg)
"Jump to the first file in the next ARG visible group."
(interactive "^p")
(let* ((old-ov (dirvish-emerge--get-group-overlay))
(old-idx (cl-position old-ov dirvish-emerge--group-overlays))
(target (+ old-idx arg))
(len (1- (length dirvish-emerge--group-overlays)))
(idx (max (min len target) 0))
(target-ov (nth idx dirvish-emerge--group-overlays)))
(while (and (not (or (>= idx len) (<= idx 0)))
(not (overlay-start target-ov)))
(setq idx (max (min len (+ idx (if (> arg 0) 1 -1))) 0))
(setq target-ov (nth idx dirvish-emerge--group-overlays)))
(cond ((eq old-idx idx))
((and target-ov (overlay-start target-ov))
(goto-char (overlay-start target-ov))))))
(defun dirvish-emerge-previous-group (arg)
"Jump to the first file in the previous ARG visible group."
(interactive "^p")
(dirvish-emerge-next-group (- 0 arg)))
(defun dirvish-emerge-toggle-current-group ()
"Toggle the current group."
(interactive)
(cl-loop
with curr-ov = (dirvish-emerge--get-group-overlay)
with groups = ()
with pos = (if (dirvish-prop :index) (overlay-start curr-ov) (point))
for o in dirvish-emerge--group-overlays
for (idx desc hide files) = (overlay-get o 'dirvish-emerge)
do (when (eq curr-ov o)
(setq hide (not hide))
(let ((group (nth idx dirvish-emerge-groups)))
(if (< (length group) 3)
(cl-callf append group '(t))
(cl-callf not (nth 2 group))))
(when hide
(setq files (buffer-substring
(save-excursion (goto-char (overlay-start o))
(forward-line 1) (point))
(overlay-end o)))))
do (push (list idx desc hide files) groups)
finally (dirvish-emerge--insert-groups (nreverse groups) pos)))
(provide 'dirvish-emerge)
;;; dirvish-emerge.el ends here

441
lisp/dirvish/dirvish-extras.el Normal file
View File

@@ -0,0 +1,441 @@
;;; dirvish-extras.el --- Extra utilities and transient prefixes for 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:
;; Extra utilities and transient prefixes for Dirvish.
;;
;; Commands included:
;; - `dirvish-find-file-true-path'
;; - `dirvish-copy-file-name' (autoload)
;; - `dirvish-copy-file-path' (autoload)
;; - `dirvish-copy-file-directory'
;; - `dirvish-total-file-size' (autoload)
;; - `dirvish-layout-toggle' (autoload)
;; - `dirvish-layout-switch' (autoload)
;; - `dirvish-rename-space-to-underscore'
;;
;; Transient prefixes included (all autoloaded):
;; - `dirvish-file-info-menu'
;; - `dirvish-renaming-menu'
;; - `dirvish-subdir-menu'
;; - `dirvish-chxxx-menu'
;; - `dirvish-mark-menu'
;; - `dirvish-epa-dired-menu'
;; - `dirvish-setup-menu'
;; - `dirvish-dired-cheatsheet'
;; - `dirvish-dispatch'
;;; Code:
(require 'dirvish)
(require 'transient)
(declare-function tramp-file-name-user "tramp")
(declare-function tramp-file-name-host "tramp")
(defcustom dirvish-layout-recipes
'((0 0 0.4) ; | CURRENT | preview
(0 0 0.8) ; | current | PREVIEW
(1 0.08 0.8) ; parent | current | PREVIEW
(1 0.11 0.55)) ; parent | current | preview
"Layout RECIPEs for `dirvish-layout-switch' command.
RECIPE has the same form as `dirvish-default-layout'."
:group 'dirvish
:type '(repeat (list (integer :tag "number of parent windows")
(float :tag "max width of parent windows")
(float :tag "width of preview window"))))
(defclass dirvish-attribute-set (transient-infix)
((variable :initarg :variable))
"Class for dirvish attributes.")
(cl-defmethod transient-format-description ((obj dirvish-attribute-set))
"Format description for DIRVISH-ATTRIBUTE instance OBJ."
(format "%s%s" (oref obj description)
(propertize " " 'display '(space :align-to (- right 5)))))
(cl-defmethod transient-format-value ((obj dirvish-attribute-set))
"Format value for DIRVISH-ATTRIBUTE instance OBJ."
(let* ((val (oref obj value))
(face (if (equal val "+") 'transient-argument 'transient-inactive-value)))
(propertize val 'face face)))
(cl-defmethod transient-init-value ((obj dirvish-attribute-set))
"Initialize value for DIRVISH-ATTRIBUTE instance OBJ."
(let ((sym (oref obj variable))
(attrs (mapcar #'car (dirvish-prop :attrs))))
(oset obj value (if (memq sym attrs) "+" "-"))))
(cl-defmethod transient-infix-read ((obj dirvish-attribute-set))
"Read value from DIRVISH-ATTRIBUTE instance OBJ."
(oset obj value (if (equal (oref obj value) "+") "-" "+")))
(cl-defmethod transient-infix-set ((obj dirvish-attribute-set) value)
"Set relevant value in DIRVISH-ATTRIBUTE instance OBJ to VALUE."
(mapc #'require '(dirvish-widgets dirvish-vc dirvish-collapse))
(let* ((item (oref obj variable))
(old-val (mapcar #'car (dirvish-prop :attrs)))
(new-val (if (equal value "+") (cl-pushnew item old-val)
(remove item old-val))))
(dirvish-prop :attrs (dirvish--attrs-expand new-val))))
;;;###autoload (autoload 'dirvish-setup-menu "dirvish-extras" nil t)
(defcustom dirvish-ui-setup-items
'(("s" file-size "File size")
("t" file-time "File modification time")
("m" file-modes "File modes")
("c" collapse "Collapse unique nested paths"
(not (dirvish-prop :remote)))
("v" vc-state "Version control state"
(and (display-graphic-p) (symbolp (dirvish-prop :vc-backend))))
("l" git-msg "Git commit's short log"
(and (symbolp (dirvish-prop :vc-backend)) (not (dirvish-prop :remote))))
("1" '(0 nil 0.4) " - | current (60%) | preview (40%)")
("2" '(0 nil 0.8) " - | current (20%) | preview (80%)")
("3" '(1 0.08 0.8) "parent (8%) | current (12%) | preview (80%)")
("4" '(1 0.11 0.55) "parent (11%) | current (33%) | preview (55%)"))
"ITEMs for `dirvish-setup-menu'.
A ITEM is a list consists of (KEY VAR DESC PRED) where KEY is the
keybinding for the item, VAR can be a valid `dirvish-attributes'
or a layout recipe (see `dirvish-layout-recipes'), DESC is the
documentation for the VAR. The optional PRED is passed as the
predicate for that infix."
:group 'dirvish :type 'alist
:set
(lambda (key value)
(set key value)
(cl-loop
with (attrs . layouts) = ()
for (k v desc pred) in value
for name = (and (symbolp v) (intern (format "dirvish-%s-infix" v)))
do (if (not name)
(push (list k (propertize desc 'face 'font-lock-doc-face)
`(lambda () (interactive) (dirvish-layout-switch ,v)))
layouts)
(eval `(transient-define-infix ,name ()
:class 'dirvish-attribute-set :variable ',v
:description ,desc :if (lambda () ,(if pred `,@pred t))))
(push (list k name) attrs))
finally
(eval
`(transient-define-prefix dirvish-setup-menu ()
"Configure current Dirvish session."
[:description (lambda () (dirvish--format-menu-heading "Setup Dirvish UI"))
["Attributes:" ,@attrs]]
["Switch layouts:"
:if (lambda () (dv-curr-layout (dirvish-curr))) ,@layouts]
["Actions:"
("f" "Toggle fullscreen" dirvish-layout-toggle)
("a" "Apply current settings to future sessions"
(lambda () (interactive)
(let* ((dv (dirvish-curr)) (tp (dv-type dv)) (dft (eq tp 'default))
(attr-sym (or (and dft 'dirvish-attributes)
(intern (format "dirvish-%s-attributes" tp))))
(attrs (mapcar #'car (dirvish-prop :attrs))))
(when (boundp attr-sym) (set-default attr-sym attrs))
(setq dirvish-default-layout (dv-ff-layout dv))
(dirvish--build-layout (dirvish-curr))
(revert-buffer))))]
(interactive)
(if (dirvish-curr) (transient-setup 'dirvish-setup-menu)
(user-error "Not in a Dirvish buffer")))))))
(defun dirvish-find-file-true-path ()
"Open truename of (maybe) symlink file under the cursor."
(interactive)
(dired-jump nil (file-truename (dired-get-filename nil t))))
(defun dirvish--kill-and-echo (string)
"Echo last killed STRING."
(kill-new string)
(let ((hint (propertize
"Copied: " 'face 'font-lock-builtin-face)))
(message "%s" (format "%s%s" hint string))))
(defun dirvish-copy-file-true-path ()
"Copy truename of (maybe) symlink file under the cursor."
(interactive)
(dirvish--kill-and-echo
(file-truename (dired-get-filename nil t))))
;;;###autoload
(defun dirvish-copy-file-name (&optional multi-line)
"Copy filename of marked files.
If MULTI-LINE, make every name occupy a new line."
(interactive "P")
(let* ((files (dired-get-marked-files t))
(names (mapconcat #'concat files (if multi-line "\n" " "))))
(dirvish--kill-and-echo (if multi-line (concat "\n" names) names))))
;;;###autoload
(defun dirvish-copy-file-path (&optional multi-line)
"Copy filepath of marked files.
If MULTI-LINE, make every path occupy a new line."
(interactive "P")
(let* ((files (mapcar #'file-local-name (dired-get-marked-files)))
(names (mapconcat #'concat files (if multi-line "\n" " "))))
(dirvish--kill-and-echo (if multi-line (concat "\n" names) names))))
(defun dirvish-copy-remote-path (&optional multi-line)
"Copy remote path of marked files.
If MULTI-LINE, every file takes a whole line."
(interactive "P")
(let* ((tramp (or (dirvish-prop :tramp)
(user-error "Not a remote folder")))
(files (cl-loop for file in (dired-get-marked-files)
for user = (tramp-file-name-user tramp)
for host = (tramp-file-name-host tramp)
for localname = (file-local-name file)
collect (format "%s%s%s:%s" (or user "")
(if user "@" "") host localname)))
(names (mapconcat #'concat files (if multi-line "\n" " "))))
(dirvish--kill-and-echo (if multi-line (concat "\n" names) names))))
(defun dirvish-copy-file-directory ()
"Copy directory name of file under the cursor."
(interactive)
(dirvish--kill-and-echo
(expand-file-name default-directory)))
;;;###autoload
(defun dirvish-total-file-size (&optional fileset)
"Echo total file size of FILESET.
FILESET defaults to `dired-get-marked-files'."
(interactive)
(cl-labels ((f-name (f) (if (not (file-directory-p f)) f
(directory-files-recursively f ".*" nil t)))
(f-size (f) (condition-case nil
(file-attribute-size (file-attributes f))
(file-error 0))))
(let* ((fileset (or fileset (dired-get-marked-files)))
(count (propertize (number-to-string (length fileset))
'face 'font-lock-builtin-face))
(size (thread-last fileset (mapcar #'f-name) flatten-tree
(mapcar #'f-size) (cl-reduce #'+)
file-size-human-readable)))
(message "%s" (format "Total size of %s entries: %s" count size)))))
;;;###autoload
(defun dirvish-layout-switch (&optional recipe)
"Switch Dirvish layout according to RECIPE.
If RECIPE is not provided, switch to the recipe next to the
current layout defined in `dirvish-layout-recipes'."
(interactive)
(cl-loop
with dv = (let ((dv (dirvish-curr)))
(unless dv (user-error "Not in a Dirvish session"))
(unless (dv-curr-layout dv)
(dirvish-layout-toggle)
(user-error "Dirvish: entering fullscreen")) dv)
with old-recipe = (dv-curr-layout dv)
with recipes = (if recipe (list recipe) dirvish-layout-recipes)
with l-length = (length recipes)
for idx from 1
for recipe in recipes
when (or (eq idx l-length) (equal old-recipe recipe))
return
(let* ((new-idx (if (> idx (1- l-length)) 0 idx))
(new-recipe (nth new-idx recipes)))
(setf (dv-curr-layout dv) new-recipe)
(setf (dv-ff-layout dv) new-recipe)
(dirvish--build-layout dv))))
(defun dirvish-rename-space-to-underscore ()
"Rename marked files by replacing space to underscore."
(interactive)
(require 'dired-aux)
(if (derived-mode-p 'dired-mode)
(let ((markedFiles (dired-get-marked-files )))
(mapc (lambda (x)
(when (string-match " " x )
(dired-rename-file x (replace-regexp-in-string " " "_" x) nil)))
markedFiles)
(revert-buffer))
(user-error "Not in a Dired buffer")))
(defun dirvish--marked-files-as-info-string ()
"Return all marked files as a string."
(let* ((files (dired-get-marked-files t))
(count (length files)))
(cond ((<= count 1)
(format "current file: %s" (dired-get-filename t t)))
((<= count 10)
(format "marked files:\n %s" (mapconcat #'concat files "\n ")))
(t (format "marked files:\n %s\n ... and %s more (%s in total)"
(mapconcat #'concat (seq-take files 10) "\n ")
(- count 10) count)))))
;;;###autoload (autoload 'dirvish-file-info-menu "dirvish-extras" nil t)
(transient-define-prefix dirvish-file-info-menu ()
"Gather file information."
[:description
(lambda () (dirvish--format-menu-heading
"Get File Information"
(dirvish--marked-files-as-info-string)))
("n" "Copy file NAMEs in one line <n> / multiple lines <C-u n>"
dirvish-copy-file-name)
("p" "Copy file PATHs in one line <p> / multiple lines <C-u p>"
dirvish-copy-file-path)
("P" "Copy remote PATHs in one line <P> / multiple lines <C-u P>"
dirvish-copy-remote-path
:if (lambda () (dirvish-prop :remote)))
("d" "Copy file DIRECTORY" dirvish-copy-file-directory)
("l" "Copy symlink's truename" dirvish-copy-file-true-path
:if (lambda () (file-symlink-p (dired-get-filename nil t))))
("L" "Go to symlink's truename" dirvish-find-file-true-path
:if (lambda () (file-symlink-p (dired-get-filename nil t))))
("s" "Get total size of marked files" dirvish-total-file-size)
("t" "Show file TYPE" dired-show-file-type)])
(transient-define-prefix dirvish-subdir-menu ()
"Help Menu for Dired subdir management."
[:description
(lambda () (dirvish--format-menu-heading "Manage subdirs"))
("i" " Insert subdir" dired-maybe-insert-subdir :transient t)
("k" " Kill subdir" dired-kill-subdir :transient t)
("n" " Next subdir" dired-next-subdir :transient t)
("p" " Prev subdir" dired-prev-subdir :transient t)
("j" " Jump to subdir" dired-goto-subdir)
("$" " Hide subdir" dired-hide-subdir :transient t)
("M-$" "Hide all subdirs" dired-hide-all)])
;;;###autoload (autoload 'dirvish-chxxx-menu "dirvish-extras" nil t)
(transient-define-prefix dirvish-chxxx-menu ()
"Help Menu for file attribute modification commands."
[:description
(lambda () (dirvish--format-menu-heading "Modify file's attributes"))
("g" "Change file's GROUP" dired-do-chgrp)
("m" "Change file's MODE" dired-do-chmod)
("o" "Change file's OWNER" dired-do-chown)
("t" "Change file's TIMESTAMP" dired-do-touch)
("p" "Change file's PATH" dired-do-rename)])
;;;###autoload (autoload 'dirvish-mark-menu "dirvish-extras" nil t)
(transient-define-prefix dirvish-mark-menu ()
"Help Menu for `dired-mark/do-*' commands."
[["Mark or unmark files:"
("e" " by Extension" dired-mark-extension :transient t)
("*" " by Regexp (file name)" dired-mark-files-regexp :transient t)
("c" " by Regexp (file content)" dired-mark-files-containing-regexp :transient t)
("s" " by Subdir" dired-mark-subdir-files :transient t)
("x" " by Executable" dired-mark-executables :transient t)
("/" " by Directory" dired-mark-directories :transient t)
("@" " by Symlink" dired-mark-symlinks :transient t)
("&" " by Garbage" dired-flag-garbage-files :transient t)
("#" " by Auto-saved" dired-flag-auto-save-files :transient t)
("~" " by Backup" dired-flag-backup-files :transient t)
("." " by Numerical backup" dired-clean-directory :transient t)
("u" " Unmark this file" dired-unmark :transient t)
("DEL" "Unmark and move up line" dired-unmark-backward :transient t)
("U" " Unmark all files" dired-unmark-all-files :transient t)
("t" " Toggle marks" dired-toggle-marks :transient t)
("n" " Move to next marked file" dired-next-marked-file :transient t)
("p" " Move to prev marked file" dired-prev-marked-file :transient t)]
["Actions on marked files:"
("O" "Open" dired-do-find-marked-files)
("S" "Symlink" dired-do-symlink)
("H" "Hardlink" dired-do-hardlink)
("P" "Print" dired-do-print)
("X" "Delete flagged" dired-do-flagged-delete)
("r" "Search file contents" dired-do-find-regexp)
("R" "Replace file contents" dired-do-find-regexp-and-replace)
("B" "Byte compile elisp" dired-do-byte-compile)
("L" "Load elisp" dired-do-load)
("z" "Compress to" dired-do-compress-to)
("Z" "Compress" dired-do-compress)
("!" "Shell command" dired-do-shell-command)
("&" "Async shell command" dired-do-async-shell-command)
("N" "Echo number of marked files" dired-number-of-marked-files)
("A" "Modify file's attributes" dirvish-chxxx-menu)
("C" "Change mark type" dired-change-marks)
("k" "Kill lines" dired-do-kill-lines)]]
(interactive)
(require 'dired-x)
(require 'dired-aux)
(transient-setup 'dirvish-mark-menu))
;;;###autoload (autoload 'dirvish-renaming-menu "dirvish-extras" nil t)
(transient-define-prefix dirvish-renaming-menu ()
"Help Menu for file renaming in Dired."
[:description
(lambda () (dirvish--format-menu-heading "File renaming"))
("u" "Upper-case file name" dired-upcase)
("l" "Lower-case file name" dired-downcase)
("_" "Replace SPC with UNDERSCORE" dirvish-rename-space-to-underscore :if-derived 'dirvish-mode)
("w" "Enter wdired [writable dired]" wdired-change-to-wdired-mode :if-not-derived wdired-mode)])
(transient-define-prefix dirvish-epa-dired-menu ()
"Help menu for `epa-dired-do-*' commands."
[:description
(lambda () (dirvish--format-menu-heading "GNUpg assistant"))
("e" "Encrypt" epa-dired-do-encrypt)
("d" "Decrypt" epa-dired-do-decrypt)
("v" "Verify" epa-dired-do-verify)
("s" "Sign" epa-dired-do-sign)])
;;;###autoload (autoload 'dirvish-dired-cheatsheet "dirvish-extras" nil t)
(transient-define-prefix dirvish-dired-cheatsheet ()
"A collection of most frequently used Dired commands."
[:description
(lambda () (dirvish--format-menu-heading
"Dired cheatsheet"
"The keys listed here may be different from the actual bindings"))
("n" " Move to next line" dired-next-line :transient t)
("p" " Move to prev line" dired-previous-line :transient t)
(">" " Move to next dirline" dired-next-dirline :transient t)
("<" " Move to prev dirline" dired-prev-dirline :transient t)
("." " Add an empty file" dired-create-empty-file)
("+" " Add a directory" dired-create-directory)
("X" " Delete files" dired-do-delete)
("v" " View this file" dired-view-file)
("g" " Refresh buffer" revert-buffer)
("f" " Find file" dired-find-file)
("o" " Find file other window" dired-find-file-other-window)
("j" " Go to line for file" dired-goto-file)
("^" " Go to parent directory" dired-up-directory)
("=" " Compare files" dired-diff)
("(" " Toggle details" dired-hide-details-mode)
("d" " Display this file" dired-display-file)
("s" " Manage subdirs" dirvish-subdir-menu)
(":" " GnuPG helpers" dirvish-epa-dired-menu)
("h" " More info about Dired" describe-mode)])
;;;###autoload (autoload 'dirvish-dispatch "dirvish-extras" nil t)
(transient-define-prefix dirvish-dispatch ()
"Main menu for Dired/Dirvish."
[:description
(lambda () (dirvish--format-menu-heading
"Dirvish main menu"
"NOTICE: these commands require relevant Dirvish extensions")
(declare-function dirvish-narrow "dirvish-narrow"))
"" "Actions & Essential commands"
("u" "User interface setup" dirvish-setup-menu)
("c" "Dired cheatsheet" dirvish-dired-cheatsheet)
("/" "Run fd search here" dirvish-fd)
("#" "Search everything in ~" (lambda () (interactive)
(dirvish-fd "~" "") (dirvish-narrow)))
("R" "Rsync marked files" dirvish-rsync)
("n" "Live narrowing" dirvish-narrow)
"Transient commands"
("a" "Quick access" dirvish-quick-access)
("h" "Go to history entries" dirvish-history-menu)
("s" "Sort current buffer" dirvish-quicksort)
("l" "Setup listing switches" dirvish-ls-switches-menu)
("f" "Setup fd-find switches" dirvish-fd-switches-menu
:if (lambda () (dirvish-prop :fd-info)))
("S" "Setup rsync switches" dirvish-rsync-switches-menu)
("m" "Manage marks" dirvish-mark-menu)
("e" "Manage emerged groups" dirvish-emerge-menu)
("t" "Manage subtrees" dirvish-subtree-menu)
("r" "Rename files" dirvish-renaming-menu)
("v" "Version control system" dirvish-vc-menu)
("y" "Yank marked files" dirvish-yank-menu)
("i" "Get file information" dirvish-file-info-menu)])
(provide 'dirvish-extras)
;;; dirvish-extras.el ends here

334
lisp/dirvish/dirvish-fd.el Normal file
View File

@@ -0,0 +1,334 @@
;;; dirvish-fd.el --- find-dired alternative using fd -*- 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:
;; `fd' integration for Dirvish.
;;; Code:
(require 'dirvish)
(require 'transient)
(defcustom dirvish-fd-switches ""
"Fd arguments inserted before user input."
:type 'string :group 'dirvish)
(defun dirvish-fd--find-fd-program (&optional remote)
"Find fd programm on a local or REMOTE host ."
(let ((fd (executable-find "fd" remote))
(fdfind (executable-find "fdfind" remote)))
(cond (fd fd)
(fdfind fdfind)
(t nil))))
(defcustom dirvish-fd-program
(dirvish-fd--find-fd-program)
"The default fd program."
:type 'string :group 'dirvish)
(defcustom dirvish-fd-setup-hook nil
"Functions called after the `fd` process exits successfully."
:type 'hook :group 'dirvish)
(defun dirvish-fd--find-gnu-ls (&optional remote)
"Find ls from gnu coreutils on a local or REMOTE host ."
(let* ((ls (executable-find "ls" remote))
(gls (executable-find "gls" remote))
(idp (executable-find insert-directory-program remote))
(ls-is-gnu? (and ls (= 0 (process-file ls nil nil nil "--version"))))
(idp-is-gnu-ls?
(and idp (= 0 (process-file idp nil nil nil "--version")))))
(cond
;; just use GNU ls if found
(ls-is-gnu? ls)
;; use insert-directory-program if it points to GNU ls
(idp-is-gnu-ls? insert-directory-program)
;; heuristic: GNU ls is often installed as gls by Homebrew on Mac
((and (eq system-type 'darwin) gls) gls)
;; fallback: use insert-directory-program, but warn the user that it may not be compatible
(t (warn "`dirvish-fd' requires `ls' from GNU coreutils, please install it")
insert-directory-program))))
(defcustom dirvish-fd-ls-program
(dirvish-fd--find-gnu-ls)
"Listing program for `fd'."
:type '(string :tag "Listing program, such as `ls'") :group 'dirvish)
(defcustom dirvish-fd-header-line-format '(:left (fd-info) :right (fd-status))
"Header line format for `dirvish-fd'."
:group 'dirvish :type 'plist)
(defun dirvish-fd--ensure-fd (remote)
"Return fd executable on REMOTE or localhost.
Raise an error if fd executable is not available."
(or (and remote (dirvish-fd--find-fd-program remote)) dirvish-fd-program
(user-error "`dirvish-fd' requires `fd', please install it")))
(defun dirvish-fd--apply-switches ()
"Apply fd SWITCHES to current buffer."
(interactive)
(cl-loop with (re . args) = nil
for arg in (transient-args transient-current-command)
if (string-prefix-p "--and=" arg) do (push arg re)
else do (push arg args)
finally do (dirvish-fd--argparser re args))
(revert-buffer))
(transient-define-infix dirvish-fd--extensions-switch ()
:description "Filter results by file extensions"
:class 'transient-option
:argument "--extension="
:multi-value 'repeat)
(transient-define-infix dirvish-fd--exclude-switch ()
:description "Exclude files/dirs that match the glob pattern"
:class 'transient-option
:argument "--exclude="
:multi-value 'repeat)
(transient-define-infix dirvish-fd--search-pattern-infix ()
:description "Change search patterns"
:class 'transient-option
:argument "--and="
:multi-value 'repeat)
;;;###autoload (autoload 'dirvish-fd-switches-menu "dirvish-fd" nil t)
(transient-define-prefix dirvish-fd-switches-menu ()
"Setup fd switches."
:init-value (lambda (o) (let ((args (dirvish-prop :fd-info)))
(oset o value (append (cadr args) (cddr args)))))
[:description
(lambda () (dirvish--format-menu-heading
"Setup FD Switches"
"Ignore Range [by default ignore ALL]
VCS: .gitignore + .git/info/exclude + $HOME/.config/git/ignore
ALL: VCS + .ignore + .fdignore + $HOME/.config/fd/ignore"))
["File types (multiple types can be included)"
(3 "f" " Search for regular files" "--type=file")
(3 "d" " Search for directories" "--type=directory")
(3 "l" " Search for symbolic links" "--type=symlink")
(3 "s" " Search for sockets" "--type=socket")
(3 "p" " Search for named pipes" "--type=pipe")
(3 "x" " Search for executable" "--type=executable")
(3 "e" " Search for empty files or directories" "--type=empty")
""
"Toggles"
(3 "-H" "Include hidden files|dirs in the results" "--hidden")
(3 "-I" "Show results from ALL" "--no-ignore")
(4 "iv" "Show results from VCS" "--no-ignore-vcs")
(5 "ip" "Show results from .gitignore in parent dirs" "--no-ignore-parent")
(3 "-s" "Perform a case-sensitive search" "--case-sensitive")
(4 "-g" "Perform a glob-based (rather than regex-based) search" "--glob")
(4 "-F" "Treat the pattern as a literal string" "--fixed-strings")
(4 "-L" "Traverse symbolic links" "--follow")
(4 "-p" "Let the pattern match against the full path" "--full-path")
(5 "mr" "Maximum number of search results" "--max-results")
(5 "mt" "Do not descend into a different file systems" "--mount")
(5 "P" " Do not traverse into matching directories" "--prune")
""
"Options"
(4 "-e" dirvish-fd--extensions-switch)
(4 "-E" dirvish-fd--exclude-switch)
(4 "-D" "Max level for directory traversing" "--max-depth=")
(5 "-d" "Only show results starting at the depth" "--mix-depth=")
(5 "gd" "Only show results starting at the exact given depth" "--exact-depth=")
(5 "if" "Add a custom ignore-file in '.gitignore' format" "--ignore-file="
:reader (lambda (_prompt _init _hist) (read-file-name "Choose ignore file: ")))
(5 "-S" "Limit results based on the size of files" "--size="
:reader (lambda (_prompt _init _hist)
(read-string "Input file size using the format <+-><NUM><UNIT> (eg. +100m): ")))
(5 "cn" "Filter results based on the file mtime newer than" "--changed-within="
:reader (lambda (_prompt _init _hist)
(read-string "Input a duration (10h, 1d, 35min) or a time point (2018-10-27 10:00:00): ")))
(5 "co" "Filter results based on the file mtime older than" "--changed-before="
:reader (lambda (_prompt _init _hist)
(read-string "Input a duration (10h, 1d, 35min) or a time point (2018-10-27 10:00:00): ")))
(6 "-o" "Filter files by their user and/or group" "--owner="
:reader (lambda (_prompt _init _hist)
(read-string "user|uid:group|gid - eg. john, :students, !john:students ('!' means to exclude files instead): ")))
""
"Actions"
("r" dirvish-fd--search-pattern-infix)
("RET" "Rerun" dirvish-fd--apply-switches)]])
(defun dirvish-fd--argparser (re args)
"Parse fd args to a list of flags from ARGS and search regexp RE."
(let* ((globp (member "--glob" args))
(casep (member "--case-sensitive" args))
(ign (cond ((member "--no-ignore" args) "no")
((member "--no-ignore-vcs" args) "no_vcs")
(t "all")))
(status (propertize " ● " 'face 'dirvish-proc-running))
comp types exts exc)
(dolist (arg args)
(cond ((string-prefix-p "--type=" arg) (push (substring arg 7) types))
((string-prefix-p "--extension=" arg) (push (substring arg 12) exts))
((string-prefix-p "--exclude=" arg) (push (substring arg 10) exc))))
(dolist (r re) (push (substring r 6) comp))
(setq types (mapconcat #'concat types ","))
(setq exts (mapconcat #'concat exts ","))
(setq exc (mapconcat #'concat exc ","))
(setq comp (mapconcat #'concat comp ","))
(dirvish-prop :fd-info
(cons (list comp globp casep ign types exts exc status) (cons re args)))))
(dirvish-define-mode-line fd-info
"Return a formatted string showing the actual fd command line arguments."
(pcase-let ((`(,re ,globp ,casep ,ign-range ,types ,exts ,excludes ,_)
(car (dirvish-prop :fd-info)))
(face (if (dirvish--selected-p) 'dired-header 'dirvish-inactive)))
(format " 🔍 ⋗ %s [ %s \"%s\" | %s %s | %s %s | %s %s | %s %s | %s %s ]"
(propertize
(abbreviate-file-name (directory-file-name default-directory))
'face 'dired-directory)
(propertize (if globp "glob:" "regex:") 'face face)
(propertize (or re "")
'face 'font-lock-regexp-grouping-construct)
(propertize "type:" 'face face)
(propertize (if (equal types "") "all" types)
'face 'font-lock-variable-name-face)
(propertize "case:" 'face face)
(propertize (if casep "sensitive" "smart")
'face 'font-lock-type-face)
(propertize "ignore:" 'face face)
(propertize ign-range 'face 'font-lock-comment-face)
(propertize "exts:" 'face face)
(propertize (if (equal exts "") "all" exts)
'face 'font-lock-string-face)
(propertize "excludes:" 'face face)
(propertize (if (equal excludes "") "none" excludes)
'face 'font-lock-variable-name-face))))
(dirvish-define-mode-line fd-status
"Status and time took by last fd search."
(car (last (car (dirvish-prop :fd-info)))))
(defun dirvish-fd--proc-filter (proc string)
"Filter for output STRING of `dirvish-fd''s process PROC."
(when-let* (((buffer-name (process-buffer proc)))
(target (process-get proc 'target)) ((buffer-live-p target)))
(with-current-buffer target
(save-excursion
(save-restriction
(widen)
(goto-char (cdar dired-subdir-alist)) (goto-char (dired-subdir-max))
(cl-loop
with buffer-read-only = nil
with (_ regexps case-fold-search) = (dirvish-prop :narrow-info)
with string = (concat (process-get proc 'tail) string)
with splits = (split-string string "\n" t)
with tail = (car (last splits))
with comp? = (string-suffix-p "\n" string)
for file in (if comp? splits (butlast splits))
for f-beg = (string-match " ./" file)
for f-name = (substring file (+ f-beg 3))
for f-line = (concat " " (substring file 0 f-beg) " " f-name "\n")
do (if (not regexps) (insert f-line)
(cl-loop for re in regexps
unless (string-match re f-name) return nil
finally do (insert f-line)))
finally do (process-put proc 'tail (unless comp? tail))))))))
(defun dirvish-fd--proc-sentinel (proc status)
"Sentinel for `dirvish-fd' process PROC and its STATUS."
(when-let* (((buffer-live-p (process-buffer proc)))
(took (float-time (time-since (process-get proc 'start))))
(target (process-get proc 'target)) ((buffer-live-p target)))
(setq took (if (< took 1.0) (format "%s ms" (round took 0.001))
(format "%s secs" (/ (round took 0.001) 1000.0))))
(with-current-buffer target
(setf (car (last (car (dirvish-prop :fd-info))))
(cond ((string-prefix-p "killed" status)
(propertize " ● " 'face 'dirvish-proc-failed))
((string-prefix-p "finished" status)
(propertize (format "%s ● " took)
'face 'dirvish-proc-finished))
(t (propertize " ● " 'face 'dirvish-proc-failed))))
(run-hooks 'dirvish-fd-setup-hook))
(force-mode-line-update t)))
(defun dirvish-fd--start-proc ()
"Start fd process."
(let* ((remote (file-remote-p default-directory))
(fd (dirvish-fd--ensure-fd remote))
(ls (dirvish-fd--find-gnu-ls remote))
(fd-args (dirvish-prop :fd-info))
(buf (get-buffer-create "*dirvish-fd*"))
process-connection-type proc)
(when-let* ((op (get-buffer-process buf))) (delete-process op))
(setq proc (apply #'start-file-process "fd" buf
`(,fd "--color=never" ,@(cddr fd-args) ,@(cadr fd-args)
"--exec-batch" ,ls
,@(or (split-string dired-actual-switches) "")
"--quoting-style=literal" "--directory")))
(set-process-filter proc #'dirvish-fd--proc-filter)
(set-process-sentinel proc #'dirvish-fd--proc-sentinel)
(set-process-query-on-exit-flag proc nil)
(process-put proc 'start (float-time))
(process-put proc 'target (current-buffer))))
(defun dirvish-fd-noselect (dv dir pattern)
"Return the fd buffer for DV at DIR with search PATTERN."
(let* ((re (mapcan (lambda (x) `(,(format "--and=%s" x)))
(if (stringp pattern) (split-string pattern ",") pattern)))
(ls-switches (or dired-actual-switches (dv-ls-switches dv)))
(key (file-name-nondirectory (directory-file-name dir)))
(query (if (stringp pattern) pattern (mapconcat #'concat pattern ",")))
(buf (get-buffer-create (concat key "🔍" query "🔍" (dv-id dv))))
(fd (dirvish-prop :fd-info)) (re (or re (cadr fd)))
(switches (or (cddr fd) (split-string dirvish-fd-switches))))
(with-current-buffer buf
(let (buffer-read-only)
(erase-buffer)
(insert " " dir ":" (make-string (dirvish--subdir-offset) ?\n)))
(unless (derived-mode-p 'dired-mode)
(let (dired-buffers) (dired-mode dir ls-switches)))
(setq-local default-directory dir
dired-subdir-alist (list (cons dir (point-min-marker))))
(dirvish-fd--argparser re switches)
(dirvish-prop :revert
(lambda (&rest _)
(setq dired-subdir-alist (list (car (reverse dired-subdir-alist))))
(let (buffer-read-only)
(buffer-disable-undo)
(delete-region (goto-char (dirvish-prop :content-begin)) (point-max)))
(buffer-enable-undo)
(dirvish-fd--start-proc)))
(let* ((fmt dirvish-fd-header-line-format)
(l (plist-get fmt :left)) (r (plist-get fmt :right)))
(dirvish-prop :cus-header (dirvish--mode-line-composer l r t)))
(dirvish-prop :global-header t)
(dirvish--setup-dired)
(dirvish-fd--start-proc) buf)))
;;;###autoload
(defun dirvish-fd (dir pattern)
"Run `fd' on DIR and go into Dired mode on a buffer of the output.
The command run is essentially:
fd --color=never `dirvish-fd-switches'
--and PATTERN [--and PATTERN1 --and PATTERN2 … ]
--exec-batch `dirvish-fd-ls-program' `dired-listing-switches' --directory
If called with \\`C-u', prompt for the target directory,
`default-directory' is used. If prefixed with \\`C-u' twice, also
prompt for the search regex PATTERN as a comma separated list."
(interactive (list (and current-prefix-arg
(read-directory-name "Fd target directory: " nil "" t))
(and (equal current-prefix-arg '(16))
(completing-read-multiple "Pattern: " nil))))
(let* ((dir (or dir default-directory))
(buf (dirvish-dired-noselect-a nil dir nil (or pattern "")))
(dv (with-current-buffer buf (dirvish-curr))))
(dirvish-save-dedication (switch-to-buffer buf) (dirvish--build-layout dv))))
(define-obsolete-function-alias 'dirvish-fd-ask #'dirvish-fd "Apr 4, 2025")
(provide 'dirvish-fd)
;;; dirvish-fd.el ends here

99
lisp/dirvish/dirvish-history.el Normal file
View File

@@ -0,0 +1,99 @@
;;; dirvish-history.el --- History navigation commands 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:
;; History navigation commands in Dirvish.
;;; Code:
(require 'dirvish)
(require 'transient)
(defcustom dirvish-history-sort-function #'dirvish-history--sort-by-atime
"Function used to sort history entries for `dirvish-history-jump'."
:group 'dirvish :type 'function)
(defun dirvish-history--sort-by-atime (file-list)
"Sort the FILE-LIST by access time, from most recent to least recent."
(thread-last
file-list
;; Use modification time, since getting file access time seems to count as
;; accessing the file, ruining future uses.
(mapcar (lambda (f) (cons f (file-attribute-access-time (file-attributes f)))))
(seq-sort (pcase-lambda (`(,f1 . ,t1) `(,f2 . ,t2))
;; Want existing, most recent, local files first.
(cond ((or (not (file-exists-p f1)) (file-remote-p f1)) nil)
((or (not (file-exists-p f2)) (file-remote-p f2)) t)
(t (time-less-p t2 t1)))))
(mapcar #'car)))
;;;###autoload
(defun dirvish-history-jump ()
"Read a recently visited directory from minibuffer and revisit it."
(interactive)
(unless dired-buffers (user-error "Dirvish[error]: no history entries"))
(when-let* ((result
(completing-read
"Recently visited: "
(dirvish--completion-table-with-metadata
(mapcar #'car dired-buffers)
`((category . file)
(display-sort-function . ,dirvish-history-sort-function))))))
(dirvish--find-entry 'find-file result)))
;;;###autoload
(defun dirvish-history-last ()
"Switch to the most recently visited dirvish buffer."
(interactive)
(unless dired-buffers (user-error "Dirvish[error]: no history entries"))
(let ((match
(cl-loop
with local-entries = (mapcar #'car (dv-roots (dirvish-curr)))
for entry in (mapcar #'car dired-buffers)
thereis (and (member entry local-entries)
(not (equal entry (dired-current-directory))) entry))))
(and match (dirvish--find-entry 'find-file match))))
;;;###autoload
(defun dirvish-history-go-forward (arg)
"Navigate to next ARG directory in history.
ARG defaults to 1."
(interactive "^p")
(let* ((dv (or (dirvish-curr) (user-error "Not in a dirvish session")))
(bufs (reverse (mapcar #'cdr (dv-roots dv))))
(len (length bufs))
(idx (cl-position (cdr (dv-index dv)) bufs))
(new-idx (+ idx arg)))
(cond ((>= new-idx len)
(dirvish-save-dedication (switch-to-buffer (nth (- len 1) bufs)))
(message "Dirvish: reached the end of history"))
((< new-idx 0)
(dirvish-save-dedication (switch-to-buffer (nth 0 bufs)))
(message "Dirvish: reached the beginning of history"))
(t (dirvish-save-dedication (switch-to-buffer (nth new-idx bufs)))))))
;;;###autoload
(defun dirvish-history-go-backward (arg)
"Navigate to previous ARG directory in history.
ARG defaults to 1."
(interactive "^p")
(dirvish-history-go-forward (- 0 arg)))
;;;###autoload (autoload 'dirvish-history-menu "dirvish-history" nil t)
(transient-define-prefix dirvish-history-menu ()
"Help menu for `dirvish-history-*' commands."
[:description
(lambda () (dirvish--format-menu-heading "Go to history entries"))
("f" "Forward history" dirvish-history-go-forward :transient t)
("b" "Backward history" dirvish-history-go-backward :transient t)
("l" "Go to most recent used" dirvish-history-last)
("a" "Access history entries" dirvish-history-jump)])
(provide 'dirvish-history)
;;; dirvish-history.el ends here

138
lisp/dirvish/dirvish-icons.el Normal file
View File

@@ -0,0 +1,138 @@
;;; dirvish-icons.el --- Icon support for 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:
;; Integrate `all-the-icons', `nerd-icons', and `vscode-icon' with Dirvish.
;;; Code:
(declare-function all-the-icons-icon-for-file "all-the-icons")
(declare-function all-the-icons-icon-for-dir "all-the-icons")
(declare-function nerd-icons-icon-for-file "nerd-icons")
(declare-function nerd-icons-icon-for-dir "nerd-icons")
(declare-function vscode-icon-can-scale-image-p "vscode-icon")
(declare-function vscode-icon-file "vscode-icon")
(declare-function vscode-icon-dir-exists-p "vscode-icon")
(declare-function vscode-icon-create-image "vscode-icon")
(defvar vscode-icon-size)
(defvar vscode-icon-dir-alist)
(defvar vscode-icon-dir)
(require 'all-the-icons nil t)
(require 'vscode-icon nil t)
(require 'dirvish)
(defvar dirvish--vscode-icon-directory
(concat (and (boundp 'vscode-icon-dir) vscode-icon-dir)
(if (and (fboundp 'vscode-icon-can-scale-image-p) (vscode-icon-can-scale-image-p)) "128/" "23/")))
(defcustom dirvish-icon-delimiter " "
"A string attached to the icon (for both backends)."
:group 'dirvish :type 'string)
(defcustom dirvish-all-the-icons-offset 0.01
"Icon's vertical offset used for `all-the-icons' backend.
Set it to nil to use the default offset from `all-the-icons'."
:group 'dirvish :type '(choice (float nil)))
(defcustom dirvish-all-the-icons-height nil
"Icon height used for `all-the-icons' backend.
The height of the icon is scaled to this value (try 0.8).
Set it to nil to use the default height from `all-the-icons'."
:group 'dirvish :type '(choice (float nil)))
(defcustom dirvish-all-the-icons-palette 'all-the-icons
"Coloring style used for file `all-the-icons' backend.
Values are interpreted as follows:
- all-the-icons, meaning let `all-the-icons.el' to do the coloring.
- A face that is used for all the icons.
- nil, inherit face at point."
:group 'dirvish :type '(choice face symbol (const nil)))
(defcustom dirvish-nerd-icons-offset 0.00
"Icon's vertical offset used for `nerd-icons' backend.
Set it to nil to use the default offset from `nerd-icons'."
:group 'dirvish :type '(choice float (const nil)))
(defcustom dirvish-nerd-icons-height nil
"Icon height used for `nerd-icons' backend.
The height of the icon is scaled to this value (try 0.8).
Set it to nil to use the default height from `nerd-icons'."
:group 'dirvish :type '(choice float (const nil)))
(defcustom dirvish-nerd-icons-palette 'nerd-icons
"Coloring style used for file `nerd-icons' backend.
Values are interpreted as follows:
- nerd-icons, meaning let `nerd-icons.el' to do the coloring.
- A face that is used for all the icons.
- nil, inherit face at point."
:group 'dirvish :type '(choice face symbol (const nil)))
(defcustom dirvish-vscode-icon-size 32
"Icon (image pixel) size used for `vscode-icon' backend.
The value should be a integer between 23 to 128."
:group 'dirvish :type 'integer)
(dirvish-define-attribute all-the-icons
"File icons provided by `all-the-icons.el'."
:width (+ (length dirvish-icon-delimiter) 2)
(let* ((offset `(:v-adjust ,dirvish-all-the-icons-offset))
(height `(:height ,dirvish-all-the-icons-height))
(face (cond (hl-face `(:face ,hl-face))
((eq dirvish-all-the-icons-palette 'all-the-icons) nil)
(t `(:face ,dirvish-all-the-icons-palette))))
(icon-attrs (append face offset height))
(icon (if (eq (car f-type) 'dir)
(apply #'all-the-icons-icon-for-dir f-name icon-attrs)
(apply #'all-the-icons-icon-for-file f-str icon-attrs)))
(icon-str (concat icon (propertize dirvish-icon-delimiter 'face hl-face)))
(ov (make-overlay (1- f-beg) f-beg)))
(overlay-put ov 'after-string icon-str)
`(ov . ,ov)))
(dirvish-define-attribute nerd-icons
"File icons provided by `nerd-icons.el'."
:width (+ (length dirvish-icon-delimiter) 2)
(let* ((offset `(:v-adjust ,dirvish-nerd-icons-offset))
(height `(:height ,dirvish-nerd-icons-height))
(face (cond (hl-face `(:face ,hl-face))
((eq dirvish-nerd-icons-palette 'nerd-icons) nil)
(t `(:face ,dirvish-nerd-icons-palette))))
(icon-attrs (append face offset height))
(icon (if (eq (car f-type) 'dir)
(apply #'nerd-icons-icon-for-dir f-name icon-attrs)
(apply #'nerd-icons-icon-for-file f-str icon-attrs)))
(icon-str (concat icon (propertize dirvish-icon-delimiter 'face hl-face)))
(ov (make-overlay (1- f-beg) f-beg)))
(overlay-put ov 'after-string icon-str)
`(ov . ,ov)))
(dirvish-define-attribute vscode-icon
"File icons provided by `vscode-icon.el'."
:width (1+ (length dirvish-icon-delimiter))
(let* ((vscode-icon-size dirvish-vscode-icon-size)
(icon
(dirvish-attribute-cache f-name :vscode-icon
(let ((default-directory dirvish--vscode-icon-directory))
(if (eq (car f-type) 'dir)
(let* ((base (file-name-sans-extension f-str))
(i-base (or (cdr (assoc base vscode-icon-dir-alist))
base))
(i-path (vscode-icon-dir-exists-p i-base)))
(vscode-icon-create-image
(or i-path (expand-file-name "default_folder.png"))))
(vscode-icon-file f-name)))))
(ov (make-overlay (1- f-beg) f-beg)))
(overlay-put ov 'display icon)
(overlay-put ov 'before-string (propertize " " 'face hl-face))
(overlay-put ov 'after-string
(propertize dirvish-icon-delimiter 'face hl-face))
`(ov . ,ov)))
(provide 'dirvish-icons)
;;; dirvish-icons.el ends here

183
lisp/dirvish/dirvish-ls.el Normal file
View File

@@ -0,0 +1,183 @@
;;; dirvish-ls.el --- Setup ls command switches on the fly -*- 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:
;; Setup ls command switches on the fly.
;;; Code:
(require 'dirvish)
(require 'transient)
(defun dirvish-ls--clear-switches-choices ()
"Reload the listing switches setup UI."
(interactive)
(transient-setup 'dirvish-ls-switches-menu))
(defun dirvish-ls--apply-switches-to-buffer (&optional switches)
"Apply listing SWITCHES to current buffer."
(interactive)
(let* ((args (transient-args transient-current-command))
(switches (or switches (string-join (append '("-l") args) " "))))
(when current-prefix-arg (setq dired-listing-switches switches))
(setq dired-actual-switches switches)
(revert-buffer)))
(defun dirvish-ls--apply-switches-to-all (&optional switches)
"Apply listing SWITCHES to current session."
(interactive)
(let* ((args (transient-args transient-current-command))
(switches (or switches (string-join (append '("-l") args) " "))))
(when current-prefix-arg (setq dired-listing-switches switches))
(setf (dv-ls-switches (dirvish-curr)) switches)
(dolist (buf (cl-remove-if-not
(lambda (b) (with-current-buffer b (derived-mode-p 'dired-mode))) (buffer-list)))
(with-current-buffer buf
(setq dired-actual-switches switches)
(revert-buffer)))))
(defun dirvish-ls--reset-switches-for-buffer ()
"Reset listing switches for current buffer."
(interactive)
(dirvish-ls--apply-switches-to-buffer dired-listing-switches))
(defun dirvish-ls--reset-switches-for-all ()
"Reset listing switches for current buffer."
(interactive)
(dirvish-ls--apply-switches-to-all dired-listing-switches))
(transient-define-infix dirvish-ls--filter-switch ()
:description "show all files"
:class 'transient-switches
:argument-format "--%s"
:argument-regexp "\\(--\\(all\\|almost-all\\)\\)"
:choices '("all" "almost-all"))
(transient-define-infix dirvish-ls--sort-switch ()
:description "sort by"
:class 'transient-switches
:argument-format "--sort=%s"
:argument-regexp "\\(--sort=\\(time\\|none\\|extension\\|size\\|version\\|width\\)\\)"
:choices '("time" "none" "extension" "size" "version" "width"))
(transient-define-infix dirvish-ls--time-switch ()
:description "show time as | sort files with"
:class 'transient-switches
:argument-format "--time=%s"
:argument-regexp "\\(--time=\\(use\\|birth\\|ctime\\)\\)"
:choices '("use" "birth" "ctime"))
(transient-define-infix dirvish-ls--time-style-switch ()
:description "time style"
:class 'transient-switches
:argument-format "--time-style=%s"
:argument-regexp "\\(--time-style=\\(full-iso\\|long-iso\\|iso\\|locale\\|+\\)\\)"
:choices '("full-iso" "long-iso" "iso" "locale" "+"))
(transient-define-infix dirvish-ls--indicator-style-switch ()
:description "add indicator"
:class 'transient-switches
:argument-format "--indicator-style=%s"
:argument-regexp "\\(--indicator-style=\\(slash\\|file-type\\|classify\\)\\)"
:choices '("slash" "file-type" "classify"))
(defun dirvish-ls--quicksort-do-sort (switches)
"Sort current buffer with Dired sort SWITCHES."
(let* ((regexp "\\(--time=\\w+\\|--sort=\\w+\\|--reverse\\)\\( \\)?")
(others (replace-regexp-in-string regexp "" dired-actual-switches))
(new-switches (concat others " " switches)))
(setq dired-actual-switches new-switches)
(revert-buffer)))
;;;###autoload (autoload 'dirvish-quicksort "dirvish-ls" nil t)
(defcustom dirvish-ls-quicksort-keys
'(("n" "" "name (a-z)")
("N" "--reverse" "name (z-a)")
("e" "--sort=extension" "extension (a-z)")
("E" "--sort=extension --reverse" "extension (z-a)")
("s" "--sort=size" "size (largest first)")
("S" "--sort=size --reverse" "size (smallest first)")
("v" "--sort=version" "version number (earliest first)")
("V" "--sort=version --reverse" "version number (latest first)")
("w" "--sort=width" "width (shortest first)")
("W" "--sort=width --reverse" "width (longest first)")
("m" "--sort=time" "modification time (newest first)")
("M" "--sort=time --reverse" "modification time (oldest first)")
("a" "--sort=time --time=use" "access time (newest first)")
("A" "--sort=time --time=use --reverse" "access time (oldest first)")
("b" "--sort=time --time=birth" "birth time (newest first)")
("B" "--sort=time --time=birth --reverse" "birth time (oldest first)")
("c" "--sort=time --time=ctime" "change time (newest first)")
("C" "--sort=time --time=ctime --reverse" "change time (oldest first)"))
"SORT-KEYs for command `dirvish-quicksort'.
A SORT-KEY is a (KEY SWITCHES DOC) alist where KEY is the key to
invoke the sort function, SWITCHES is the the sort flags for
`dired-sort-other', DOC is the documentation string."
:group 'dirvish :type 'alist
:set
(lambda (k v)
(set k v)
(eval
`(transient-define-prefix dirvish-quicksort ()
"Sort Dirvish buffer by different criteria."
[:description
(lambda () (dirvish--format-menu-heading "Sort by:"))
,@(cl-loop
for (key switches desc) in v collect
(list key desc `(lambda ()
(interactive)
(dirvish-ls--quicksort-do-sort ,switches))))]))))
;;;###autoload (autoload 'dirvish-ls-switches-menu "dirvish-ls" nil t)
(transient-define-prefix dirvish-ls-switches-menu ()
"Setup Dired listing switches."
:init-value
(lambda (o) (oset o value (split-string (or dired-actual-switches ""))))
[:description
(lambda ()
(format "%s\n%s %s\n%s %s"
(propertize "Setup Listing Switches"
'face '(:inherit dired-mark :underline t)
'display '((height 1.2)))
(propertize "lowercased switches also work in" 'face 'font-lock-doc-face)
(propertize "dired-hide-details-mode" 'face 'font-lock-constant-face)
(propertize "C-u RET and C-u M-RET will modify" 'face 'font-lock-doc-face)
(propertize "dired-listing-switches" 'face 'font-lock-constant-face)))
["options"
("a" dirvish-ls--filter-switch)
("s" dirvish-ls--sort-switch)
("i" dirvish-ls--indicator-style-switch)
("t" dirvish-ls--time-switch)
("T" dirvish-ls--time-style-switch)
("B" "Scale sizes when printing, eg. 10K" "--block-size=")
""
"toggles"
("r" "Reverse order while sorting" "--reverse")
("d" "List directories on top" "--group-directories-first")
("~" "Hide backups files (eg. foo~)" "--ignore-backups")
("A" "Show the author" "--author")
("C" "Show security context" "--context")
("H" "Human readable file size" "--human-readable")
("G" "Hide group names" "--no-group")
("O" "Hide owner names" "-g")
("L" "Info for link references or link itself" "--dereference")
("N" "Numeric user and group IDs" "--numeric-uid-gid")
("P" "Powers of 1000 for file size rather than 1024" "--si")
("I" "Show index number" "--inode")
("S" "Show the allocated size" "--size")
""
"Actions"
("RET" " Apply to this buffer" dirvish-ls--apply-switches-to-buffer)
("M-RET" "Apply to all Dired buffers" dirvish-ls--apply-switches-to-all)
("C-r" " Reset this buffer" dirvish-ls--reset-switches-for-buffer)
("M-r" " Reset all Dired buffers" dirvish-ls--reset-switches-for-all)
("C-l" " Clear choices" dirvish-ls--clear-switches-choices :transient t)]])
(provide 'dirvish-ls)
;;; dirvish-ls.el ends here

174
lisp/dirvish/dirvish-narrow.el Normal file
View File

@@ -0,0 +1,174 @@
;;; dirvish-narrow.el --- Live-narrowing of search results for 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 package provides live filtering of files in Dirvish buffers. It is a
;; stripped-down version of `dired-narrow'.
;;; Code:
(require 'dirvish-fd)
;; Credit: copied from `orderless.el'
(defcustom dirvish-narrow-match-faces
[dirvish-narrow-match-face-0
dirvish-narrow-match-face-1
dirvish-narrow-match-face-2
dirvish-narrow-match-face-3]
"Vector of faces used (cyclically) for component matches."
:group 'dirvish :type '(vector face))
(defface dirvish-narrow-match-face-0
'((default :weight bold)
(((class color) (min-colors 88) (background dark)) :foreground "#72a4ff")
(((class color) (min-colors 88) (background light)) :foreground "#223fbf")
(t :foreground "blue"))
"Face for matches of components numbered 0 mod 4."
:group 'dirvish)
(defface dirvish-narrow-match-face-1
'((default :weight bold)
(((class color) (min-colors 88) (background dark)) :foreground "#ed92f8")
(((class color) (min-colors 88) (background light)) :foreground "#8f0075")
(t :foreground "magenta"))
"Face for matches of components numbered 1 mod 4."
:group 'dirvish)
(defface dirvish-narrow-match-face-2
'((default :weight bold)
(((class color) (min-colors 88) (background dark)) :foreground "#90d800")
(((class color) (min-colors 88) (background light)) :foreground "#145a00")
(t :foreground "green"))
"Face for matches of components numbered 2 mod 4."
:group 'dirvish)
(defface dirvish-narrow-match-face-3
'((default :weight bold)
(((class color) (min-colors 88) (background dark)) :foreground "#f0ce43")
(((class color) (min-colors 88) (background light)) :foreground "#804000")
(t :foreground "yellow"))
"Face for matches of components numbered 3 mod 4."
:group 'dirvish)
(defface dirvish-narrow-split
'((t :inherit font-lock-negation-char-face))
"Face used to highlight punctuation character."
:group 'dirvish)
(defun dirvish-narrow--build-indices ()
"Update the Dirvish buffer based on the input of the minibuffer."
(save-excursion
(cl-loop
for (dir . beg) in dired-subdir-alist and idx from 0
unless (and (eq idx 0) (dirvish-prop :fd-info))
do (goto-char beg)
(let ((end (dired-subdir-max)) (files (dirvish--ht)))
(while (< (point) end)
(when-let* ((f-beg (dired-move-to-filename))
(f-end (dired-move-to-end-of-filename))
(f-name (buffer-substring-no-properties f-beg f-end))
(l-beg (line-beginning-position))
(l-end (1+ (line-end-position)))
(l-str (buffer-substring l-beg l-end)))
(puthash f-name l-str files))
(forward-line 1))
(puthash (md5 dir) files dirvish--dir-data)))))
(defun dirvish-narrow--compiler (s)
"Compile `completion-regexp-list' from string S."
(if (fboundp 'orderless-compile) (cdr (orderless-compile s)) (split-string s)))
(defun dirvish-narrow-update-h ()
"Update the Dirvish buffer based on the input of the minibuffer."
(let* ((mc (minibuffer-contents-no-properties))
(filter mc) async rel igc)
(save-match-data
(when-let* (((string-match "^#\\([^ #]*\\)\\(.*\\)" mc))
(beg (minibuffer-prompt-end)))
(add-text-properties beg (1+ beg) '(rear-nonsticky t))
(add-face-text-property beg (1+ beg) 'dirvish-narrow-split)
(setq async (match-string 1 mc) filter (match-string 2 mc))))
(with-current-buffer (cdr (dv-index (dirvish-curr)))
(when (and async (dirvish-prop :fd-info))
(dirvish-fd--argparser (mapcan (lambda (x) `(,(format "--and=%s" x)))
(split-string async "," t))
(cddr (dirvish-prop :fd-info))))
(setq rel (dirvish-narrow--compiler filter)
igc (cl-loop for re in (ensure-list rel)
always (isearch-no-upper-case-p re t)))
(dirvish-prop :narrow-info (list async rel igc)))
(dirvish--run-with-delay mc :narrow
(lambda (_action)
(with-current-buffer (cdr (dv-index (dirvish-curr)))
(when (dirvish-prop :fd-info) (dirvish-fd--start-proc))
(save-excursion
(cl-loop for (dir . pos) in dired-subdir-alist and idx from 0
do (delete-region
(progn (goto-char pos)
(forward-line (dirvish--subdir-offset)) (point))
(- (dired-subdir-max) (if (eq idx 0) 0 1)))
unless (and (eq idx 0) (dirvish-prop :fd-info))
do (cl-loop with files = (gethash (md5 dir) dirvish--dir-data)
with completion-regexp-list = rel
with completion-ignore-case = igc
for f in (all-completions "" files)
do (insert (gethash f files))))))
(when (dv-curr-layout (dirvish-curr)) (force-mode-line-update t))))))
(dirvish-define-attribute narrow-match
"Highlight matched part of narrowed files."
(cl-loop with (_ regexps case-fold-search) = (dirvish-prop :narrow-info)
with n = (length dirvish-narrow-match-faces) with ovs = nil
for regexp in regexps and i from 0
when (string-match regexp f-str) do
(cl-loop
for (x y) on (let ((m (match-data))) (or (cddr m) m)) by #'cddr
when x do (let ((ov (make-overlay (+ f-beg x) (+ f-beg y)))
(face (aref dirvish-narrow-match-faces (mod i n))))
(overlay-put ov 'face face)
(push ov ovs)))
finally return `(ovs . ,ovs)))
;;;###autoload
(defun dirvish-narrow ()
"Narrow a Dirvish buffer to the files matching a regex."
(interactive nil dired-mode)
(when (bound-and-true-p dirvish-subtree--overlays)
(declare-function dirvish-subtree--revert "dirvish-subtree")
(dirvish-subtree--revert t))
(require 'orderless nil t)
(dirvish-narrow--build-indices)
(let ((dv (dirvish-prop :dv))
(idx (dirvish-prop :index))
(fd (dirvish-prop :fd-info))
(attrs (mapcar #'car (dirvish-prop :attrs)))
buffer-read-only)
(when fd
(setq dired-subdir-alist (list (car (reverse dired-subdir-alist))))
(delete-region (goto-char (dirvish-prop :content-begin)) (point-max)))
(dirvish-prop :attrs
(dirvish--attrs-expand (append '(narrow-match) attrs)))
(minibuffer-with-setup-hook
(lambda ()
(dirvish-prop :dv dv)
(add-hook 'post-command-hook #'dirvish-narrow-update-h nil t))
(unwind-protect
(read-from-minibuffer "Focus on files: " (if fd "#" ""))
(when idx (dired-goto-file idx))
(dirvish-prop :attrs (dirvish--attrs-expand attrs))
(when-let* (((not (eq (dv-type (dirvish-curr)) 'side)))
(query (caar (dirvish-prop :fd-info)))
(key (file-name-nondirectory
(directory-file-name default-directory))))
(rename-buffer (concat key "🔍" query "🔍" (dv-id (dirvish-curr)))))
(dirvish--run-with-delay 'reset)
(dirvish--run-with-delay 'reset :narrow)))))
(provide 'dirvish-narrow)
;;; dirvish-narrow.el ends here

173
lisp/dirvish/dirvish-peek.el Normal file
View File

@@ -0,0 +1,173 @@
;;; dirvish-peek.el --- Minibuffer file preview powered by 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 extension introduces `dirvish-peek-mode', a minor mode that enables file
;; previews within the minibuffer as you narrow down candidates. By leveraging
;; `dirvish.el' for its core functionality, it delivers a seamless and
;; consistent preview experience.
;;; Code:
(declare-function vertico--candidate "vertico")
(declare-function ivy-state-current "ivy")
(defvar ivy-last)
(require 'dirvish)
(require 'find-func)
(defcustom dirvish-peek-candidate-fetcher nil
"Function to get current candidate in minibuffer.
If this value is nil, a candidate fetcher function is
automatically choosed according to your completion framework
being used at runtime."
:group 'dirvish :type '(choice function (const nil)))
(defcustom dirvish-peek-categories '(file project-file library)
"Minibuffer metadata categories to show file preview.
For now only `file', `project-file' and `library' are supported.
- `file': preview files on `find-file' command and friends.
- `project-file': preview files on `project-find-file' command and friends.
- `library': preview files on `find-library' command.
Notice that the `dirvish-preview-dispatchers' option is respected across
all categories."
:group 'dirvish :type '(repeat :tag "each item can be 'file 'project-file 'library" symbol))
;; Credit: copied from `consult-preview-key'
(defcustom dirvish-peek-key 'any
"Preview trigger keys, can be nil, `any', a single key or a list of keys.
Debouncing can be specified via the `:debounce' attribute. The
individual keys must be strings accepted by `key-valid-p'."
:group 'dirvish
:type '(choice (const :tag "Any key" any)
(list :tag "Debounced" (const :debounce) (float :tag "Seconds" 0.1) (const any))
(const :tag "No preview" nil)
(key :tag "Key")
(repeat :tag "List of keys" key)))
(defun dirvish-peek--prepare-cand-fetcher ()
"Set candidate fetcher according to current completion framework."
(dirvish-prop :peek-fetcher
(cond (dirvish-peek-candidate-fetcher dirvish-peek-candidate-fetcher)
((bound-and-true-p vertico-mode) #'vertico--candidate)
((bound-and-true-p ivy-mode) (lambda () (ivy-state-current ivy-last)))
((bound-and-true-p icomplete-mode)
(lambda () (car completion-all-sorted-completions))))))
;; Credit: copied from `consult--preview-key-normalize'
(defun dirvish-peek--normalize-keys (peek-key)
"Normalize PEEK-KEY, return alist of keys and debounce times."
(let ((keys) (debounce 0))
(setq peek-key (ensure-list peek-key))
(while peek-key
(if (eq (car peek-key) :debounce)
(setq debounce (cadr peek-key)
peek-key (cddr peek-key))
(let ((key (car peek-key)))
(cond
((eq key 'any))
((not (key-valid-p key))
(error "%S is not a valid key definition; see `key-valid-p'" key))
(t (setq key (key-parse key))))
(push (cons key debounce) keys))
(pop peek-key)))
keys))
(dirvish-define-preview peek-exception (file)
"Handle exceptions when peek files."
(cond ((string-prefix-p "LIB_EXCEPTION:::" file)
(pcase-let ((`(_ ,cand ,err) (split-string file ":::"))
(fmt "Caught exception peeking [ %s ]\n Error: %s"))
`(info . ,(format fmt cand err))))
((string-prefix-p "FILE_REMOTE_EXCEPTION:::" file)
(pcase-let ((`(_ ,cand) (split-string file ":::")))
`(info . ,(format "Unable to peek remote file: [ %s ]" cand))))))
(defun dirvish-peek-setup-h ()
"Create dirvish minibuffer preview window.
The window is created only when metadata in current minibuffer is
one of categories in `dirvish-peek-categories'."
(let* ((meta (ignore-errors
(completion-metadata
(buffer-substring-no-properties (field-beginning) (point))
minibuffer-completion-table
minibuffer-completion-predicate)))
(category (completion-metadata-get meta 'category))
(p-category (and (memq category dirvish-peek-categories) category))
(dv (dirvish--get-session 'curr-layout 'any))
(win (and dv (dv-preview-window dv))) new-dv)
(dirvish-prop :peek-category p-category)
(when (and p-category dirvish-peek-key)
(let ((old-map (current-local-map))
(map (make-sparse-keymap))
(keys (dirvish-peek--normalize-keys dirvish-peek-key)))
(pcase-dolist (`(,k . ,_) keys)
(unless (or (eq k 'any) (lookup-key old-map k))
(define-key map k #'ignore)))
(use-local-map (make-composed-keymap map old-map)))
(dirvish-peek--prepare-cand-fetcher)
(add-hook 'post-command-hook #'dirvish-peek-update-h 90 t)
(add-hook 'minibuffer-exit-hook #'dirvish-peek-exit-h nil t)
(setq new-dv (dirvish--new :type 'peek))
(dirvish--init-special-buffers new-dv)
;; `dirvish-image-dp' needs this.
(setf (dv-index new-dv) (cons default-directory (current-buffer)))
(setf (dv-preview-window new-dv)
(or (and (window-live-p win) win)
(minibuffer-selected-window) (next-window)))
(cl-loop for (k v) on dirvish--scopes by 'cddr
do (dirvish-prop k (and (functionp v) (funcall v))))
(dirvish-prop :dv (dv-id new-dv))
(dirvish-prop :preview-dps
(append '(dirvish-peek-exception-dp)
(dv-preview-dispatchers new-dv))))))
(defun dirvish-peek-update-h ()
"Hook for `post-command-hook' to update peek window."
(when-let* ((category (dirvish-prop :peek-category))
(key (this-single-command-keys))
(peek-keys (dirvish-peek--normalize-keys dirvish-peek-key))
(peek-key (or (assq 'any peek-keys) (assoc key peek-keys)))
(cand-fetcher (dirvish-prop :peek-fetcher))
(cand (funcall cand-fetcher))
(dv (dirvish-curr)))
(pcase category
('file
(let ((fname (expand-file-name cand)))
(if (file-remote-p fname)
(setq cand (format "FILE_REMOTE_EXCEPTION:::%s" fname))
(setq cand fname))))
('project-file
(setq cand (expand-file-name cand (dirvish--vc-root-dir))))
('library
(condition-case err
(setq cand (file-truename (find-library-name cand)))
(error (setq cand (format "LIB_EXCEPTION:::%s:::%s" cand
(error-message-string err)))))))
(dirvish-prop :index cand)
(dirvish--run-with-delay cand nil
(lambda (action) (dirvish--preview-update dv action)) (cdr peek-key))))
(defun dirvish-peek-exit-h ()
"Hook for `minibuffer-exit-hook' to destroy peek session."
(when-let* ((dv (dirvish--get-session 'type 'peek)))
(dirvish--clear-session dv)
(remhash (dv-id dv) dirvish--sessions)))
;;;###autoload
(define-minor-mode dirvish-peek-mode
"Show file preview when narrowing candidates using minibuffer."
:group 'dirvish :global t
(if dirvish-peek-mode
(add-hook 'minibuffer-setup-hook #'dirvish-peek-setup-h)
(remove-hook 'minibuffer-setup-hook #'dirvish-peek-setup-h)))
(provide 'dirvish-peek)
;;; dirvish-peek.el ends here

11
lisp/dirvish/dirvish-pkg.el Normal file
View File

@@ -0,0 +1,11 @@
;; -*- no-byte-compile: t; lexical-binding: nil -*-
(define-package "dirvish" "20250504.807"
"A modern file manager based on dired mode."
'((emacs "28.1")
(compat "30"))
:url "https://github.com/alexluigit/dirvish"
:commit "d877433f957a363ad78b228e13a8e5215f2d6593"
:revdesc "d877433f957a"
:keywords '("files" "convenience")
:authors '(("Alex Lu" . "https://github.com/alexluigit"))
:maintainers '(("Alex Lu" . "https://github.com/alexluigit")))

70
lisp/dirvish/dirvish-quick-access.el Normal file
View File

@@ -0,0 +1,70 @@
;;; dirvish-quick-access.el --- Quick keys for frequently visited places -*- 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 Dirvish extension allows the user to define a list of frequently visited
;; directories and a quick key to jump to the path. `dirvish-quick-access' is
;; designed to be a complementary command to the bookmark system in Emacs. One
;; can have as many as bookmarks they want, and jump to a particular one by the
;; help of their choice of completion framework or commands like
;; `consult-bookmark'. But for those very frequently visited places in the file
;; system, the user would expect to access these directories with the shortest
;; key sequence, plus a mnemonic way to remember those keys.
;;; Code:
(require 'dirvish)
(require 'transient)
(defcustom dirvish-quick-access-function 'dirvish-dwim
"Function used to access `dirvish-quick-access-entries'.
The function takes the entry as the sole argument."
:group 'dirvish :type 'function)
;;;###autoload (autoload 'dirvish-quick-access "dirvish-quick-access" nil t)
(defcustom dirvish-quick-access-entries
`(("h" "~/" "Home")
("e" ,user-emacs-directory "Emacs user directory"))
"Quick access entries for command `dirvish-quick-access'.
A ENTRY is a (KEY PATH DOC) alist where KEY is the key to
invoke the navigation, PATH is the the argument for command
`dired-jump', DOC (optional) is its documentation string.
Here is a sample value for this variable.
\((\"h\" \"~/\" \"Home\")
(\"t\" \"~/.local/share/Trash/\" \"Trashes\")
(\"pa\" \"~/Code/proj-a/\" \"Project A\")
(\"pb\" \"~/Code/proj-b/\" \"Project B\"))"
:group 'dirvish :type 'alist
:set
(lambda (k v)
(set k v)
(when-let* ((desc-len (mapcar (lambda (i) (length (nth 2 i))) v))
(max-desc-len (seq-max desc-len)))
(eval
`(transient-define-prefix dirvish-quick-access ()
"Jump to Dirvish quick access entries."
[:description
(lambda () (dirvish--format-menu-heading "Go to Directory: "))
,@(cl-loop
for (key path desc) in v
collect
(list key
(concat desc " "
(make-string (- max-desc-len (length desc)) ?\ )
(propertize path 'face 'font-lock-comment-face))
`(lambda ()
(interactive)
(funcall dirvish-quick-access-function ,path))))]
(interactive)
(transient-setup 'dirvish-quick-access))))))
(provide 'dirvish-quick-access)
;;; dirvish-quick-access.el ends here

378
lisp/dirvish/dirvish-rsync.el Normal file
View File

@@ -0,0 +1,378 @@
;;; dirvish-rsync.el --- Rsync integration for 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 extension introduces `dirvish-rsync' command (which requires `rsync'
;; executable), mirroring the functionality of Alex Bennée's `dired-rsync'.
;; Uniquely, `dirvish-rsync' gathers marked files from multiple Dired buffers.
;; It also provides a transient menu `dirvish-rsync-switches-menu', for
;; temporary adjustments to `dirvish-rsync-args'.
;;; Code:
(require 'dirvish-yank)
(require 'tramp)
(define-obsolete-variable-alias 'dirvish-yank-rsync-program 'dirvish-rsync-program "Fed 9, 2025")
(defcustom dirvish-rsync-program "rsync"
"The rsync binary that we are going to use."
:type 'string :group 'dirvish)
(define-obsolete-variable-alias 'dirvish-yank-rsync-args 'dirvish-rsync-args "Fed 9, 2025")
(defcustom dirvish-rsync-args
'("--archive" "--verbose" "--compress" "--info=progress2")
"The default options for the rsync command."
:type '(repeat string) :group 'dirvish)
(defcustom dirvish-rsync-r2r-ssh-port "22"
"Default ssh port of receiver when yanking in remote to remote scenario.
In this scenario rsync will be run on remote host, so it has no access
to your ~/.ssh/config file. If you have some settings there you have to
specify them somehow. One way is to set global default values and other
way is to set them locally before copying, using rsync-transient menu."
:type 'string :group 'dirvish)
(defcustom dirvish-rsync-r2r-ssh-user nil
"Default ssh user of receiver when yanking in remote to remote scenario.
When it is nil, do not specify any user. See
`dirvish-rsync-r2r-ssh-port' for more details."
:type '(choice string (const nil)) :group 'dirvish)
(defcustom dirvish-rsync-r2r-use-direct-connection nil
"When t, copy data directly from host1 to host2.
If this is not possible, for example when host2 is not reacheable from
host1 set this option to nil. When it is nil the tunnel will be created
between host1 and host2, using running machine as proxy. For both cases
make sure that you have passwordless access to both hosts and that
ssh-agent is properly set-up. For checking that, everything works try
to execute a command \"ssh -A host1 ssh -o StrictHostKeyChecking=no
host2 hostname\". Also make sure that ssh-agent Environment variables
are propagated to Emacs."
:type 'boolean :group 'dirvish)
(defcustom dirvish-rsync-shortcut-key-for-yank-menu "R"
"A shortcut key added to `dirvish-yank-menu'."
:type 'string :group 'dirvish)
(defcustom dirvish-rsync-use-yank-menu t
"When t, append a shortcut to invoke `dirvish-rsync' in `dirvish-yank-menu'.
The shortcut key is denoted by `dirvish-rsync-shortcut-key-for-yank-menu'."
:type 'boolean :group 'dirvish
:set (lambda (k v)
(set k v)
(if v (dirvish-yank--menu-setter
nil (append dirvish-yank-keys
`((,dirvish-rsync-shortcut-key-for-yank-menu
"Rsync here" dirvish-rsync))))
(dirvish-yank--menu-setter nil dirvish-yank-keys))))
(defvar dirvish-rsync--remote-ssh-args
"-o StrictHostKeyChecking=no -o UserKnownHostsFile=/dev/null"
"These args will be used for invoking ssh on remote host (in r2r case).")
(defvar dirvish-rsync--transient-input-history nil
"History list of rsync transient input in the minibuffer.")
(defvar crm-separator)
(defvar-local dirvish-rsync--r2r-direct-conn nil
"Local value for enabling direct copy in r2r case.")
(defvar-local dirvish-rsync--r2r-ssh-recv-host nil
"Local value of r2r receiver host.")
(defvar-local dirvish-rsync--r2r-ssh-recv-port nil
"Local value of r2r receiver port.")
(defvar-local dirvish-rsync--r2r-ssh-recv-user nil
"Local value of r2r receiver user.")
(defun dirvish-rsync--get-remote-host ()
"Return the remote port we shall use for the reverse port-forward."
(+ 50000 (length dirvish-yank-log-buffers)))
(defun dirvish-rsync--filename (file)
"Reformat a tramp FILE to one usable for rsync."
(if (tramp-tramp-file-p file)
(with-parsed-tramp-file-name file tfop
(format "%s%s:%s" (if tfop-user (format "%s@" tfop-user) "") tfop-host
(shell-quote-argument tfop-localname)))
(shell-quote-argument file)))
(defun dirvish-rsync--compose-command ()
"Compose rsync command and args into the string.
Retrieve rsync args from current session or `dirvish-rsync-args'."
(format "%s %s"
dirvish-rsync-program
(string-join
(or (dirvish-prop :rsync-switches) dirvish-rsync-args) " ")))
(defun dirvish-rsync--local-ssh-args (host-info)
"Compose ssh args used for sshing to source host.
HOST-INFO is a list of host/user/port parsed from the tramp string."
(let* ((port (cl-third host-info))
(port-str (if port (concat "-p" port) ""))
(user (cl-second host-info))
(user-str (if user (concat user "@") "")))
(concat port-str " " user-str (cl-first host-info))))
(defun dirvish-rsync--r2r-escape-single-quote (str)
"Properly escape all single quotes in STR.
STR should be processed by `shell-quote-argument' already. Single
quotes require special care since we wrap remote command with them.
Bash doesn't allow nesting of single quotes (even escaped ones), so we
need to turn string into multiple concatenated strings."
;; use string-replace from emacs-28.1 when support of older versions is dropped
(replace-regexp-in-string "'" "'\"'\"'" str t t))
;; Thanks to `dired-rsync.el'
;; also see: https://unix.stackexchange.com/questions/183504/how-to-rsync-files-between-two-remotes
(defun dirvish-rsync--r2r-handler (srcs shost-info dhost-info)
"Construct and trigger an rsync run for remote copy.
This command sync SRCS on SHOST to DEST on DHOST. SHOST-INFO and
DHOST-INFO are lists containing host,user,port,localname extracted from
the tramp string."
(let* ((srcs (mapcar (lambda (x)
(thread-last x file-local-name shell-quote-argument
dirvish-rsync--r2r-escape-single-quote))
srcs))
(src-str (string-join srcs " "))
(shost (cl-first shost-info))
(dhost (cl-first dhost-info))
(dhost-real (or dirvish-rsync--r2r-ssh-recv-host
(cl-first dhost-info)))
(duser (or dirvish-rsync--r2r-ssh-recv-user
(cl-second dhost-info)
dirvish-rsync-r2r-ssh-user))
(dport (or dirvish-rsync--r2r-ssh-recv-port
(cl-third dhost-info)
dirvish-rsync-r2r-ssh-port))
(dest (thread-last (cl-fourth dhost-info)
shell-quote-argument
dirvish-rsync--r2r-escape-single-quote))
;; 1. dhost == shost
;; ssh [-p dport] [duser@]dhost 'rsync <rsync-args> <srcs> <dest>'
;; 2. dhost != shost and `dirvish-rsync-r2r-use-direct-connection' == t
;; ssh -A [-p sport] [suser@]shost 'rsync <rsync-args> -e "ssh <ssh-remote-opts> [-p dport]" <srcs> [duser@]dhost:<dest> '
;; 3. dhost != shost and `dirvish-rsync-r2r-use-direct-connection' == nil
;; ssh -A -R <bind-addr> [-p sport] [suser@]shost 'rsync <rsync-args> -e "ssh <ssh-remote-opts> -p <tunnel_port>" <srcs> [duser@]localhost:<dest>'
(cmd (cond ((equal shost dhost)
(string-join
(list "ssh"
(dirvish-rsync--local-ssh-args dhost-info)
"'"
(dirvish-rsync--compose-command)
src-str dest "'")
" "))
((if dirvish-rsync--r2r-direct-conn
(equal dirvish-rsync--r2r-direct-conn "yes")
dirvish-rsync-r2r-use-direct-connection)
(string-join
(list "ssh -A "
(dirvish-rsync--local-ssh-args shost-info)
" '" (dirvish-rsync--compose-command)
(format " -e \"ssh %s %s\" "
(if dport (concat "-p" dport) "")
dirvish-rsync--remote-ssh-args)
src-str " "
(if duser
(format "%s@%s" duser dhost-real)
dhost-real)
":" dest "'")))
(t (let* ((port (dirvish-rsync--get-remote-host))
(bind-addr (format "localhost:%d:%s:%s"
port dhost-real dport)))
(string-join
(list "ssh -A -R " bind-addr " "
(dirvish-rsync--local-ssh-args shost-info)
" '" (dirvish-rsync--compose-command)
(format " -e \"ssh -p %s %s\" "
port dirvish-rsync--remote-ssh-args)
src-str
" "
(if duser
(format "%s@localhost" duser)
"localhost")
":" dest "'")))))))
(dirvish-yank--execute cmd (list (current-buffer) srcs dest 'rsync))))
(defun dirvish-rsync--l2fr-handler (srcs dest)
"Execute a local to/from remote rsync command for SRCS and DEST."
(let* ((srcs (mapcar #'dirvish-rsync--filename srcs))
(dest (dirvish-rsync--filename dest))
(rsync-cmd (flatten-tree (list (dirvish-rsync--compose-command)
srcs dest)))
(cmd (string-join rsync-cmd " ")))
(dirvish-yank--execute cmd (list (current-buffer) srcs dest 'rsync))))
;; copied from `dired-rsync'
(defun dirvish-rsync--extract-host-from-tramp (file-or-path)
"Extract the tramp host part of FILE-OR-PATH.
Returns list that contains (host user port localname)."
(with-parsed-tramp-file-name file-or-path tfop
(when tfop-hop
(user-error "DIRVISH[rsync]: Paths with hop are not supported!"))
(list tfop-host tfop-user tfop-port tfop-localname)))
(defun dirvish-rsync--extract-remote (files)
"Get string identifying the remote connection of FILES."
(cl-loop with hosts = () for f in files for h = (file-remote-p f)
do (cl-pushnew h hosts :test #'equal)
when (> (length hosts) 1)
do (user-error "DIRVISH[rsync]: SOURCEs need to be in the same host")
finally return (car hosts)))
;;;###autoload
(defun dirvish-rsync (dest)
"Rsync marked files to DEST, prompt for DEST if not called with.
If either the sources or the DEST is located in a remote host, the
`dirvish-rsync-program' and `dirvish-rsync-args' are used to transfer
the files.
This command requires proper ssh authentication setup to work correctly
for file transfer involving remote hosts, because rsync command is
always run locally, the password prompts may lead to unexpected errors."
(interactive (dirvish-yank--read-dest 'rsync))
(setq dest (expand-file-name (or dest (dired-current-directory))))
(let* ((dvec (and (tramp-tramp-file-p dest) (tramp-dissect-file-name dest)))
(srcs (or (and (functionp dirvish-yank-sources)
(funcall dirvish-yank-sources))
(dirvish-yank--get-srcs dirvish-yank-sources)
(user-error "DIRVISH[rsync]: no marked files")))
(src-0 (prog1 (car srcs) (dirvish-rsync--extract-remote srcs)))
(svec (and (tramp-tramp-file-p src-0) (tramp-dissect-file-name src-0))))
(cond
;; shost and dhost are different remote hosts
((and svec dvec (not (tramp-local-host-p svec))
(not (tramp-local-host-p dvec)))
(dirvish-rsync--r2r-handler
srcs (dirvish-rsync--extract-host-from-tramp src-0)
(dirvish-rsync--extract-host-from-tramp dest)))
;; either shost, dhost or both are localhost
(t (dirvish-rsync--l2fr-handler srcs dest)))))
(defun dirvish-rsync--transient-init-rsync-switches (obj)
"Select initial values for transient suffixes, possibly from OBJ.
Use values from the local session or Emacs session or saved transient
values."
(or (dirvish-prop :rsync-switches)
;; don't touch if it is alreday set
(if (and (slot-boundp obj 'value) (oref obj value))
(oref obj value)
;; check saved values
(if-let* ((saved (assq (oref obj command) transient-values)))
(cdr saved)
;; use default value at last resort
dirvish-rsync-args))))
(transient-define-infix dirvish-rsync--r2r-ssh-host ()
"Set ssh host of receiver in remote to remote case."
:description "Ssh host of receiver"
:class 'transient-lisp-variable
:variable 'dirvish-rsync--r2r-ssh-recv-host
:reader (lambda (_prompt _init _hist)
(completing-read
"Ssh receiver host: "
nil nil nil dirvish-rsync--transient-input-history)))
(transient-define-infix dirvish-rsync--r2r-ssh-port ()
"Set ssh port of receiver in remote to remote case."
:description "Ssh port of receiver"
:class 'transient-lisp-variable
:variable 'dirvish-rsync--r2r-ssh-recv-port
:reader (lambda (_prompt _init _hist)
(completing-read
"Ssh receiver port: "
nil nil nil dirvish-rsync--transient-input-history)))
(transient-define-infix dirvish-rsync--r2r-ssh-user ()
"Set ssh user of receiver in remote to remote case."
:description "Ssh user of receiver"
:class 'transient-lisp-variable
:variable 'dirvish-rsync--r2r-ssh-recv-user
:reader (lambda (_prompt _init _hist)
(completing-read
"Ssh receiver user: "
nil nil nil dirvish-rsync--transient-input-history)))
(transient-define-infix dirvish-rsync--r2r-direct-conn ()
:class 'transient-lisp-variable
:variable 'dirvish-rsync--r2r-direct-conn
:reader (lambda (_prompt _init _hist)
(completing-read "direct: " '(yes no) nil t)))
(transient-define-prefix dirvish-rsync-transient-configure ()
"Configure romete-to-remote connections for `dirvish-rsync'."
["Remote to remote"
("rh" "Receiver host" dirvish-rsync--r2r-ssh-host)
("rp" "Receiver port" dirvish-rsync--r2r-ssh-port)
("ru" "Receiver user" dirvish-rsync--r2r-ssh-user)
("rd" "Direct connection" dirvish-rsync--r2r-direct-conn)])
;; inspired by `dired-rsync-transient'
(define-obsolete-function-alias 'dirvish-rsync-transient #'dirvish-rsync-switches-menu "Feb 09, 2025")
;;;###autoload (autoload 'dirvish-rsync-switches-menu "dirvish-rsync" nil t)
(transient-define-prefix dirvish-rsync-switches-menu ()
"Transient menu for `dirvish-rsync'."
:init-value (lambda (o)
(oset o value (dirvish-rsync--transient-init-rsync-switches o)))
["Common Arguments"
("-a" "archive mode; equals to -rlptgoD" ("-a" "--archive"))
("-s" "no space-splitting; useful when remote filenames contain spaces" ("-s" "--protect-args") :level 4)
("-r" "recurse into directories" ("-r" "--recursive") :level 5)
("-z" "compress file data during the transfer" ("-z" "--compress"))]
["Files selection args"
("-C" "auto-ignore files in the same way CVS does" ("-C" "--cvs-exclude") :level 4)
("=e" "exclude files matching PATTERN" "--exclude="
:multi-value repeat :reader dirvish-rsync--transient-read-multiple
:prompt "exclude (e.g. ‘*.git’ or ‘*.bin,*.elc’): ")
("=i" "include files matching PATTERN" "--include="
:multi-value repeat :reader dirvish-rsync--transient-read-multiple
:prompt "include (e.g. ‘*.pdf’ or ‘*.org,*.el’): " :level 5)]
["Sender specific args"
("-L" "transform symlink into referent file/dir" ("-L" "--copy-links") :level 4)
("-x" "don't cross filesystem boundaries" ("-x" "--one-file-system") :level 5)
("-l" "copy symlinks as symlinks" ("-l" "--links") :level 5)
("-c" "skip based on checksum, not mod-time & size" ("-c" "--checksum") :level 6)
("-m" "prune empty directory chains from file-list" ("-m" "--prune-empty-dirs") :level 6)
("--size-only" "skip files that match in size" "--size-only" :level 6)]
["Receiver specific args"
("-R" "use relative path names" ("-R" "--relative") :level 4)
("-u" "skip files that are newer on the receiver" ("-u" "--update") :level 4)
("=d" "delete extraneous files from dest dirs" "--delete" :level 4)
("-b" "make backups" ("-b" "--backup") :level 5)
("=bs" "backup suffix" "--suffix="
:prompt "backup suffix: "
:reader (lambda (prompt &optional _initial-input history)
(completing-read prompt nil nil nil nil history))
:level 5)
("-num" "don't map uid/gid values by user/group name" "--numeric-ids" :level 5)
("-ex" "skip creating new files on receiver" "--existing" :level 6)
("-K" "treat symlinked dir on receiver as dir" ("-K" "--keep-dirlinks") :level 6)]
["Information output"
("-v" "increase verbosity" ("-v" "--verbose"))
("-i" "output a change-summary for all updates" "-i" :level 5)
("-h" "output numbers in a human-readable format" "-h" :level 5)
("=I" "per-file (1) or total transfer (2) progress" "--info="
:choices ("progress1" "progress2") :level 4)]
["Configure"
("C" "Set variables..." dirvish-rsync-transient-configure)]
["Action"
[("RET" "Apply switches and copy" dirvish-rsync--apply-switches-and-copy)]])
(defun dirvish-rsync--transient-read-multiple
(prompt &optional _initial-input _history)
"Read multiple values after PROMPT with optional INITIAL_INPUT and HISTORY."
(let ((crm-separator ","))
(completing-read-multiple
prompt nil nil nil nil dirvish-rsync--transient-input-history)))
(defun dirvish-rsync--apply-switches-and-copy (args)
"Execute rsync command generated by transient ARGS."
(interactive (list (transient-args transient-current-command)))
(dirvish-prop :rsync-switches args)
(call-interactively #'dirvish-rsync))
(provide 'dirvish-rsync)
;;; dirvish-rsync.el ends here

203
lisp/dirvish/dirvish-side.el Normal file
View File

@@ -0,0 +1,203 @@
;;; dirvish-side.el --- Toggle Dirvish in side window like treemacs -*- 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:
;; Toggle Dirvish in side window like treemacs.
;;; Code:
(require 'dirvish-subtree)
(defcustom dirvish-side-display-alist '((side . left) (slot . -1))
"Display alist for `dirvish-side' window."
:group 'dirvish :type 'alist)
(defcustom dirvish-side-width 35
"Width of the `dirvish-side' buffer."
:type 'integer :group 'dirvish)
(defcustom dirvish-side-window-parameters
'((no-delete-other-windows . t) (no-other-window . t))
"Window parameters for `dirvish-side' window."
:group 'dirvish :type 'alist)
(defcustom dirvish-side-mode-line-format dirvish-mode-line-format
"Mode line format used in `dirvish-side' window.
See `dirvish-mode-line-format' for details."
:group 'dirvish :type 'plist)
(defcustom dirvish-side-header-line-format '(:left (project))
"Header line format used in `dirvish-side' window.
See `dirvish-mode-line-format' for details."
:group 'dirvish :type 'plist)
(defcustom dirvish-side-attributes dirvish-attributes
"File attributes used in `dirvish-side' window.
See `dirvish-attributes' for details."
:group 'dirvish :type '(repeat (symbol :tag "Dirvish attribute")))
(defcustom dirvish-side-open-file-action nil
"Action to perform before opening a file in a side window.
The value is a function called before switching to the file buffer. The
most recent used window is select if it is nil."
:group 'dirvish
:type '(choice (const :tag "open the file in the most-recent-used window" nil)
(function :tag "custom function")))
(defcustom dirvish-side-auto-expand t
"Whether to auto expand parent directories of current file.
If non-nil, expand all the parent directories of current buffer's
filename until the project root when opening a side session."
:group 'dirvish :type 'boolean)
(defun dirvish-side-root-conf (buffer)
"Setup BUFFER for side session."
(let ((name (buffer-name buffer)))
(unless (string-prefix-p " *SIDE :: " name)
(rename-buffer (format " *SIDE :: %s :: %s" ; hide it by prefix with " "
(file-name-base (directory-file-name
default-directory))
(dirvish--timestamp))))))
(defun dirvish-side-root-window-fn (dv)
"Create root window of DV according to `dirvish-side-display-alist'."
(let* ((buf (with-current-buffer (get-buffer-create " *dirvish-temp*")
;; set the :dv prop for `dirvish-curr'
(setq window-size-fixed 'width)
(dirvish-prop :dv (dv-id dv))
(current-buffer)))
(win (display-buffer-in-side-window
buf (append '((dedicated . t)) dirvish-side-display-alist))))
(cl-loop for (key . value) in dirvish-side-window-parameters
do (set-window-parameter win key value))
(with-selected-window win ; Set window width to `dirvish-side-width'
(let ((w (max dirvish-side-width window-min-width))
window-size-fixed) ; Temporarily unfix size for initial adjustment
;; Ignore errors during resizing (eg. already minimum)
(ignore-errors (enlarge-window-horizontally (- w (window-width))))))
(select-window win)))
(defun dirvish-side-open-file (dv find-fn file)
"Open FILE using FIND-FN for default DV sessions."
(let ((idx (current-buffer)) fbuf)
(unwind-protect (if (eq find-fn 'find-file-other-window)
(funcall find-fn file) ; a new window is split
(dirvish-save-dedication (funcall find-fn file)))
(cond ((eq (setq fbuf (current-buffer)) idx) nil)
((eq find-fn 'find-file-other-window) (dirvish--clear-session dv))
(t (dirvish--clear-session dv)
(setf (dv-curr-layout dv) nil)
(if (buffer-live-p idx) ; `find-alternate-file' kills idx
(dirvish-save-dedication (switch-to-buffer idx))
(delete-window))
(when (dirvish-curr) (other-window 1))
(when (functionp dirvish-side-open-file-action)
(funcall dirvish-side-open-file-action))
(dirvish-save-dedication (switch-to-buffer fbuf)))))))
(defun dirvish-side--session-visible-p ()
"Return the root window of visible side session."
(cl-loop
for w in (window-list)
for b = (window-buffer w)
for dv = (with-current-buffer b (dirvish-curr))
thereis (and dv (eq 'side (dv-type dv)) w)))
(defun dirvish-side--auto-jump ()
"Select latest buffer file in the visible `dirvish-side' session."
(when-let* (((not (dirvish-curr)))
((not (active-minibuffer-window)))
(win (dirvish-side--session-visible-p))
(dv (with-current-buffer (window-buffer win) (dirvish-curr)))
(dir (or (dirvish--vc-root-dir) default-directory))
(prev (with-selected-window win (dirvish-prop :index)))
(curr buffer-file-name)
((not (string-suffix-p "COMMIT_EDITMSG" curr)))
((not (equal prev curr))))
(with-selected-window win
(let (buffer-list-update-hook window-buffer-change-functions)
(or (cl-loop for (d . _) in dired-subdir-alist
if (string-prefix-p d (expand-file-name dir))
return (dired-goto-subdir d))
(dirvish--find-entry 'find-alternate-file dir)))
;; delay the running of this hook to eliminate race condition
(dirvish-winbuf-change-h win)
(unwind-protect (if dirvish-side-auto-expand
(dirvish-subtree-expand-to curr)
(dired-goto-file curr))
(dirvish--redisplay)))))
(defun dirvish-side--new (path)
"Open a side session in PATH."
(let ((bname buffer-file-name)
(dv (or (dirvish--get-session 'type 'side)
(dirvish--new
:type 'side
:size-fixed 'width
:dedicated t
:root-conf #'dirvish-side-root-conf
:root-window-fn #'dirvish-side-root-window-fn
:open-file #'dirvish-side-open-file))))
(with-selected-window (dirvish--create-root-window dv)
(dirvish--find-entry 'find-alternate-file path)
(cond ((not bname) nil)
(dirvish-side-auto-expand
(dirvish-subtree-expand-to bname))
(t (dired-goto-file bname))))))
(defun dirvish-side-increase-width (delta)
"Increase width of the `dirvish-side' window by DELTA columns.
Interactively, if no argument is given, DELTA is seen as 1."
(interactive "^p")
(let ((win (dirvish-side--session-visible-p)))
(unless win (user-error "No visible dirvish-side window found"))
(with-selected-window win
(let ((window-size-fixed nil))
(ignore-errors (enlarge-window-horizontally delta))))))
(defun dirvish-side-decrease-width (delta)
"Decrease width of the `dirvish-side' window by DELTA columns.
Interactively, if no argument is given, DELTA is seen as 1."
(interactive "^p")
(dirvish-side-increase-width (- delta)))
;;;###autoload
(define-minor-mode dirvish-side-follow-mode
"Toggle `dirvish-side-follow-mode'.
When enabled the visible side session will select the current
buffer's filename. It will also visits the latest `project-root'
after switching to a new project."
:init-value nil :global t :group 'dirvish
(if dirvish-side-follow-mode
(add-hook 'buffer-list-update-hook #'dirvish-side--auto-jump)
(remove-hook 'buffer-list-update-hook #'dirvish-side--auto-jump)))
;;;###autoload
(defun dirvish-side (&optional path)
"Toggle a Dirvish session at the side window.
- If the current window is a side session window, hide it.
- If a side session is visible, select it.
- If a side session exists but is not visible, show it.
- If there is no side session exists, create a new one with PATH.
If called with \\[universal-arguments], prompt for PATH,
otherwise it defaults to `project-current'."
(interactive (list (and current-prefix-arg
(read-directory-name "Open sidetree: "))))
(let ((fullframep (when-let* ((dv (dirvish-curr))) (dv-curr-layout dv)))
(visible (dirvish-side--session-visible-p))
(path (or path (dirvish--vc-root-dir) default-directory)))
(cond (fullframep (user-error "Can not create side session here"))
((eq visible (selected-window)) (dirvish-quit))
(visible (select-window visible))
(t (dirvish-side--new path)))))
(provide 'dirvish-side)
;;; dirvish-side.el ends here

436
lisp/dirvish/dirvish-subtree.el Normal file
View File

@@ -0,0 +1,436 @@
;;; dirvish-subtree.el --- Turn Dirvish into a tree browser -*- 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 extension allows users to insert subdirectories in a tree-like fashion,
;; like `dired-subtree' or `treemacs', but simpler and faster.
;;; Code:
(declare-function all-the-icons-octicon "all-the-icons")
(declare-function nerd-icons-octicon "nerd-icons")
(declare-function consult-lsp-file-symbols "consult-lsp")
(declare-function consult-imenu "consult-imenu")
(declare-function consult-line "consult")
(require 'dirvish)
(require 'dired-x)
(require 'transient)
(defcustom dirvish-subtree-listing-switches nil
"Listing SWITCHES used in subtrees.
The value may be a string of options or nil which means the
working switches of current buffer will be used."
:type '(choice symbol string) :group 'dirvish)
(defcustom dirvish-subtree-prefix " │"
"A string put into each nested subtree.
The prefix is repeated \"depth\" times."
:type 'string :group 'dirvish)
(defcustom dirvish-subtree-save-on-revert t
"Non-nil means `revert-buffer' keeps all expanded subtrees."
:type 'boolean :group 'dirvish
:set (lambda (k v)
(set k v)
(if v (add-hook 'dirvish-after-revert-hook #'dirvish-subtree--revert)
(remove-hook 'dirvish-after-revert-hook #'dirvish-subtree--revert))))
(defcustom dirvish-subtree-always-show-state t
"Non-nil means show subtree state indicator even there is no subtrees."
:type 'boolean :group 'dirvish)
(defcustom dirvish-subtree-icon-scale-factor '(0.8 . 0.1)
"Scale factor for subtree state indicator.
The value is a cons of \\='(HEIGHT . V-ADJUST) that used as values of
:height and :v-adjust keyword respectively in `all-the-icons' and
`nerd-icons'."
:type '(cons float float) :group 'dirvish)
(defvar dirvish-subtree--state-icons nil)
(defcustom dirvish-subtree-state-style 'chevron
"Icon/string used for directory expanded state.
The value can be one of: `plus', `arrow', `chevron', `nerd'."
:group 'dirvish :type 'symbol
:set
(lambda (k v)
(and (eq v 'chevron) (not (require 'all-the-icons nil t)) (setq v 'arrow))
(and (eq v 'nerd) (not (require 'nerd-icons nil t)) (setq v 'arrow))
(set k v)
(setq dirvish-subtree--state-icons
(pcase (symbol-value k)
('plus (cons (propertize "-" 'face 'dirvish-subtree-state)
(propertize "+" 'face 'dirvish-subtree-state)))
('arrow (cons (propertize "▾" 'face 'dirvish-subtree-state)
(propertize "▸" 'face 'dirvish-subtree-state)))
('nerd
(cons
(nerd-icons-octicon
"nf-oct-chevron_down"
:height (* (or (bound-and-true-p dirvish-nerd-icons-height) 1)
(car dirvish-subtree-icon-scale-factor))
:v-adjust (cdr dirvish-subtree-icon-scale-factor)
:face 'dirvish-subtree-state)
(nerd-icons-octicon
"nf-oct-chevron_right"
:height (* (or (bound-and-true-p dirvish-nerd-icons-height) 1)
(car dirvish-subtree-icon-scale-factor))
:v-adjust (cdr dirvish-subtree-icon-scale-factor)
:face 'dirvish-subtree-state)))
('chevron
(cons
(all-the-icons-octicon
"chevron-down"
:height (* (or (bound-and-true-p dirvish-all-the-icons-height) 1)
(car dirvish-subtree-icon-scale-factor))
:v-adjust (cdr dirvish-subtree-icon-scale-factor)
:face 'dirvish-subtree-state)
(all-the-icons-octicon
"chevron-right"
:height (* (or (bound-and-true-p dirvish-all-the-icons-height) 1)
(car dirvish-subtree-icon-scale-factor))
:v-adjust (cdr dirvish-subtree-icon-scale-factor)
:face 'dirvish-subtree-state)))))))
(defcustom dirvish-subtree-file-viewer #'dirvish-subtree-default-file-viewer
"The function used to view a file node.
After executing `dirvish-subtree-toggle' on a file node, the
newly opened file buffer is put in either the session preview
window or whatever returned by `next-window'. This function is
called in the opened file buffer with the original buffer of the
window as its sole argument."
:type 'function :group 'dirvish)
(defface dirvish-subtree-state
'((t (:inherit dired-ignored :underline nil :background unspecified)))
"Face used for `expanded-state' attribute."
:group 'dirvish)
(defface dirvish-subtree-guide
'((t (:inherit dired-ignored :underline nil :background unspecified)))
"Face used for `expanded-state' attribute."
:group 'dirvish)
(defvar-local dirvish-subtree--overlays nil "Subtree overlays in this buffer.")
(cl-loop
for (sym ad how) in '((dired-current-directory dirvish-curr-dir-a :around)
(dired-subdir-index dirvish-subdir-index-a :around)
(dired-get-subdir dirvish-get-subdir-a :around)
(dired-remove-entry dirvish-remove-entry-a :around)
(dired-create-empty-file dirvish-new-empty-file-a :around)
(dired-create-directory dirvish-new-directory-a :after))
do (advice-add sym how ad))
(defun dirvish-curr-dir-a (fn &optional localp)
"Advice for FN `dired-current-directory'.
LOCALP is the arg for `dired-current-directory', which see."
(if-let* ((parent (dirvish-subtree--parent))
(dir (concat (overlay-get parent 'dired-subtree-name) "/")))
(if localp (dired-make-relative dir default-directory) dir)
(funcall fn localp)))
(defun dirvish-get-subdir-a (&rest fn-args)
"Advice for FN-ARGS `dired-get-subdir'."
(unless (dirvish-subtree--parent) (apply fn-args)))
(defun dirvish-subdir-index-a (fn dir)
"Advice for FN `dired-subdir-index'.
Ensure correct DIR when inside of a subtree."
(save-excursion
(let ((count 0) ov)
(while (and (setq ov (dirvish-subtree--parent)) (cl-incf count))
(goto-char (overlay-start ov))
(dired-previous-line 1))
(unless (eq count 0) (setq dir (dired-current-directory))))
(funcall fn dir)))
(defun dirvish-remove-entry-a (fn file)
"Advice for FN `dired-remove-entry' FILE."
(if dirvish-subtree--overlays
(save-excursion
(and (dirvish-subtree-expand-to file)
(let (buffer-read-only)
(delete-region (line-beginning-position)
(line-beginning-position 2)))))
(funcall fn file)))
(defun dirvish-new-empty-file-a (fn file)
"Create an empty file called FILE.
Same as FN `dired-create-empty-file', but use
`dired-current-directory' as the prompt."
(interactive (list (read-file-name
"Create empty file: " (dired-current-directory))))
(funcall fn file)
(when dirvish-subtree--overlays (revert-buffer)))
(defun dirvish-new-directory-a (&rest _)
"Advice for `dired-create-directory'.
Ensure the entry is inserted to the buffer after directory
creation even the entry is in nested subtree nodes."
(when dirvish-subtree--overlays (revert-buffer)))
(defun dirvish-subtree--depth ()
"Get subtree depth at point."
(let ((dps (cl-loop for ov in (overlays-at (point)) collect
(or (overlay-get ov 'dired-subtree-depth) 0))))
(or (and dps (apply #'max dps)) 0)))
(defun dirvish-subtree--expanded-p ()
"70x Faster version of `dired-subtree--is-expanded-p'."
(save-excursion (< (dirvish-subtree--depth)
(progn (forward-line 1) (dirvish-subtree--depth)))))
(defun dirvish-subtree--parent (&optional p)
"Get the parent subtree overlay at point P."
(setq p (or p (point)))
(cl-loop
with (pov . max) = (cons nil 0)
for ov in (overlays-at p)
for depth = (or (overlay-get ov 'dired-subtree-depth) 0)
do (when (> depth max) (setq pov ov) (setq max depth))
finally return pov))
(defun dirvish-subtree--readin (dir)
"Readin DIR as a subtree node."
(let ((flags (or dirvish-subtree-listing-switches dired-actual-switches))
(omit-p (bound-and-true-p dired-omit-mode))
str)
(with-temp-buffer
(cl-letf (((symbol-function 'dired-insert-set-properties) #'ignore))
(save-excursion
(dired-insert-directory (file-name-as-directory dir) flags))
(when (looking-at-p " total used in directory")
(delete-region (point) (line-beginning-position 2)))
(setq str (buffer-string))
(if (or (= (length str) 0) (string-prefix-p "//DIRED-OPTIONS//" str)) ""
(let ((str (substring (buffer-string) 0 -1)))
(if omit-p
(string-join
(seq-remove
(lambda (s)
(string-match-p
(dired-omit-regexp)
(substring s (next-single-property-change
0 'dired-filename s))))
(split-string str "\n"))
"\n")
str)))))))
(defun dirvish-subtree--insert ()
"Insert subtree under this directory."
(let* ((dir (dired-get-filename))
(listing (dirvish-subtree--readin dir))
buffer-read-only beg end)
(dirvish--dir-data-async dir (current-buffer) t)
(with-silent-modifications
(save-excursion
(setq beg (progn (move-end-of-line 1) (insert "\n") (point)))
(setq end (progn (insert listing) (1+ (point))))))
(let* ((ov (make-overlay beg end))
(parent (dirvish-subtree--parent (1- beg)))
(p-depth (and parent (1+ (overlay-get parent 'dired-subtree-depth))))
(depth (or p-depth 1))
(prefix (apply #'concat (make-list depth dirvish-subtree-prefix)))
(prefix-len (length prefix)))
(save-excursion
(goto-char beg)
(while (< (point) end)
(add-text-properties (point) (1+ (point)) `(line-prefix ,prefix-len))
(forward-line 1)))
(overlay-put ov 'line-prefix
(propertize prefix 'face 'dirvish-subtree-guide))
(overlay-put ov 'dired-subtree-name dir)
(overlay-put ov 'dired-subtree-depth depth)
(overlay-put ov 'evaporate t)
(push ov dirvish-subtree--overlays))))
(defun dirvish-subtree--revert (&optional clear)
"Reinsert saved subtree nodes into the buffer.
When CLEAR, remove all subtrees in the buffer."
(cl-loop
with filenames = (cl-loop for o in dirvish-subtree--overlays
collect (overlay-get o 'dired-subtree-name))
with index = (dirvish-prop :old-index)
with clear = (or clear (bound-and-true-p dirvish-emerge--group-overlays))
initially (setq dirvish-subtree--overlays nil)
for filename in filenames
do (if clear (when (dired-goto-file filename)
(dired-next-line 1) (dirvish-subtree-remove))
(when (and (dirvish-subtree-expand-to filename)
(not (dirvish-subtree--expanded-p)))
(dirvish-subtree--insert)))
finally (and index (if clear (dired-goto-file index)
(dirvish-subtree-expand-to index)))))
(defun dirvish-subtree-default-file-viewer (orig-buffer)
"Default `dirvish-subtree-file-viewer'.
Try executing `consult-lsp-file-symbols', `consult-imenu',
`consult-line' and `imenu' sequentially until one of them
succeed, switch back to ORIG-BUFFER afterwards regardlessly."
(unwind-protect
(condition-case nil (consult-lsp-file-symbols t)
(error (condition-case nil (consult-imenu)
(error (condition-case nil (consult-line)
(error (message "Failed to view file `%s'. \
See `dirvish-subtree-file-viewer' for details"
buffer-file-name)))))))
(switch-to-buffer orig-buffer)))
(dirvish-define-attribute subtree-state
"A indicator for directory expanding state."
:when (or dirvish-subtree-always-show-state dirvish-subtree--overlays)
:width 1
(let ((state-str
(propertize (if (eq (car f-type) 'dir)
(if (dirvish-subtree--expanded-p)
(car dirvish-subtree--state-icons)
(cdr dirvish-subtree--state-icons))
" ")))
(ov (make-overlay (1+ l-beg) (1+ l-beg))))
(when hl-face
(add-face-text-property 0 1 hl-face t state-str))
(overlay-put ov 'after-string state-str)
`(ov . ,ov)))
(defun dirvish-subtree--move-to-file (file depth)
"Move to FILE at subtree DEPTH."
(let (stop f-beg)
(while (and (not stop)
(= (forward-line) 0)
(setq f-beg (dired-move-to-filename)))
(and (eq depth (dirvish-subtree--depth))
(equal file (buffer-substring f-beg (dired-move-to-end-of-filename)))
(setq stop t)))
stop))
(defun dirvish-subtree-expand-to (target)
"Go to line describing TARGET and expand its parent directories."
(interactive
(list (directory-file-name (expand-file-name
(read-file-name "Expand to file: "
(dired-current-directory))))))
(let* ((file (dired-get-filename nil t))
(dir (dired-current-directory))
(f-dir (and file (file-directory-p file) (file-name-as-directory file))))
(cond ((equal file target) target)
;; distinguish directories with same prefix, e.g .git/ and .github/
((and file (string-prefix-p (or f-dir file) target))
(unless (dirvish-subtree--expanded-p) (dirvish-subtree--insert))
(let ((depth (1+ (dirvish-subtree--depth)))
(next (car (split-string
(substring target (1+ (length file))) "/"))))
(when (dirvish-subtree--move-to-file next depth)
(dirvish-subtree-expand-to target))))
((string-prefix-p dir target)
(let ((depth (dirvish-subtree--depth))
(next (car (split-string (substring target (length dir)) "/"))))
(goto-char (dired-subdir-min))
(goto-char (next-single-property-change (point) 'dired-filename))
(forward-line -1)
;; TARGET is either not exist or being hidden (#135)
(when (dirvish-subtree--move-to-file next depth)
(dirvish-subtree-expand-to target))))
((cl-loop for (d . _) in dired-subdir-alist
if (string-prefix-p d target)
return (dired-goto-subdir d))
(dirvish-subtree-expand-to target))
(t (user-error "[ %s ] does not belong to any subdir" target)))))
;;;###autoload
(defun dirvish-subtree-up ()
"Jump to beginning of current subtree."
(interactive)
(when-let* ((ov (dirvish-subtree--parent)))
(goto-char (overlay-start ov))
(dired-previous-line 1)))
;;;###autoload
(defun dirvish-subtree-remove ()
"Remove subtree at point."
(interactive)
(when-let* ((ov (dirvish-subtree--parent))
(beg (overlay-start ov))
(end (overlay-end ov)))
(goto-char beg)
(dired-previous-line 1)
(cl-loop for o in (overlays-in (point-min) (point-max))
when (and (overlay-get o 'dired-subtree-depth)
(>= (overlay-start o) beg)
(<= (overlay-end o) end))
do (setq dirvish-subtree--overlays
(delq o dirvish-subtree--overlays)))
(with-silent-modifications
(delete-region (overlay-start ov) (overlay-end ov)))))
;;;###autoload
(defun dirvish-subtree-clear ()
"Clear all subtrees in the buffer."
(interactive)
(dirvish-subtree--revert t)
(goto-char (point-min)))
(defun dirvish-subtree--view-file ()
"View file node using `dirvish-subtree-file-viewer'."
(let* ((index (dirvish-prop :index))
(file (or (and (dirvish-prop :remote)
(user-error "Remote file `%s' not previewed" index))
index))
(buf (or (get-file-buffer file) (find-file-noselect file)))
orig-buf)
(when (with-current-buffer buf
(save-excursion (goto-char (point-min))
(search-forward "\0" nil 'noerror)))
(kill-buffer buf)
(user-error "Binary file `%s' not previewed" file))
(with-selected-window (or (get-buffer-window buf) (next-window))
(setq orig-buf (current-buffer))
(switch-to-buffer buf)
(funcall dirvish-subtree-file-viewer orig-buf))))
(defalias 'dirvish-toggle-subtree #'dirvish-subtree-toggle
"Insert subtree at point or remove it if it was not present.")
;;;###autoload
(defun dirvish-subtree-toggle ()
"Insert subtree at point or remove it if it was not present."
(interactive)
(if (dirvish-subtree--expanded-p)
(progn (dired-next-line 1) (dirvish-subtree-remove))
(condition-case err (dirvish-subtree--insert)
(file-error (dirvish-subtree--view-file))
(error (message "%s" (cdr err))))))
(defun dirvish-subtree-toggle-or-open (ev)
"Toggle the subtree if in a dirline, otherwise open the file.
This command takes a mouse event EV as its argument."
(interactive "e")
(let ((win (posn-window (event-end ev)))
(pos (posn-point (event-end ev))))
(unless (windowp win) (error "No file chosen"))
(select-window win)
(with-current-buffer (window-buffer win)
(goto-char pos)
(when-let* ((entry (dired-get-filename nil t)))
(if (file-directory-p entry)
(dirvish-subtree-toggle)
(dirvish--find-entry 'find-file entry))))
(when (window-live-p win) (select-window win))))
;;;###autoload (autoload 'dirvish-subtree-menu "dirvish-subtree" nil t)
(transient-define-prefix dirvish-subtree-menu ()
"Help menu for `dirvish-subtree-*' commands."
[:description
(lambda () (dirvish--format-menu-heading "Manage subtrees"))
("TAB" "Toggle subtree" dirvish-subtree-toggle :transient t)
("t" " Expand until target" dirvish-subtree-expand-to)
("u" " Move up 1 depth level" dirvish-subtree-up)
("r" " Remove current subtree" dirvish-subtree-remove)
("c" " Remove all subtrees" dirvish-subtree-clear)])
(provide 'dirvish-subtree)
;;; dirvish-subtree.el ends here

147
lisp/dirvish/dirvish-tramp.el Normal file
View File

@@ -0,0 +1,147 @@
;;; dirvish-tramp.el --- Dirvish tramp integration -*- 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:
;; Handle directory opening, file attributes retrieving and file preview on
;; TRAMP connections within Dirvish. This library is only loaded after a TRAMP
;; connection is initiated, which speeds up the package loading.
;;; Code:
(require 'dirvish)
(require 'tramp)
;; TODO: we don't have to use -Alh if the connection has GNU ls
(defconst dirvish-tramp-preview-cmd
"head -n 1000 %s 2>/dev/null || ls -Alh %s 2>/dev/null")
(defvar dirvish-tramp-hosts '())
(defun dirvish-tramp-noselect (fn dir flags remote local-dispatchers)
"Return the Dired buffer at DIR with listing FLAGS.
Save the REMOTE host to `dirvish-tramp-hosts'.
FN is the original `dired-noselect' closure."
(let* ((saved-flags (cdr (assoc remote dirvish-tramp-hosts #'equal)))
(short-flags "-Alh")
(default-directory dir)
(vec (tramp-dissect-file-name dir))
(async-type (dirvish-tramp--async-p vec))
(gnuls "ls")
(dired-buffers nil) ; disable reuse from `dired'
(buffer (cond ((eq async-type 'local) (funcall fn dir flags))
(saved-flags (funcall fn dir saved-flags)) ; skip
((= (or (process-file gnuls nil nil nil "--version") 1) 0)
(push (cons remote flags) dirvish-tramp-hosts)
(funcall fn dir flags))
(t (setq gnuls nil)
(push (cons remote short-flags) dirvish-tramp-hosts)
(funcall fn dir short-flags)))))
(with-current-buffer buffer
(dirvish-prop :gnuls gnuls)
(cond ((eq async-type 'local)
(dirvish-prop :sudo 1)
(dirvish-prop :preview-dps local-dispatchers))
((eq async-type 'async)
(dirvish-prop :remote-async 1)
(dirvish-prop :preview-dps '(dirvish-tramp-dp)))
(t (dirvish-prop :preview-dps '(dirvish-tramp-unsupported-dp))))
(dirvish-prop :tramp vec)
buffer)))
(defun dirvish-tramp--async-p (vec)
"Return t if tramp connection VEC support async commands."
(cond ((tramp-local-host-p vec) 'local) ; the connection is either localhost
;; or it's a remote host that supports `direct-async'
((tramp-direct-async-process-p) 'async)))
(defun dirvish-tramp--ls-parser (entry output)
"Parse ls OUTPUT for ENTRY and store it in `dirvish--dir-data'."
(dolist (file (and (> (length output) 2) (cl-subseq output 2 -1)))
(cl-destructuring-bind
(inode priv lnum user group size mon day time &rest path)
(split-string file)
(let* ((sym (cl-position "->" path :test #'equal))
(f-name (string-join (cl-subseq path 0 sym) " "))
(f-mtime (concat mon " " day " " time))
(f-truename (and sym (string-join (cl-subseq path (1+ sym)) " ")))
(f-dirp (string-prefix-p "d" priv))
(f-type (or f-truename f-dirp)))
(puthash (secure-hash 'md5 (expand-file-name f-name entry))
`(:builtin ,(list f-type lnum user group nil
f-mtime nil size priv nil inode)
:type ,(cons (if f-dirp 'dir 'file) f-truename))
dirvish--dir-data)))))
(defun dirvish-tramp-dir-data-proc-s (proc _exit)
"Sentinel for `dirvish-data-for-dir''s process PROC."
(unwind-protect
(pcase-let* ((`(,dir ,buf ,inhibit-setup) (process-get proc 'meta))
(str (with-current-buffer (process-buffer proc)
(substring-no-properties (buffer-string))))
(data (split-string str "\n")))
(when (buffer-live-p buf)
(with-current-buffer buf
(dirvish-tramp--ls-parser dir data)
(unless inhibit-setup (run-hooks 'dirvish-setup-hook))
(dirvish--redisplay))))
(dirvish--kill-buffer (process-buffer proc))))
(cl-defmethod dirvish-data-for-dir
(dir buffer inhibit-setup
&context ((dirvish-prop :remote-async) number)
&context ((dirvish-prop :gnuls) string))
"Fetch data for DIR in BUFFER.
It is called when DIRVISH-PROP has key `:remote-aysnc' and `:gnuls',
which means DIR is opened over a remote host that supports
`direct-async' and comes with valid gnuls executable. Run
`dirvish-setup-hook' after data parsing unless INHIBIT-SETUP is non-nil."
(let* ((process-connection-type nil)
(buf (get-buffer-create (make-temp-name "tramp-data-")))
(cmd (format "%s -1lahi %s" (dirvish-prop :gnuls)
(file-local-name dir)))
(proc (start-file-process-shell-command (buffer-name buf) buf cmd)))
(process-put proc 'meta (list dir buffer inhibit-setup))
(set-process-sentinel proc #'dirvish-tramp-dir-data-proc-s)))
(dirvish-define-preview tramp-unsupported ()
"Preview files with `ls' or `head' for tramp files."
(let ((msg "File preview is not supported in this connection.
1. Please check if you have GNU ls installed over remote host.
2. Adjust your `direct-async' tramp settings, for example:
;; set `tramp-direct-async-process' locally in all ssh connections
(connection-local-set-profile-variables
'remote-direct-async-process
'((tramp-direct-async-process . t)))
(connection-local-set-profiles
'(:application tramp :protocol \"ssh\")
'remote-direct-async-process)
See (info \"(tramp) Improving performance of asynchronous remote processes\") for details."))
`(info . ,msg)))
(dirvish-define-preview tramp (file _ dv)
"Preview files with `ls' or `head' for tramp files."
(let ((process-connection-type nil)
(buf (dirvish--special-buffer 'preview dv t)) proc)
(when-let* ((proc (get-buffer-process buf))) (delete-process proc))
(setq proc (start-file-process-shell-command
(buffer-name buf) buf
(format dirvish-tramp-preview-cmd file file)))
(set-process-sentinel
proc (lambda (proc _sig)
(when (memq (process-status proc) '(exit signal))
(shell-command-set-point-after-cmd (process-buffer proc)))))
(set-process-filter
proc (lambda (proc str)
(when-let* ((b (process-buffer proc)) ((buffer-live-p b)))
(with-current-buffer b (let (buffer-read-only) (insert str))))))
`(buffer . ,buf)))
(provide 'dirvish-tramp)
;;; dirvish-tramp.el ends here

271
lisp/dirvish/dirvish-vc.el Normal file
View File

@@ -0,0 +1,271 @@
;;; dirvish-vc.el --- Version-control integration for 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:
;; Show version-control info such as git commit message at root window and git
;; diff at preview window in Dirvish.
;;; Code:
(require 'dirvish)
(require 'transient)
(define-fringe-bitmap 'dirvish-vc-gutter [250] nil nil '(center repeated))
(defclass dirvish-vc-preview (transient-switches) ()
"Class for dirvish vc-* preview dispatchers.")
(defcustom dirvish-vc-state-face-alist
'((up-to-date . nil)
(edited . dirvish-vc-edited-state)
(added . dirvish-vc-added-state)
(removed . dirvish-vc-removed-state)
(missing . dirvish-vc-missing-state)
(needs-merge . dirvish-vc-needs-merge-face)
(conflict . dirvish-vc-conflict-state)
(unlocked-changes . dirvish-vc-locked-state)
(needs-update . dirvish-vc-needs-update-state)
(ignored . nil)
(unregistered . dirvish-vc-unregistered-face))
"Alist of (VC-STATE . FACE).
This value is consumed by `vc-state' attribute in Dirvish. FACE is the
face used for that VC-STATE. See `vc-state' in (in vc-hooks.el) for
detail explanation of these states."
:group 'dirvish
:type '(alist :key-type symbol :value-type (symbol :tag "Face")))
(defvar dirvish-vc--always-ignored "/node_modules"
"Always ignore folders matches this regex, as they may choke Emacs.")
(defface dirvish-vc-needs-merge-face
'((((background dark)) (:background "#500f29"))
(t (:background "#efcbcf")))
"Face used for `needs-merge' vc state in the Dirvish buffer."
:group 'dirvish)
(defface dirvish-vc-unregistered-face
'((t (:inherit font-lock-constant-face)))
"Face used for `unregistered' vc state in the Dirvish buffer."
:group 'dirvish)
(defface dirvish-git-commit-message-face
'((t (:inherit dired-ignored :underline nil :background unspecified)))
"Face for commit message overlays."
:group 'dirvish)
(defface dirvish-vc-edited-state
'((t :inherit vc-edited-state))
"Face used for `edited' vc state in the Dirvish buffer."
:group 'dirvish)
(defface dirvish-vc-added-state
'((t :inherit vc-locally-added-state))
"Face used for `added' vc state in the Dirvish buffer."
:group 'dirvish)
(defface dirvish-vc-removed-state
'((t :inherit vc-removed-state))
"Face used for `removed' vc state in the Dirvish buffer."
:group 'dirvish)
(defface dirvish-vc-missing-state
'((t :inherit vc-missing-state))
"Face used for `missing' vc state in the Dirvish buffer."
:group 'dirvish)
(defface dirvish-vc-conflict-state
'((t :inherit vc-conflict-state))
"Face used for `conflict' vc state in the Dirvish buffer."
:group 'dirvish)
(defface dirvish-vc-locked-state
'((t :inherit vc-locked-state))
"Face used for `locked' vc state in the Dirvish buffer."
:group 'dirvish)
(defface dirvish-vc-needs-update-state
'((t :inherit vc-needs-update-state))
"Face used for `needs-update' vc state in the Dirvish buffer."
:group 'dirvish)
(defvar vc-dir-process-buffer)
(cl-defmethod dirvish-data-for-dir
(dir buffer inhibit-setup
&context ((dirvish-prop :vc-backend) symbol)
&context ((dirvish-prop :remote) symbol))
"Fetch data for DIR in BUFFER.
It is called when `:vc-backend' is included in DIRVISH-PROPs while
`:remote' is not, i.e. a local version-controlled directory. Run
`dirvish-setup-hook' after data parsing unless INHIBIT-SETUP is non-nil."
(dirvish--make-proc
`(prin1
(let* ((hs (make-hash-table))
(bk ',(dirvish-prop :vc-backend))
(info (vc-call-backend bk 'mode-line-string ,dir)))
;; keep this until `vc-git' fixed upstream. See: #224 and #273
(advice-add #'vc-git--git-status-to-vc-state :around
(lambda (fn codes) (apply fn (list (delete-dups codes)))))
(dolist (file (directory-files ,dir t nil t))
(let ((state (if (string-suffix-p ,dirvish-vc--always-ignored file)
'ignored (vc-state-refresh file bk)))
(msg (and (eq bk 'Git)
(shell-command-to-string
(format "git log -1 --pretty=%%s %s"
(shell-quote-argument file))))))
(puthash (secure-hash 'md5 file)
`(:vc-state ,state :git-msg ,msg) hs)))
(cons info hs)))
(lambda (p _)
(pcase-let ((`(,buf . ,inhibit-setup) (process-get p 'meta))
(`(,info . ,data) (with-current-buffer (process-buffer p)
(read (buffer-string)))))
(when (buffer-live-p buf)
(with-current-buffer buf
(maphash
(lambda (k v)
(let ((orig (gethash k dirvish--dir-data)))
(setf (plist-get orig :vc-state) (plist-get v :vc-state))
(setf (plist-get orig :git-msg) (plist-get v :git-msg))
(puthash k orig dirvish--dir-data)))
data)
(dirvish-prop :vc-info info)
(unless inhibit-setup (run-hooks 'dirvish-setup-hook))
(dirvish--redisplay))))
(delete-process p)
(dirvish--kill-buffer (process-buffer p)))
nil 'meta (cons buffer inhibit-setup)))
(cl-defmethod transient-infix-set ((obj dirvish-vc-preview) value)
"Set relevant value in DIRVISH-VC-PREVIEW instance OBJ to VALUE."
(oset obj value value)
(let* ((dv (dirvish-curr))
(buf (current-buffer))
(old-layout (dv-curr-layout dv))
(new-layout (unless old-layout (dv-ff-layout dv)))
(new-dps (seq-difference
dirvish-preview-dispatchers '(vc-diff vc-log vc-blame))))
(when value (push (intern (format "%s" value)) new-dps))
(dirvish-prop :preview-dps (dirvish--preview-dps-validate new-dps))
(if (not new-layout)
(dirvish--preview-update dv (dirvish-prop :index))
(quit-window nil (dv-root-window dv))
(delete-window transient--window)
(setf (dv-curr-layout dv) new-layout)
(switch-to-buffer buf)
(dirvish--build-layout dv))))
(transient-define-infix dirvish-vc-preview-ifx ()
:description "Preview style"
:class 'dirvish-vc-preview
:argument-format "vc-%s"
:argument-regexp "\\(vc-\\(log\\|diff\\|blame\\)\\)"
:choices '("log" "diff" "blame"))
(dirvish-define-attribute vc-state
"The version control state at left fringe.
This attribute only works on graphic displays."
:when (and (symbolp (dirvish-prop :vc-backend)) (not (dirvish-prop :remote)))
(let ((ov (make-overlay l-beg l-beg)))
(when-let* ((state (dirvish-attribute-cache f-name :vc-state))
(face (alist-get state dirvish-vc-state-face-alist))
(display `(left-fringe dirvish-vc-gutter . ,(cons face nil))))
(overlay-put ov 'before-string (propertize " " 'display display)))
`(ov . ,ov)))
(dirvish-define-attribute git-msg
"Display short git log."
:when (and (eq (dirvish-prop :vc-backend) 'Git) (not (dirvish-prop :remote)))
:setup (dirvish-prop :gm-chop
(seq-reduce (lambda (acc i) (cl-incf acc (nth 2 i)))
(dirvish-prop :attrs) 0))
(let* ((msg-raw (dirvish-attribute-cache f-name :git-msg))
(msg (if (>= (length msg-raw) 1) (substring msg-raw 0 -1) ""))
(face (or hl-face 'dirvish-git-commit-message-face))
(chop (dirvish-prop :gm-chop)) (mlen (length msg)) (stop t)
(limit (- (floor (* (if (< w-width 70) 0.48 0.6) w-width)) chop))
(count 0) (whole (concat " " msg (make-string w-width ?\ ))) str len)
(cond ((or (not msg-raw) (< w-width 30)) (setq str ""))
((and (>= w-width 30) (< w-width 50)) (setq str (propertize " … ")))
(t (setq str "" stop (<= limit 0))))
(while (not stop) ; prevent multibyte string taking too much space
(setq str (substring whole 0 count))
(if (>= (- limit (string-width str)) 1)
(cl-incf count)
(setq str (concat str (if (> count mlen) " " "… ")) stop t)))
(add-face-text-property 0 (setq len (length str)) face t str)
(add-text-properties 0 len `(help-echo ,msg) str)
`(right . ,str)))
(dirvish-define-preview vc-diff (ext)
"Use output of `vc-diff' as preview."
(when (and (symbolp (dirvish-prop :vc-backend))
(not (member ext dirvish-binary-exts))
(cl-letf (((symbol-function 'pop-to-buffer) #'ignore)
((symbol-function 'message) #'ignore))
(vc-diff)))
'(buffer . "*vc-diff*")))
(dirvish-define-preview vc-log ()
"Use output of `vc-print-log' as preview."
(when (and (symbolp (dirvish-prop :vc-backend))
(cl-letf (((symbol-function 'pop-to-buffer) #'ignore))
(prog1 t (vc-print-log))))
'(buffer . "*vc-change-log*")))
(dirvish-define-preview vc-blame (file ext preview-window dv)
"Use output of `vc-annotate' (file) or `vc-dir' (dir) as preview."
(when-let* ((bk (dirvish-prop :vc-backend))
((symbolp bk))
(display-buffer-alist
'(("\\*\\(Annotate \\|vc-dir\\).*\\*"
(display-buffer-same-window)))))
(if (file-directory-p file)
(with-selected-window preview-window
(vc-dir file bk)
(cl-pushnew vc-dir-process-buffer (dv-preview-buffers dv))
`(buffer . ,(current-buffer)))
(when-let* ((file (and (not (member ext dirvish-binary-exts))
(not (memq (vc-state file bk)
'(unregistered ignored)))
file))
(f-buf (cdr (dirvish--find-file-temporarily file)))
((bufferp f-buf)))
(cl-pushnew f-buf (dv-preview-buffers dv))
(with-selected-window preview-window
(with-current-buffer f-buf
(cl-letf (((symbol-function 'message) #'ignore))
(vc-annotate file nil 'fullscale nil nil bk))
(cl-pushnew (window-buffer) (dv-preview-buffers dv))
`(buffer . ,(window-buffer))))))))
(dirvish-define-mode-line vc-info
"Version control info such as git branch."
(when-let* (((> (window-width) 30))
(info-seq (dirvish-prop :vc-info))
(info (copy-sequence info-seq)))
(unless (dirvish--selected-p)
(put-text-property 0 (length info) 'face 'dirvish-inactive info))
info))
;;;###autoload (autoload 'dirvish-vc-menu "dirvish-vc" nil t)
(transient-define-prefix dirvish-vc-menu ()
"Help menu for features in `dirvish-vc'."
:init-value
(lambda (o) (oset o value (mapcar (lambda (d) (format "%s" d))
dirvish-preview-dispatchers)))
[:description
(lambda () (dirvish--format-menu-heading "Version control commands"))
("v" dirvish-vc-preview-ifx
:if (lambda () (symbolp (dirvish-prop :vc-backend))))
("n" "Do the next action" dired-vc-next-action
:if (lambda () (symbolp (dirvish-prop :vc-backend))))
("c" "Create repo" vc-create-repo)])
(provide 'dirvish-vc)
;;; dirvish-vc.el ends here

754
lisp/dirvish/dirvish-widgets.el Normal file
View File

@@ -0,0 +1,754 @@
;;; 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

420
lisp/dirvish/dirvish-yank.el Normal file
View File

@@ -0,0 +1,420 @@
;;; dirvish-yank.el --- Multi-stage and async copy/paste/link utilities -*- 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:
;; Multi-stage and asynchronous copy/paste/link utilities in Dirvish.
;; With the multi-stage operations, you can gather files from multiple Dired
;; buffers into a single "clipboard", then copy or move all of them to the
;; target location.
;; Here are the available commands:
;; Note that they are asynchronous and work on both localhost and remote host.
;; - `dirvish-yank'
;; - `dirvish-move'
;; - `dirvish-symlink'
;; - `dirvish-relative-symlink'
;; - `dirvish-hardlink'
;;; Code:
(require 'dired-aux)
(require 'dirvish)
(require 'transient)
(defcustom dirvish-yank-sources 'all
"The way to collect source files.
The value can be a symbol or a function that returns a fileset."
:group 'dirvish
:type '(choice (const :tag "Marked files in current buffer" buffer)
(const :tag "Marked files in current session" session)
(const :tag "Marked files in all Dired buffers" all)
(function :tag "Custom function")))
(defcustom dirvish-yank-auto-unmark t
"Control if yank commands should unmark when complete."
:group 'dirvish :type 'boolean)
(defcustom dirvish-yank-overwrite-existing-files 'ask
"Whether to overwrite existing files when calling yank commands."
:group 'dirvish
:type '(choice (const :tag "prompt for confirmation" ask)
(const :tag "always overwrite" always)
(const :tag "skip transferring files with same names" skip)
(const :tag "overwrite and backup the original file" backup)))
(defcustom dirvish-yank-new-name-style 'append-to-ext
"Control the way to compose new filename."
:group 'dirvish
:type '(choice (const :tag "append INDEX~ to file extension" append-to-ext)
(const :tag "append INDEX~ to file name" append-to-filename)
(const :tag "prepend INDEX~ to file name" prepend-to-filename)))
(defcustom dirvish-yank-keep-success-log t
"If non-nil then keep logs of all completed yanks.
By default only keep the log buffer alive for failed tasks."
:type 'boolean :group 'dirvish)
(defun dirvish-yank--menu-setter (symbol pairs)
"Set key-command PAIRS for SYMBOL `dirvish-yank-menu'."
(when symbol (set symbol pairs))
(eval
`(transient-define-prefix dirvish-yank-menu ()
"Yank commands menu."
[:description
(lambda () (dirvish--format-menu-heading
"Select yank operation on marked files:"))
,@pairs]
(interactive)
(if (derived-mode-p 'dired-mode)
(transient-setup 'dirvish-yank-menu)
(user-error "Not in a Dirvish buffer")))))
;;;###autoload (autoload 'dirvish-yank-menu "dirvish-yank" nil t)
(defcustom dirvish-yank-keys
'(("y" "Yank (paste) here" dirvish-yank)
("m" "Move here" dirvish-move)
("s" "Make symlinks here" dirvish-symlink)
("r" "Make relative symlinks here" dirvish-relative-symlink)
("h" "Make hardlinks here" dirvish-hardlink))
"YANK-KEYs for command `dirvish-yank-menu'.
A YANK-KEY is a (KEY DOC CMD) alist where KEY is the key to invoke the
CMD, DOC is the documentation string."
:group 'dirvish :type 'alist :set #'dirvish-yank--menu-setter)
(defconst dirvish-yank-fn-string
'((dired-copy-file . "Copying")
(dired-rename-file . "Moving")
(dired-hardlink . "Hardlink")
(make-symbolic-link . "Symlink")
(dired-make-relative-symlink . "Relative symlink")
(rsync . "Rsync")))
(defvar dirvish-yank-log-buffers nil)
;; copied from `dired-async' and `dired-rsync'
(defconst dirvish-yank-env-variables-regexp
"\\`\\(tramp-\\(default\\|connection\\|remote\\)\\|ange-ftp\\)-.*"
"Variables matching this regexp will be loaded on Child Emacs.")
;; matches "Enter passphrase for key ..." (ssh) and "password for ..." (samba)
(defvar dirvish-yank-passphrase-stall-regex
"\\(Enter \\)?[Pp]ass\\(word\\|phrase\\) for\\( key\\)?"
"A regex to detect passphrase prompts.")
(defvar dirvish-yank-percent-complete-regex "[[:digit:]]\\{1,3\\}%"
"A regex to extract the % complete from a file.")
(defun dirvish-yank--get-srcs (&optional range)
"Get all marked filenames in RANGE.
RANGE can be `buffer', `session', `all'."
(setq range (or range 'buffer))
(cl-remove-duplicates
(cl-loop
with case-fold-search = nil
with regexp = (dired-marker-regexp)
with buffers = (pcase range
('buffer (list (current-buffer)))
('session (mapcar #'cdr (dv-roots (dirvish-curr))))
('all (cl-loop for b in (buffer-list)
when (with-current-buffer b
(derived-mode-p 'dired-mode))
collect b)))
for buffer in (seq-filter #'buffer-live-p buffers) append
(with-current-buffer buffer
(when (save-excursion (goto-char (point-min))
(re-search-forward regexp nil t))
(dired-map-over-marks (dired-get-filename) nil))))
:test #'equal))
(defun dirvish-yank--read-dest (method)
"Read dest dir for METHOD when prefixed with `current-prefix-arg'."
(list (when current-prefix-arg
(read-file-name (format "%s files to: " method)
(dired-dwim-target-directory)
nil nil nil 'file-directory-p))))
(defun dirvish-yank-proc-sentinel (proc _exit)
"Sentinel for yank task PROC."
(pcase-let ((proc-buf (process-buffer proc))
(`(,buffer ,_ ,_ ,method) (process-get proc 'details))
(status (process-status proc))
(success (eq (process-exit-status proc) 0)))
(when (memq status '(exit signal))
(if (and success (not dirvish-yank-keep-success-log))
(kill-buffer proc-buf)
(with-current-buffer (get-buffer-create "*dirvish-yank-log*")
(goto-char (point-max))
(insert "\n\n" (format "%s" method)
" finished @ " (current-time-string) "\n")
(insert-buffer-substring proc-buf)
(kill-buffer proc-buf)
;; truncate old logs
(save-excursion
(delete-region
(point-min)
(let ((max (point-max)))
(if (< max 20000)
(point-min)
(goto-char max)
(dotimes (_n 40) (backward-paragraph))
(point)))))
(unless success
(message "Task FAILED with exit code %s" (process-exit-status proc))
(pop-to-buffer (current-buffer)))))
(when (eq buffer (current-buffer))
(with-current-buffer buffer (revert-buffer) (dirvish--redisplay))))))
(defun dirvish-yank-proc-filter (proc string)
"Filter for yank task PROC's STRING."
(let ((proc-buf (process-buffer proc)))
;; check for passphrase prompt
(when (string-match dirvish-yank-passphrase-stall-regex string)
(process-send-string proc (concat (read-passwd string) "\n")))
;; Answer yes for `large file' prompt
(when (string-match "File .* is large\\(.*\\), really copy" string)
(process-send-string proc "y\n"))
(let ((old-process-mark (process-mark proc)))
(when (buffer-live-p proc-buf)
(with-current-buffer proc-buf
(when (string-match dirvish-yank-percent-complete-regex string)
(dirvish-prop :yank-percent (match-string 0 string))
(force-mode-line-update t))
(let ((moving (= (point) old-process-mark)))
(save-excursion
(goto-char old-process-mark)
(insert string)
(set-marker (process-mark proc) (point)))
(if moving (goto-char (process-mark proc)))))))))
(defun dirvish-yank--execute (cmd details &optional batch)
"Handle execution of CMD.
When BATCH, execute the command using `emacs -q -batch'. Propagate
DETAILS to the process. Remove markers when `dirvish-yank-auto-unmark'
is t."
(pcase-let* ((`(,_ ,_ ,dest ,_) details)
(command (if batch
(let ((q (if (file-remote-p dest) "-q" "-Q")))
(list dirvish-emacs-bin q "-batch" "--eval" cmd))
cmd)))
(dirvish-yank--start-proc command details)
(when dirvish-yank-auto-unmark
(cl-loop for buf in (buffer-list)
do (with-current-buffer buf
(when (derived-mode-p 'dired-mode)
(dired-unmark-all-marks)))))))
(defun dirvish-yank--start-proc (cmd details)
"Start a new process for CMD, put DETAILS into the process."
(let* ((process-connection-type nil) (name "*dirvish-yank*")
(buf (get-buffer-create (format "*yank@%s*" (current-time-string))))
(fn (lambda () (setq dirvish-yank-log-buffers
(delete buf dirvish-yank-log-buffers))))
(proc (if (listp cmd)
(make-process :name name :buffer buf :command cmd)
(start-process-shell-command name buf cmd))))
(with-current-buffer buf
(add-hook 'kill-buffer-hook fn nil t) ; user may kill yank buffers
(dirvish-prop :yank-details details))
(process-put proc 'details details)
(set-process-sentinel proc #'dirvish-yank-proc-sentinel)
(set-process-filter proc #'dirvish-yank-proc-filter)
(push buf dirvish-yank-log-buffers)))
(defun dirvish-yank--newbase (base-name fileset dest)
"Ensure an unique filename for BASE-NAME at DEST with FILESET."
(let ((bname~ base-name) (idx 1))
(while (member bname~ fileset)
(setq bname~
(pcase dirvish-yank-new-name-style
('append-to-ext (format "%s%s~" base-name idx))
('append-to-filename
(format "%s%s~.%s"
(file-name-sans-extension base-name)
idx (file-name-extension base-name)))
('prepend-to-filename (format "%s~%s" idx base-name)))
idx (1+ idx)))
(cons (expand-file-name base-name dest) (expand-file-name bname~ dest))))
(defun dirvish-yank--filename-pairs (method srcs dest)
"Generate file name pairs from SRCS and DEST for yank METHOD."
(cl-loop
with overwrite = (eq dirvish-yank-overwrite-existing-files 'always)
with backup = (eq dirvish-yank-overwrite-existing-files 'backup)
with skip = (eq dirvish-yank-overwrite-existing-files 'skip)
with (result to-rename) = ()
with dfiles = (directory-files dest nil nil t)
for src in srcs
for help-form = (format-message "\
File `%s' exists, type one of the following keys to continue.
- y or SPC to overwrite this file WITHOUT backup
- ! answer y for all remaining files
- n or DEL to skip this file
- N answer n for all remaining files
- b to overwrite and backup this files
- B answer b for all remaining files
- q or ESC to abort the task" src)
for base = (file-name-nondirectory src)
for collision = (member base dfiles) do
(cond ((equal src (concat dest base))
;; user may want to make symlink in the same directory
(if (memq method '(dired-make-relative-symlink make-symbolic-link))
(push (cons src (cdr (dirvish-yank--newbase base dfiles dest)))
result)
(user-error
"DIRVISH[yank]: source and target are the same file `%s'" src)))
(overwrite (push (cons src dest) result))
((and backup collision)
(push (dirvish-yank--newbase base dfiles dest) to-rename)
(push (cons src dest) result))
((and skip collision))
(collision
(cl-case (read-char-choice
(concat (format-message "Overwrite `%s'?" base)
(format " [Type yn!bq or %s] "
(key-description (vector help-char))))
'(?y ?\s ?! ?n ?\177 ?N ?b ?B ?q ?\e))
((?y ?\s) (push (cons src dest) result))
(?! (setq overwrite t) (push (cons src dest) result))
((?n ?\177) nil)
(?N (setq skip t) nil)
(?b (push (dirvish-yank--newbase base dfiles dest) to-rename)
(push (cons src dest) result))
(?B (setq backup t)
(push (dirvish-yank--newbase base dfiles dest) to-rename)
(push (cons src dest) result))
((?q ?\e) (user-error "DIRVISH[yank]: task aborted"))))
(t (push (cons src dest) result)))
finally return
(prog1 result
(cl-loop for (from . to) in to-rename do (rename-file from to)))))
(defun dirvish-yank--inject-env (include-regexp)
"Return a `setq' form that replicates part of the calling environment.
It sets the value for every variable matching INCLUDE-REGEXP."
`(setq ,@(let (bindings)
(mapatoms
(lambda (sym)
(let* ((sname (and (boundp sym) (symbol-name sym)))
(value (and sname (symbol-value sym))))
(when (and sname (string-match include-regexp sname)
(not (string-match "-syntax-table\\'" sname)))
(unless (or (stringp value) (memq value '(nil t))
(numberp value) (vectorp value))
(setq value `(quote ,value)))
(setq bindings (cons value bindings)
bindings (cons sym bindings))))))
bindings)))
(defun dirvish-yank-default-handler (method srcs dest)
"Execute yank METHOD on SRCS to DEST."
(let* ((pairs (dirvish-yank--filename-pairs method srcs dest))
(count (float (length pairs)))
(cmd `(progn
(require 'dired-aux)
(require 'dired-x)
,(dirvish-yank--inject-env dirvish-yank-env-variables-regexp)
(cl-loop
with dired-recursive-copies = 'always
with dired-copy-preserve-time = ,dired-copy-preserve-time
for idx from 1
for (from . to) in '(,@pairs)
for percent = (if (eq (float idx) ,count) 100
(floor (* (/ idx ,count) 100)))
do (progn (message "%s -> %s [%s%%]" from to percent)
(condition-case err
(funcall #',method from to t)
(file-error
(message "%s: %s\n" (car err) (cdr err)) nil)))
finally (cl-loop for b in (buffer-list) thereis
(and (string-match "\\`\\*ftp.*"
(buffer-name b))
(prog1 b (kill-buffer b)))))))
print-level print-length)
(dirvish-yank--execute
(prin1-to-string cmd) (list (current-buffer) srcs dest method) 'batch)))
(defun dirvish-yank--apply (method dest)
"Apply yank METHOD to DEST."
(setq dest (expand-file-name (or dest (dired-current-directory))))
(let ((srcs (or (and (functionp dirvish-yank-sources)
(funcall dirvish-yank-sources))
(dirvish-yank--get-srcs dirvish-yank-sources)
(user-error "DIRVISH[yank]: no marked files"))))
(dirvish-yank-default-handler method srcs dest)))
(dirvish-define-mode-line yank
"Progress of yank tasks."
(let ((number-of-tasks (length dirvish-yank-log-buffers)))
(cond ((= number-of-tasks 0))
((= number-of-tasks 1)
(pcase-let* ((buf (car dirvish-yank-log-buffers))
(`(,_ ,srcs ,dest ,method)
(with-current-buffer buf (dirvish-prop :yank-details)))
(percent (with-current-buffer buf
(dirvish-prop :yank-percent)))
(count (length srcs)))
(format "%s%s: %s ⇛ %s "
(propertize
(format "%s" (alist-get method dirvish-yank-fn-string))
'face 'font-lock-constant-face)
(if (not percent) ""
(propertize (format " [ %s%%%%%%%% ] " percent)
'face 'success))
(propertize
(if (= count 1) (car srcs) (format "%s files" count))
'face 'font-lock-keyword-face)
(propertize dest 'face 'font-lock-doc-face))))
((> number-of-tasks 1)
(format " %s %s%s "
(propertize (number-to-string number-of-tasks)
'face 'font-lock-keyword-face)
(propertize "running tasks" 'face 'font-lock-doc-face)
(propertize (if (> number-of-tasks 1) "s" "")
'face 'font-lock-doc-face))))))
;;;###autoload
(defun dirvish-yank (&optional dest)
"Paste marked files to DEST.
Prompt for DEST when prefixed with \\[universal-argument], it defaults
to `dired-current-directory.'"
(interactive (dirvish-yank--read-dest 'yank))
(dirvish-yank--apply 'dired-copy-file dest))
;;;###autoload
(defun dirvish-move (&optional dest)
"Move marked files to DEST.
Prompt for DEST when prefixed with \\[universal-argument], it defaults
to `dired-current-directory'."
(interactive (dirvish-yank--read-dest 'move))
(dirvish-yank--apply 'dired-rename-file dest))
;;;###autoload
(defun dirvish-symlink (&optional dest)
"Symlink marked files to DEST.
Prompt for DEST when prefixed with \\[universal-argument], it defaults
to `dired-current-directory'."
(interactive (dirvish-yank--read-dest 'symlink))
(dirvish-yank--apply 'make-symbolic-link dest))
;;;###autoload
(defun dirvish-relative-symlink (&optional dest)
"Similar to `dirvish-symlink', but link files relatively.
Prompt for DEST when prefixed with \\[universal-argument], it defaults
to `dired-current-directory'."
(interactive (dirvish-yank--read-dest 'relalink))
(dirvish-yank--apply 'dired-make-relative-symlink dest))
;;;###autoload
(defun dirvish-hardlink (&optional dest)
"Hardlink marked files to DEST.
Prompt for DEST when prefixed with \\[universal-argument], it defaults
to `dired-current-directory'."
(interactive (dirvish-yank--read-dest 'hardlink))
(dirvish-yank--apply 'dired-hardlink dest))
(provide 'dirvish-yank)
;;; dirvish-yank.el ends here

1614
lisp/dirvish/dirvish.el Normal file
View File

File diff suppressed because it is too large Load Diff

11
lisp/epl/epl-pkg.el Normal file
View File

@@ -0,0 +1,11 @@
;; -*- no-byte-compile: t; lexical-binding: nil -*-
(define-package "epl" "20180205.2049"
"Emacs Package Library."
'((cl-lib "0.3"))
:url "http://github.com/cask/epl"
:commit "78ab7a85c08222cd15582a298a364774e3282ce6"
:revdesc "78ab7a85c082"
:keywords '("convenience")
:authors '(("Sebastian Wiesner" . "swiesner@lunaryorn.com"))
:maintainers '(("Johan Andersson" . "johan.rejeep@gmail.com")
("Sebastian Wiesner" . "swiesner@lunaryorn.com")))

711
lisp/epl/epl.el Normal file
View File

@@ -0,0 +1,711 @@
;;; epl.el --- Emacs Package Library -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2015 Sebastian Wiesner
;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2015 Free Software
;; Author: Sebastian Wiesner <swiesner@lunaryorn.com>
;; Maintainer: Johan Andersson <johan.rejeep@gmail.com>
;; Sebastian Wiesner <swiesner@lunaryorn.com>
;; Package-Version: 20180205.2049
;; Package-Revision: 78ab7a85c082
;; Package-Requires: ((cl-lib "0.3"))
;; Keywords: convenience
;; URL: http://github.com/cask/epl
;; This file is NOT part of GNU Emacs.
;; 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, or
;; (at your option) any later version.
;; 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 this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; A package management library for Emacs, based on package.el.
;; The purpose of this library is to wrap all the quirks and hassle of
;; package.el into a sane API.
;; The following functions comprise the public interface of this library:
;;; Package directory selection
;; `epl-package-dir' gets the directory of packages.
;; `epl-default-package-dir' gets the default package directory.
;; `epl-change-package-dir' changes the directory of packages.
;;; Package system management
;; `epl-initialize' initializes the package system and activates all
;; packages.
;; `epl-reset' resets the package system.
;; `epl-refresh' refreshes all package archives.
;; `epl-add-archive' adds a new package archive.
;;; Package objects
;; Struct `epl-requirement' describes a requirement of a package with `name' and
;; `version' slots.
;; `epl-requirement-version-string' gets a requirement version as string.
;; Struct `epl-package' describes an installed or installable package with a
;; `name' and some internal `description'.
;; `epl-package-version' gets the version of a package.
;; `epl-package-version-string' gets the version of a package as string.
;; `epl-package-summary' gets the summary of a package.
;; `epl-package-requirements' gets the requirements of a package.
;; `epl-package-directory' gets the installation directory of a package.
;; `epl-package-from-buffer' creates a package object for the package contained
;; in the current buffer.
;; `epl-package-from-file' creates a package object for a package file, either
;; plain lisp or tarball.
;; `epl-package-from-descriptor-file' creates a package object for a package
;; description (i.e. *-pkg.el) file.
;;; Package database access
;; `epl-package-installed-p' determines whether a package is installed, either
;; built-in or explicitly installed.
;; `epl-package-outdated-p' determines whether a package is outdated, that is,
;; whether a package with a higher version number is available.
;; `epl-built-in-packages', `epl-installed-packages', `epl-outdated-packages'
;; and `epl-available-packages' get all packages built-in, installed, outdated,
;; or available for installation respectively.
;; `epl-find-built-in-package', `epl-find-installed-packages' and
;; `epl-find-available-packages' find built-in, installed and available packages
;; by name.
;; `epl-find-upgrades' finds all upgradable packages.
;; `epl-built-in-p' return true if package is built-in to Emacs.
;;; Package operations
;; `epl-install-file' installs a package file.
;; `epl-package-install' installs a package.
;; `epl-package-delete' deletes a package.
;; `epl-upgrade' upgrades packages.
;;; Code:
(require 'cl-lib)
(require 'package)
(unless (fboundp #'define-error)
;; `define-error' for 24.3 and earlier, copied from subr.el
(defun define-error (name message &optional parent)
"Define NAME as a new error signal.
MESSAGE is a string that will be output to the echo area if such an error
is signaled without being caught by a `condition-case'.
PARENT is either a signal or a list of signals from which it inherits.
Defaults to `error'."
(unless parent (setq parent 'error))
(let ((conditions
(if (consp parent)
(apply #'append
(mapcar (lambda (parent)
(cons parent
(or (get parent 'error-conditions)
(error "Unknown signal `%s'" parent))))
parent))
(cons parent (get parent 'error-conditions)))))
(put name 'error-conditions
(delete-dups (copy-sequence (cons name conditions))))
(when message (put name 'error-message message)))))
(defsubst epl--package-desc-p (package)
"Whether PACKAGE is a `package-desc' object.
Like `package-desc-p', but return nil, if `package-desc-p' is not
defined as function."
(and (fboundp 'package-desc-p) (package-desc-p package)))
;;; EPL errors
(define-error 'epl-error "EPL error")
(define-error 'epl-invalid-package "Invalid EPL package" 'epl-error)
(define-error 'epl-invalid-package-file "Invalid EPL package file"
'epl-invalid-package)
;;; Package directory
(defun epl-package-dir ()
"Get the directory of packages."
package-user-dir)
(defun epl-default-package-dir ()
"Get the default directory of packages."
(eval (car (get 'package-user-dir 'standard-value))))
(defun epl-change-package-dir (directory)
"Change the directory of packages to DIRECTORY."
(setq package-user-dir directory)
(epl-initialize))
;;; Package system management
(defvar epl--load-path-before-initialize nil
"Remember the load path for `epl-reset'.")
(defun epl-initialize (&optional no-activate)
"Load Emacs Lisp packages and activate them.
With NO-ACTIVATE non-nil, do not activate packages."
(setq epl--load-path-before-initialize load-path)
(package-initialize no-activate))
(defalias 'epl-refresh 'package-refresh-contents)
(defun epl-add-archive (name url)
"Add a package archive with NAME and URL."
(add-to-list 'package-archives (cons name url)))
(defun epl-reset ()
"Reset the package system.
Clear the list of installed and available packages, the list of
package archives and reset the package directory."
(setq package-alist nil
package-archives nil
package-archive-contents nil
load-path epl--load-path-before-initialize)
(when (boundp 'package-obsolete-alist) ; Legacy package.el
(setq package-obsolete-alist nil))
(epl-change-package-dir (epl-default-package-dir)))
;;; Package structures
(cl-defstruct (epl-requirement
(:constructor epl-requirement-create))
"Structure describing a requirement.
Slots:
`name' The name of the required package, as symbol.
`version' The version of the required package, as version list."
name
version)
(defun epl-requirement-version-string (requirement)
"The version of a REQUIREMENT, as string."
(package-version-join (epl-requirement-version requirement)))
(cl-defstruct (epl-package (:constructor epl-package-create))
"Structure representing a package.
Slots:
`name' The package name, as symbol.
`description' The package description.
The format package description varies between package.el
variants. For `package-desc' variants, it is simply the
corresponding `package-desc' object. For legacy variants, it is
a vector `[VERSION REQS DOCSTRING]'.
Do not access `description' directly, but instead use the
`epl-package' accessors."
name
description)
(defmacro epl-package-as-description (var &rest body)
"Cast VAR to a package description in BODY.
VAR is a symbol, bound to an `epl-package' object. This macro
casts this object to the `description' object, and binds the
description to VAR in BODY."
(declare (indent 1))
(unless (symbolp var)
(signal 'wrong-type-argument (list #'symbolp var)))
`(if (epl-package-p ,var)
(let ((,var (epl-package-description ,var)))
,@body)
(signal 'wrong-type-argument (list #'epl-package-p ,var))))
(defsubst epl-package--package-desc-p (package)
"Whether the description of PACKAGE is a `package-desc'."
(epl--package-desc-p (epl-package-description package)))
(defun epl-package-version (package)
"Get the version of PACKAGE, as version list."
(epl-package-as-description package
(cond
((fboundp 'package-desc-version) (package-desc-version package))
;; Legacy
((fboundp 'package-desc-vers)
(let ((version (package-desc-vers package)))
(if (listp version) version (version-to-list version))))
(:else (error "Cannot get version from %S" package)))))
(defun epl-package-version-string (package)
"Get the version from a PACKAGE, as string."
(package-version-join (epl-package-version package)))
(defun epl-package-summary (package)
"Get the summary of PACKAGE, as string."
(epl-package-as-description package
(cond
((fboundp 'package-desc-summary) (package-desc-summary package))
((fboundp 'package-desc-doc) (package-desc-doc package)) ; Legacy
(:else (error "Cannot get summary from %S" package)))))
(defsubst epl-requirement--from-req (req)
"Create a `epl-requirement' from a `package-desc' REQ."
(let ((version (cadr req)))
(epl-requirement-create :name (car req)
:version (if (listp version) version
(version-to-list version)))))
(defun epl-package-requirements (package)
"Get the requirements of PACKAGE.
The requirements are a list of `epl-requirement' objects."
(epl-package-as-description package
(mapcar #'epl-requirement--from-req (package-desc-reqs package))))
(defun epl-package-directory (package)
"Get the directory PACKAGE is installed to.
Return the absolute path of the installation directory of
PACKAGE, or nil, if PACKAGE is not installed."
(cond
((fboundp 'package-desc-dir)
(package-desc-dir (epl-package-description package)))
((fboundp 'package--dir)
(package--dir (symbol-name (epl-package-name package))
(epl-package-version-string package)))
(:else (error "Cannot get package directory from %S" package))))
(defun epl-package-->= (pkg1 pkg2)
"Determine whether PKG1 is before PKG2 by version."
(not (version-list-< (epl-package-version pkg1)
(epl-package-version pkg2))))
(defun epl-package--from-package-desc (package-desc)
"Create an `epl-package' from a PACKAGE-DESC.
PACKAGE-DESC is a `package-desc' object, from recent package.el
variants."
(if (and (fboundp 'package-desc-name)
(epl--package-desc-p package-desc))
(epl-package-create :name (package-desc-name package-desc)
:description package-desc)
(signal 'wrong-type-argument (list 'epl--package-desc-p package-desc))))
(defun epl-package--parse-info (info)
"Parse a package.el INFO."
(if (epl--package-desc-p info)
(epl-package--from-package-desc info)
;; For legacy package.el, info is a vector [NAME REQUIRES DESCRIPTION
;; VERSION COMMENTARY]. We need to re-shape this vector into the
;; `package-alist' format [VERSION REQUIRES DESCRIPTION] to attach it to the
;; new `epl-package'.
(let ((name (intern (aref info 0)))
(info (vector (aref info 3) (aref info 1) (aref info 2))))
(epl-package-create :name name :description info))))
(defun epl-package-from-buffer (&optional buffer)
"Create an `epl-package' object from BUFFER.
BUFFER defaults to the current buffer.
Signal `epl-invalid-package' if the buffer does not contain a
valid package file."
(let ((info (with-current-buffer (or buffer (current-buffer))
(condition-case err
(package-buffer-info)
(error (signal 'epl-invalid-package (cdr err)))))))
(epl-package--parse-info info)))
(defun epl-package-from-lisp-file (file-name)
"Parse the package headers the file at FILE-NAME.
Return an `epl-package' object with the header metadata."
(with-temp-buffer
(insert-file-contents file-name)
(condition-case err
(epl-package-from-buffer (current-buffer))
;; Attach file names to invalid package errors
(epl-invalid-package
(signal 'epl-invalid-package-file (cons file-name (cdr err))))
;; Forward other errors
(error (signal (car err) (cdr err))))))
(defun epl-package-from-tar-file (file-name)
"Parse the package tarball at FILE-NAME.
Return a `epl-package' object with the meta data of the tarball
package in FILE-NAME."
(condition-case nil
;; In legacy package.el, `package-tar-file-info' takes the name of the tar
;; file to parse as argument. In modern package.el, it has no arguments
;; and works on the current buffer. Hence, we just try to call the legacy
;; version, and if that fails because of a mismatch between formal and
;; actual arguments, we use the modern approach. To avoid spurious
;; signature warnings by the byte compiler, we suppress warnings when
;; calling the function.
(epl-package--parse-info (with-no-warnings
(package-tar-file-info file-name)))
(wrong-number-of-arguments
(with-temp-buffer
(insert-file-contents-literally file-name)
;; Switch to `tar-mode' to enable extraction of the file. Modern
;; `package-tar-file-info' relies on `tar-mode', and signals an error if
;; called in a buffer with a different mode.
(tar-mode)
(epl-package--parse-info (with-no-warnings
(package-tar-file-info)))))))
(defun epl-package-from-file (file-name)
"Parse the package at FILE-NAME.
Return an `epl-package' object with the meta data of the package
at FILE-NAME."
(if (string-match-p (rx ".tar" string-end) file-name)
(epl-package-from-tar-file file-name)
(epl-package-from-lisp-file file-name)))
(defun epl-package--parse-descriptor-requirement (requirement)
"Parse a REQUIREMENT in a package descriptor."
;; This function is only called on legacy package.el. On package-desc
;; package.el, we just let package.el do the work.
(cl-destructuring-bind (name version-string) requirement
(list name (version-to-list version-string))))
(defun epl-package-from-descriptor-file (descriptor-file)
"Load a `epl-package' from a package DESCRIPTOR-FILE.
A package descriptor is a file defining a new package. Its name
typically ends with -pkg.el."
(with-temp-buffer
(insert-file-contents descriptor-file)
(goto-char (point-min))
(let ((sexp (read (current-buffer))))
(unless (eq (car sexp) 'define-package)
(error "%S is no valid package descriptor" descriptor-file))
(if (and (fboundp 'package-desc-from-define)
(fboundp 'package-desc-name))
;; In Emacs snapshot, we can conveniently call a function to parse the
;; descriptor
(let ((desc (apply #'package-desc-from-define (cdr sexp))))
(epl-package-create :name (package-desc-name desc)
:description desc))
;; In legacy package.el, we must manually deconstruct the descriptor,
;; because the load function has eval's the descriptor and has a lot of
;; global side-effects.
(cl-destructuring-bind
(name version-string summary requirements) (cdr sexp)
(epl-package-create
:name (intern name)
:description
(vector (version-to-list version-string)
(mapcar #'epl-package--parse-descriptor-requirement
;; Strip the leading `quote' from the package list
(cadr requirements))
summary)))))))
;;; Package database access
(defun epl-package-installed-p (package &optional min-version)
"Determine whether a PACKAGE, of MIN-VERSION or newer, is installed.
PACKAGE is either a package name as symbol, or a package object.
When a explicit MIN-VERSION is provided it overwrites the version of the PACKAGE object."
(let ((name (if (epl-package-p package)
(epl-package-name package)
package))
(min-version (or min-version (and (epl-package-p package)
(epl-package-version package)))))
(package-installed-p name min-version)))
(defun epl--parse-built-in-entry (entry)
"Parse an ENTRY from the list of built-in packages.
Return the corresponding `epl-package' object."
(if (fboundp 'package--from-builtin)
;; In package-desc package.el, convert the built-in package to a
;; `package-desc' and convert that to an `epl-package'
(epl-package--from-package-desc (package--from-builtin entry))
(epl-package-create :name (car entry) :description (cdr entry))))
(defun epl-built-in-packages ()
"Get all built-in packages.
Return a list of `epl-package' objects."
;; This looks mighty strange, but it's the only way to force package.el to
;; build the list of built-in packages. Without this, `package--builtins'
;; might be empty.
(package-built-in-p 'foo)
(mapcar #'epl--parse-built-in-entry package--builtins))
(defun epl-find-built-in-package (name)
"Find a built-in package with NAME.
NAME is a package name, as symbol.
Return the built-in package as `epl-package' object, or nil if
there is no built-in package with NAME."
(when (package-built-in-p name)
;; We must call `package-built-in-p' *before* inspecting
;; `package--builtins', because otherwise `package--builtins' might be
;; empty.
(epl--parse-built-in-entry (assq name package--builtins))))
(defun epl-package-outdated-p (package)
"Determine whether a PACKAGE is outdated.
A package is outdated, if there is an available package with a
higher version.
PACKAGE is either a package name as symbol, or a package object.
In the former case, test the installed or built-in package with
the highest version number, in the later case, test the package
object itself.
Return t, if the package is outdated, or nil otherwise."
(let* ((package (if (epl-package-p package)
package
(or (car (epl-find-installed-packages package))
(epl-find-built-in-package package))))
(available (car (epl-find-available-packages
(epl-package-name package)))))
(and package available (version-list-< (epl-package-version package)
(epl-package-version available)))))
(defun epl--parse-package-list-entry (entry)
"Parse a list of packages from ENTRY.
ENTRY is a single entry in a package list, e.g. `package-alist',
`package-archive-contents', etc. Typically it is a cons cell,
but the exact format varies between package.el versions. This
function tries to parse all known variants.
Return a list of `epl-package' objects parsed from ENTRY."
(let ((descriptions (cdr entry)))
(cond
((listp descriptions)
(sort (mapcar #'epl-package--from-package-desc descriptions)
#'epl-package-->=))
;; Legacy package.el has just a single package in an entry, which is a
;; standard description vector
((vectorp descriptions)
(list (epl-package-create :name (car entry)
:description descriptions)))
(:else (error "Cannot parse entry %S" entry)))))
(defun epl-installed-packages ()
"Get all installed packages.
Return a list of package objects."
(apply #'append (mapcar #'epl--parse-package-list-entry package-alist)))
(defsubst epl--filter-outdated-packages (packages)
"Filter outdated packages from PACKAGES."
(let (res)
(dolist (package packages)
(when (epl-package-outdated-p package)
(push package res)))
(nreverse res)))
(defun epl-outdated-packages ()
"Get all outdated packages, as in `epl-package-outdated-p'.
Return a list of package objects."
(epl--filter-outdated-packages (epl-installed-packages)))
(defsubst epl--find-package-in-list (name list)
"Find a package by NAME in a package LIST.
Return a list of corresponding `epl-package' objects."
(let ((entry (assq name list)))
(when entry
(epl--parse-package-list-entry entry))))
(defun epl-find-installed-package (name)
"Find the latest installed package by NAME.
NAME is a package name, as symbol.
Return the installed package with the highest version number as
`epl-package' object, or nil, if no package with NAME is
installed."
(car (epl-find-installed-packages name)))
(make-obsolete 'epl-find-installed-package 'epl-find-installed-packages "0.7")
(defun epl-find-installed-packages (name)
"Find all installed packages by NAME.
NAME is a package name, as symbol.
Return a list of all installed packages with NAME, sorted by
version number in descending order. Return nil, if there are no
packages with NAME."
(epl--find-package-in-list name package-alist))
(defun epl-available-packages ()
"Get all packages available for installation.
Return a list of package objects."
(apply #'append (mapcar #'epl--parse-package-list-entry
package-archive-contents)))
(defun epl-find-available-packages (name)
"Find available packages for NAME.
NAME is a package name, as symbol.
Return a list of available packages for NAME, sorted by version
number in descending order. Return nil, if there are no packages
for NAME."
(epl--find-package-in-list name package-archive-contents))
(cl-defstruct (epl-upgrade
(:constructor epl-upgrade-create))
"Structure describing an upgradable package.
Slots:
`installed' The installed package
`available' The package available for installation."
installed
available)
(defun epl-find-upgrades (&optional packages)
"Find all upgradable PACKAGES.
PACKAGES is a list of package objects to upgrade, defaulting to
all installed packages.
Return a list of `epl-upgrade' objects describing all upgradable
packages."
(let ((packages (or packages (epl-installed-packages)))
upgrades)
(dolist (pkg packages)
(let* ((version (epl-package-version pkg))
(name (epl-package-name pkg))
;; Find the latest available package for NAME
(available-pkg (car (epl-find-available-packages name)))
(available-version (when available-pkg
(epl-package-version available-pkg))))
(when (and available-version (version-list-< version available-version))
(push (epl-upgrade-create :installed pkg
:available available-pkg)
upgrades))))
(nreverse upgrades)))
(defalias 'epl-built-in-p 'package-built-in-p)
;;; Package operations
(defun epl-install-file (file)
"Install a package from FILE, like `package-install-file'."
(interactive (advice-eval-interactive-spec
(cadr (interactive-form #'package-install-file))))
(apply #'package-install-file (list file))
(let ((package (epl-package-from-file file)))
(unless (epl-package--package-desc-p package)
(epl--kill-autoload-buffer package))))
(defun epl--kill-autoload-buffer (package)
"Kill the buffer associated with autoloads for PACKAGE."
(let* ((auto-name (format "%s-autoloads.el" (epl-package-name package)))
(generated-autoload-file (expand-file-name auto-name (epl-package-directory package)))
(buf (find-buffer-visiting generated-autoload-file)))
(when buf (kill-buffer buf))))
(defun epl-package-install (package &optional force)
"Install a PACKAGE.
PACKAGE is a `epl-package' object. If FORCE is given and
non-nil, install PACKAGE, even if it is already installed."
(when (or force (not (epl-package-installed-p package)))
(if (epl-package--package-desc-p package)
(package-install (epl-package-description package))
;; The legacy API installs by name. We have no control over versioning,
;; etc.
(package-install (epl-package-name package))
(epl--kill-autoload-buffer package))))
(defun epl-package-delete (package)
"Delete a PACKAGE.
PACKAGE is a `epl-package' object to delete."
;; package-delete allows for packages being trashed instead of fully deleted.
;; Let's prevent his silly behavior
(let ((delete-by-moving-to-trash nil))
;; The byte compiler will warn us that we are calling `package-delete' with
;; the wrong number of arguments, since it can't infer that we guarantee to
;; always call the correct version. Thus we suppress all warnings when
;; calling `package-delete'. I wish there was a more granular way to
;; disable just that specific warning, but it is what it is.
(if (epl-package--package-desc-p package)
(with-no-warnings
(package-delete (epl-package-description package)))
;; The legacy API deletes by name (as string!) and version instead by
;; descriptor. Hence `package-delete' takes two arguments. For some
;; insane reason, the arguments are strings here!
(let ((name (symbol-name (epl-package-name package)))
(version (epl-package-version-string package)))
(with-no-warnings
(package-delete name version))
;; Legacy package.el does not remove the deleted package
;; from the `package-alist', so we do it manually here.
(let ((pkg (assq (epl-package-name package) package-alist)))
(when pkg
(setq package-alist (delq pkg package-alist))))))))
(defun epl-upgrade (&optional packages preserve-obsolete)
"Upgrade PACKAGES.
PACKAGES is a list of package objects to upgrade, defaulting to
all installed packages.
The old versions of the updated packages are deleted, unless
PRESERVE-OBSOLETE is non-nil.
Return a list of all performed upgrades, as a list of
`epl-upgrade' objects."
(let ((upgrades (epl-find-upgrades packages)))
(dolist (upgrade upgrades)
(epl-package-install (epl-upgrade-available upgrade) 'force)
(unless preserve-obsolete
(epl-package-delete (epl-upgrade-installed upgrade))))
upgrades))
(provide 'epl)
;;; epl.el ends here