diff options
| author | Paul Eggert | 2017-09-17 12:56:00 -0700 |
|---|---|---|
| committer | Paul Eggert | 2017-09-17 13:06:54 -0700 |
| commit | 37b5e661d298cbfe51422cd515b6696a1cdaa868 (patch) | |
| tree | bd37e0f404e7061640f89de39b33968d8df29076 | |
| parent | 6bbbc38b3421723521f7cdd4fd617a4fc889aceb (diff) | |
| download | emacs-37b5e661d298cbfe51422cd515b6696a1cdaa868.tar.gz emacs-37b5e661d298cbfe51422cd515b6696a1cdaa868.zip | |
Fix recently-introduced copy-directory bug
Problem reported by Andrew Christianson (Bug#28451):
* lisp/files.el (copy-directory): If COPY-CONTENTS, make the
destination directory if it does not exist, even if it is a
directory name. Simplify, and omit unnecessary test for an
already-existing non-directory target, since make-directory
diagnoses that for us now.
* test/lisp/files-tests.el (files-tests--copy-directory):
Test for this bug.
| -rw-r--r-- | lisp/files.el | 20 | ||||
| -rw-r--r-- | test/lisp/files-tests.el | 11 |
2 files changed, 20 insertions, 11 deletions
diff --git a/lisp/files.el b/lisp/files.el index c55c8097c16..133fed90c34 100644 --- a/lisp/files.el +++ b/lisp/files.el | |||
| @@ -5372,7 +5372,7 @@ raised." | |||
| 5372 | (while (progn | 5372 | (while (progn |
| 5373 | (setq parent (directory-file-name | 5373 | (setq parent (directory-file-name |
| 5374 | (file-name-directory dir))) | 5374 | (file-name-directory dir))) |
| 5375 | (condition-case err | 5375 | (condition-case () |
| 5376 | (files--ensure-directory dir) | 5376 | (files--ensure-directory dir) |
| 5377 | (file-missing | 5377 | (file-missing |
| 5378 | ;; Do not loop if root does not exist (Bug#2309). | 5378 | ;; Do not loop if root does not exist (Bug#2309). |
| @@ -5544,16 +5544,14 @@ into NEWNAME instead." | |||
| 5544 | ;; If NEWNAME is not a directory name, create it; | 5544 | ;; If NEWNAME is not a directory name, create it; |
| 5545 | ;; that is where we will copy the files of DIRECTORY. | 5545 | ;; that is where we will copy the files of DIRECTORY. |
| 5546 | (make-directory newname parents)) | 5546 | (make-directory newname parents)) |
| 5547 | ;; If NEWNAME is a directory name and COPY-CONTENTS | 5547 | ;; NEWNAME is a directory name. If COPY-CONTENTS is non-nil, |
| 5548 | ;; is nil, copy into NEWNAME/[DIRECTORY-BASENAME]. | 5548 | ;; create NEWNAME if it is not already a directory; |
| 5549 | ((not copy-contents) | 5549 | ;; otherwise, create NEWNAME/[DIRECTORY-BASENAME]. |
| 5550 | (setq newname (concat newname | 5550 | ((if copy-contents |
| 5551 | (file-name-nondirectory directory))) | 5551 | (or parents (not (file-directory-p newname))) |
| 5552 | (and (file-exists-p newname) | 5552 | (setq newname (concat newname |
| 5553 | (not (file-directory-p newname)) | 5553 | (file-name-nondirectory directory)))) |
| 5554 | (error "Cannot overwrite non-directory %s with a directory" | 5554 | (make-directory (directory-file-name newname) parents))) |
| 5555 | newname)) | ||
| 5556 | (make-directory newname t))) | ||
| 5557 | 5555 | ||
| 5558 | ;; Copy recursively. | 5556 | ;; Copy recursively. |
| 5559 | (dolist (file | 5557 | (dolist (file |
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index ef216c3f34a..3117ea697ec 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el | |||
| @@ -393,5 +393,16 @@ name (Bug#28412)." | |||
| 393 | (should (null (save-buffer))) | 393 | (should (null (save-buffer))) |
| 394 | (should (eq (buffer-size) 1)))))) | 394 | (should (eq (buffer-size) 1)))))) |
| 395 | 395 | ||
| 396 | (ert-deftest files-tests--copy-directory () | ||
| 397 | (let* ((dir (make-temp-file "files-mkdir-test" t)) | ||
| 398 | (dirname (file-name-as-directory dir)) | ||
| 399 | (source (concat dirname "source")) | ||
| 400 | (dest (concat dirname "dest/new/directory/")) | ||
| 401 | (file (concat (file-name-as-directory source) "file"))) | ||
| 402 | (make-directory source) | ||
| 403 | (write-region "" nil file) | ||
| 404 | (copy-directory source dest t t t) | ||
| 405 | (should (file-exists-p (concat dest "file"))))) | ||
| 406 | |||
| 396 | (provide 'files-tests) | 407 | (provide 'files-tests) |
| 397 | ;;; files-tests.el ends here | 408 | ;;; files-tests.el ends here |