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