From 4efc33f01d0344a52670eb0c0250d5ef40bb7952 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Mon, 28 Oct 2013 20:30:40 +0100 Subject: [PATCH] * net/tramp-sh.el (tramp-sh-handle-copy-directory): * net/tramp-smb.el (tramp-smb-handle-copy-directory): Handle COPY-CONTENTS. (Bug#15737) --- lisp/ChangeLog | 6 ++ lisp/net/tramp-sh.el | 13 ++- lisp/net/tramp-smb.el | 277 ++++++++++++++++++++++++++------------------------ 3 files changed, 158 insertions(+), 138 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index aac29e86ad6..34ac8ffd5e5 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2013-10-28 Michael Albinus + + * net/tramp-sh.el (tramp-sh-handle-copy-directory): + * net/tramp-smb.el (tramp-smb-handle-copy-directory): + Handle COPY-CONTENTS. (Bug#15737) + 2013-10-28 Daiki Ueno * epa-file.el diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 147113ba5a1..f69859ddb10 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1831,18 +1831,20 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" 'copy-file (list filename newname ok-if-already-exists keep-date))))) (defun tramp-sh-handle-copy-directory - (dirname newname &optional keep-date parents _copy-contents) + (dirname newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." (let ((t1 (tramp-tramp-file-p dirname)) (t2 (tramp-tramp-file-p newname))) (with-parsed-tramp-file-name (if t1 dirname newname) nil - (if (and (tramp-get-method-parameter method 'tramp-copy-recursive) + (if (and (not copy-contents) + (tramp-get-method-parameter method 'tramp-copy-recursive) ;; When DIRNAME and NEWNAME are remote, they must have ;; the same method. (or (null t1) (null t2) (string-equal (tramp-file-name-method (tramp-dissect-file-name dirname)) - (tramp-file-name-method (tramp-dissect-file-name newname))))) + (tramp-file-name-method + (tramp-dissect-file-name newname))))) ;; scp or rsync DTRT. (progn (setq dirname (directory-file-name (expand-file-name dirname)) @@ -1859,7 +1861,10 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" 'copy dirname newname keep-date)) ;; We must do it file-wise. (tramp-run-real-handler - 'copy-directory (list dirname newname keep-date parents))) + 'copy-directory + (if copy-contents + (list dirname newname keep-date parents copy-contents) + (list dirname newname keep-date parents)))) ;; When newname did exist, we have wrong cached values. (when t2 diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index fe7097edbde..4f294050bb9 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -387,141 +387,150 @@ pass to the OPERATION." (throw 'tramp-action 'ok))))) (defun tramp-smb-handle-copy-directory - (dirname newname &optional keep-date parents _copy-contents) + (dirname newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." - (setq dirname (expand-file-name dirname) - newname (expand-file-name newname)) - (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname))) - (with-parsed-tramp-file-name (if t1 dirname newname) nil - (with-tramp-progress-reporter - v 0 (format "Copying %s to %s" dirname newname) - (cond - ;; We must use a local temporary directory. - ((and t1 t2) - (let ((tmpdir - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) - (unwind-protect - (progn - (tramp-compat-copy-directory dirname tmpdir keep-date parents) - (tramp-compat-copy-directory tmpdir newname keep-date parents)) - (tramp-compat-delete-directory tmpdir 'recursive)))) - - ;; We can copy recursively. - ((or t1 t2) - (when (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory dirname) newname)) - (if t2 (setq v (tramp-dissect-file-name newname)))) - (if (not (file-directory-p newname)) - (make-directory newname parents)) - - (setq tramp-current-method (tramp-file-name-method v) - tramp-current-user (tramp-file-name-user v) - tramp-current-host (tramp-file-name-real-host v)) - - (let* ((real-user (tramp-file-name-real-user v)) - (real-host (tramp-file-name-real-host v)) - (domain (tramp-file-name-domain v)) - (port (tramp-file-name-port v)) - (share (tramp-smb-get-share v)) - (localname (file-name-as-directory - (tramp-compat-replace-regexp-in-string - "\\\\" "/" (tramp-smb-get-localname v)))) - (tmpdir (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory)))) - (args (list tramp-smb-program - (concat "//" real-host "/" share) "-E"))) - - (if (not (zerop (length real-user))) - (setq args (append args (list "-U" real-user))) - (setq args (append args (list "-N")))) - - (when domain (setq args (append args (list "-W" domain)))) - (when port (setq args (append args (list "-p" port)))) - (when tramp-smb-conf - (setq args (append args (list "-s" tramp-smb-conf)))) - (setq args - (if t1 - ;; Source is remote. - (append args - (list "-D" (shell-quote-argument localname) - "-c" (shell-quote-argument "tar qc - *") - "|" "tar" "xfC" "-" - (shell-quote-argument tmpdir))) - ;; Target is remote. - (append (list "tar" "cfC" "-" (shell-quote-argument dirname) - "." "|") - args - (list "-D" (shell-quote-argument localname) - "-c" (shell-quote-argument "tar qx -"))))) - - (unwind-protect - (with-temp-buffer - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - - (when t1 - ;; The smbclient tar command creates always complete - ;; paths. We must emulate the directory structure, - ;; and symlink to the real target. - (make-directory - (expand-file-name ".." (concat tmpdir localname)) 'parents) - (make-symbolic-link - newname (directory-file-name (concat tmpdir localname)))) - - ;; Use an asynchronous processes. By this, password - ;; can be handled. - (let* ((default-directory tmpdir) - (p (start-process-shell-command - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - (mapconcat 'identity args " ")))) - - (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) - (tramp-compat-set-process-query-on-exit-flag p nil) - (tramp-process-actions p v nil tramp-smb-actions-with-tar) - - (while (memq (process-status p) '(run open)) - (sit-for 0.1)) - (tramp-message v 6 "\n%s" (buffer-string)))) - - ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil) - (when t1 (delete-directory tmpdir 'recurse)))) - - ;; Handle KEEP-DATE argument. - (when keep-date - (set-file-times newname (nth 5 (file-attributes dirname)))) - - ;; Set the mode. - (unless keep-date - (set-file-modes newname (tramp-default-file-modes dirname))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))) - - ;; We must do it file-wise. - (t - (tramp-run-real-handler - 'copy-directory (list dirname newname keep-date parents)))))))) + (if copy-contents + ;; We must do it file-wise. + (tramp-run-real-handler + 'copy-directory (list dirname newname keep-date parents copy-contents)) + + (setq dirname (expand-file-name dirname) + newname (expand-file-name newname)) + (let ((t1 (tramp-tramp-file-p dirname)) + (t2 (tramp-tramp-file-p newname))) + (with-parsed-tramp-file-name (if t1 dirname newname) nil + (with-tramp-progress-reporter + v 0 (format "Copying %s to %s" dirname newname) + (cond + ;; We must use a local temporary directory. + ((and t1 t2) + (let ((tmpdir + (make-temp-name + (expand-file-name + tramp-temp-name-prefix + (tramp-compat-temporary-file-directory))))) + (unwind-protect + (progn + (tramp-compat-copy-directory + dirname tmpdir keep-date parents) + (tramp-compat-copy-directory + tmpdir newname keep-date parents)) + (tramp-compat-delete-directory tmpdir 'recursive)))) + + ;; We can copy recursively. + ((or t1 t2) + (when (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name + (file-name-nondirectory dirname) newname)) + (if t2 (setq v (tramp-dissect-file-name newname)))) + (if (not (file-directory-p newname)) + (make-directory newname parents)) + + (setq tramp-current-method (tramp-file-name-method v) + tramp-current-user (tramp-file-name-user v) + tramp-current-host (tramp-file-name-real-host v)) + + (let* ((real-user (tramp-file-name-real-user v)) + (real-host (tramp-file-name-real-host v)) + (domain (tramp-file-name-domain v)) + (port (tramp-file-name-port v)) + (share (tramp-smb-get-share v)) + (localname (file-name-as-directory + (tramp-compat-replace-regexp-in-string + "\\\\" "/" (tramp-smb-get-localname v)))) + (tmpdir (make-temp-name + (expand-file-name + tramp-temp-name-prefix + (tramp-compat-temporary-file-directory)))) + (args (list tramp-smb-program + (concat "//" real-host "/" share) "-E"))) + + (if (not (zerop (length real-user))) + (setq args (append args (list "-U" real-user))) + (setq args (append args (list "-N")))) + + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (setq args + (if t1 + ;; Source is remote. + (append args + (list "-D" (shell-quote-argument localname) + "-c" (shell-quote-argument "tar qc - *") + "|" "tar" "xfC" "-" + (shell-quote-argument tmpdir))) + ;; Target is remote. + (append (list "tar" "cfC" "-" + (shell-quote-argument dirname) "." "|") + args + (list "-D" (shell-quote-argument localname) + "-c" (shell-quote-argument "tar qx -"))))) + + (unwind-protect + (with-temp-buffer + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + + (when t1 + ;; The smbclient tar command creates always + ;; complete paths. We must emulate the + ;; directory structure, and symlink to the real + ;; target. + (make-directory + (expand-file-name + ".." (concat tmpdir localname)) 'parents) + (make-symbolic-link + newname (directory-file-name (concat tmpdir localname)))) + + ;; Use an asynchronous processes. By this, + ;; password can be handled. + (let* ((default-directory tmpdir) + (p (start-process-shell-command + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + (mapconcat 'identity args " ")))) + + (tramp-message + v 6 "%s" (mapconcat 'identity (process-command p) " ")) + (tramp-set-connection-property p "vector" v) + (tramp-compat-set-process-query-on-exit-flag p nil) + (tramp-process-actions p v nil tramp-smb-actions-with-tar) + + (while (memq (process-status p) '(run open)) + (sit-for 0.1)) + (tramp-message v 6 "\n%s" (buffer-string)))) + + ;; Reset the transfer process properties. + (tramp-set-connection-property v "process-name" nil) + (tramp-set-connection-property v "process-buffer" nil) + (when t1 (delete-directory tmpdir 'recurse)))) + + ;; Handle KEEP-DATE argument. + (when keep-date + (set-file-times newname (nth 5 (file-attributes dirname)))) + + ;; Set the mode. + (unless keep-date + (set-file-modes newname (tramp-default-file-modes dirname))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname)))) + + ;; We must do it file-wise. + (t + (tramp-run-real-handler + 'copy-directory (list dirname newname keep-date parents))))))))) (defun tramp-smb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date -- 2.11.4.GIT