Fix some make-directory bugs

* lisp/files.el (files--ensure-directory): New function.
(make-directory): Use it to avoid bugs when (make-directory FOO t)
is invoked on a non-directory, or on a directory hierarchy that
is being built by some other process while Emacs is running.
* test/lisp/files-tests.el (files-tests--make-directory): New test.

diff --git a/lisp/files.el b/lisp/files.el
index 43aec8173d98494e3eb9dd078859161040e735aa..85e649fbb592dd452a1feec99664471016a36f88 100644 (file)
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -5320,6 +5320,14 @@ instance of such commands."
       (rename-buffer (generate-new-buffer-name base-name))
       (force-mode-line-update))))
 
+(defun files--ensure-directory (dir)
+  "Make directory DIR if it is not already a directory.  Return nil."
+  (condition-case err
+      (make-directory-internal dir)
+    (file-already-exists
+     (unless (file-directory-p dir)
+       (signal (car err) (cdr err))))))
+
 (defun make-directory (dir &optional parents)
   "Create the directory DIR and optionally any nonexistent parent dirs.
 If DIR already exists as a directory, signal an error, unless
@@ -5348,18 +5356,19 @@ raised."
       (if (not parents)
          (make-directory-internal dir)
        (let ((dir (directory-file-name (expand-file-name dir)))
-             create-list)
-         (while (and (not (file-exists-p dir))
-                     ;; If directory is its own parent, then we can't
-                     ;; keep looping forever
-                     (not (equal dir
-                                 (directory-file-name
-                                  (file-name-directory dir)))))
+             create-list parent)
+         (while (progn
+                  (setq parent (directory-file-name
+                                (file-name-directory dir)))
+                  (condition-case err
+                      (files--ensure-directory dir)
+                    (file-missing
+                     ;; Do not loop if root does not exist (Bug#2309).
+                     (not (string= dir parent)))))
            (setq create-list (cons dir create-list)
-                 dir (directory-file-name (file-name-directory dir))))
-         (while create-list
-           (make-directory-internal (car create-list))
-           (setq create-list (cdr create-list))))))))
+                 dir parent))
+         (dolist (dir create-list)
+            (files--ensure-directory dir)))))))
 
 (defconst directory-files-no-dot-files-regexp
   "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"

diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index a2f2b74312f6c759a18434a8db0da5c90b0c487b..b52965a02b4119f8d5e531382a6e7f6815204fb8 100644 (file)
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -344,6 +344,27 @@ be invoked with the right arguments."
         (cdr path-res)
         (insert-directory-wildcard-in-dir-p (car path-res)))))))
 
+(ert-deftest files-tests--make-directory ()
+  (let* ((dir (make-temp-file "files-mkdir-test" t))
+        (dirname (file-name-as-directory dir))
+        (file (concat dirname "file"))
+        (subdir1 (concat dirname "subdir1"))
+        (subdir2 (concat dirname "subdir2"))
+        (a/b (concat dirname "a/b")))
+    (write-region "" nil file)
+    (should-error (make-directory "/"))
+    (should-not (make-directory "/" t))
+    (should-error (make-directory dir))
+    (should-not (make-directory dir t))
+    (should-error (make-directory dirname))
+    (should-not (make-directory dirname t))
+    (should-error (make-directory file))
+    (should-error (make-directory file t))
+    (should-not (make-directory subdir1))
+    (should-not (make-directory subdir2 t))
+    (should-error (make-directory a/b))
+    (should-not (make-directory a/b t))))
+
 
 (provide 'files-tests)
 ;;; files-tests.el ends here