From 807d0f28f63916d0b648d67a982fbf0e7437c4d9 Mon Sep 17 00:00:00 2001 From: Daniel Weschke Date: Sun, 6 Jul 2025 21:26:51 +0200 Subject: [PATCH] add package dependencies --- lisp/deflate/deflate-pkg.el | 11 + lisp/deflate/deflate.el | 1006 ++++++++++++++++ lisp/dirvish/dirvish-collapse.el | 87 ++ lisp/dirvish/dirvish-emerge.el | 577 +++++++++ lisp/dirvish/dirvish-extras.el | 441 +++++++ lisp/dirvish/dirvish-fd.el | 334 ++++++ lisp/dirvish/dirvish-history.el | 99 ++ lisp/dirvish/dirvish-icons.el | 138 +++ lisp/dirvish/dirvish-ls.el | 183 +++ lisp/dirvish/dirvish-narrow.el | 174 +++ lisp/dirvish/dirvish-peek.el | 173 +++ lisp/dirvish/dirvish-pkg.el | 11 + lisp/dirvish/dirvish-quick-access.el | 70 ++ lisp/dirvish/dirvish-rsync.el | 378 ++++++ lisp/dirvish/dirvish-side.el | 203 ++++ lisp/dirvish/dirvish-subtree.el | 436 +++++++ lisp/dirvish/dirvish-tramp.el | 147 +++ lisp/dirvish/dirvish-vc.el | 271 +++++ lisp/dirvish/dirvish-widgets.el | 754 ++++++++++++ lisp/dirvish/dirvish-yank.el | 420 +++++++ lisp/dirvish/dirvish.el | 1614 ++++++++++++++++++++++++++ lisp/epl/epl-pkg.el | 11 + lisp/epl/epl.el | 711 ++++++++++++ 23 files changed, 8249 insertions(+) create mode 100644 lisp/deflate/deflate-pkg.el create mode 100644 lisp/deflate/deflate.el create mode 100644 lisp/dirvish/dirvish-collapse.el create mode 100644 lisp/dirvish/dirvish-emerge.el create mode 100644 lisp/dirvish/dirvish-extras.el create mode 100644 lisp/dirvish/dirvish-fd.el create mode 100644 lisp/dirvish/dirvish-history.el create mode 100644 lisp/dirvish/dirvish-icons.el create mode 100644 lisp/dirvish/dirvish-ls.el create mode 100644 lisp/dirvish/dirvish-narrow.el create mode 100644 lisp/dirvish/dirvish-peek.el create mode 100644 lisp/dirvish/dirvish-pkg.el create mode 100644 lisp/dirvish/dirvish-quick-access.el create mode 100644 lisp/dirvish/dirvish-rsync.el create mode 100644 lisp/dirvish/dirvish-side.el create mode 100644 lisp/dirvish/dirvish-subtree.el create mode 100644 lisp/dirvish/dirvish-tramp.el create mode 100644 lisp/dirvish/dirvish-vc.el create mode 100644 lisp/dirvish/dirvish-widgets.el create mode 100644 lisp/dirvish/dirvish-yank.el create mode 100644 lisp/dirvish/dirvish.el create mode 100644 lisp/epl/epl-pkg.el create mode 100644 lisp/epl/epl.el diff --git a/lisp/deflate/deflate-pkg.el b/lisp/deflate/deflate-pkg.el new file mode 100644 index 00000000..51ac81e8 --- /dev/null +++ b/lisp/deflate/deflate-pkg.el @@ -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"))) diff --git a/lisp/deflate/deflate.el b/lisp/deflate/deflate.el new file mode 100644 index 00000000..e60b8d53 --- /dev/null +++ b/lisp/deflate/deflate.el @@ -0,0 +1,1006 @@ +;;; deflate.el --- The DEFLATE compression algorithm in pure Emacs LISP -*- lexical-binding: t; -*- + +;; Copyright (C) 2025 Carlo Sciolla + +;; Author: Carlo Sciolla +;; Maintainer: Carlo Sciolla +;; Keywords: files, tools +;; Filename: deflate.el +;; Description: The DEFLATE compression algorithm in pure Emacs LISP +;; Compatibility: Tested with Emacs 25 through 30 +;; Package-Version: 20250703.808 +;; Package-Revision: 4896cdf0c1d0 +;; Package-Requires: ((dash "2.0.0") (emacs "25.1")) +;; Homepage: https://github.com/skuro/deflate + +;; 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 . + +;;; Commentary: + +;; The DEFLATE algorithm is specified by the RFC 1951. +;; See: https://datatracker.ietf.org/doc/html/rfc1951 + +;;; Change log: +;; +;; version 0.0.5, 2025-07-03 Fixed bug with single-nodes huffman trees +;; version 0.0.4, 2025-07-01 Added deflate-zlib-compress to facilitate zlib usage +;; version 0.0.3, 2025-06-12 Fixed critical bug with dynamic Huffman +;; version 0.0.2, 2025-06-11 Fixed a few warnings and bugs, preparing for actual release +;; version 0.0.1, 2025-06-11 Initial release with support for dynamic Huffman / no-compression blocks + +;;; Code: + +;; ---- Bit/byte level utility Functions ---- + +(require 'dash) + +(defun deflate--bytes-to-bits (bytes) + "Convert a list of BYTES into a list of bits (0 or 1)." + (let ((bits '())) + (dolist (byte bytes) + (dotimes (i 8) + (push (if (= (logand byte (ash 1 i)) 0) 0 1) bits))) + (nreverse bits))) + +(defun deflate--bits-to-bytes (bits) + "Convert a list of BITS into a list of bytes. +The `car' of the list is considered to be the least position bit." + (let ((bytes '()) + (current-byte 0) + (bit-position 0)) + (dolist (bit bits) + (when (= bit 1) + (setq current-byte (logior current-byte (ash 1 bit-position)))) + (setq bit-position (1+ bit-position)) + (when (= bit-position 8) + (push current-byte bytes) + (setq current-byte 0 + bit-position 0))) + ;; Handle any remaining bits + (when (> bit-position 0) + (push current-byte bytes)) + (nreverse bytes))) + +(defun deflate--number->bits (num len) + "Convert NUM to a list of binary digits (0 and 1) of length LEN." + (let ((result nil)) + (while (< (length result) len) + (push (mod num 2) result) + (setq num (/ num 2))) + result)) + +;; ---- LZ77 Compression ---- + +(defconst deflate--window-size 32768 + "Size of the sliding window for LZ77 compression.") + +(defconst deflate--min-match 3 + "Minimum match length for LZ77 compression.") + +(defconst deflate--max-match 258 + "Maximum match length for LZ77 compression.") + + +(defun deflate--find-match (data pos) + "Find the longest match for DATA at POS within the sliding window. +Returns a list (offset length) or nil if no match found." + (let ((best-length 0) + (best-distance 0) + (window-start (max 0 (- pos deflate--window-size))) + (data-length (length data))) + ;; Create a range of numbers from window-start to pos-1 + (let ((indices (-map (lambda (x) (+ x window-start)) + (-iota (- pos window-start))))) + ;; Process each index + (--each indices + (let* ((i it) ;; Current index + (max-match-len (min deflate--max-match (- data-length pos))) + (match-len 0)) + ;; Find the maximum match length + (while (and (< match-len max-match-len) + (< (+ pos match-len) data-length) + (< (+ i match-len) pos) + (= (nth (+ i match-len) data) + (nth (+ pos match-len) data))) + (setq match-len (1+ match-len))) + + ;; Update the best match if this one is better + (when (and (>= match-len deflate--min-match) + (> match-len best-length)) + (setq best-length match-len + best-distance (- pos i)))))) + + (if (>= best-length deflate--min-match) + (list best-length best-distance) + nil))) + +(defun deflate--lz77-compress (data) + "Perform LZ77 compression on DATA. +Returns a list of tokens, where each token is either a literal byte +or a list (distance length) for a match." + (let ((result '()) + (pos 0) + (data-length (length data))) + (while (< pos data-length) + (let ((match (deflate--find-match data pos))) + (if match + (let ((length (car match)) + (distance_ (cadr match))) + (push (list length distance_) result) + (setq pos (+ pos length))) + (push (nth pos data) result) + (setq pos (1+ pos))))) + (nreverse result))) + +;; ---- Huffman Coding ---- + +(defun deflate--get-length-code (length) + "Convert a match LENGTH to the appropriate DEFLATE length code. +Returns a cons cell (code . extra-bits) where code is 257-285 +and extra-bits is a cons of (num-bits . value)." + (cond + ;; Direct encoding for lengths 3-10 (codes 257-264) + ((<= length 10) + (cons (+ 257 (- length 3)) '(0 . 0))) + + ;; Lengths 11-12 (code 265, 1 extra bit) + ((<= length 12) + (cons 265 (cons 1 (- length 11)))) + + ;; Lengths 13-14 (code 266, 1 extra bit) + ((<= length 14) + (cons 266 (cons 1 (- length 13)))) + + ;; Lengths 15-16 (code 267, 1 extra bit) + ((<= length 16) + (cons 267 (cons 1 (- length 15)))) + + ;; Lengths 17-18 (code 268, 1 extra bit) + ((<= length 18) + (cons 268 (cons 1 (- length 17)))) + + ;; Lengths 19-22 (code 269, 2 extra bits) + ((<= length 22) + (cons 269 (cons 2 (- length 19)))) + + ;; Lengths 23-26 (code 270, 2 extra bits) + ((<= length 26) + (cons 270 (cons 2 (- length 23)))) + + ;; Lengths 27-30 (code 271, 2 extra bits) + ((<= length 30) + (cons 271 (cons 2 (- length 27)))) + + ;; Lengths 31-34 (code 272, 2 extra bits) + ((<= length 34) + (cons 272 (cons 2 (- length 31)))) + + ;; Lengths 35-42 (code 273, 3 extra bits) + ((<= length 42) + (cons 273 (cons 3 (- length 35)))) + + ;; Lengths 43-50 (code 274, 3 extra bits) + ((<= length 50) + (cons 274 (cons 3 (- length 43)))) + + ;; Lengths 51-58 (code 275, 3 extra bits) + ((<= length 58) + (cons 275 (cons 3 (- length 51)))) + + ;; Lengths 59-66 (code 276, 3 extra bits) + ((<= length 66) + (cons 276 (cons 3 (- length 59)))) + + ;; Lengths 67-82 (code 277, 4 extra bits) + ((<= length 82) + (cons 277 (cons 4 (- length 67)))) + + ;; Lengths 83-98 (code 278, 4 extra bits) + ((<= length 98) + (cons 278 (cons 4 (- length 83)))) + + ;; Lengths 99-114 (code 279, 4 extra bits) + ((<= length 114) + (cons 279 (cons 4 (- length 99)))) + + ;; Lengths 115-130 (code 280, 4 extra bits) + ((<= length 130) + (cons 280 (cons 4 (- length 115)))) + + ;; Lengths 131-162 (code 281, 5 extra bits) + ((<= length 162) + (cons 281 (cons 5 (- length 131)))) + + ;; Lengths 163-194 (code 282, 5 extra bits) + ((<= length 194) + (cons 282 (cons 5 (- length 163)))) + + ;; Lengths 195-226 (code 283, 5 extra bits) + ((<= length 226) + (cons 283 (cons 5 (- length 195)))) + + ;; Lengths 227-257 (code 284, 5 extra bits) + ((<= length 257) + (cons 284 (cons 5 (- length 227)))) + + ;; Length 258 (code 285, 0 extra bits) + (t + (cons 285 '(0 . 0))))) + +;; NOTE: the formal parameter has the * character +(defun deflate--get-distance-code (distance*) + "Convert a match DISTANCE* to the appropriate DEFLATE distance code. +Returns a cons cell (code . extra-bits) where code is 0-29 +and extra-bits is a cons of (num-bits . value)." + (cond + ;; Direct encoding for distances 1-4 (codes 0-3) + ((<= distance* 4) + (cons (- distance* 1) '(0 . 0))) + + ;; Distances 5-6 (code 4, 1 extra bit) + ((<= distance* 6) + (cons 4 (cons 1 (- distance* 5)))) + + ;; Distances 7-8 (code 5, 1 extra bit) + ((<= distance* 8) + (cons 5 (cons 1 (- distance* 7)))) + + ;; Distances 9-12 (code 6, 2 extra bits) + ((<= distance* 12) + (cons 6 (cons 2 (- distance* 9)))) + + ;; Distances 13-16 (code 7, 2 extra bits) + ((<= distance* 16) + (cons 7 (cons 2 (- distance* 13)))) + + ;; Distances 17-24 (code 8, 3 extra bits) + ((<= distance* 24) + (cons 8 (cons 3 (- distance* 17)))) + + ;; Distances 25-32 (code 9, 3 extra bits) + ((<= distance* 32) + (cons 9 (cons 3 (- distance* 25)))) + + ;; Distances 33-48 (code 10, 4 extra bits) + ((<= distance* 48) + (cons 10 (cons 4 (- distance* 33)))) + + ;; Distances 49-64 (code 11, 4 extra bits) + ((<= distance* 64) + (cons 11 (cons 4 (- distance* 49)))) + + ;; Distances 65-96 (code 12, 5 extra bits) + ((<= distance* 96) + (cons 12 (cons 5 (- distance* 65)))) + + ;; Distances 97-128 (code 13, 5 extra bits) + ((<= distance* 128) + (cons 13 (cons 5 (- distance* 97)))) + + ;; Distances 129-192 (code 14, 6 extra bits) + ((<= distance* 192) + (cons 14 (cons 6 (- distance* 129)))) + + ;; Distances 193-256 (code 15, 6 extra bits) + ((<= distance* 256) + (cons 15 (cons 6 (- distance* 193)))) + + ;; Distances 257-384 (code 16, 7 extra bits) + ((<= distance* 384) + (cons 16 (cons 7 (- distance* 257)))) + + ;; Distances 385-512 (code 17, 7 extra bits) + ((<= distance* 512) + (cons 17 (cons 7 (- distance* 385)))) + + ;; Distances 513-768 (code 18, 8 extra bits) + ((<= distance* 768) + (cons 18 (cons 8 (- distance* 513)))) + + ;; Distances 769-1024 (code 19, 8 extra bits) + ((<= distance* 1024) + (cons 19 (cons 8 (- distance* 769)))) + + ;; Distances 1025-1536 (code 20, 9 extra bits) + ((<= distance* 1536) + (cons 20 (cons 9 (- distance* 1025)))) + + ;; Distances 1537-2048 (code 21, 9 extra bits) + ((<= distance* 2048) + (cons 21 (cons 9 (- distance* 1537)))) + + ;; Distances 2049-3072 (code 22, 10 extra bits) + ((<= distance* 3072) + (cons 22 (cons 10 (- distance* 2049)))) + + ;; Distances 3073-4096 (code 23, 10 extra bits) + ((<= distance* 4096) + (cons 23 (cons 10 (- distance* 3073)))) + + ;; Distances 4097-6144 (code 24, 11 extra bits) + ((<= distance* 6144) + (cons 24 (cons 11 (- distance* 4097)))) + + ;; Distances 6145-8192 (code 25, 11 extra bits) + ((<= distance* 8192) + (cons 25 (cons 11 (- distance* 6145)))) + + ;; Distances 8193-12288 (code 26, 12 extra bits) + ((<= distance* 12288) + (cons 26 (cons 12 (- distance* 8193)))) + + ;; Distances 12289-16384 (code 27, 12 extra bits) + ((<= distance* 16384) + (cons 27 (cons 12 (- distance* 12289)))) + + ;; Distances 16385-24576 (code 28, 13 extra bits) + ((<= distance* 24576) + (cons 28 (cons 13 (- distance* 16385)))) + + ;; Distances 24577-32768 (code 29, 13 extra bits) + (t + (cons 29 (cons 13 (- distance* 24577)))))) + +(defun deflate--huffman-encode-token (token ll-codes dd-codes) + "Encode TOKEN using Huffman codes. +Codes are provided separately for literal/length (as LL-CODES) and +distance (as DD-CODES). +Returns a list of alists of `code', `code-length', `num-extra-bits' and +`extra-bits-value'." + (let ((result '())) + (if (listp token) + ;; This is a length-distance pair + (let* (;; process length first + (length-original (car token)) + (length-spec (deflate--get-length-code length-original)) + (length (car length-spec)) + (length-extra-bits (cdr length-spec)) + (length-code (car (gethash length ll-codes))) + (length-code-length (cdr (gethash length ll-codes))) + + ;; then process distance + (distance-original (cadr token)) + (distance-spec (deflate--get-distance-code distance-original)) + (distance* (car distance-spec)) + (distance-extra-bits (cdr distance-spec)) + (distance-code (car (gethash distance* dd-codes))) + (distance-code-length (cdr (gethash distance* dd-codes)))) + + ;; encode length + (let* ((extra-bits (car length-extra-bits)) + (extra-bits-value (cdr length-extra-bits)) + (length-alist `((code . ,length-code) + (code-length . ,length-code-length) + (num-extra-bits . ,extra-bits) + (extra-bits-value . ,extra-bits-value)))) + (setq result (append result (list length-alist)))) + + ;; encode distance + (let* ((extra-bits (car distance-extra-bits)) + (extra-bits-value (cdr distance-extra-bits)) + (distance-alist `((code . ,distance-code) + (code-length . ,distance-code-length) + (num-extra-bits . ,extra-bits) + (extra-bits-value . ,extra-bits-value)))) + (setq result (append result (list distance-alist)))) + result) + + ;; This is a literal token + (let* ((code-spec (gethash token ll-codes)) + (code (car code-spec)) + (code-length (cdr code-spec)) + (literal-alist `((code . ,code) + (code-length . ,code-length)))) + + (append result (list literal-alist)))))) + +;; ---- Dynamic Huffman DEFLATE Implementation ---- + +(defun deflate--build-huffman-tree (freq-alist) + "Build a Huffman tree from FREQ-ALIST. +Returns the root node of the tree." + ;; we start by copying the `freq-alist' into a new list + (let ((heap (mapcar (lambda (pair) (cons (car pair) (cdr pair))) + freq-alist))) + (while (> (length heap) 1) + ;; Sort heap by frequency ascending + (setq heap (--sort (< (cdr it) (cdr other)) heap)) + ;; Take two lowest freq nodes + (let* ((a (pop heap)) + (b (pop heap)) + (merged (cons (list a b) (+ (cdr a) (cdr b))))) + ;; add a new node to the tree as a cons of `((left right) . sum-of-freqs)' + (push merged heap))) + ;; Return the single tree + (car heap))) + +(defun deflate--build-frequency-table (tokens) + "Build a frequency table from TOKENS. +Returns an hash table of keys `literal-length' and `distance', with alists of +`(symbol . frequency)' as values." + (let ((literal-length-freq-table (make-hash-table)) + (distance-freq-table (make-hash-table))) + + ;; Process each token + (dolist (token tokens) + (if (listp token) + ;; This is a length-distance pair + (let* ((length (car token)) + (distance_ (cadr token)) + ;; Get length code and extra bits according to DEFLATE spec + (length-result (deflate--get-length-code length)) + (length-code (car length-result)) + ;; Get distance code and extra bits according to DEFLATE spec + (distance-result (deflate--get-distance-code distance_)) + (distance-code (car distance-result))) + + ;; Update length code frequency + (puthash length-code (1+ (gethash length-code literal-length-freq-table 0)) literal-length-freq-table) + + ;; Update distance code frequency (offset by 286) + (let ((dist-symbol distance-code)) + (puthash dist-symbol (1+ (gethash dist-symbol distance-freq-table 0)) distance-freq-table))) + + ;; This is a literal byte + (puthash token (1+ (gethash token literal-length-freq-table 0)) literal-length-freq-table))) + + ;; Add EOF symbol + (puthash 256 1 literal-length-freq-table) + + ;; Convert hash tables to alists + (let ((literal-length-result '()) + (distance-result '()) + (result (make-hash-table))) + (maphash (lambda (k v) (push (cons k v) literal-length-result)) literal-length-freq-table) + (maphash (lambda (k v) (push (cons k v) distance-result)) distance-freq-table) + (puthash 'literal-length literal-length-result result) + (puthash 'distance distance-result result) + + result))) + +(defun deflate--build-huffman-code-lengths (tree) + "Build Huffman codes from TREE. +Returns an alist of `(symbol . length)' where `length' is the depth of `symbol' +in the `tree'. +Returns nil if TREE is nil." + (when tree + (letrec ((walk (lambda (node depth) + (if (consp (car node)) + ;; internal node, e.g. `(((7 . 1) (5 . 1)) . 2)' + (append (funcall walk (car (car node)) (1+ depth)) + (funcall walk (cadr (car node)) (1+ depth))) + ;; leaf node, e.g. `(7 . 1)' + (list (cons (car node) (max 1 depth))))))) + (funcall walk tree 0)))) + +(defun deflate--assign-huffman-codes (code-lengths) + "Assign canonical Huffman codes from the CODE-LENGTHS alist. +Returns a map of `symbol' -> `(code . length)' where `code' is an integer." + (let ((table (make-hash-table :test #'eq))) + (if code-lengths + (let* ((max-len (apply #'max (mapcar #'cdr code-lengths))) + (bl-count (make-vector (1+ max-len) 0)) + (next-code (make-vector (1+ max-len) 0)) + (code 0)) + ;; Count number of codes for each length + (dolist (pair code-lengths) + (let ((len (cdr pair))) + (when (> len 0) + (aset bl-count len (1+ (aref bl-count len)))))) + ;; Compute starting code for each length + (dotimes (bits max-len) + (setq code (ash (+ code (aref bl-count bits)) 1)) + (aset next-code (1+ bits) code)) + ;; Sort symbols by (length . symbol) + (dolist (pair (sort code-lengths + (lambda (a b) + (if (= (cdr a) (cdr b)) + (< (car a) (car b)) + (< (cdr a) (cdr b))))) + table) + (let ((sym (car pair)) + (len (cdr pair))) + (when (> len 0) + (let ((code (aref next-code len))) + (puthash sym (cons code len) table) + (aset next-code len (1+ code))))))) + table))) + +(defun deflate--encode-code-lengths-to-alphabet (code-lengths) + "Encode the sequence of CODE-LENGTHS into the RLE alphabet, RFC 3.2.7. +Returns a list of (token . (num-extra-bits . extra-bits-value)) where token +comes from the custom alphabet and extra-bits-value is an integer." + (let ((result '()) + (i 0) + (len (length code-lengths))) + (while (< i len) + (let* ((current-length (nth i code-lengths)) + (run-length 1)) + + ;; Count consecutive identical values + (while (and (< (+ i run-length) len) + (= current-length (nth (+ i run-length) code-lengths))) + (setq run-length (1+ run-length))) + + (cond + ;; Handle zeros (use codes 17 and 18) + ((= current-length 0) + (cond + ;; Use code 17 for runs of 3-10 zeros + ((<= 3 run-length 10) + (push (cons 17 (cons 3 (- run-length 3))) result) + (setq i (+ i run-length))) + ;; Use code 18 for runs of 11-138 zeros + ((<= 11 run-length 138) + (push (cons 18 (cons 7 (- run-length 11))) result) + (setq i (+ i run-length))) + ;; Use code 18 with full extra bits for runs of more than 138 zeros + ((< 138 run-length) + (push (cons 18 (cons 7 127)) result) ;; 127 'cause 138 - 11 + (setq i (+ i 138))) + ;; For runs of 1-2 zeros or very short runs, just output individual zeros + (t + (let ((zeros-to-output (min run-length 2))) + (dotimes (_ zeros-to-output) + (push (cons 0 (cons 0 0)) result)) + (setq i (+ i zeros-to-output)))))) + + ;; Handle non-zero values (use code 16 for repetitions) + (t + ;; Always output the first occurrence + (push (cons current-length (cons 0 0)) result) + (setq i (1+ i)) + (setq run-length (1- run-length)) + + ;; Handle repetitions with code 16 (3-6 repetitions) + (while (>= run-length 3) + (let ((reps (min 6 run-length))) + (push (cons 16 (cons 2 (- reps 3))) result) + (setq run-length (- run-length reps)) + (setq i (+ i reps)))) + + ;; Handle remaining 1-2 repetitions by outputting individual values + (dotimes (_ run-length) + (push (cons current-length (cons 0 0)) result) + (setq i (1+ i))))))) + + (setq result (nreverse result)) + result)) + + +(defun deflate--calculate-hlit-length (code-lengths-array) + "Calculate the base length for the HLIT header. +The literal/lengths are given as CODE-LENGTHS-ARRAY whose indices are symbols +and values are code lengths." + (let* ((hlit-min 257) + (hlit-max-index (-find-last-index (lambda (x) (/= x 0)) + ;; -find-last-index requires a list + (append code-lengths-array nil))) + ;; HLIT is the count of codes (index + 1), but for literal/length codes we need at least 257 codes + ;; From the spec: + (hlit (if hlit-max-index + (max hlit-min (1+ hlit-max-index)) + hlit-min))) + hlit)) + +(defun deflate--calculate-hdist-length (code-lengths-array) + "Calculate the base length for HDIST header. +The distances ar given as CODE-LENGTHS-ARRAY whose indices are symbols +and values are code lenghts." + (let* ((hdist-min 1) + (hdist-max-index (-find-last-index (lambda (x) (/= x 0)) + ;; -find-last-index requires a list + (append code-lengths-array nil))) + ;; HDIST is the count of codes (index + 1), but we need at least 1 distance code + (hdist (if hdist-max-index + (max hdist-min (1+ hdist-max-index)) + hdist-min))) + hdist)) + +(defconst deflate--code-lengths-order + '(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15) + "Code length alphabet order as per DEFLATE spec.") + +(defun deflate--calculate-hclen-length (cl-lengths-array) + "Calculate HCLEN from the CL-LENGTHS-ARRAY." + (let* ((hclen-min 4) + (code-lengths-ordered-lengths (mapcar (lambda (i) (aref cl-lengths-array i)) + deflate--code-lengths-order)) + (last-nonzero-index (-find-last-index (lambda (x) (/= x 0)) code-lengths-ordered-lengths)) + ;; HCLEN, # of Code Length codes + (hclen (if last-nonzero-index + (max hclen-min (1+ last-nonzero-index)) + hclen-min))) + hclen)) + +(defun deflate--pack-bits (bitstream bits &optional invert) + "Packs BITS into the BITSTREAM, optionally inverting the bits if INVERT is t." + (let ((bits-to-pack (if invert bits (seq-reverse bits)))) + (append bitstream bits-to-pack))) + +(defun deflate--write-dynamic-header (bitstream final hlit hdist hclen cl-lengths-array) + "Write the DEFLATE header into BITSTREAM. +The (meta) Huffman parameters HLIT / HDIST / HCLEN use the standard bit length. +The CL-LENGTHS-ARRAY array contains the code lengths for the code length +alphabet. +If the FINAL flag is non-nil it sets the BFINAL flag to 1." + ;; Block header: + ;; - First bit: Final block flag (1 for final block) + (if final + (setq bitstream (deflate--pack-bits bitstream '(1))) + (setq bitstream (deflate--pack-bits bitstream '(0)))) + + ;; - Next 2 bits: Block type (10 for dynamic Huffman) + (setq bitstream (deflate--pack-bits bitstream '(1 0))) + + ;; Encode HLIT (5 bits) + (setq bitstream + (deflate--pack-bits + bitstream + (deflate--number->bits hlit 5))) + + ;; Encode HDIST (5 bits) + (setq bitstream + (deflate--pack-bits + bitstream + (deflate--number->bits hdist 5))) + + ;; Encode HCLEN (4 bits) + (setq bitstream + (deflate--pack-bits + bitstream + (deflate--number->bits hclen 4))) + + ;; Encode code lengths for the code length alphabet + (dotimes (i (+ hclen 4)) + (let ((cl-index (nth i deflate--code-lengths-order))) + (setq bitstream + (deflate--pack-bits + bitstream + (deflate--number->bits + (aref cl-lengths-array cl-index) 3))))) + bitstream) + +(defun deflate--write-huffman-code (bitstream code code-length &optional num-extra-bits extra-bits-value) + "Write a single Huffman CODE into the BITSTREAM in invenrted bit order. +The CODE is going to be exactly CODE-LENGTH bits. +Optionally adds EXTRA-BITS-VALUE as a sequence of NUM-EXTRA-BITS bits." + (setq bitstream (deflate--pack-bits bitstream + (deflate--number->bits code code-length) + t)) ;; <- huffman codes are written in MSB order + (when (and num-extra-bits + (> num-extra-bits 0)) + (let ((extra-bits (deflate--number->bits extra-bits-value num-extra-bits))) + (setq bitstream (deflate--pack-bits bitstream + extra-bits + nil) ;; <- extra bits are written in LSB order + ))) + bitstream) + +(defun deflate--write-code-lengths (bitstream cl-encoded cl-huff-codes) + "Write the Huffman code lengths into the BITSTREAM. +Code lengths are provided in the CL-ENCODED alist of +`(code-length . (num-extra-bits . extra-bits-value)'. +The CL-HUFF-CODES hashmap contains the Huffman codes for each code length." + ;; Encode the code length sequence + (dolist (cl-spec cl-encoded) + (let* ((cl (car cl-spec)) ;; cons of (code-length . (num-extra-bits . extra-bits-value)) + (num-extra-bits (cadr cl-spec)) + (extra-bits-value (cddr cl-spec)) + (code-spec (gethash cl cl-huff-codes)) + (code (car code-spec)) + (code-length (cdr code-spec))) + (setq bitstream + (deflate--write-huffman-code bitstream + code + code-length + num-extra-bits + extra-bits-value)))) + bitstream) + +(defun deflate--write-compressed-data (bitstream encoded-tokens) + "Write compressed data into BITSTREAM. +ENCODED-TOKENS is a list of alists which represents either literal, +lengths or distances." + (dolist (encoded-token encoded-tokens) + (let* ((code (cdr (assoc 'code encoded-token))) + (code-length (cdr (assoc 'code-length encoded-token))) + (num-extra-bits (cdr (assoc 'num-extra-bits encoded-token))) + (extra-bits-value (cdr (assoc 'extra-bits-value encoded-token)))) + (setq bitstream + (deflate--write-huffman-code bitstream + code + code-length + num-extra-bits + extra-bits-value)))) + bitstream) + +(defun deflate--encode-dynamic-huffman-block (lz77-tokens &optional final) + "Encode LZ77-TOKENS using dynamic Huffman coding. +Header and compressed data is packed in LSB order, while Huffman codes in MSB. +Returns a list of bits representing the compressed data for a DEFLATE block. +If FINAL is non-nil it sets the BFINAL flag to 1 to signal it's the last block." + (let* ((final (or final t)) + (freq-table (deflate--build-frequency-table lz77-tokens)) + + ;; build the Huffman codes for literals/lengths + (ll-huff-tree (deflate--build-huffman-tree (gethash 'literal-length freq-table))) + (ll-code-lengths (deflate--build-huffman-code-lengths ll-huff-tree)) + (ll-huff-code (deflate--assign-huffman-codes ll-code-lengths)) + + ;; build the Huffman codes for distances + (dd-huff-tree (deflate--build-huffman-tree (gethash 'distance freq-table))) + (dd-code-lengths (deflate--build-huffman-code-lengths dd-huff-tree)) + (dd-huff-code (deflate--assign-huffman-codes dd-code-lengths)) + + ;; Encode all LZ77 tokens using the above Huffman codes + (encoded-tokens (-mapcat (lambda (token) + (deflate--huffman-encode-token token ll-huff-code dd-huff-code)) + lz77-tokens))) + + (let* ((bitstream '()) + + ;; Build code length arrays (max 286 literal/length codes, max 30 distance codes) + (ll-code-lengths-array (make-vector 286 0)) + (dd-code-lengths-array (make-vector 30 0))) + + ;; Fill code length arrays from the hash tables + (dolist (pair ll-code-lengths) + (aset ll-code-lengths-array (car pair) (cdr pair))) + (dolist (pair dd-code-lengths) + (aset dd-code-lengths-array (car pair) (cdr pair))) + + ;; Find the count (ie index + 1) of the highest non-zero code for each alphabet: + (let* (;; - HLIT, amount of Literal/Length codes - 257 (257 - 286) + (hlit-length (deflate--calculate-hlit-length ll-code-lengths-array)) + (hlit (- hlit-length 257)) + + ;; - HDIST, amount of Distance codes - 1 (1 - 32) + (hdist-length (deflate--calculate-hdist-length dd-code-lengths-array)) + (hdist (- hdist-length 1))) + + ;; Build combined code length sequence for encoding + (let* ((ll-slice (mapcar (lambda (i) (aref ll-code-lengths-array i)) + (number-sequence 0 (1- hlit-length)))) ;; we need the index here, but `hlit' is a count + (dd-slice (mapcar (lambda (i) (aref dd-code-lengths-array i)) + (number-sequence 0 (1- hdist-length)))) ;; we need the index here, but `hdist' is a count + (code-lengths-combined (append ll-slice dd-slice)) + ;; Build frequency table for code lengths + (cl-freq-table (make-hash-table)) + ;; RLE encoded code lengths + (cl-encoded (deflate--encode-code-lengths-to-alphabet code-lengths-combined))) + + ;; Count frequencies of encoded code lengths + (dolist (cl (mapcar #'car cl-encoded)) + (puthash cl (1+ (gethash cl cl-freq-table 0)) cl-freq-table)) + + ;; Build Huffman tree for encoded code lengths + (let* ((cl-freq-alist (let (result) + (maphash (lambda (k v) (push (cons k v) result)) cl-freq-table) + result)) + (cl-huff-tree (deflate--build-huffman-tree cl-freq-alist)) + (cl-code-lengths (deflate--build-huffman-code-lengths cl-huff-tree)) + (cl-huff-codes (deflate--assign-huffman-codes cl-code-lengths)) + ;; Build code length array for transmission + (cl-lengths-array (make-vector 19 0))) + + ;; Fill code length array + (dolist (pair cl-code-lengths) + (let ((sym (car pair)) + (len (cdr pair))) + (when (or (< sym 0) (>= sym 19)) + (error "DEFLATE: illegal encoded code length code: %s" sym)) + (aset cl-lengths-array sym len))) + + (let* (;; - HCLEN, amount of code lengths codes - 4 (4 - 19) + (hclen-length (deflate--calculate-hclen-length cl-lengths-array)) + (hclen (- hclen-length 4))) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; + ;; We now have all of the data that needs to be put into the bitstream + ;; + ;; From the spec: + ;; + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; + ;; + ;; We can now define the format of the block: + + ;; 5 Bits: HLIT, # of Literal/Length codes - 257 (257 - 286) (a) + ;; 5 Bits: HDIST, # of Distance codes - 1 (1 - 32) (b) + ;; 4 Bits: HCLEN, # of Code Length codes - 4 (4 - 19) (c) + + ;; (HCLEN + 4) x 3 bits: code lengths for the code length (d) + ;; alphabet given just above, in the order: 16, 17, 18, + ;; 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15 + + ;; These code lengths are interpreted as 3-bit integers + ;; (0-7); as above, a code length of 0 means the + ;; corresponding symbol (literal/length or distance code + ;; length) is not used. + + ;; HLIT + 257 code lengths for the literal/length alphabet, (e) + ;; encoded using the code length Huffman code + + ;; HDIST + 1 code lengths for the distance alphabet, (f) + ;; encoded using the code length Huffman code + + ;; The actual compressed data of the block, (g) + ;; encoded using the literal/length and distance Huffman + ;; codes + + ;; The literal/length symbol 256 (end of data), (h) + ;; encoded using the literal/length Huffman code + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; + + ;; the header takes care of points a / b / c / d + (setq bitstream (deflate--write-dynamic-header bitstream final hlit hdist hclen cl-lengths-array)) + + ;; this is for points e / f + (setq bitstream (deflate--write-code-lengths bitstream cl-encoded cl-huff-codes)) + + ;; Encode the actual data tokens -- point g + (setq bitstream (deflate--write-compressed-data bitstream encoded-tokens)) + + ;; Add EOF symbol (256) -- point h + (let* ((eof-code-spec (gethash 256 ll-huff-code)) + (eof-code (car eof-code-spec)) + (eof-code-length (cdr eof-code-spec))) + (setq bitstream (deflate--write-huffman-code bitstream eof-code eof-code-length))) + + bitstream))))))) + +;; ---- No-compression type ---- + +(defun deflate--encode-none-block (data final) + "Writes out DATA as a non-compressed DEFLATE block (BTYPE=00). +When FINAL is non-nil (default) the block is marked as final." + (let* ((final (or final t)) + (bitstream '()) + + ;; LEN: amount of data bytes in the block + (len (length data)) + + ;; NLEN: 1-complement of LEN + (nlen (- #xFFFF len))) + ;; Block header: + ;; - First bit: Final block flag (1 for final block) + (if final + (setq bitstream (deflate--pack-bits bitstream '(1))) + (setq bitstream (deflate--pack-bits bitstream '(0)))) + + ;; - Next 2 bits: Block type (00 for no compression) + (setq bitstream (deflate--pack-bits bitstream '(0 0))) + + ;; - Next 5 bits: Padding (need to get to byte boundary) + (setq bitstream (deflate--pack-bits bitstream (-repeat 5 0))) + + ;; - Next 16 bits: LEN + (setq bitstream (deflate--pack-bits bitstream (deflate--number->bits len 16))) + + ;; - Next 16 bits: NLEN + (setq bitstream (deflate--pack-bits bitstream (deflate--number->bits nlen 16))) + + ;; - Finally, the raw, uncompressed data bytes + (dolist (data-byte data) + (setq bitstream (deflate--pack-bits bitstream (deflate--number->bits data-byte 8)))) + + bitstream)) + +;; ---- / ---- + +(defun deflate-compress--dynamic (data final) + "Compress DATA into a block using the Dynamic Huffman coding DEFLATE variant. +See the RFC paragraph 3.2.7. +When FINAL is non-nil the block is marked as final." + (let* ((lz77-tokens (deflate--lz77-compress data)) + ;; Use dynamic Huffman coding + (compressed-bits (deflate--encode-dynamic-huffman-block lz77-tokens final))) + compressed-bits)) + +(defun deflate-compress--static (_ _) + "Compress DATA using the Static Huffman coding DEFLATE variant. +See the RFC paragraph 3.2.6. +When FINAL is non-nil the block is marked as final." + (error "Static huffman codes are not supported yet (see https://github.com/skuro/deflate/issues/1)")) + +(defun deflate-compress--none (data final) + "Writes DATA using the non-compressed block DEFLATE variant. +See the RFC paragraph 3.2.4. +When FINAL is non-nil the block is marked as final." + (deflate--encode-none-block data final)) + +;; ---- Public API follows ---- + +;;;###autoload +(defun deflate-compress (data &optional compression-type final) + "Compress DATA using the DEFLATE algorithm. +DATA should be a string or a vector of bytes. +Returns a vector of compressed bytes. +COMPRESSION-TYPE is one of the following: + `'dynamic' (default) - Use dynamic Huffman coding + `'static' - Use static Huffman coding + `'none' - Store without compression. +If FINAL is non-nil (default) it produces a final block (BFINAL=1)." + (when (stringp data) + (setq data (string-to-list data))) + + (when (> (length data) deflate--window-size) + (error "Data cannot be longer than 32k")) + + ;; Perform LZ77 compression + (let* ((final (or final t)) + (compression-type (or compression-type 'dynamic)) + (compressed-bits (cond ((eq compression-type 'dynamic) (deflate-compress--dynamic data final)) + ((eq compression-type 'static) (deflate-compress--static data final)) + ((eq compression-type 'none) (deflate-compress--none data final)) + (t (error "Invalid compression type: %s" compression-type))))) + (deflate--bits-to-bytes compressed-bits))) + +;; ---- Minimal ZLIB compatibility layer Implementation ---- + +(defun deflate-zlib-adler32 (data) + "Calculate Adler-32 checksum for DATA (string or list of bytes). +Returns a 4-bytes list checksum compatible with the zlib format." + (let ((a 1) + (b 0) + (mod-adler 65521)) + (dolist (byte (if (stringp data) + (string-to-list data) + data)) + (setq a (% (+ a byte) mod-adler)) + (setq b (% (+ b a) mod-adler))) + (let ((checksum (logior (ash b 16) a))) + (list (logand (ash checksum -24) 255) + (logand (ash checksum -16) 255) + (logand (ash checksum -8) 255) + (logand checksum 255))))) + +(defconst deflate--zlib-cmf #x78 + "The CMF header byte for zlib compatibiliy. +CM=8 for DEFLATE, CINFO=7 for 32KB window.") + +(defconst deflate--zlib-flg #x9C + "The FLG header byte for zlib compatibility. +Chosen so that CMF*256 + FLG is divisible by 31).") + +(defconst deflate-zlib-header + (list deflate--zlib-cmf + deflate--zlib-flg) + "The fixed zlib compatibility header.") + +(defun deflate-zlib-compress (instr block-type) + "Compress INSTR using DEFLATE BLOCK-TYPE then add the zlib envelope." + (let* ((block-type (or block-type 'dynamic)) + (compressed-bytes (deflate-compress instr block-type)) + (adler32 (deflate-zlib-adler32 instr))) + (append deflate-zlib-header + compressed-bytes + adler32))) + +;; ---- Only useful for debugging purposes ---- + +(defun deflate--debug (instr outpath &optional block-type) + "Compresses instr and writes the result into OUTPATH for debugging purposes. +The INSTR string is compressed with DEFLATE and the bytes are stored in the file + at OUTPATH. +The file at OUTPATH can be inspected with tools such as `infgen': +https://github.com/madler/infgen. +BLOCK-TYPE is one of `'dymamic', `'static' or `'none'." + (with-temp-file outpath + (set-buffer-file-coding-system 'binary) + (dolist (byte (deflate-zlib-compress instr block-type)) + (insert-byte byte 1)))) + +(provide 'deflate) +;;; deflate.el ends here diff --git a/lisp/dirvish/dirvish-collapse.el b/lisp/dirvish/dirvish-collapse.el new file mode 100644 index 00000000..963c06fc --- /dev/null +++ b/lisp/dirvish/dirvish-collapse.el @@ -0,0 +1,87 @@ +;;; dirvish-collapse.el --- Collapse unique nested paths -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2025 Alex Lu +;; Author : Alex Lu +;; 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 diff --git a/lisp/dirvish/dirvish-emerge.el b/lisp/dirvish/dirvish-emerge.el new file mode 100644 index 00000000..ffbbced0 --- /dev/null +++ b/lisp/dirvish/dirvish-emerge.el @@ -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 +;; 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 diff --git a/lisp/dirvish/dirvish-extras.el b/lisp/dirvish/dirvish-extras.el new file mode 100644 index 00000000..391b6f74 --- /dev/null +++ b/lisp/dirvish/dirvish-extras.el @@ -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 +;; 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 / multiple lines " + dirvish-copy-file-name) + ("p" "Copy file PATHs in one line

/ multiple lines " + dirvish-copy-file-path) + ("P" "Copy remote PATHs in one line

/ multiple lines " + 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 diff --git a/lisp/dirvish/dirvish-fd.el b/lisp/dirvish/dirvish-fd.el new file mode 100644 index 00000000..143a8913 --- /dev/null +++ b/lisp/dirvish/dirvish-fd.el @@ -0,0 +1,334 @@ +;;; dirvish-fd.el --- find-dired alternative using fd -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2025 Alex Lu +;; Author : Alex Lu +;; 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 <+-> (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 diff --git a/lisp/dirvish/dirvish-history.el b/lisp/dirvish/dirvish-history.el new file mode 100644 index 00000000..1b0d5e0b --- /dev/null +++ b/lisp/dirvish/dirvish-history.el @@ -0,0 +1,99 @@ +;;; dirvish-history.el --- History navigation commands in Dirvish -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2025 Alex Lu +;; Author : Alex Lu +;; 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 diff --git a/lisp/dirvish/dirvish-icons.el b/lisp/dirvish/dirvish-icons.el new file mode 100644 index 00000000..8490d743 --- /dev/null +++ b/lisp/dirvish/dirvish-icons.el @@ -0,0 +1,138 @@ +;;; dirvish-icons.el --- Icon support for Dirvish -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2025 Alex Lu +;; Author : Alex Lu +;; 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 diff --git a/lisp/dirvish/dirvish-ls.el b/lisp/dirvish/dirvish-ls.el new file mode 100644 index 00000000..6d73d0f6 --- /dev/null +++ b/lisp/dirvish/dirvish-ls.el @@ -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 +;; 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 diff --git a/lisp/dirvish/dirvish-narrow.el b/lisp/dirvish/dirvish-narrow.el new file mode 100644 index 00000000..a14f6c25 --- /dev/null +++ b/lisp/dirvish/dirvish-narrow.el @@ -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 +;; 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 diff --git a/lisp/dirvish/dirvish-peek.el b/lisp/dirvish/dirvish-peek.el new file mode 100644 index 00000000..15156ef3 --- /dev/null +++ b/lisp/dirvish/dirvish-peek.el @@ -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 +;; 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 diff --git a/lisp/dirvish/dirvish-pkg.el b/lisp/dirvish/dirvish-pkg.el new file mode 100644 index 00000000..f8615f55 --- /dev/null +++ b/lisp/dirvish/dirvish-pkg.el @@ -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"))) diff --git a/lisp/dirvish/dirvish-quick-access.el b/lisp/dirvish/dirvish-quick-access.el new file mode 100644 index 00000000..ccd0903a --- /dev/null +++ b/lisp/dirvish/dirvish-quick-access.el @@ -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 +;; 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 diff --git a/lisp/dirvish/dirvish-rsync.el b/lisp/dirvish/dirvish-rsync.el new file mode 100644 index 00000000..0625ea79 --- /dev/null +++ b/lisp/dirvish/dirvish-rsync.el @@ -0,0 +1,378 @@ +;;; dirvish-rsync.el --- Rsync integration for Dirvish -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2025 Alex Lu +;; Author : Alex Lu +;; 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 ' + ;; 2. dhost != shost and `dirvish-rsync-r2r-use-direct-connection' == t + ;; ssh -A [-p sport] [suser@]shost 'rsync -e "ssh [-p dport]" [duser@]dhost: ' + ;; 3. dhost != shost and `dirvish-rsync-r2r-use-direct-connection' == nil + ;; ssh -A -R [-p sport] [suser@]shost 'rsync -e "ssh -p " [duser@]localhost:' + (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 diff --git a/lisp/dirvish/dirvish-side.el b/lisp/dirvish/dirvish-side.el new file mode 100644 index 00000000..36670764 --- /dev/null +++ b/lisp/dirvish/dirvish-side.el @@ -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 +;; 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 diff --git a/lisp/dirvish/dirvish-subtree.el b/lisp/dirvish/dirvish-subtree.el new file mode 100644 index 00000000..601d3de3 --- /dev/null +++ b/lisp/dirvish/dirvish-subtree.el @@ -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 +;; 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 diff --git a/lisp/dirvish/dirvish-tramp.el b/lisp/dirvish/dirvish-tramp.el new file mode 100644 index 00000000..0d836ea2 --- /dev/null +++ b/lisp/dirvish/dirvish-tramp.el @@ -0,0 +1,147 @@ +;;; dirvish-tramp.el --- Dirvish tramp integration -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2025 Alex Lu +;; Author : Alex Lu +;; 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 diff --git a/lisp/dirvish/dirvish-vc.el b/lisp/dirvish/dirvish-vc.el new file mode 100644 index 00000000..93213fb8 --- /dev/null +++ b/lisp/dirvish/dirvish-vc.el @@ -0,0 +1,271 @@ +;;; dirvish-vc.el --- Version-control integration for Dirvish -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2025 Alex Lu +;; Author : Alex Lu +;; 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 diff --git a/lisp/dirvish/dirvish-widgets.el b/lisp/dirvish/dirvish-widgets.el new file mode 100644 index 00000000..8cf23ea3 --- /dev/null +++ b/lisp/dirvish/dirvish-widgets.el @@ -0,0 +1,754 @@ +;;; dirvish-widgets.el --- Core widgets in dirvish -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2025 Alex Lu +;; Author : Alex Lu +;; 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 diff --git a/lisp/dirvish/dirvish-yank.el b/lisp/dirvish/dirvish-yank.el new file mode 100644 index 00000000..80431a59 --- /dev/null +++ b/lisp/dirvish/dirvish-yank.el @@ -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 +;; 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 diff --git a/lisp/dirvish/dirvish.el b/lisp/dirvish/dirvish.el new file mode 100644 index 00000000..d665cf9a --- /dev/null +++ b/lisp/dirvish/dirvish.el @@ -0,0 +1,1614 @@ +;;; dirvish.el --- A modern file manager based on dired mode -*- lexical-binding: t -*- +;; Copyright (C) 2021-2025 Alex Lu + +;; Author : Alex Lu +;; Package-Version: 20250504.807 +;; Package-Revision: d877433f957a +;; Keywords: files, convenience +;; Homepage: https://github.com/alexluigit/dirvish +;; SPDX-License-Identifier: GPL-3.0-or-later +;; Package-Requires: ((emacs "28.1") (compat "30")) + +;; This file is not part of GNU Emacs. + +;;; Commentary: +;; A minimalistic yet versatile file manager based on Dired. +;; This package gives Dired the following features: +;; +;; - Multiple window layouts +;; - Always available file preview +;; - Isolated sessions +;; - A modern and composable user interface + +;;; Code: + +(require 'dired) +(require 'compat) + +;;;; User Options + +(defgroup dirvish nil "A better Dired." :group 'dired) + +(defcustom dirvish-attributes '(file-size) + "File attributes showing in file lines. +Dirvish ships with these attributes: + +- `subtree-state': A indicator for directory expanding state. +- `nerd-icons' | `all-the-icons' | `vscode-icons': File icons. +- `collapse': Collapse unique nested paths. +- `git-msg': Append git commit message to filename. +- `vc-state': The version control state at left fringe. +- `file-size': file size or directories file count at right fringe. +- `file-time': Show file modification time before the `file-size'." + :group 'dirvish :type '(repeat (symbol :tag "Dirvish attribute"))) + +(defcustom dirvish-preview-dispatchers + `(,(if (memq system-type '(ms-dos windows-nt)) 'video-mtn 'video) + image gif audio epub archive font pdf) + "List of preview dispatchers. +Each dispatcher in this list handles the validation and preview +content generation for the corresponding filetype. + +The default value contains: + +- image: preview image files, requires `vipsthumbnail'. +- gif: preview GIF image files with animation. +- video: preview videos files with thumbnail. + requires `ffmpegthumbnailer' on Linux/macOS | `mtn' on Windows +- audio: preview audio files with metadata, requires `mediainfo'. +- epub: preview epub documents, requires `epub-thumbnailer'. +- pdf: preview pdf with thumbnail generated by `pdftoppm'. +- font: preview font files, requires `magick'. +- archive: preview archives such as .tar, .zip, requires `7z' (`7zz' on macOS)." + :group 'dirvish :type '(repeat (symbol :tag "Dirvish preview methods"))) + +(defcustom dirvish-preview-disabled-exts '("bin" "exe" "gpg" "elc" "eln") + "Do not preview files end with these extensions." + :group 'dirvish :type '(repeat (string :tag "File name extension"))) + +(defcustom dirvish-preview-environment + '((inhibit-message . t) (non-essential . t) + (enable-dir-local-variables . nil) (enable-local-variables . :safe)) + "Variables which are bound for default file preview dispatcher. +Credit: copied from `consult-preview-variables' in `consult.el'." + :group 'dirvish :type 'alist) + +(defcustom dirvish-cache-dir + (expand-file-name "dirvish/" user-emacs-directory) + "Preview / thumbnail cache directory for dirvish." + :group 'dirvish :type 'string) + +(defcustom dirvish-default-layout '(1 0.11 0.55) + "Default layout recipe for Dirvish sessions. +The value has the form (DEPTH MAX-PARENT-WIDTH PREVIEW-WIDTH). + +- DEPTH controls the number of windows displaying parent directories, it +can be 0 if you don't need the parent directories. +- MAX-PARENT-WIDTH controls the max width allocated to each parent windows. +- PREVIEW-WIDTH controls the width allocated to preview window. + +The default value provides a 1:3:5 (approximately) pane ratio. Also see +`dirvish-layout-recipes' in `dirvish-extras.el'. + +Alternatively, set this to nil to hide both the parent and preview +windows. In this case, \\='(1 0.11 0.55) will be used as the fallback +full-frame recipe. This is useful when you want to use `dirvish' +exclusively for directory entries without `dired' or similar commands, +and want to prevent the preview from appearing at startup. You can +still use `dirvish-layout-toggle' or `dirvish-layout-switch' to display +the full-frame layout when file previews are needed." + :group 'dirvish + :type '(choice (const :tag "no default layout" nil) + (list (integer :tag "number of parent windows") + (float :tag "max width of parent windows") + (float :tag "width of preview windows")))) + +(defcustom dirvish-large-directory-threshold nil + "Directories with file count greater than this are opened using `dirvish-fd'." + :group 'dirvish :type '(choice (const :tag "Never use `dirvish-fd'" nil) + (natnum :tag "File counts in integer"))) + +(defface dirvish-hl-line + '((t :inherit highlight :extend t)) + "Face used for Dirvish line highlighting in focused Dirvish window." + :group 'dirvish) + +(defface dirvish-hl-line-inactive + '((t :inherit region :extend t)) + "Face used for Dirvish line highlighting in unfocused Dirvish windows." + :group 'dirvish) + +(defface dirvish-inactive + '((t :inherit shadow)) + "Face used for mode-line segments in unfocused Dirvish windows." + :group 'dirvish) + +(defface dirvish-proc-running + '((t :inherit warning)) + "Face used if asynchronous process is running." + :group 'dirvish) + +(defface dirvish-proc-finished + '((t :inherit success)) + "Face used if asynchronous process has finished." + :group 'dirvish) + +(defface dirvish-proc-failed + '((t :inherit error)) + "Face used if asynchronous process has failed." + :group 'dirvish) + +(defcustom dirvish-use-mode-line t + "Whether to display mode line in dirvish buffers. +The valid value are: +- nil: hide mode line in dirvish sessions +- global: display the mode line across all panes +- t (and others): Display the mode line across directory panes" + :group 'dirvish + :type '(choice (const :tag "Do not show the mode line" nil) + (const :tag "Display the mode line across directory panes" t) + (const :tag "Make the mode line span all panes" global))) + +(defcustom dirvish-use-header-line t + "Like `dirvish-use-mode-line', but for header line." + :group 'dirvish :type 'symbol) + +(defcustom dirvish-mode-line-height 21 + "Height of Dirvish's mode line. +The value should be a cons cell (H-WIN . H-FRAME), where H-WIN +and H-FRAME represent the height of mode line in single window +state and fullframe state respectively. If this value is a +integer INT, it is seen as a shorthand for (INT . INT)." + :group 'dirvish + :type '(choice integer (cons integer integer))) + +(defcustom dirvish-header-line-height '(25 . 35) + "Like `dirvish-mode-line-height', but for header line." + :type '(choice integer (cons integer integer))) + +(defcustom dirvish-mode-line-format + '(:left (sort omit symlink) :right (index)) + "Mode line SEGMENTs aligned to left/right respectively. +Here are all the predefined segments you can choose from: + +* Basics (from `dirvish-extras') +`path': directory path under the cursor. +`symlink': target of symlink under the cursor. +`sort': sort criteria applied in current buffer. +`omit': a `dired-omit-mode' indicator. +`index': line number / total line count. +`free-space': amount of free space on `default-directory''s file system. +Others are self-explanatory: +`file-size', `file-modes', `file-link-number', `file-user', +`file-group',`file-time',`file-inode-number',`file-device-number'. + +* Miscs +`vc-info': version control information (from `dirvish-vc'). +`yank': file transfer progress (from `dirvish-yank'). + +Set it to nil to use the default `mode-line-format'." + :group 'dirvish :type 'plist) + +(defcustom dirvish-header-line-format + '(:left (path) :right ()) + "Like `dirvish-mode-line-format', but for header line ." + :group 'dirvish :type 'plist) + +(defcustom dirvish-mode-line-bar-image-width 3 + "Pixel width of the leading bar image in both mode-line and header-line. +If the value is 0, the bar image is hidden." + :group 'dirvish :type 'integer) + +(defcustom dirvish-hide-details t + "Whether to enable `dired-hide-details-mode' in Dirvish buffers. +When sets to t, it is enabled for all Dirvish buffers. + +Alternatively, the value can be a list of symbols to instruct Dirvish in +what contexts it should be enabled. The accepted values are: + - `dired': when opening a directory using `dired-*' commands. + - `dirvish': when opening full-frame Dirvish. + - `dirvish-fd': when the buffer is create by `dirvish-fd*' commands. + - `dirvish-side': when opening Dirvish in the sidebar." + :group 'dirvish + :type '(choice (boolean :tag "Apply to all Dirvish buffers") + (repeat :tag "Apply to a list of buffer types: 'dired, 'dirvish, 'dirvish-fd or 'dirvish-side" symbol))) + +(defcustom dirvish-hide-cursor t + "Whether to hide cursor in dirvish buffers. +Works all the same as `dirvish-hide-details' but for cursor." + :group 'dirvish + :type '(choice (boolean :tag "Apply to all Dirvish buffers") + (repeat :tag "Apply to a list of buffer types: 'dired, 'dirvish, 'dirvish-fd or 'dirvish-side" symbol))) + +(defcustom dirvish-window-fringe 2 + "Root window's left fringe in pixels." + :group 'dirvish :type 'natnum) + +(defcustom dirvish-preview-dired-sync-omit nil + "If non-nil, `dired' preview buffers sync `dired-omit-mode' from root window. +Notice that it only take effects on the built-in `dired' preview dispatcher." + :group 'dirvish :type 'boolean) + +(defcustom dirvish-preview-large-file-threshold 1048576 ; 1mb + "Text files larger than this byte limit are previewed partially." + :group 'dirvish :type '(natnum :tag "File size in bytes")) + +(defcustom dirvish-preview-buffers-max-count 5 + "Number of file buffers to keep open temporarily during preview." + :group 'dirvish :type '(natnum :tag "Number of buffers")) + +(defcustom dirvish-reuse-session 'open + "Whether to keep the latest session index buffer for later reuse. +The valid values are: +- t: keep index buffer on both `dirvish-quit' and file open +- `resume': keep and resume to the index when using `dirvish' w/o specify a path +- `quit': only keep index after `dirvish-quit' +- `open': only keep index after open a file +- nil: never keep any index buffers on `dirvish-quit' or open files" + :group 'dirvish :type '(choice (const :tag "keep index buffer on both `dirvish-quit' and file open" t) + (const :tag "keep and resume to the index when using `dirvish' w/o specify a path" resume) + (const :tag "only keep index after `dirvish-quit'" quit) + (const :tag "only keep index after open a file" open) + (const :tag "never keep any index buffer" nil))) + +(defcustom dirvish-input-throttle 0.25 + "Input THROTTLE for commands run repeatedly within a short period of time. +The preview window and any associated asynchronous processes for the +file under the cursor are updated and started only every THROTTLE +seconds. This also applies root window's refreshing for synchronous +filtering commands like ``dirvish-narrow'`." + :group 'dirvish :type '(float :tag "Delay in seconds")) + +(define-obsolete-variable-alias 'dirvish-redisplay-debounce 'dirvish-input-debounce "Mar 25, 2025") +(defcustom dirvish-input-debounce 0.02 + "Input DEBOUNCE for commands run repeatedly within a short period of time. +The preview window and any associated asynchronous processes for the +file under the cursor are updated and started only when there has not +been new input for DEBOUNCE seconds. This also applies to root window's +refreshing for synchronous filtering commands like `dirvish-narrow'." + :group 'dirvish :type '(float :tag "Delay in seconds")) + +(cl-defgeneric dirvish-clean-cache () "Clean cache for selected files." nil) +(cl-defgeneric dirvish-build-cache () "Build cache for current directory." nil) + +(defcustom dirvish-after-revert-hook '(dirvish-clean-cache) + "Functions called after running `revert-buffer' command." + :group 'dirvish :type 'hook) + +(defcustom dirvish-setup-hook '(dirvish-build-cache) + "Functions called when directory data for the root buffer is ready." + :group 'dirvish :type 'hook) + +(defcustom dirvish-find-entry-hook nil + "Functions to be called before opening a directory or file. +Each function is called with the file's FILENAME and FIND-FN until one +returns a non-nil value. When a Dired buffer is created for the first +time, FIND-FN is `dired', and the function is called with that Dired +buffer as `current-buffer'; Otherwise, it is one of `find-file', +`find-alternate-file', or `find-file-other-window'. A non-nil return +value terminates `dirvish--find-entry', allowing interception of file +opening and customized handling of specific file types." + :group 'dirvish :type 'hook) + +(defcustom dirvish-preview-setup-hook nil + "Functions called in the file preview buffer." + :group 'dirvish :type 'hook) + +;;;; Constants + +(defconst dirvish-emacs-bin + (cond + ((and invocation-directory invocation-name) + (expand-file-name (concat (file-name-as-directory invocation-directory) invocation-name))) + ((eq system-type 'darwin) + "/Applications/Emacs.app/Contents/MacOS/Emacs") + (t "emacs"))) +(defconst dirvish-image-exts '("webp" "wmf" "pcx" "xif" "wbmp" "vtf" "tap" "s1j" "sjp" "sjpg" "s1g" "sgi" "sgif" "s1n" "spn" "spng" "xyze" "rgbe" "hdr" "b16" "mdi" "apng" "ico" "pgb" "rlc" "mmr" "fst" "fpx" "fbs" "dxf" "dwg" "djv" "uvvg" "uvg" "uvvi" "uvi" "azv" "psd" "tfx" "t38" "svgz" "svg" "pti" "btf" "btif" "ktx2" "ktx" "jxss" "jxsi" "jxsc" "jxs" "jxrs" "jxra" "jxr" "jxl" "jpf" "jpx" "jpgm" "jpm" "jfif" "jhc" "jph" "jpg2" "jp2" "jls" "hsj2" "hej2" "heifs" "heif" "heics" "heic" "fts" "fit" "fits" "emf" "drle" "cgm" "dib" "bmp" "hif" "avif" "avcs" "avci" "exr" "fax" "icon" "ief" "jpg" "macp" "pbm" "pgm" "pict" "png" "pnm" "ppm" "ras" "rgb" "tga" "tif" "tiff" "xbm" "xpm" "xwd" "jpe" "jpeg" "cr2" "arw")) +(defconst dirvish-audio-exts '("ape" "stm" "s3m" "ra" "rm" "ram" "wma" "wax" "m3u" "med" "669" "mtm" "m15" "uni" "ult" "mka" "flac" "axa" "kar" "midi" "mid" "s1m" "smp" "smp3" "rip" "multitrack" "ecelp9600" "ecelp7470" "ecelp4800" "vbk" "pya" "lvp" "plj" "dtshd" "dts" "mlp" "eol" "uvva" "uva" "koz" "xhe" "loas" "sofa" "smv" "qcp" "psid" "sid" "spx" "opus" "ogg" "oga" "mp1" "mpga" "m4a" "mxmf" "mhas" "l16" "lbc" "evw" "enw" "evb" "evc" "dls" "omg" "aa3" "at3" "atx" "aal" "acn" "awb" "amr" "ac3" "ass" "aac" "adts" "726" "abs" "aif" "aifc" "aiff" "au" "mp2" "mp3" "mp2a" "mpa" "mpa2" "mpega" "snd" "vox" "wav")) +(defconst dirvish-video-exts '("f4v" "rmvb" "wvx" "wmx" "wmv" "wm" "asx" "mk3d" "mkv" "fxm" "flv" "axv" "webm" "viv" "yt" "s1q" "smo" "smov" "ssw" "sswf" "s14" "s11" "smpg" "smk" "bk2" "bik" "nim" "pyv" "m4u" "mxu" "fvt" "dvb" "uvvv" "uvv" "uvvs" "uvs" "uvvp" "uvp" "uvvu" "uvu" "uvvm" "uvm" "uvvh" "uvh" "ogv" "m2v" "m1v" "m4v" "mpg4" "mp4" "mjp2" "mj2" "m4s" "3gpp2" "3g2" "3gpp" "3gp" "avi" "mov" "movie" "mpe" "mpeg" "mpegv" "mpg" "mpv" "qt" "vbs")) +(defconst dirvish-font-exts '("ttf" "ttc" "otf" "woff" "eot")) +(defconst dirvish-archive-exts '("7z" "xz" "bzip2" "gzip" "tar" "zip" "wim" "ar" "arj" "cab" "chm" "dmg" "ext" "fat" "gpt" "hfs" "ihex" "iso" "mbr" "msi" "ntfs" "qcow2" "rar" "rpm" "udf" "uefi" "vdi" "vhd" "vmdk" "xar")) +(defconst dirvish-binary-exts (append dirvish-image-exts dirvish-video-exts dirvish-audio-exts dirvish-font-exts dirvish-archive-exts '("pdf" "epub" "gif" "icns"))) + +;;;; Keymaps + +(defvar dirvish-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map dired-mode-map) + (define-key map (kbd "q") 'dirvish-quit) map) + "Keymap used in dirvish buffers, it inherits `dired-mode-map'.") +(defvar dirvish-directory-view-mode-map + (let ((km (make-sparse-keymap))) (define-key km (kbd "q") 'dirvish-quit) km)) +(defvar dirvish-misc-mode-map + (let ((km (make-sparse-keymap))) (define-key km (kbd "q") 'dirvish-quit) km)) +(defvar dirvish-special-preview-mode-map + (let ((km (make-sparse-keymap))) (define-key km (kbd "q") 'dirvish-quit) km)) + +;;;; Internal variables + +(defvar dirvish--scopes + '(:frame selected-frame :tab tab-bar--current-tab-index :persp persp-curr)) +(defvar dirvish--libraries + '((dirvish-vc vc-state git-msg vc-diff vc-blame vc-log vc-info) + (dirvish-icons all-the-icons nerd-icons vscode-icon) + (dirvish-collapse collapse) + (dirvish-subtree subtree-state) + (dirvish-yank yank))) +(defvar dirvish--timers `(:default (,(timer-create) ,(float-time) nil))) +(defvar dirvish--selected-window nil) +(defvar dirvish--sessions (make-hash-table :test #'equal)) +(defvar dirvish--available-attrs '()) +(defvar dirvish--available-preview-dispatchers '()) +(defvar-local dirvish--props '()) +(defvar-local dirvish--dir-data nil) + +;;;; Helpers + +(defmacro dirvish-prop (prop &rest body) + "Retrieve PROP from `dirvish--props'. +Set the PROP with BODY if given." + (declare (indent defun)) + `(let* ((pair (assq ,prop dirvish--props)) (val (cdr pair))) + ,(if body `(prog1 (setq val ,@body) + (if pair (setcdr (assq ,prop dirvish--props) val) + (push (cons ,prop val) dirvish--props))) + `val))) + +(defun dirvish--run-with-delay (action &optional record fun debounce throttle) + "Run function FUN accroding to ACTION with delay. +DEBOUNCE defaults to `dirvish-input-debounce'. +THROTTLE defaults to `dirvish-input-throttle'. +RECORD defaults to `:default' record in `dirvish--timers'." + (declare (indent defun)) + (unless (plist-get dirvish--timers (setq record (or record :default))) + (cl-callf append dirvish--timers + `(,record (,(timer-create) ,(float-time) nil)))) + (setq record (plist-get dirvish--timers record) fun (or fun #'ignore) + debounce (or debounce dirvish-input-debounce) + throttle (or throttle dirvish-input-throttle)) + (pcase action + ((pred stringp) + (unless (equal action (nth 2 record)) + (cancel-timer (car record)) + (timer-set-function + (car record) + (lambda () (setf (nth 1 record) (float-time)) (funcall fun action))) + (timer-set-time + (car record) + (timer-relative-time + nil (max debounce (- (+ (nth 1 record) throttle) (float-time))))) + (setf (nth 2 record) action) + (timer-activate (car record)))) + ('reset (setf (nth 2 record) "")))) + +(defmacro dirvish-save-dedication (&rest body) + "Run BODY after undedicating window, restore dedication afterwards." + (declare (debug (&rest form))) + `(let* ((w (selected-window)) (ded (window-dedicated-p w))) + (set-window-dedicated-p w nil) + (prog1 ,@body (and (window-live-p w) (set-window-dedicated-p w ded))))) + +(defsubst dirvish-curr () + "Return Dirvish session attached to current buffer, if there is any." + (gethash (dirvish-prop :dv) dirvish--sessions)) + +(defun dirvish--ht () + "Return a new hash-table with `equal' as its test function." + (make-hash-table :test #'equal)) + +(defun dirvish--timestamp () + "Return current timestamp string with \"%D|%T\" format." + (format-time-string "%D|%T")) + +(defun dirvish--display-buffer (buffer alist) + "Try displaying BUFFER with ALIST. +This splits the window at the designated side of the frame. +ALIST is window arguments passed to `window--display-buffer'." + (let* ((side (cdr (assq 'side alist))) + (window-configuration-change-hook nil) + (width (or (cdr (assq 'window-width alist)) 0.5)) + (height (cdr (assq 'window-height alist))) + (size (or height (ceiling (* (frame-width) width)))) + (split-width-threshold 0) + (ignore-window-parameters t) + (new-window (split-window-no-error nil size side))) + (window--display-buffer buffer new-window 'window alist))) + +(defun dirvish--kill-buffer (buffer) + "Kill BUFFER without side effects." + (and (buffer-live-p buffer) + (cl-letf (((symbol-function 'undo-tree-save-history-from-hook) #'ignore) + ((symbol-function 'recentf-track-closed-file) #'ignore)) + (let (kill-buffer-query-functions) (kill-buffer buffer))))) + +(defun dirvish--vc-root-dir () + "Get expanded `vc-root-dir'." + (when-let* ((root (vc-root-dir))) (expand-file-name root))) + +(defun dirvish--get-parent-path (path) + "Get parent directory of PATH." + (file-name-directory (directory-file-name (expand-file-name path)))) + +(defun dirvish--completion-table-with-metadata (table metadata) + "Return new completion TABLE with METADATA, see `completion-metadata'." + (lambda (string pred action) + (if (eq action 'metadata) + `(metadata . ,metadata) + (complete-with-action action table string pred)))) + +(defun dirvish--format-menu-heading (title &optional note) + "Format TITLE as a menu heading. +When NOTE is non-nil, append it the next line." + (let ((no-wb (= (frame-bottom-divider-width) 0))) + (format "%s%s%s" + (propertize title 'face `(:inherit dired-mark :overline ,no-wb) + 'display '((height 1.1))) + (propertize " " 'face `(:inherit dired-mark :overline ,no-wb) + 'display '(space :align-to right)) + (propertize (if note (concat "\n" note) "") 'face 'font-lock-doc-face)))) + +(defun dirvish--special-buffer (type dv &optional no-hiding) + "Return DV's special TYPE buffer, do not hide it if NO-HIDING is non-nil." + (get-buffer-create + (format "%s*dirvish-%s@%s*" (if no-hiding "" " ") type (dv-id dv)))) + +(defun dirvish--make-proc (form sentinel buffer-or-name &rest puts) + "Make process for shell or batch FORM in BUFFER-OR-NAME. +Set process's SENTINEL and PUTS accordingly." + (let* ((buf (or buffer-or-name (make-temp-name "*dirvish-batch*"))) + (print-length nil) (print-level nil) + (cmd (if (stringp (car form)) form + (list dirvish-emacs-bin + "-Q" "-batch" "--eval" (prin1-to-string form)))) + (proc (make-process :name "dirvish" :connection-type nil :buffer buf + :command cmd :sentinel sentinel :noquery t))) + (while-let ((k (pop puts)) (v (pop puts))) (process-put proc k v)))) + +;;;; Session Struct + +(cl-defstruct (dirvish (:conc-name dv-)) + "Define dirvish session (DV for short) struct." + (id (make-temp-name "") :documentation "is the unique key of DV stored in `dirvish--sessions'.") + (timestamp (dirvish--timestamp) :documentation "is the last access timestamp of DV.") + (type 'default :documentation "is the type of DV.") + (root-window () :documentation "is the root/main window of DV.") + (dedicated () :documentation "passes to `set-window-dedicated-p' for ROOT-WINDOW.") + (size-fixed () :documentation "passes to `window-size-fixed' for ROOT-WINDOW.") + (root-conf #'ignore :documentation "is a function to apply extra configs for INDEX buffer.") + (root-window-fn () :documentation "is a function used to create the ROOT-WINDOW for DV.") + (open-file #'dirvish-open-file :documentation "is a function to handle file opening.") + (curr-layout () :documentation "is the working layout recipe of DV.") + (ff-layout dirvish-default-layout :documentation "is a full-frame layout recipe.") + (ls-switches dired-listing-switches :documentation "is the directory listing switches.") + (mode-line () :documentation "is the `mode-line-format' used by DV.") + (header-line () :documentation "is the `header-line-format' used by DV.") + (preview-dispatchers () :documentation "is the working preview methods of DV.") + (preview-hash (dirvish--ht) :documentation "is a hash-table to record content of preview files.") + (parent-hash (dirvish--ht) :documentation "is a hash-table to record content of parent directories.") + (attributes () :documentation "is the working attributes of DV.") + (preview-buffers () :documentation "holds all file preview buffers of DV.") + (special-buffers () :documentation "holds all special buffers of DV e.g. mode-line buffer.") + (preview-window () :documentation "is the window to display preview buffer.") + (winconf () :documentation "is a saved window configuration.") + (index () :documentation "is the (cwd-str . buf-obj) cons within ROOT-WINDOW.") + (roots () :documentation "is all the history INDEX entries in DV.")) + +(defun dirvish--new (&rest args) + "Create and save a new dirvish struct to `dirvish--sessions'. +ARGS is a list of keyword arguments for `dirvish' struct." + (let (slots new) + (while (keywordp (car args)) (dotimes (_ 2) (push (pop args) slots))) + (setq new (apply #'make-dirvish (reverse slots))) + ;; ensure we have a fallback fullframe layout + (unless dirvish-default-layout (setf (dv-ff-layout new) '(1 0.11 0.55))) + (puthash (dv-id new) new dirvish--sessions) + (dirvish--check-dependencies new) + (dirvish--create-root-window new) new)) + +(defun dirvish--selected-p (&optional dv) + "Return t if session DV (defaults to `dirvish-curr') is selected." + (when-let* ((dv (or dv (dirvish-curr)))) + (if (dv-curr-layout dv) (eq (dv-root-window dv) dirvish--selected-window) + (eq (frame-selected-window) dirvish--selected-window)))) + +(defun dirvish--get-session (&optional key val) + "Return the first matched session has KEY of VAL." + (setq key (or key 'type) val (or val 'default)) + (cl-loop for dv being the hash-values of dirvish--sessions + for b = (cdr (dv-index dv)) + with (fr tab psp) = (cl-loop for (_ v) on dirvish--scopes by 'cddr + collect (and (functionp v) (funcall v))) + if (or (null b) ; newly created session + (and (buffer-live-p b) + (eq (with-current-buffer b (dirvish-prop :tab)) tab) + (eq (with-current-buffer b (dirvish-prop :frame)) fr) + (eq (with-current-buffer b (dirvish-prop :persp)) psp))) + if (let ((res (funcall (intern (format "dv-%s" key)) dv))) + (cond ((eq val 'any) res) + ((eq key 'roots) (memq val (mapcar #'cdr res))) + (t (equal val res)))) + return dv)) + +(defun dirvish--clear-session (dv &optional from-quit) + "Reset DV's slot and kill its buffers. +FROM-QUIT is used to signify the calling command." + (let* ((idx (dv-index dv)) (ff (dv-curr-layout dv)) (wcon (dv-winconf dv)) + (server-buf? (lambda (root) (with-current-buffer (cdr root) + (bound-and-true-p server-buffer-clients)))) + (keep (list idx)) roots kill-buffer-hook) + (cl-loop with killer = (lambda (r) (unless (member r keep) (kill-buffer (cdr r)))) + for root in (setq roots (dv-roots dv)) + if (or (get-buffer-window (cdr root)) (funcall server-buf? root)) + do (cl-pushnew root keep :test #'equal) + finally do (mapc killer roots)) + (when (and ff wcon) (set-window-configuration wcon)) + (set-window-fringes + nil (frame-parameter nil 'left-fringe) (frame-parameter nil 'left-fringe)) + (mapc #'dirvish--kill-buffer (dv-preview-buffers dv)) + (mapc #'dirvish--kill-buffer (dv-special-buffers dv)) + (when (or (null dirvish-reuse-session) + (eq dirvish-reuse-session (if from-quit 'open 'quit))) + (unless (or (funcall server-buf? idx) ; client buf or displayed elsewhere + (length> (get-buffer-window-list (cdr idx)) 1)) + (kill-buffer (cdr idx)))) + (setq roots (cl-remove-if-not (lambda (i) (buffer-live-p (cdr i))) keep)) + (setf (dv-preview-hash dv) (dirvish--ht) (dv-parent-hash dv) (dirvish--ht) + (dv-roots dv) roots (dv-index dv) (car roots) + (dv-preview-buffers dv) nil (dv-winconf dv) nil) + (unless roots (remhash (dv-id dv) dirvish--sessions)))) + +(defun dirvish--create-root-window (dv) + "Create root window of DV." + (if-let* ((fn (dv-root-window-fn dv))) + (setf (dv-root-window dv) (funcall fn dv)) + (setf (dv-root-window dv) (frame-selected-window)))) + +(defun dirvish--preview-dps-validate (&optional dps) + "Check if the requirements of dispatchers DPS are met." + (cl-loop with dps = (or dps dirvish-preview-dispatchers) + with res = (prog1 '() (require 'recentf) (require 'ansi-color)) + with fmt = "[Dirvish]: install '%s' executable to preview %s files." + for dp in (append '(disable) dps '(dired fallback)) + for info = (alist-get dp dirvish--available-preview-dispatchers) + for requirements = (plist-get info :require) + for met = t + do (progn (dolist (pkg requirements) + (unless (executable-find pkg) + (message fmt pkg dp) (setq met nil))) + (when met (push (intern (format "dirvish-%s-dp" dp)) res))) + finally return (reverse res))) + +(defun dirvish--check-dependencies (dv) + "Require necessary extensions for DV, raise warnings for missing executables." + (cl-loop + with tp = (dv-type dv) with dft = (eq tp 'default) + with fn = (lambda (f) (eval `(bound-and-true-p + ,(intern (format "dirvish-%s-%s" tp f))))) + with attrs = (if dft dirvish-attributes (funcall fn 'attributes)) + with m = (if dft dirvish-mode-line-format (funcall fn 'mode-line-format)) + with h = (if dft dirvish-header-line-format (funcall fn 'header-line-format)) + with (ml . mr) = (cons (plist-get m :left) (plist-get m :right)) + with (hl . hr) = (cons (plist-get h :left) (plist-get h :right)) + with feat-reqs = (append dirvish-preview-dispatchers attrs ml mr hl hr) + when feat-reqs do (require 'dirvish-widgets) + for (lib . feat) in dirvish--libraries do + (when (cl-intersection feat feat-reqs) (require lib)) + finally (setf (dv-mode-line dv) (dirvish--mode-line-composer ml mr) + (dv-header-line dv) (dirvish--mode-line-composer hl hr t) + (dv-preview-dispatchers dv) (dirvish--preview-dps-validate) + (dv-attributes dv) (dirvish--attrs-expand attrs)))) + +(defun dirvish-open-file (dv find-fn file) + "Open FILE using FIND-FN for default DV sessions." + (let ((cur (current-buffer)) fbuf) + (unwind-protect (funcall find-fn file) + (unless (eq (setq fbuf (current-buffer)) cur) + (dirvish--clear-session dv) + (dirvish-save-dedication (switch-to-buffer fbuf)))))) + +(cl-defun dirvish--find-entry (find-fn entry) + "Find ENTRY using FIND-FN in current dirvish session. +FIND-FN can be one of `find-file', `find-alternate-file', +`find-file-other-window' or `find-file-other-frame'." + (let ((switch-to-buffer-preserve-window-point (null dired-auto-revert-buffer)) + (find-file-run-dired t) (dv (dirvish-curr)) + (dir? (file-directory-p entry)) (cur (current-buffer))) + (and (run-hook-with-args-until-success + 'dirvish-find-entry-hook entry find-fn) + (cl-return-from dirvish--find-entry)) + ;; forward requests from `find-dired' + (unless dv (cl-return-from dirvish--find-entry (funcall find-fn entry))) + (unless dir? (mapc #'dirvish--kill-buffer (dv-preview-buffers dv))) + (when (and (dv-curr-layout dv) (eq find-fn 'find-file-other-window)) + (if dir? (dirvish-layout-toggle) + (select-window (dv-preview-window dv)) + (cl-return-from dirvish--find-entry (find-file entry)))) + (when (and dir? (eq find-fn 'find-alternate-file)) + (dirvish-save-dedication (find-file entry)) + (with-current-buffer cur ; check if the buffer should be killed + (and (bound-and-true-p server-buffer-clients) + (cl-return-from dirvish--find-entry))) + (cl-return-from dirvish--find-entry (dirvish--kill-buffer cur))) + (if dir? (dirvish-save-dedication (funcall find-fn entry)) + (funcall (dv-open-file dv) dv find-fn entry)))) + +;;;; Preview + +(cl-defmacro dirvish-define-preview (name &optional arglist docstring &rest body) + "Define a Dirvish preview dispatcher NAME. +A dirvish preview dispatcher is a function consumed by + `dirvish-preview-dispatch' which takes `file' (filename under + the cursor) and `preview-window' as ARGLIST. DOCSTRING and BODY + is the docstring and body for this function." + (declare (indent defun) (doc-string 3)) + (let* ((dp-name (intern (format "dirvish-%s-dp" name))) + (default-arglist '(file ext preview-window dv)) + (ignore-list (cl-set-difference default-arglist arglist)) + (keywords `(:doc ,docstring))) + (while (keywordp (car body)) (dotimes (_ 2) (push (pop body) keywords))) + `(progn + (add-to-list + 'dirvish--available-preview-dispatchers (cons ',name ',keywords)) + (defun ,dp-name ,default-arglist (ignore ,@ignore-list) ,@body)))) + +(defun dirvish--preview-file-maybe-truncate (dv file size) + "Return preview buffer of FILE with SIZE in DV." + (when (>= (length (dv-preview-buffers dv)) dirvish-preview-buffers-max-count) + (dirvish--kill-buffer (frame-parameter nil 'dv-preview-last))) + (with-current-buffer (get-buffer-create "*preview-temp*") + (let ((text (gethash file (dv-preview-hash dv))) info jka-compr-verbose) + (with-silent-modifications + (setq buffer-read-only t) + (if text (insert text) + (insert-file-contents + file nil 0 dirvish-preview-large-file-threshold) + (when (>= size dirvish-preview-large-file-threshold) + (goto-char (point-max)) + (insert "\n\nFile truncated. End of partial preview.\n"))) + (setq buffer-file-name file) + (goto-char (point-min)) + (rename-buffer (format "PREVIEW :: %s :: %s" + (dv-timestamp dv) (file-name-nondirectory file)))) + (condition-case err + (eval `(let ,(mapcar (lambda (env) `(,(car env) ,(cdr env))) + (remove '(delay-mode-hooks . t) + dirvish-preview-environment)) + (setq-local delay-mode-hooks t) + (set-auto-mode) (font-lock-mode 1) + (and (bound-and-true-p so-long-detected-p) + (error "No preview of file with long lines")))) + (error (setq info (error-message-string err)))) + (if info (prog1 `(info . ,info) (dirvish--kill-buffer (current-buffer))) + (set-frame-parameter nil 'dv-preview-last (current-buffer)) + (run-hooks 'dirvish-preview-setup-hook) + (unless text (puthash file (buffer-string) (dv-preview-hash dv))) + `(buffer . ,(current-buffer)))))) + +(defun dirvish--find-file-temporarily (name) + "Open file NAME temporarily for preview." + `(buffer . ,(eval `(let ,(mapcar (lambda (env) `(,(car env) ,(cdr env))) + (append '((vc-follow-symlinks . t) + (find-file-hook . nil)) + dirvish-preview-environment)) + (find-file-noselect ,name 'nowarn))))) + +(dirvish-define-preview disable (file ext) + "Disable preview in some cases." + (cond + ((not (file-exists-p file)) + `(info . ,(format "[ %s ] does not exist" file))) + ((not (file-readable-p file)) + `(info . ,(format "[ %s ] is not readable" file))) + ((member ext dirvish-preview-disabled-exts) + `(info . ,(format "Preview for filetype [ %s ] has been disabled" ext))))) + +(dirvish-define-preview dired (file) + "Preview dispatcher for directory FILE." + (when (file-directory-p file) + `(dired . (let ,(mapcar (lambda (env) `(,(car env) ,(cdr env))) + (remove (cons 'inhibit-message t) + dirvish-preview-environment)) + (setq insert-directory-program ,insert-directory-program) + (setq dired-listing-switches ,dired-listing-switches) + (setq dired-omit-verbose ,(bound-and-true-p dired-omit-verbose)) + (setq dired-omit-files ,(bound-and-true-p dired-omit-files)) + ;; for `sudo-edit' compat + (with-current-buffer (dired-noselect ,file) + ,(and dirvish-preview-dired-sync-omit + (bound-and-true-p dired-omit-mode) + `(dired-omit-mode)) + (message "\n%s" (buffer-string))))))) + +(dirvish-define-preview fallback (file ext dv) + "Fallback preview dispatcher for FILE." + (let* ((attrs (ignore-errors (file-attributes file))) + (size (file-attribute-size attrs)) buf) + (cond ((setq buf (get-buffer + (format "PREVIEW :: %s :: %s" + (dv-timestamp dv) (file-name-nondirectory file)))) + `(buffer . ,buf)) + ((not attrs) + `(info . ,(format "Can not get attributes of [ %s ]." file))) + ((not size) + `(info . ,(format "Can not get file size of [ %s ]." file))) + ((> size (or large-file-warning-threshold 10000000)) + `(info . ,(format "File [ %s ] is too big for literal preview." file))) + ((member ext dirvish-binary-exts) + `(info . "Preview disabled for binary files")) + (t (dirvish--preview-file-maybe-truncate dv file size))))) + +(cl-defgeneric dirvish-preview-dispatch (recipe dv) + "Return preview buffer generated according to RECIPE in session DV.") + +(cl-defmethod dirvish-preview-dispatch ((recipe (head info)) dv) + "Insert info string from RECIPE into DV's preview buffer." + (let ((buf (dirvish--special-buffer 'preview dv t))) + (with-current-buffer buf + (let (buffer-read-only) + (erase-buffer) (remove-overlays) (insert "\n\n " (cdr recipe)) buf)))) + +(cl-defmethod dirvish-preview-dispatch ((recipe (head buffer)) dv) + "Use payload of RECIPE as preview buffer of DV directly." + (let ((p-buf (dirvish--special-buffer 'preview dv t))) + (with-current-buffer p-buf + (let (buffer-read-only) (erase-buffer) (remove-overlays) (cdr recipe))))) + +(defun dirvish-apply-ansicolor-h (_win pos) + "Update dirvish ansicolor in preview window from POS." + (declare-function ansi-color-apply-on-region "ansi-color") + (let (buffer-read-only) + (ansi-color-apply-on-region + (goto-char pos) (progn (forward-line (frame-height)) (point))))) + +(defun dirvish-shell-preview-proc-s (proc _exitcode) + "A sentinel for dirvish preview process. +When PROC finishes, fill preview buffer with process result." + (when-let* ((dv (dirvish-curr)) (cmd-type (process-get proc 'cmd-info)) + (str (with-current-buffer (process-buffer proc) (buffer-string)))) + (if (eq cmd-type 'shell) + (with-current-buffer (dirvish--special-buffer 'shell dv t) + (let (buffer-read-only) (erase-buffer) (remove-overlays) (insert str)) + (dirvish-apply-ansicolor-h nil (point-min))) + (with-current-buffer (dirvish--special-buffer 'dired dv t) + (let (buffer-read-only) (erase-buffer) (remove-overlays) (insert str)) + (setq-local dired-subdir-alist + (list (cons (car (dv-index dv)) (point-min-marker)))))) + (kill-buffer (process-buffer proc)))) + +(defun dirvish--run-shell-for-preview (dv recipe) + "Dispatch shell cmd with RECIPE for session DV." + (let ((proc (get-buffer-process (get-buffer " *dirvish-sh*"))) + (buf (dirvish--special-buffer (car recipe) dv t))) + (when proc (delete-process proc)) + (dirvish--make-proc + (cdr recipe) 'dirvish-shell-preview-proc-s " *dirvish-sh*" + 'cmd-info (car recipe)) + (with-current-buffer buf + (let (buffer-read-only) (erase-buffer) buf)))) + +(cl-defmethod dirvish-preview-dispatch ((recipe (head shell)) dv) + "Fill DV's preview buffer with output of sh command from RECIPE." + (dirvish--run-shell-for-preview dv recipe)) + +(cl-defmethod dirvish-preview-dispatch ((recipe (head dired)) dv) + "Fill DV's preview buffer with output of sh command from RECIPE." + (dirvish--run-shell-for-preview dv recipe)) + +(defun dirvish--preview-update (dv index) + "Update preview content of INDEX for DV." + (when-let* ((pwin (dv-preview-window dv)) ((window-live-p pwin)) + (root (cdr (dv-index dv))) ((buffer-live-p root)) + (ext (downcase (or (file-name-extension index) ""))) + (fns (with-current-buffer root (dirvish-prop :preview-dps))) + (buf (cl-loop for fn in fns + for rcp = (funcall fn index ext pwin dv) thereis + (and rcp (dirvish-preview-dispatch rcp dv))))) + (setq-local other-window-scroll-buffer buf) + (unless (memq buf (dv-special-buffers dv)) + (cl-pushnew buf (dv-preview-buffers dv))) + (set-window-buffer pwin buf))) + +;;;; Attributes + +(defmacro dirvish-define-attribute (name docstring &rest body) + "Define a Dirvish attribute NAME with DOCSTRING. +An Dirvish attribute contains: +- a PREDICATE form, which is the value of `:when' keyword +- a SETUP form, which is the value of `:setup' keyword +- a RENDER function runs BODY (excludes all the keywords) + +During redisplay, the PREDICATE is evaluated with WIN-WIDTH (from +`window-width') bound locally, a nil result means the attribute should +not be rendered. Otherwise, SETUP form is evalutated once and RENDER is +called for every file line in the viewport with the following arguments: + +- `f-beg' from `dired-move-to-filename' +- `f-end' from `dired-move-to-end-of-filename' +- `f-str' from (`buffer-substring' F-BEG F-END) +- `f-name' from `dired-get-filename' +- `f-attrs' from `file-attributes' +- `f-type' from `file-directory-p' along with `file-symlink-p' +- `l-beg' from `line-beginning-position' +- `l-end' from `line-end-position' +- `hl-face' from `dirvish-hl-line' face, only passed in for current line +- `w-width' from `window-width' + +RENDER should return a cons of (TYPE . VAL) where: +- TYPE can be one of `ov', `left' or `right' +- When TYPE is `ov', VAL is a overlay to be put; otherwise VAL is a string + +The collected `left' strings as a whole is then attached to `f-end', +while `right' would fill up remaining space within the file line. These +keywords are used to calculate the starting position of the collected +`right' strings: + +- `:width': a form denotes the constant length of the attribute. +- `:right': like `:width', but only used by `right' TYPE RENDER." + (declare (indent defun) (doc-string 2)) + (let ((render (intern (format "dirvish-attribute-%s-rd" name))) + (args '(f-beg f-end f-str f-name f-attrs + f-type l-beg l-end hl-face w-width)) + options) + (while (keywordp (car body)) (dotimes (_ 2) (push (pop body) options))) + (setq options (reverse options)) + `(progn + (add-to-list + 'dirvish--available-attrs + (cons ',name '(,(or (plist-get options :width) 0) + ,(or (plist-get options :right) 0) + ,(or (plist-get options :when) t) + ,(or (plist-get options :setup) nil) + ,render ,docstring))) + (defun ,render ,args (ignore ,@args) ,@body)))) + +(defmacro dirvish-attribute-cache (file attribute &rest body) + "Get FILE's ATTRIBUTE from `dirvish--dir-data'. +When the attribute does not exist, set it with BODY." + (declare (indent defun)) + `(let* ((md5 (secure-hash 'md5 ,file)) + (hash (gethash md5 dirvish--dir-data)) + (cached (plist-get hash ,attribute)) + (attr (or cached ,@body))) + (unless cached + (puthash md5 (append hash (list ,attribute attr)) dirvish--dir-data)) + attr)) + +(defun dirvish--attrs-expand (attrs) + "Expand ATTRS from `dirvish--available-attrs'." + (cl-pushnew 'hl-line attrs) (cl-pushnew 'symlink-target attrs) + (sort (cl-loop for attr in attrs + for lst = (alist-get attr dirvish--available-attrs) + for (wd wd-r pred setup render _) = lst + collect (list attr (eval wd) (eval wd-r) pred setup render)) + (lambda (a b) (< (cl-position (car a) attrs) (cl-position (car b) attrs))))) + +(defun dirvish--render-attrs-1 + (height width pos remote fns align-to hl w-width) + "HEIGHT WIDTH POS REMOTE FNS ALIGN-TO HL W-WIDTH." + ;; jump over subdir header lines where `forward-line' is ignored + (when (cdr dired-subdir-alist) (goto-char (window-start))) + (forward-line (- 0 height)) + (cl-dotimes (_ (* 2 height)) + (when (eobp) (cl-return)) + (let ((f-beg (dired-move-to-filename)) + (f-end (dired-move-to-end-of-filename t)) + (l-beg (line-beginning-position)) (l-end (line-end-position)) + (f-wid 0) f-str f-name f-attrs f-type hl-face left right f-line?) + (setq hl-face (and (eq (or f-beg l-beg) pos) hl)) + (when (setq f-line? (and f-beg f-end (eq (char-after l-end) 10))) + (setq f-str (buffer-substring f-beg f-end) + f-wid (string-width f-str) + f-name (concat (if remote (dired-current-directory) + (file-local-name (dired-current-directory))) + f-str) + f-attrs (dirvish-attribute-cache f-name :builtin + (unless remote (ignore-errors (file-attributes f-name)))) + f-type (dirvish-attribute-cache f-name :type + (let ((ch (progn (back-to-indentation) (char-after)))) + (cond ; ASCII: d -> 100, l -> 108, LF(\n) -> 10 + (remote `(,(if (eq ch 100) 'dir 'file) . nil)) + ((eq ch 100) '(dir . nil)) + ((eq ch 108) ; use slash for dir check is unreliable + `(,(if (file-directory-p f-name) 'dir 'file) . + ,(buffer-substring (+ f-end 4) l-end))) + (t '(file . nil)))))) + (unless (get-text-property f-beg 'mouse-face) + (dired-insert-set-properties l-beg l-end))) + (cl-loop + for fn in (if f-line? fns '(dirvish-attribute-hl-line-rd)) + for (k . v) = (funcall fn f-beg f-end f-str f-name + f-attrs f-type l-beg l-end hl-face w-width) + do (pcase k ('ov (overlay-put v 'dirvish-a-ov t)) + ('ovs (dolist (ov v) (overlay-put ov 'dirvish-a-ov t))) + ('left (setq left (concat v left))) + ('right (setq right (concat v right)))) + finally + (prog1 (unless (or left right) (cl-return)) + (let* ((len1 (string-width (or right ""))) + (remain (- width len1 + (or (get-text-property l-beg 'line-prefix) 0))) + (len2 (min (length left) (max 0 (- remain f-wid 1)))) + (ovl (make-overlay f-end f-end)) + (r-pos (if (> remain f-wid) l-end + (let ((end (+ f-beg remain)) + (offset (- f-wid (length f-str)))) + (- end offset)))) + (spec `(space :align-to (- right-fringe ,len1 ,align-to))) + (spc (propertize " " 'display spec 'face hl-face)) + (ovr (make-overlay r-pos r-pos))) + (overlay-put ovl 'dirvish-l-ov t) + (overlay-put ovl 'after-string (substring (or left "") 0 len2)) + (overlay-put ovr 'dirvish-r-ov t) + (overlay-put ovr 'after-string (concat spc right)))))) + (forward-line 1))) + +(defun dirvish--render-attrs (window &optional selected) + "Render attributes in WINDOW, SELECTED defaults to `frame-selected-window'." + (setq selected (or selected (frame-selected-window))) + (with-selected-window window + (cl-loop with attrs = (dirvish-prop :attrs) unless attrs do (cl-return) + with ww = (window-width) and pm = (point-min) and pM = (point-max) + with rmt = (and (dirvish-prop :remote) (not (dirvish-prop :sudo))) + with fns = () with height = (frame-height) with gui = nil + with hl = (and (dirvish--apply-hiding-p dirvish-hide-cursor) + (if (eq selected window) + 'dirvish-hl-line 'dirvish-hl-line-inactive)) + with remain = (- ww (if (setq gui (dirvish-prop :gui)) 1 2)) + for (_ width _ pred setup render) in attrs + when (eval pred `((win-width . ,remain))) + do (eval setup) (setq remain (- remain width)) (push render fns) + initially (dolist (ov '(dirvish-a-ov dirvish-l-ov dirvish-r-ov)) + (remove-overlays pm pM ov t)) + finally (with-silent-modifications + (save-excursion + (dirvish--render-attrs-1 + height remain (point) rmt fns (if gui 0 2) hl ww)))))) + +(dirvish-define-attribute hl-line + "Highlight current line. +This attribute is disabled when cursor is visible." + (when hl-face + (let ((ov (make-overlay l-beg (1+ l-end)))) + (overlay-put ov 'face hl-face) `(ov . ,ov)))) + +(dirvish-define-attribute symlink-target + "Hide symlink target." + :when (or (derived-mode-p 'dirvish-directory-view-mode) + (and dired-hide-details-mode + (default-value 'dired-hide-details-hide-symlink-targets))) + (when (< (+ f-end 4) l-end) + (let ((ov (make-overlay f-end l-end))) + (overlay-put ov 'invisible t) `(ov . ,ov)))) + +;;;; Mode Line | Header Line + +(defmacro dirvish-define-mode-line (name &optional docstring &rest body) + "Define a mode line segment NAME with BODY and DOCSTRING." + (declare (indent defun) (doc-string 2)) + (let ((ml-name (intern (format "dirvish-%s-ml" name)))) + `(defun ,ml-name () ,docstring ,@body))) + +(defun dirvish--mode-line-composer (left right &optional header) + "Compose `mode-line-format' from LEFT and RIGHT segments. +If HEADER, the format is used for `header-line-format'." + `((:eval + (let* ((dv (dirvish-curr)) + (fullframe-p (and dv (dv-curr-layout dv))) + (buf (if fullframe-p (cdr (dv-index dv)) (current-buffer))) + (expand + (lambda (segs) + (cl-loop for s in segs collect + (if (stringp s) s + `(:eval (,(intern (format "dirvish-%s-ml" s)))))))) + (face ',(if header 'header-line 'mode-line-inactive)) + (default (face-attribute 'default :height)) + (ml-height (face-attribute face :height)) + (scale (cond ((floatp ml-height) ml-height) + ((integerp ml-height) (/ (float ml-height) default)) + (t 1))) + (win-width (floor (/ (window-width) scale))) + (str-l (if dv " DIRVISH: context buffer is a killed buffer" + " DIRVISH: failed to get current session")) + (str-r (propertize "WARNING " 'face 'dired-warning)) + (len-r 8)) + (when (buffer-live-p buf) + (setq str-l (format-mode-line (funcall expand ',left) nil nil buf)) + (setq str-r (format-mode-line (funcall expand ',right) nil nil buf)) + (setq len-r (string-width str-r))) + (concat + (dirvish--mode-line-bar-img fullframe-p ,header) + (if (< (+ (string-width str-l) len-r) win-width) + str-l + (let ((trim (1- (- win-width len-r)))) + (if (>= trim 0) + (substring str-l 0 (min trim (1- (length str-l)))) + ""))) + (propertize + " " 'display `((space :align-to (- (+ right right-fringe right-margin) + ,(ceiling (* scale len-r)))))) + str-r))))) + +(defun dirvish--mode-line-height (fullframe &optional header) + "Get mode/header-line (when HEADER) height in single pane or FULLFRAME." + (let ((hv (if header dirvish-header-line-height dirvish-mode-line-height))) + (cond ((numberp hv) hv) (fullframe (cdr hv)) (t (car hv))))) + +;; Thanks to `doom-modeline'. +(defun dirvish--mode-line-bar-img (fullframe-p header) + "Create a bar image with height of `dirvish-mode-line-height'. +If FULLFRAME-P, use the `cdr' of the value as height, otherwise +use `car'. If HEADER, use `dirvish-header-line-height' instead." + (when (and (display-graphic-p) (image-type-available-p 'pbm) + (numberp dirvish-mode-line-bar-image-width)) + (let ((ht (dirvish--mode-line-height fullframe-p header)) + (wd dirvish-mode-line-bar-image-width)) + (propertize + " " 'display + (ignore-errors + (create-image + (concat (format "P1\n%i %i\n" (if (eq wd 0) 1 wd) ht) + (make-string (* wd ht) (if (> wd 0) ?1 ?0)) "\n") + 'pbm t :foreground "None" :ascent 'center)))))) + +(defun dirvish--setup-mode-line (dv) + "Setup the mode/header line for dirvish DV." + (let* ((idx-buf (cdr (dv-index dv))) + (hl (or (dirvish-prop :cus-header) (dv-header-line dv))) + (ml (dv-mode-line dv)) + (fullframe-p (dv-curr-layout dv))) + (cond ; setup `header-line-format' + ((and fullframe-p (not dirvish-use-header-line))) + (fullframe-p + (with-current-buffer idx-buf (setq header-line-format nil)) + (with-current-buffer (dirvish--special-buffer 'header dv) + (setq header-line-format hl))) + (dirvish-use-header-line + (with-current-buffer idx-buf (setq header-line-format hl)))) + (cond ; setup `mode-line-format' + ((and fullframe-p (not dirvish-use-mode-line))) + (fullframe-p + (with-current-buffer idx-buf (setq mode-line-format nil)) + (with-current-buffer (dirvish--special-buffer 'footer dv) + (setq mode-line-format ml))) + (dirvish-use-mode-line + (with-current-buffer idx-buf (setq mode-line-format ml)))))) + +;;;; Buffer Initialization + +(defun dirvish--apply-hiding-p (ctx) + "Return t when it should hide cursor/details within context CTX." + (cond ((booleanp ctx) ctx) + ((dirvish-prop :fd-info) + (memq 'dirvish-fd ctx)) + ((and (dirvish-curr) (dv-curr-layout (dirvish-curr))) + (memq 'dirvish ctx)) + ((and (dirvish-curr) (eq (dv-type (dirvish-curr)) 'side)) + (memq 'dirvish-side ctx)) + (t (memq 'dired ctx)))) + +(defun dirvish--subdir-offset () + "Return number of lines occupied by subdir header." + (if (eq (bound-and-true-p dired-free-space) 'separate) 2 1)) + +(defun dirvish--maybe-toggle-cursor (&optional cursor) + "Toggle cursor's invisibility according to context. +Optionally, use CURSOR as the enabled cursor type." + (if (dirvish--apply-hiding-p dirvish-hide-cursor) + (prog1 (setq-local cursor-type nil) + (cond ((bound-and-true-p evil-local-mode) + (setq-local evil-normal-state-cursor '(bar . 0))) + ((bound-and-true-p meow-motion-mode) + (setq-local meow-cursor-type-motion nil)))) + (setq-local cursor-type (or cursor '(box . 4))) + (cond ((bound-and-true-p evil-local-mode) + (setq-local evil-normal-state-cursor (or cursor '(box . 4)))) + ((bound-and-true-p meow-motion-mode) + (setq-local meow-cursor-type-motion (or cursor '(box . 4))))))) + +(defun dirvish--maybe-toggle-details () + "Toggle `dired-hide-details-mode' according to context." + (if (dirvish--apply-hiding-p dirvish-hide-details) + (dired-hide-details-mode 1) + (dired-hide-details-mode -1))) + +(defun dirvish--hide-dired-header () + "Hide the Dired header." + (remove-overlays (point-min) (point) 'dired-header t) + (save-excursion + (let* ((beg (goto-char (point-min))) + (next-file (next-single-property-change beg 'dired-filename)) + (end (or (dirvish-prop :content-begin) + (and (not next-file) (point-max)) + (progn (goto-char next-file) (line-beginning-position)))) + (o (make-overlay beg end))) + (dirvish-prop :content-begin end) + (overlay-put o 'dired-header t) + (overlay-put o 'invisible + (cond ((cdr dired-subdir-alist) nil) + (dirvish-use-header-line t)))))) + +(defun dirvish-pre-redisplay-h (window) + "Record root WINDOW and redisplay sessions in selected frame." + (setq dirvish--selected-window (frame-selected-window)) + (when-let* ((dv (dirvish-curr))) (setf (dv-root-window dv) window)) + (dirvish--redisplay)) + +(defun dirvish-post-command-h () + "Reset cursor shape and position and update preview." + (cond ((not (dirvish--apply-hiding-p dirvish-hide-cursor))) + ((eobp) (forward-line -1)) + ((cdr dired-subdir-alist)) + ((and (bobp) dirvish-use-header-line) + (goto-char (dirvish-prop :content-begin))))) + +(defun dirvish-kill-buffer-h () + "Remove buffer from session's roots, clear session when roots is empty." + (when-let* ((dv (dirvish-curr)) (buf (current-buffer))) + (setf (dv-roots dv) (cl-remove-if (lambda (i) (eq (cdr i) buf)) (dv-roots dv))) + (when (eq (cdr (dv-index dv)) buf) (setf (dv-index dv) (car (dv-roots dv)))) + (if (dv-roots dv) ; killed by user in `ibuffer' or using `kill-current-buffer' + (when-let* ((win (dv-root-window dv)) + ((and (window-live-p win) (window-dedicated-p win)))) + (with-selected-window win ; prevend this dedicated window get deleted + (dirvish-save-dedication (switch-to-buffer (cdr (dv-index dv)))))) + (when-let* ((layout (dv-curr-layout dv)) (wc (dv-winconf dv))) + (cond ((eq buf (window-buffer (selected-window))) ; in a session, reset + (set-window-configuration wc nil t)) + (t (cl-loop for tab in (funcall tab-bar-tabs-function) + for ws = (alist-get 'ws tab) + for bs = (window-state-buffers ws) + if (or (memq buf bs) (member (buffer-name buf) bs)) + do (setf (alist-get 'wc tab) wc))))) + (mapc #'dirvish--kill-buffer (dv-preview-buffers dv)) + (mapc #'dirvish--kill-buffer (dv-special-buffers dv)) + (remhash (dv-id dv) dirvish--sessions)) + (when (memq this-command ; clear lingering sessions when killing manually + '(kill-current-buffer ibuffer-do-kill-on-deletion-marks)) + (cl-loop for b in (buffer-list) with rs = nil + unless (eq b buf) ; this buffer is not killed yet + if (with-current-buffer b (derived-mode-p 'dired-mode)) + do (push b rs) ; in case there is any lingering sessions + finally do (unless rs (setq dirvish--sessions (dirvish--ht))))))) + +(defun dirvish--setup-dired () + "Initialize Dired buffers." + (use-local-map dirvish-mode-map) + (dirvish--hide-dired-header) + (dirvish--maybe-toggle-cursor 'box) ; restore from `wdired' + (setq-local dirvish--dir-data (or dirvish--dir-data (dirvish--ht)) + revert-buffer-function (or (dirvish-prop :revert) #'dirvish-revert) + truncate-lines t dired-hide-details-hide-symlink-targets nil) + (add-hook 'pre-redisplay-functions #'dirvish-pre-redisplay-h nil t) + (add-hook 'window-buffer-change-functions #'dirvish-winbuf-change-h nil t) + (add-hook 'post-command-hook #'dirvish-post-command-h nil t) + (add-hook 'kill-buffer-hook #'dirvish-kill-buffer-h nil t)) + +(defun dirvish--create-parent-buffer (dv dir index level) + "Create parent buffer at DIR in DV selecting file INDEX. +LEVEL is the depth of current window." + (let* ((index (directory-file-name index)) + (buf (dirvish--special-buffer (format "parent-%s" level) dv t)) + (str (or (gethash dir (dv-parent-hash dv)) + (let ((flags dired-actual-switches)) + (with-temp-buffer (dired-insert-directory dir flags) + (buffer-string))))) + (attrs (mapcar #'car (dv-attributes dv))) + (icon (cond ((memq 'all-the-icons attrs) '(all-the-icons)) + ((memq 'nerd-icons attrs) '(nerd-icons)) + ((memq 'vscode-icon attrs) '(vscode-icon))))) + (cl-pushnew buf (dv-special-buffers dv)) + (with-current-buffer buf + (dirvish-directory-view-mode) + (dirvish-prop :dv (dv-id dv)) + (dirvish-prop :remote (file-remote-p dir)) + (dirvish-prop :sudo ; copy this from root avoids requiring tramp + (with-current-buffer (cdr (dv-index dv)) (dirvish-prop :sudo))) + (puthash dir str (dv-parent-hash dv)) + (let (buffer-read-only) (erase-buffer) (save-excursion (insert str))) + (setq-local dired-subdir-alist (list (cons dir (point-min-marker)))) + (dired-goto-file-1 (file-name-nondirectory index) index (point-max)) + (dirvish--maybe-toggle-cursor '(box . 0)) ; always hide cursor in parents + (dirvish-prop :attrs (dirvish--attrs-expand icon)) buf))) + +(defun dirvish--init-special-buffers (dv) + "Initialize special buffers for DV." + (let ((dired (dirvish--special-buffer 'dired dv t)) + (regular (dirvish--special-buffer 'preview dv t)) + (shell (dirvish--special-buffer 'shell dv t)) + (head (dirvish--special-buffer 'header dv)) + (foot (dirvish--special-buffer 'footer dv)) + (id (dv-id dv))) + (with-current-buffer dired + (dirvish-directory-view-mode) (dirvish-prop :dv id)) + (with-current-buffer regular + (dirvish-special-preview-mode) (dirvish-prop :dv id)) + (with-current-buffer shell + (dirvish-prop :dv id) + (dirvish-special-preview-mode) + (add-hook 'window-scroll-functions #'dirvish-apply-ansicolor-h nil t)) + (with-current-buffer head (dirvish-misc-mode) (dirvish-prop :dv id)) + (with-current-buffer foot (dirvish-misc-mode) (dirvish-prop :dv id)) + (setf (dv-special-buffers dv) (list dired regular shell head foot)))) + +(defun dirvish--dir-data-async (dir buffer &optional inhibit-setup) + "Asynchronously fetch metadata for DIR, stored locally in BUFFER. +INHIBIT-SETUP is passed to `dirvish-data-for-dir'." + (dirvish--make-proc + `(prin1 + (let ((hs (make-hash-table)) (bk ',(dirvish-prop :vc-backend))) + (if ,(and (not (dirvish-prop :sudo)) (dirvish-prop :remote)) (setq bk 0) + (dolist (f (ignore-errors ; `dir' can be problematic due to its encoding + (directory-files ,(file-local-name dir) t nil t 20000))) + (let* ((attrs (ignore-errors (file-attributes f))) (tp (nth 0 attrs))) + (cond ((eq t tp) (setq tp '(dir . nil))) + (tp (setq tp `(,(if (file-directory-p tp) 'dir 'file) . ,tp))) + (t (setq tp '(file . nil)))) + (puthash (secure-hash 'md5 f) `(:builtin ,attrs :type ,tp) hs))) + (setq bk (or bk (vc-responsible-backend ,(file-local-name dir) t)))) + (cons bk hs))) + (lambda (p _) + (pcase-let ((`(,buf . ,inhibit-setup) (process-get p 'meta)) + (`(,pb . ,data) (cons (process-buffer p) nil))) + (condition-case err + (setq data (with-current-buffer pb (read (buffer-string)))) + (error (message "Fetch dir data failed with error: %s" err))) + (when (buffer-live-p buf) + (with-current-buffer buf + (when-let* ((attrs (cdr data)) ((hash-table-p attrs))) + (maphash (lambda (k v) (puthash k v dirvish--dir-data)) attrs)) + (dirvish-prop :vc-backend (or (car data) 0)) ; for &context compat + (dirvish-data-for-dir dir buf inhibit-setup)))) + (delete-process p) + (dirvish--kill-buffer (process-buffer p))) + nil 'meta (cons buffer inhibit-setup))) + +(cl-defgeneric dirvish-data-for-dir (dir buffer inhibit-setup) + "Fetch data for DIR in BUFFER. +It is called when DIR is in localhost and is not being +version-controlled. Run `dirvish-setup-hook' after data parsing unless +INHIBIT-SETUP is non-nil." + (when (buffer-live-p buffer) + (with-current-buffer buffer + (unless inhibit-setup (run-hooks 'dirvish-setup-hook)) + (ignore dir)))) + +;;;; Layout Build & Teardown + +(defun dirvish-revert (&optional ignore-auto _noconfirm) + "Reread the Dirvish buffer. +When IGNORE-AUTO, refresh file attributes as well. +Dirvish sets `revert-buffer-function' to this function." + (dirvish-prop :old-index (dired-get-filename nil t)) + (let ((dv (dirvish-curr))) + (dirvish--check-dependencies dv) ; update dirvish setups + (dirvish-prop :attrs (dv-attributes dv))) + (dolist (keyword '(:free-space :content-begin)) (dirvish-prop keyword nil)) + (dired-revert) + (dirvish--hide-dired-header) + (when ignore-auto ; meaning it is called interactively from user + (setq-local dirvish--dir-data (dirvish--ht)) + (dirvish--dir-data-async (dirvish-prop :root) (current-buffer))) + (run-hooks 'dirvish-after-revert-hook)) + +(defun dirvish--redisplay () + "Refresh UI for all session windows in selected frame." + (when-let* ((dv (dirvish-curr)) ((not (derived-mode-p 'wdired-mode))) + (r-win (dv-root-window dv)) ((window-live-p r-win))) + (when (dirvish--apply-hiding-p dirvish-hide-cursor) (dired-move-to-filename)) + (dolist (w (window-list)) + (when (and (not (eq r-win w)) + (with-selected-window w (derived-mode-p 'dired-mode))) + (dirvish--render-attrs w))) + (dirvish--render-attrs r-win) + (when-let* ((idx (save-excursion (dired-get-filename nil t)))) + (dirvish-prop :index (setq idx (file-local-name idx))) + (when (dv-curr-layout dv) + (dirvish--run-with-delay idx nil + (lambda (action) + ;; don't grab focus when peeking or preview window is selected + (force-mode-line-update t) + (when (and (dirvish--selected-p dv) + (not (dirvish--get-session 'type 'peek))) + (dirvish--preview-update dv action)))))))) + +(defun dirvish-winbuf-change-h (window) + "Rebuild layout once buffer in WINDOW changed." + (when-let* ((dv (with-selected-window window (dirvish-curr))) + (dir (car (dv-index dv))) (buf (cdr (dv-index dv))) + (old-tab (with-selected-window window (dirvish-prop :tab))) + (old-frame (with-selected-window window (dirvish-prop :frame))) + (sc (cl-loop for (k v) on dirvish--scopes by 'cddr + append (list k (and (functionp v) (funcall v))))) + (layout t) (frame t) (tab t)) + (setq layout (dv-curr-layout dv) + frame (plist-get sc :frame) tab (plist-get sc :tab)) + (cl-flet ((killall (bufs) (mapc #'dirvish--kill-buffer bufs)) + (build-dv (dv frame dir) + (with-selected-frame frame + (with-selected-window (dirvish--create-root-window dv) + (dirvish-save-dedication + (switch-to-buffer (get-buffer-create "*scratch*"))) + (dirvish-save-dedication + (switch-to-buffer (dired-noselect dir))) + (dirvish--build-layout dv))))) + (cond ; created new tab / frame in a reused session, clear the old one + ((not (equal old-frame frame)) + (killall (append (list buf) (mapcar #'cdr (dv-roots dv)))) + (build-dv (dirvish--new :curr-layout layout) frame dir)) + ((not (equal old-tab tab)) + (tab-bar-switch-to-recent-tab) + (killall (append (list buf) (mapcar #'cdr (dv-roots dv)))) + (tab-bar-switch-to-recent-tab) + (build-dv (dirvish--new :curr-layout layout) frame dir)) + (t (with-selected-window window (dirvish--build-layout dv))))))) + +(defun dirvish--create-parent-windows (dv) + "Create all dirvish parent windows for DV." + (let* ((current (expand-file-name default-directory)) + (parent (dirvish--get-parent-path current)) + (parent-dirs ()) + (depth (or (car (dv-curr-layout dv)) 0)) + (i 0)) + (while (and (< i depth) (not (string= current parent))) + (cl-incf i) + (push (cons current parent) parent-dirs) + (setq current (dirvish--get-parent-path current)) + (setq parent (dirvish--get-parent-path parent))) + (when (> depth 0) + (cl-loop with layout = (dv-curr-layout dv) + with parent-width = (nth 1 layout) + with remain = (- 1 (nth 2 layout) parent-width) + with width = (min (/ remain depth) parent-width) + for level from 1 for (current . parent) in parent-dirs + for args = `((side . left) (inhibit-same-window . t) + (window-width . ,width) + (window-parameters . ((no-other-window . t)))) + for b = (dirvish--create-parent-buffer dv parent current level) + for w = (display-buffer b `(dirvish--display-buffer . ,args)) do + (dirvish--render-attrs w 'never) ; only render icon + (with-selected-window w + (set-window-fringes w 1 1) (set-window-dedicated-p w t)))))) + +(defun dirvish--window-split-order () + "Compute the window split order." + (let* ((weights '((nil . 0) (t . 1) (global . 2))) + (ord + '((00 preview) (12 footer preview header) (21 header preview footer) + (20 header preview) (11 preview header footer) (10 preview header) + (01 preview footer) (02 footer preview) (22 footer header preview))) + (h-pos (if (dirvish-prop :global-header) 2 + (alist-get dirvish-use-header-line weights))) + (m-pos (alist-get dirvish-use-mode-line weights)) + (key (string-to-number (format "%s%s" (or h-pos 1) (or m-pos 1))))) + (cdr (assq key ord)))) + +(defun dirvish--build-layout (dv) + "Build layout for Dirvish session DV." + (let* ((layout (dv-curr-layout dv)) (conf (dv-winconf dv)) + (w-args `((preview (side . right) (window-width . ,(nth 2 layout))) + (header (side . above) (window-height . -2) + (window-parameters . ((no-other-window . t)))) + (footer (side . below) (window-height . -2) + (window-parameters . ((no-other-window . t)))))) + (w-order (and layout (dirvish--window-split-order))) + (window-safe-min-height 0) (window-resize-pixelwise t) + (lh (line-pixel-height)) (gui? (display-graphic-p)) sf + (mh (dirvish--mode-line-height t)) (hh (dirvish--mode-line-height t t))) + (setf (dv-index dv) (cons (dirvish-prop :root) (current-buffer))) + ;; only refresh window config before creating fullframe layout + (setf (dv-winconf dv) (when layout (or conf (current-window-configuration)))) + (and (not layout) (setq sf (dv-size-fixed dv)) (setq window-size-fixed sf)) + (when layout (dirvish--init-special-buffers dv)) + (dirvish--setup-mode-line dv) + (when w-order (let ((ignore-window-parameters t)) (delete-other-windows))) + (when (or (dv-curr-layout dv) (dv-dedicated dv)) + (set-window-dedicated-p nil t)) + ;; ensure a positive fringe on both sides for `dirvish-subtree' (#311) + (set-window-fringes nil (1+ dirvish-window-fringe) 1) + (dolist (pane w-order) + (let* ((buf (dirvish--special-buffer pane dv (eq pane 'preview))) + (args (alist-get pane w-args)) + (win (display-buffer buf `(dirvish--display-buffer . ,args)))) + (pcase pane + ('preview (setf (dv-preview-window dv) win)) + ('header (when (and gui? (> hh lh)) (fit-window-to-buffer win 2 1))) + ('footer (when (and gui? (> mh lh)) (fit-window-to-buffer win 2 1)))) + (unless (eq pane 'preview) (set-window-dedicated-p win t)) + (set-window-buffer win buf))) + (dirvish--create-parent-windows dv) + (dirvish--run-with-delay 'reset) ; preview initialization + (dirvish--maybe-toggle-cursor) + (dirvish--maybe-toggle-details))) + +;;;; Major modes + +(define-derived-mode dirvish-directory-view-mode special-mode "Dirvish DIRview" + "Major mode for parent directory and directory preview buffer." + (setq-local mode-line-format nil header-line-format nil truncate-lines t + dirvish--dir-data (dirvish--ht) font-lock-defaults + '(dired-font-lock-keywords t nil nil beginning-of-line)) + (font-lock-mode 1) + :group 'dirvish :interactive nil) + +(define-derived-mode dirvish-special-preview-mode special-mode "Dirvish Special" + "Major mode for info, shell command output and non-text file preview buffer." + (setq-local mode-line-format nil header-line-format nil) + :group 'dirvish :interactive nil) + +(define-derived-mode dirvish-misc-mode special-mode "Dirvish Misc" + "Major mode for mode/header-line and other special buffers." + (setq-local face-remapping-alist '((header-line-inactive header-line) + (mode-line-inactive mode-line)) + cursor-type nil window-size-fixed 'height + mode-line-format nil header-line-format nil) + :group 'dirvish :interactive nil) + +;;;; Advices + +(defun dirvish-insert-subdir-a (dirname &rest _) + "Setup newly inserted subdir DIRNAME for this Dirvish buffer." + (dirvish--hide-dired-header) + (dirvish--dir-data-async dirname (current-buffer) t)) + +(defun dirvish-wdired-enter-a (&rest _) + "Advice for `wdired-change-to-wdired-mode'." + (let (dirvish-hide-cursor) (dirvish--maybe-toggle-cursor 'hollow)) + (dolist (ov '(dirvish-a-ov dirvish-l-ov dirvish-r-ov)) + (remove-overlays (point-min) (point-max) ov t))) + +(defun dirvish-find-alt-a () + "Advice for `dired-find-alternate-file'." + (dirvish--find-entry 'find-alternate-file (dired-get-file-for-visit))) + +(defun dirvish-find-marked-files-a (&optional noselect) + "Find all marked files displaying all of them simultaneously. +With optional NOSELECT just find files but do not select them." + (declare-function dired-simultaneous-find-file "dired-x") + (when-let* ((dv (dirvish-curr)) + (files (dired-get-marked-files nil nil nil nil t))) + (unless noselect (dirvish--clear-session dv)) + (mapc #'dirvish--kill-buffer (dv-preview-buffers dv)) + (dired-simultaneous-find-file files noselect))) + +(defun dirvish-dired-noselect-a (fn dir-or-list &optional flags re) + "Return buffer for DIR-OR-LIST with FLAGS, FN is `dired-noselect'." + (let* ((dir (if (consp dir-or-list) (car dir-or-list) dir-or-list)) + (key (file-name-as-directory (expand-file-name dir))) + (dvc (dirvish-curr)) + (dv (if (and dvc (not (eq (dv-type dvc) 'peek))) dvc + (or (dirvish--get-session) (dirvish--new)))) + (bname buffer-file-name) (remote (file-remote-p dir)) + (flags (or flags (dv-ls-switches dv))) + (mc dirvish-large-directory-threshold) + (buffer (alist-get key (dv-roots dv) nil nil #'equal)) + (new? (null buffer)) (dps (dv-preview-dispatchers dv)) + (hist (cons key nil)) tramp fd) + (setf (dv-timestamp dv) (dirvish--timestamp)) + (cond ((and new? remote) + (setq tramp (prog1 'dirvish-tramp-noselect (require 'dirvish-tramp)) + buffer (apply tramp (list fn dir-or-list flags remote dps)))) + ((or re (and mc (length> (directory-files key nil nil t mc) (1- mc)))) + (setq fd (prog1 'dirvish-fd-noselect (require 'dirvish-fd nil t)) + buffer (apply fd (list dv key (or re ""))) + re (if (stringp re) re (mapconcat #'concat re ",")) + key (concat key "🔍" re))) + (new? (let (dired-buffers) ; disable reuse from `dired' + (setq buffer (apply fn (list dir-or-list flags)))))) + (when (setq new? (null (alist-get key (dv-roots dv) nil nil #'equal))) + (push (cons key buffer) (dv-roots dv))) + (unless (member (car hist) (mapcar #'car dired-buffers)) + (setq dired-buffers (seq-take (push hist dired-buffers) 20000))) + (setcdr (assoc (car hist) dired-buffers) buffer) + (with-current-buffer buffer + (dirvish--setup-dired) + (funcall (dv-root-conf dv) buffer) + (dirvish-prop :dv (dv-id dv)) + (dirvish-prop :gui (display-graphic-p)) + (dirvish-prop :remote remote) + (dirvish-prop :root key) + (unless remote (dirvish-prop :preview-dps dps)) + (dirvish-prop :attrs (dv-attributes dv)) + (cl-loop for (k v) on dirvish--scopes by 'cddr + do (dirvish-prop k (and (functionp v) (funcall v)))) + (when new? (dirvish--dir-data-async (car hist) buffer)) + (when bname (dired-goto-file bname)) + (setf (dv-index dv) (cons key buffer)) + (run-hook-with-args 'dirvish-find-entry-hook (car hist) 'dired) + buffer))) + +;;;; Commands + +(defun dirvish-layout-toggle () + "Toggle layout of current Dirvish session. +A session with layout means it has a companion preview window and +possibly one or more parent windows." + (interactive) + (let* ((dv (or (dirvish-curr) (user-error "Not a dirvish buffer"))) + (old-layout (dv-curr-layout dv)) (conf (dv-winconf dv)) + (new-layout (unless old-layout (dv-ff-layout dv))) + (buf (current-buffer))) + (setf (dv-preview-hash dv) (dirvish--ht) (dv-parent-hash dv) (dirvish--ht)) + (if old-layout (and conf (set-window-configuration conf)) + (with-selected-window (dv-root-window dv) (quit-window))) + (setf (dv-curr-layout dv) new-layout) + (with-selected-window (dirvish--create-root-window dv) + (dirvish-save-dedication (switch-to-buffer buf)) + (dirvish--build-layout dv)))) + +(defun dirvish-quit () + "Quit current Dirvish session. +If the session is a full-framed one, the window layout is restored. If +`dirvish-reuse-session' is nil, all Dired buffers in the session are +killed, otherwise only the invisible Dired buffers within the session +are killed and the Dired buffer(s) in the selected window are buried." + (interactive) + (when-let* ((dv (dirvish-curr)) (ct 0) (max-c (length (dv-roots dv)))) + (dirvish--clear-session dv t) + (while (and (dirvish-curr) (<= ct max-c)) (cl-incf ct) (quit-window)))) + +;;;###autoload +(define-minor-mode dirvish-override-dired-mode + "Let Dirvish take over Dired globally." + :group 'dirvish :global t + (let ((ads '((dired--find-file dirvish--find-entry :override) + (dired-find-alternate-file dirvish-find-alt-a :override) + (dired-do-find-marked-files dirvish-find-marked-files-a :override) + (dired-noselect dirvish-dired-noselect-a :around) + (dired-insert-subdir dirvish-insert-subdir-a :after) + (wdired-change-to-wdired-mode dirvish-wdired-enter-a :after) + (wdired-change-to-dired-mode dirvish--setup-dired :after)))) + (if dirvish-override-dired-mode + (pcase-dolist (`(,sym ,fn ,how) ads) (advice-add sym how fn)) + (pcase-dolist (`(,sym ,fn) ads) (advice-remove sym fn))))) + +(defun dirvish--try-reuse (path &optional dwim) + "Find PATH in existed or new session, DWIM is passed from `dirvish-dwim'." + (let* ((dir (or path default-directory)) + (fn (if dired-kill-when-opening-new-dired-buffer 'find-alternate-file + 'find-file)) + (cur? (dirvish-curr)) ; can be a non-default session, reuse it directly + (vis? (cl-loop for w in (window-list) + for b = (window-buffer w) + for dv = (with-current-buffer b (dirvish-curr)) + thereis (and dv (eq 'default (dv-type dv)) dv))) + (reuse? (unless vis? (dirvish--get-session 'type 'default)))) + (cond (cur? (dirvish--find-entry fn dir) + (when (and dirvish-default-layout (not (dv-curr-layout cur?))) + (unless dwim (dirvish-layout-toggle)))) + (vis? + (dirvish-save-dedication (switch-to-buffer (cdr (dv-index vis?)))) + (dirvish--find-entry fn dir) + (when (and dirvish-default-layout (not (dv-curr-layout vis?))) + (unless dwim (dirvish-layout-toggle)))) + (reuse? + (with-selected-window (dirvish--create-root-window reuse?) + (setf (dv-curr-layout reuse?) + (or (dv-curr-layout reuse?) dirvish-default-layout)) + (and dwim (not (one-window-p)) (setf (dv-curr-layout reuse?) nil)) + (dirvish-save-dedication (switch-to-buffer (cdr (dv-index reuse?)))) + (unless (eq dirvish-reuse-session 'resume) + (dirvish--find-entry fn dir)))) + (t (dirvish--new + :curr-layout (if dwim (and (one-window-p) dirvish-default-layout) + dirvish-default-layout)) + (dirvish--find-entry 'find-file dir))))) + +;;;###autoload +(defun dirvish (&optional path) + "Open PATH in a fullframe Dirvish session. +Prompt for PATH if called with \\[universal-arguments], otherwise PATH +defaults to `default-directory'." + (interactive (list (and current-prefix-arg (read-directory-name "Dirvish: ")))) + (dirvish--try-reuse path)) + +;;;###autoload +(defun dirvish-dwim (&optional path) + "Open PATH in a fullframe session if selected window is the only window. +Prompt for PATH if called with \\[universal-arguments], otherwise PATH +defaults to `default-directory'. If there are other windows exist in the +selected frame, the session occupies only the selected window." + (interactive (list (and current-prefix-arg (read-directory-name "Dirvish: ")))) + (dirvish--try-reuse path 'dwim)) + +(provide 'dirvish) +;;; dirvish.el ends here diff --git a/lisp/epl/epl-pkg.el b/lisp/epl/epl-pkg.el new file mode 100644 index 00000000..3b8dee4e --- /dev/null +++ b/lisp/epl/epl-pkg.el @@ -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"))) diff --git a/lisp/epl/epl.el b/lisp/epl/epl.el new file mode 100644 index 00000000..c47a339a --- /dev/null +++ b/lisp/epl/epl.el @@ -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 +;; Maintainer: Johan Andersson +;; Sebastian Wiesner +;; 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 . + +;;; 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