bug#10489: 24.0.92; dired-do-copy may create infinite directory hierarchy

[Thierry Volpiatto <thierry.volpiatto@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 1519 bytes --]

Michael Albinus <michael.albinus@gmx.de> writes:

> Thierry Volpiatto <thierry.volpiatto@gmail.com> writes:
>
>> What about this?
>>
>> (defun file-name-equal-p (name1 name2 &optional dir)
>>   (let* ((n1     (file-truename (expand-file-name name1 dir)))
>>          (n2     (file-truename (expand-file-name name2 dir)))
>>          (rhost1 (file-remote-p n1 'host))
>>          (rhost2 (file-remote-p n2 'host))
>>          (lname1 (file-remote-p n1 'localname))
>>          (lname2 (file-remote-p n2 'localname))
>>          (rem-n1 (if rhost1
>>                      (list (cons rhost1 lname1))
>>                      (list (cons (system-name) n1))))
>>          (rem-n2 (if rhost2
>>                      (list (cons rhost2 lname2))
>>                      (list (cons (system-name) n2)))))
>>     (loop for (x1 . y1) in rem-n1
>>           for (x2 . y2) in rem-n2
>>           thereis (and (equal x1 x2)
>>                        (equal y1 y2)))))
>
> Nope. User name and method also matter.
>
> "/ftp:host:/file" <> "/ssh:@host:/file"
>
> "/ftp:user1@host:/file" <> "/ftp:user1@host:/file"
I see.

> You shouldn't mess with remote files, really :-)
Indeed yes!

> That's what file name handlers are good for.
>
> Best regards, Michael.

I post here the last version of the patch I wrote today,
waiting something better to compare files.
it works and fix this bug in most use cases.
 
-- 
  Thierry
Get my Gnupg key:
gpg --keyserver pgp.mit.edu --recv-keys 59F29997 

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: Singlepatch-r118414ToTip.patch --]
[-- Type: text/x-diff, Size: 8329 bytes --]

##Merge of all patches applied from revision 118413
## patch-r118414: Fix error when trying to copy directory on itself (bug#10489).
## patch-r118415: * lisp/dired-aux.el (dired-copy-file-recursive): Handle also remote file/dir.
## patch-r118416: Handle only remote files with sudo method when copying directories.
## patch-r118417: * lisp/dired-aux.el (dired-copy-file-recursive): Use file-truename.
## 
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -1264,24 +1264,34 @@
 
 (defun dired-copy-file-recursive (from to ok-flag &optional
 				       preserve-time top recursive)
-  (let ((attrs (file-attributes from)))
+  (let* ((case-fold-search t)
+         (fromname    (file-name-as-directory (file-truename from)))
+         (destname    (file-name-as-directory (file-truename to)))
+         (rem-dirname (and (equal "sudo" (file-remote-p fromname 'method))
+                           (file-remote-p fromname 'localname)))
+         (rem-newname (and (equal "sudo" (file-remote-p destname 'method))
+                           (file-remote-p destname 'localname)))
+         (attrs       (file-attributes from)))
+    (when (equal (or rem-dirname fromname)
+                 (or rem-newname destname))
+      (error "Can't copy directory `%s' on itself" from))
     (if (and recursive
-	     (eq t (car attrs))
-	     (or (eq recursive 'always)
-		 (yes-or-no-p (format "Recursive copies of %s? " from))))
-	;; This is a directory.
-	(copy-directory from to preserve-time)
+             (eq t (car attrs))
+             (or (eq recursive 'always)
+                 (yes-or-no-p (format "Recursive copies of %s? " from))))
+        ;; This is a directory.
+        (copy-directory from to preserve-time)
       ;; Not a directory.
       (or top (dired-handle-overwrite to))
       (condition-case err
-	  (if (stringp (car attrs))
-	      ;; It is a symlink
-	      (make-symbolic-link (car attrs) to ok-flag)
-	    (copy-file from to ok-flag preserve-time))
-	(file-date-error
-	 (push (dired-make-relative from)
-	       dired-create-files-failures)
-	 (dired-log "Can't set date on %s:\n%s\n" from err))))))
+          (if (stringp (car attrs))
+              ;; It is a symlink
+              (make-symbolic-link (car attrs) to ok-flag)
+            (copy-file from to ok-flag preserve-time))
+        (file-date-error
+         (push (dired-make-relative from)
+               dired-create-files-failures)
+         (dired-log "Can't set date on %s:\n%s\n" from err))))))
 
 ;;;###autoload
 (defun dired-rename-file (file newname ok-if-already-exists)
@@ -1402,7 +1412,7 @@
 newfile's entry, or t to use the current marker character if the
 old file was marked."
   (let (dired-create-files-failures failures
-	skipped (success-count 0) (total (length fn-list)))
+                                    skipped (success-count 0) (total (length fn-list)))
     (let (to overwrite-query
 	     overwrite-backup-query)	; for dired-handle-overwrite
       (dolist (from fn-list)
@@ -1430,10 +1440,40 @@
                   (cond  ((integerp marker-char) marker-char)
                          (marker-char (dired-file-marker from)) ; slow
                          (t nil))))
-	    (when (and (file-directory-p from)
-		       (file-directory-p to)
-		       (eq file-creator 'dired-copy-file))
-	      (setq to (file-name-directory to)))
+            ;; Handle the `dired-copy-file' file-creator specially
+            ;; When copying a directory to another directory or
+            ;; possibly to itself.
+            ;; (e.g "~/foo" => "~/test" or "~/foo" =>"~/foo")
+            ;; In this case the 'name-constructor' have set the destination
+            ;; 'to' to "~/test/foo" because the old
+            ;; emacs23 behavior of `copy-directory'
+            ;; was no not create the subdir and copy instead the contents only.
+            ;; With it's new behavior (similar to cp shell command) we don't
+            ;; need such a construction, so modify the destination 'to' to
+            ;; "~/test/" instead of "~/test/foo/".
+            ;; If from and to are the same directory do the same,
+            ;; the error will be handled by `dired-copy-file-recursive'.
+            (let* ((case-fold-search t)
+                   (fromname     (file-name-as-directory (file-truename from)))
+                   (destname     (file-name-as-directory (file-name-directory
+                                                          (file-truename to))))
+                   (rem-fromname (and (equal "sudo" (file-remote-p fromname
+                                                                   'method))
+                                      (file-remote-p fromname 'localname)))
+                   (rem-newname  (and (equal "sudo" (file-remote-p destname
+                                                                   'method))
+                                      (file-remote-p destname 'localname))))
+              (when (and (file-directory-p from)
+                         (or (equal (or
+                                     ;; Maybe a remote file with sudo method
+                                     ;; converted to its localname.
+                                     rem-fromname
+                                     ;; Otherwise compare with local name.
+                                     fromname)
+                                    (or rem-newname destname))
+                             (file-directory-p to))
+                         (eq file-creator 'dired-copy-file))
+                (setq to (file-name-directory to))))
             (condition-case err
                 (progn
                   (funcall file-creator from to dired-overwrite-confirmed)
@@ -1456,21 +1496,21 @@
       (setq failures (nconc failures dired-create-files-failures))
       (dired-log-summary
        (format "%s failed for %d file%s in %d requests"
-		operation (length failures)
-		(dired-plural-s (length failures))
-		total)
+               operation (length failures)
+               (dired-plural-s (length failures))
+               total)
        failures))
      (failures
       (dired-log-summary
        (format "%s failed for %d of %d file%s"
-		operation (length failures)
-		total (dired-plural-s total))
+               operation (length failures)
+               total (dired-plural-s total))
        failures))
      (skipped
       (dired-log-summary
        (format "%s: %d of %d file%s skipped"
-		operation (length skipped) total
-		(dired-plural-s total))
+               operation (length skipped) total
+               (dired-plural-s total))
        skipped))
      (t
       (message "%s: %s file%s"
diff --git a/lisp/files.el b/lisp/files.el
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -4928,10 +4928,20 @@
 	    (format "Copy directory %s to: " dir)
 	    default-directory default-directory nil nil)
 	   current-prefix-arg t nil)))
-  ;; If default-directory is a remote directory, make sure we find its
-  ;; copy-directory handler.
-  (let ((handler (or (find-file-name-handler directory 'copy-directory)
-		     (find-file-name-handler newname 'copy-directory))))
+  (let* ((case-fold-search t)
+         (fromname    (file-name-as-directory (file-truename directory)))
+         (destname    (file-name-as-directory (file-truename newname)))
+         (rem-dirname (and (equal "sudo" (file-remote-p fromname 'method))
+                           (file-remote-p fromname 'localname)))
+         (rem-newname (and (equal "sudo" (file-remote-p destname 'method))
+                           (file-remote-p destname 'localname)))
+         ;; If default-directory is a remote directory, make sure we find its
+         ;; copy-directory handler.
+         (handler (or (find-file-name-handler directory 'copy-directory)
+                      (find-file-name-handler newname 'copy-directory))))
+    (when (equal (or rem-dirname fromname)
+                 (or rem-newname destname))
+      (error "Can't copy directory `%s' on itself" directory))
     (if handler
 	(funcall handler 'copy-directory directory newname keep-time parents)
 

[-- Attachment #2: Type: application/pgp-signature, Size: 197 bytes --]