dired-rsync.el 5.64 KB
Newer Older
Lev Lamberov's avatar
Lev Lamberov committed
1
;;; dired-rsync.el --- Allow rsync from dired buffers -*- lexical-binding: t -*-
Lev Lamberov's avatar
Lev Lamberov committed
2 3 4 5 6
;;
;; Copyright (C) 2018 Alex Bennée
;;
;; Author: Alex Bennée <alex@bennee.com>
;; Maintainer: Alex Bennée <alex@bennee.com>
Lev Lamberov's avatar
Lev Lamberov committed
7
;; Version: 0.3
Lev Lamberov's avatar
Lev Lamberov committed
8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
;; Package-Requires: ((s "1.12.0") (dash "2.0.0") (emacs "24"))
;; Homepage: https://github.com/stsquad/dired-rsync
;;
;; This file is not part of GNU Emacs.
;;
;; This file 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, or (at your option)
;; any later version.
;;
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;;; Commentary:
;;
;; dired-rsync is a command that can be run from a dired buffer to
Lev Lamberov's avatar
Lev Lamberov committed
29 30
;; copy files using rsync rather than tramps in-built mechanism.
;; This is especially useful for copying large files to/from remote
Lev Lamberov's avatar
Lev Lamberov committed
31 32 33
;; locations without locking up tramp.
;;
;; To use simply open a dired buffer, mark some files and invoke
Lev Lamberov's avatar
Lev Lamberov committed
34
;; dired-rsync.  After being prompted for a location to copy to an
Lev Lamberov's avatar
Lev Lamberov committed
35 36 37 38 39 40
;; inferior rsync process will be spawned.
;;
;; Wherever the files are selected from the rsync will always run from
;; your local machine.
;;

Lev Lamberov's avatar
Lev Lamberov committed
41 42
(eval-when-compile (require 'cl)) ; for lexical-let
(require 'tramp) ; for tramp-tramp-file-p
Lev Lamberov's avatar
Lev Lamberov committed
43 44 45 46 47 48
(require 'dired-aux) ; for dired-dwim-target-directory
(require 'dash)
(require 's)

;;; Code:

Lev Lamberov's avatar
Lev Lamberov committed
49
;; Customisation options
Lev Lamberov's avatar
Lev Lamberov committed
50

Lev Lamberov's avatar
Lev Lamberov committed
51 52 53 54
(defcustom dired-rsync-command "rsync"
  "The rsync binary that we are going to use."
  :type 'string
  :group 'dired-rsync)
Lev Lamberov's avatar
Lev Lamberov committed
55

Lev Lamberov's avatar
Lev Lamberov committed
56 57 58 59 60 61 62 63 64 65 66 67 68
(defcustom dired-rsync-options "-avz --progress"
  "The default options for the rsync command."
  :type 'string
  :group 'dired-rsync)

(defcustom dired-rsync-unmark-on-completion t
  "Control if dired-rsync should unmark when complete."
  :type 'boolean
  :group 'dired-rsync)

;; Internal variables
(defvar dired-rsync-job-count 0
  "Count of running rsync jobs.")
Lev Lamberov's avatar
Lev Lamberov committed
69 70 71

(defvar dired-rsync-modeline-status
  ""
Lev Lamberov's avatar
Lev Lamberov committed
72
  "A string defining current `dired-rsync' status, useful for modelines.")
Lev Lamberov's avatar
Lev Lamberov committed
73 74 75

;; Helpers

Lev Lamberov's avatar
Lev Lamberov committed
76
(defun dired-rsync--quote-and-maybe-convert-from-tramp (file-or-path)
Lev Lamberov's avatar
Lev Lamberov committed
77
  "Reformat a tramp FILE-OR-PATH to one usable for rsync."
Lev Lamberov's avatar
Lev Lamberov committed
78
  (if (tramp-tramp-file-p file-or-path)
Lev Lamberov's avatar
Lev Lamberov committed
79 80 81
      ;; tramp format is /method:remote:path
      (let ((parts (s-split ":" file-or-path)))
        (format "%s:\"%s\"" (nth 1 parts) (shell-quote-argument (nth 2 parts))))
Lev Lamberov's avatar
Lev Lamberov committed
82
    (shell-quote-argument file-or-path)))
Lev Lamberov's avatar
Lev Lamberov committed
83 84

;; Update status with count/speed
Lev Lamberov's avatar
Lev Lamberov committed
85 86
(defun dired-rsync--update-modeline ()
  "Update the number of current jobs."
Lev Lamberov's avatar
Lev Lamberov committed
87
  (setq mode-line-process
Lev Lamberov's avatar
Lev Lamberov committed
88
          (setq dired-rsync-modeline-status
Lev Lamberov's avatar
Lev Lamberov committed
89 90 91
                (if (> dired-rsync-job-count 0)
                    (format " R:%d " dired-rsync-job-count)
                  nil))))
Lev Lamberov's avatar
Lev Lamberov committed
92 93 94 95 96 97 98 99 100

;;
;; Running rsync: We need to take care of a couple of things here. We
;; need to ensure we run from the local host as you shouldn't expect
;; the remote target to be as aware of the ssh shortcuts home as from
;; the local system out (.ssh/config). We also want to track when it
;; is finished so we can inform the user the copy is complete.
;;

Lev Lamberov's avatar
Lev Lamberov committed
101
(defun dired-rsync--sentinel(proc desc details)
Lev Lamberov's avatar
Lev Lamberov committed
102 103 104
  "Process sentinel for rsync processes.
This gets called whenever the inferior `PROC' changes state as
  described by `DESC'."
Lev Lamberov's avatar
Lev Lamberov committed
105 106 107 108 109 110 111 112 113 114 115
  (when (s-starts-with-p "finished" desc)
    ;; clean-up finished tasks
    (let ((proc-buf (process-buffer proc))
          (dired-buf (plist-get details ':dired-buffer)))
      (when dired-rsync-unmark-on-completion
        (with-current-buffer dired-buf
          (dired-unmark-all-marks)))
      (kill-buffer proc-buf)))
  ;; clean-up data left from dead/finished processes
  (when (not (process-live-p proc))
    (setq dired-rsync-job-count (1- dired-rsync-job-count)))
Lev Lamberov's avatar
Lev Lamberov committed
116
  (dired-rsync--update-modeline))
Lev Lamberov's avatar
Lev Lamberov committed
117 118

(defun dired-rsync--do-run (command details)
Lev Lamberov's avatar
Lev Lamberov committed
119
  "Run rsync COMMAND in a unique buffer, passing DETAILS to sentinel."
Lev Lamberov's avatar
Lev Lamberov committed
120 121
  (let* ((buf (format "*rsync @ %s" (current-time-string)))
         (proc (start-process-shell-command "*rsync*" buf command)))
Lev Lamberov's avatar
Lev Lamberov committed
122 123 124 125 126 127
    (lexical-let ((job-details details))
      (set-process-sentinel
       proc
       #'(lambda (proc desc)
           (dired-rsync--sentinel proc desc job-details))))
    (setq dired-rsync-job-count (1+ dired-rsync-job-count))
Lev Lamberov's avatar
Lev Lamberov committed
128
    (dired-rsync--update-modeline)))
Lev Lamberov's avatar
Lev Lamberov committed
129 130 131 132 133 134 135 136 137 138 139 140

;;;###autoload
(defun dired-rsync (dest)
  "Asynchronously copy files in dired to DEST using rsync.

This function runs the copy asynchronously so Emacs won't block whilst
the copy is running. It also handles both source and destinations on
ssh/scp tramp connections."
  ;; Interactively grab dest if not called with
  (interactive
   (list (read-file-name "rsync to:" (dired-dwim-target-directory))))

Lev Lamberov's avatar
Lev Lamberov committed
141 142 143 144
  (let ((src-files (-map
                    'dired-rsync--quote-and-maybe-convert-from-tramp
                    (dired-get-marked-files nil current-prefix-arg)))
        (final-dest (dired-rsync--quote-and-maybe-convert-from-tramp dest)))
Lev Lamberov's avatar
Lev Lamberov committed
145 146 147 148 149 150

    ;; now build the rsync command
    (let ((cmd (s-join " "
                       (-flatten
                        (list dired-rsync-command
                              dired-rsync-options
Lev Lamberov's avatar
Lev Lamberov committed
151 152
                              src-files
                              final-dest)))))
Lev Lamberov's avatar
Lev Lamberov committed
153 154 155 156 157 158
      (dired-rsync--do-run cmd
                           (list :marked-files src-files
                                 :dired-buffer (buffer-name))))))

(provide 'dired-rsync)
;;; dired-rsync.el ends here