test/lisp/dired-tests.el

   1 ;;; dired-tests.el --- Test suite. -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2015-2018 Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software: you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  19
  20 ;;; Code:
  21 (require 'ert)
  22 (require 'dired)
  23 (require 'nadvice)
  24
  25 (ert-deftest dired-autoload ()
  26   "Tests to see whether dired-x has been autoloaded"
  27   (should
  28    (fboundp 'dired-jump))
  29   (should
  30    (autoloadp
  31     (symbol-function
  32      'dired-jump))))
  33
  34 (ert-deftest dired-test-bug22694 ()
  35   "Test for https://debbugs.gnu.org/22694 ."
  36   (let* ((dir       (expand-file-name "bug22694" default-directory))
  37          (file      "test")
  38          (full-name (expand-file-name file dir))
  39          (regexp    "bar")
  40          (dired-always-read-filesystem t) buffers)
  41     (if (file-exists-p dir)
  42         (delete-directory dir 'recursive))
  43     (make-directory dir)
  44     (with-temp-file full-name (insert "foo"))
  45     (push (find-file-noselect full-name) buffers)
  46     (push (dired dir) buffers)
  47     (with-temp-file full-name (insert "bar"))
  48     (dired-mark-files-containing-regexp regexp)
  49     (unwind-protect
  50         (should (equal (dired-get-marked-files nil nil nil 'distinguish-1-mark)
  51                        `(t ,full-name)))
  52       ;; Clean up
  53       (dolist (buf buffers)
  54         (when (buffer-live-p buf) (kill-buffer buf)))
  55       (delete-directory dir 'recursive))))
  56
  57 (defvar dired-dwim-target)
  58 (ert-deftest dired-test-bug25609 ()
  59   "Test for https://debbugs.gnu.org/25609 ."
  60   (let* ((from (make-temp-file "foo" 'dir))
  61          ;; Make sure we have long file-names in 'from' and 'to', not
  62          ;; their 8+3 short aliases, because the latter will confuse
  63          ;; Dired commands invoked below.
  64          (from (if (memq system-type '(ms-dos windows-nt))
  65                    (file-truename from)
  66                  from))
  67          (to (make-temp-file "bar" 'dir))
  68          (to (if (memq system-type '(ms-dos windows-nt))
  69                  (file-truename to)
  70                  to))
  71          (target (expand-file-name (file-name-nondirectory from) to))
  72          (nested (expand-file-name (file-name-nondirectory from) target))
  73          (dired-dwim-target t)
  74          (dired-recursive-copies 'always) ; Don't prompt me.
  75          buffers)
  76     (advice-add 'dired-query ; Don't ask confirmation to overwrite a file.
  77                 :override
  78                 (lambda (_sym _prompt &rest _args) (setq dired-query t))
  79                 '((name . "advice-dired-query")))
  80     (advice-add 'completing-read ; Don't prompt me: just return init.
  81                 :override
  82                 (lambda (_prompt _coll &optional _pred _match init _hist _def _inherit _keymap)
  83                   init)
  84                 '((name . "advice-completing-read")))
  85     (delete-other-windows) ; We don't want to display any other dired buffers.
  86     (push (dired to) buffers)
  87     (push (dired-other-window temporary-file-directory) buffers)
  88     (unwind-protect
  89         (let ((ok-fn
  90                (lambda ()
  91                  (let ((win-buffers (mapcar #'window-buffer (window-list))))
  92                    (and (memq (car buffers) win-buffers)
  93                         (memq (cadr buffers) win-buffers))))))
  94           (dired-goto-file from)
  95           ;; Right before `dired-do-copy' call, to reproduce the bug conditions,
  96           ;; ensure we have windows displaying the two dired buffers.
  97           (and (funcall ok-fn) (dired-do-copy))
  98           ;; Call `dired-do-copy' again: this must overwrite `target'; if the bug
  99           ;; still exists, then it creates `nested' instead.
 100           (when (funcall ok-fn)
 101             (dired-do-copy)
 102             (should (file-exists-p target))
 103             (should-not (file-exists-p nested))))
 104       (dolist (buf buffers)
 105         (when (buffer-live-p buf) (kill-buffer buf)))
 106       (delete-directory from 'recursive)
 107       (delete-directory to 'recursive)
 108       (advice-remove 'dired-query "advice-dired-query")
 109       (advice-remove 'completing-read "advice-completing-read"))))
 110
 111 ;; (ert-deftest dired-test-bug27243 ()
 112 ;;   "Test for https://debbugs.gnu.org/27243 ."
 113 ;;   (let ((test-dir (make-temp-file "test-dir-" t))
 114 ;;         (dired-auto-revert-buffer t) buffers)
 115 ;;     (with-current-buffer (find-file-noselect test-dir)
 116 ;;       (make-directory "test-subdir"))
 117 ;;     (push (dired test-dir) buffers)
 118 ;;     (unwind-protect
 119 ;;         (let ((buf (current-buffer))
 120 ;;               (pt1 (point))
 121 ;;               (test-file (concat (file-name-as-directory "test-subdir")
 122 ;;                                  "test-file")))
 123 ;;           (write-region "Test" nil test-file nil 'silent nil 'excl)
 124 ;;           ;; Sanity check: point should now be on the subdirectory.
 125 ;;           (should (equal (dired-file-name-at-point)
 126 ;;                          (concat (file-name-as-directory test-dir)
 127 ;;                                  (file-name-as-directory "test-subdir"))))
 128 ;;           (push (dired-find-file) buffers)
 129 ;;           (let ((pt2 (point)))          ; Point is on test-file.
 130 ;;             (switch-to-buffer buf)
 131 ;;             ;; Sanity check: point should now be back on the subdirectory.
 132 ;;             (should (eq (point) pt1))
 133 ;;             ;; Case 1: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#5
 134 ;;             (push (dired-find-file) buffers)
 135 ;;             (should (eq (point) pt2))
 136 ;;             ;; Case 2: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#28
 137 ;;             (push (dired test-dir) buffers)
 138 ;;             (should (eq (point) pt1))))
 139 ;;       (dolist (buf buffers)
 140 ;;         (when (buffer-live-p buf) (kill-buffer buf)))
 141 ;;       (delete-directory test-dir t))))
 142
 143 (ert-deftest dired-test-bug27243-01 ()
 144   "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#5 ."
 145   (let* ((test-dir (file-name-as-directory (make-temp-file "test-dir-" t)))
 146          (save-pos (lambda ()
 147                      (with-current-buffer (car (dired-buffers-for-dir test-dir))
 148                        (dired-save-positions))))
 149          (dired-auto-revert-buffer t) buffers)
 150     ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the
 151     ;; corresponding long file names exist, otherwise such names trip
 152     ;; dired-buffers-for-dir.
 153     (if (eq system-type 'windows-nt)
 154         (setq test-dir (file-truename test-dir)))
 155     (should-not (dired-buffers-for-dir test-dir))
 156     (with-current-buffer (find-file-noselect test-dir)
 157       (make-directory "test-subdir"))
 158     (message "Saved pos: %S" (funcall save-pos))
 159     ;; Point must be at end-of-buffer.
 160     (with-current-buffer (car (dired-buffers-for-dir test-dir))
 161       (should (eobp)))
 162     (push (dired test-dir) buffers)
 163     (message "Saved pos: %S" (funcall save-pos))
 164     ;; Previous dired call shouldn't create a new buffer: must visit the one
 165     ;; created by `find-file-noselect' above.
 166     (should (eq 1 (length (dired-buffers-for-dir test-dir))))
 167     (unwind-protect
 168         (let ((buf (current-buffer))
 169               (pt1 (point))
 170               (test-file (concat (file-name-as-directory "test-subdir")
 171                                  "test-file")))
 172           (message "Saved pos: %S" (funcall save-pos))
 173           (write-region "Test" nil test-file nil 'silent nil 'excl)
 174           (message "Saved pos: %S" (funcall save-pos))
 175           ;; Sanity check: point should now be on the subdirectory.
 176           (should (equal (dired-file-name-at-point)
 177                          (concat test-dir (file-name-as-directory "test-subdir"))))
 178           (message "Saved pos: %S" (funcall save-pos))
 179           (push (dired-find-file) buffers)
 180           (let ((pt2 (point)))          ; Point is on test-file.
 181             (pop-to-buffer-same-window buf)
 182             ;; Sanity check: point should now be back on the subdirectory.
 183             (should (eq (point) pt1))
 184             (push (dired-find-file) buffers)
 185             (should (eq (point) pt2))))
 186       (dolist (buf buffers)
 187         (when (buffer-live-p buf) (kill-buffer buf)))
 188       (delete-directory test-dir t))))
 189
 190 (ert-deftest dired-test-bug27243-02 ()
 191   "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#28 ."
 192   (let ((test-dir (make-temp-file "test-dir-" t))
 193         (dired-auto-revert-buffer t) buffers)
 194     ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the
 195     ;; corresponding long file names exist, otherwise such names trip
 196     ;; string comparisons below.
 197     (if (eq system-type 'windows-nt)
 198         (setq test-dir (file-truename test-dir)))
 199     (with-current-buffer (find-file-noselect test-dir)
 200       (make-directory "test-subdir"))
 201     (push (dired test-dir) buffers)
 202     (unwind-protect
 203         (let ((buf (current-buffer))
 204               (pt1 (point))
 205               (test-file (concat (file-name-as-directory "test-subdir")
 206                                  "test-file")))
 207           (write-region "Test" nil test-file nil 'silent nil 'excl)
 208           ;; Sanity check: point should now be on the subdirectory.
 209           (should (equal (dired-file-name-at-point)
 210                          (concat (file-name-as-directory test-dir)
 211                                  (file-name-as-directory "test-subdir"))))
 212           (push (dired-find-file) buffers)
 213           (let ((pt2 (point)))          ; Point is on test-file.
 214             (switch-to-buffer buf)
 215             ;; Sanity check: point should now be back on the subdirectory.
 216             (should (eq (point) pt1))
 217             (push (dired test-dir) buffers)
 218             (should (eq (point) pt1))))
 219       (dolist (buf buffers)
 220         (when (buffer-live-p buf) (kill-buffer buf)))
 221       (delete-directory test-dir t))))
 222
 223 (ert-deftest dired-test-bug27243-03 ()
 224   "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#61 ."
 225   (let ((test-dir (make-temp-file "test-dir-" t))
 226         (dired-auto-revert-buffer t)
 227         test-subdir1 test-subdir2 allbufs)
 228     (unwind-protect
 229         (progn
 230           (with-current-buffer (find-file-noselect test-dir)
 231             (push (current-buffer) allbufs)
 232             (make-directory "test-subdir1")
 233             (make-directory "test-subdir2")
 234             (let ((test-file1 "test-file1")
 235                   (test-file2 "test-file2"))
 236               (with-current-buffer (find-file-noselect "test-subdir1")
 237                 (push (current-buffer) allbufs)
 238                 (write-region "Test1" nil test-file1 nil 'silent nil 'excl))
 239               (with-current-buffer (find-file-noselect "test-subdir2")
 240                 (push (current-buffer) allbufs)
 241                 (write-region "Test2" nil test-file2 nil 'silent nil 'excl))))
 242           ;; Call find-file with a wild card and test point in each file.
 243           (let ((buffers (find-file (concat (file-name-as-directory test-dir)
 244                                             "*")
 245                                     t)))
 246             (dolist (buf buffers)
 247               (let ((pt (with-current-buffer buf (point))))
 248                 (switch-to-buffer (find-file-noselect test-dir))
 249                 (find-file (buffer-name buf))
 250                 (should (equal (point) pt))))
 251             (append buffers allbufs)))
 252       (dolist (buf allbufs)
 253         (when (buffer-live-p buf) (kill-buffer buf)))
 254       (delete-directory test-dir t))))
 255
 256 (ert-deftest dired-test-bug7131 ()
 257   "Test for https://debbugs.gnu.org/7131 ."
 258   (let* ((dir (expand-file-name "lisp" source-directory))
 259          (buf (dired dir)))
 260     (unwind-protect
 261         (progn
 262           (setq buf (dired (list dir "simple.el")))
 263           (dired-toggle-marks)
 264           (should-not (cdr (dired-get-marked-files)))
 265           (kill-buffer buf)
 266           (setq buf (dired (list dir "simple.el"))
 267                 buf (dired dir))
 268           (dired-toggle-marks)
 269           (should (cdr (dired-get-marked-files))))
 270       (when (buffer-live-p buf) (kill-buffer buf)))))
 271
 272 (ert-deftest dired-test-bug27631 ()
 273   "Test for https://debbugs.gnu.org/27631 ."
 274   ;; For dired using 'ls' emulation we test for this bug in
 275   ;; ls-lisp-tests.el and em-ls-tests.el.
 276   (skip-unless (and (not (featurep 'ls-lisp))
 277                     (not (featurep 'eshell))))
 278   (let* ((dir (make-temp-file "bug27631" 'dir))
 279          (dir1 (expand-file-name "dir1" dir))
 280          (dir2 (expand-file-name "dir2" dir))
 281          (default-directory dir)
 282          buf)
 283     (unwind-protect
 284         (progn
 285           (make-directory dir1)
 286           (make-directory dir2)
 287           (with-temp-file (expand-file-name "a.txt" dir1))
 288           (with-temp-file (expand-file-name "b.txt" dir2))
 289           (setq buf (dired (expand-file-name "dir*/*.txt" dir)))
 290           (dired-toggle-marks)
 291           (should (cdr (dired-get-marked-files))))
 292       (delete-directory dir 'recursive)
 293       (when (buffer-live-p buf) (kill-buffer buf)))))
 294
 295 (ert-deftest dired-test-bug27899 ()
 296   "Test for https://debbugs.gnu.org/27899 ."
 297   (let* ((dir (expand-file-name "src" source-directory))
 298          (buf (dired (list dir "cygw32.c" "alloc.c" "w32xfns.c" "xdisp.c")))
 299          (orig dired-hide-details-mode))
 300     (dired-goto-file (expand-file-name "cygw32.c"))
 301     (forward-line 0)
 302     (unwind-protect
 303         (progn
 304           (let ((inhibit-read-only t))
 305             (dired-align-file (point) (point-max)))
 306           (dired-hide-details-mode t)
 307           (dired-move-to-filename)
 308           (should (eq 2 (current-column))))
 309       (dired-hide-details-mode orig))))
 310
 311 (ert-deftest dired-test-bug27968 ()
 312   "Test for https://debbugs.gnu.org/27968 ."
 313   (let* ((top-dir (make-temp-file "top-dir" t))
 314          (subdir (expand-file-name "subdir" top-dir))
 315          (header-len-fn (lambda ()
 316                           (save-excursion
 317                             (goto-char 1)
 318                             (forward-line 1)
 319                             (- (point-at-eol) (point)))))
 320          orig-len len diff pos line-nb)
 321     (make-directory subdir 'parents)
 322     (unwind-protect
 323         (with-current-buffer (dired-noselect subdir)
 324           (setq orig-len (funcall header-len-fn)
 325                 pos (point)
 326                 line-nb (line-number-at-pos))
 327           ;; Bug arises when the header line changes its length; this may
 328           ;; happen if the used space has changed: for instance, with the
 329           ;; creation of additional files.
 330           (make-directory "subdir" t)
 331           (dired-revert)
 332           ;; Change the header line.
 333           (save-excursion
 334             (goto-char 1)
 335             (forward-line 1)
 336             (let ((inhibit-read-only t)
 337                   (new-header "  test-bug27968"))
 338               (delete-region (point) (point-at-eol))
 339               (when (= orig-len (length new-header))
 340                 ;; Wow lucky guy! I must buy lottery today.
 341                 (setq new-header (concat new-header " :-)")))
 342               (insert new-header)))
 343           (setq len (funcall header-len-fn)
 344                 diff (- len orig-len))
 345           (should-not (zerop diff)) ; Header length has changed.
 346           ;; If diff > 0, then the point moves back.
 347           ;; If diff < 0, then the point moves forward.
 348           ;; If diff = 0, then the point doesn't move.
 349           ;; Sometimes this point movement causes
 350           ;; line-nb != (line-number-at-pos pos), so that we get
 351           ;; an unexpected file at point if we store buffer points.
 352           ;; Note that the line number before/after revert
 353           ;; doesn't change.
 354           (should (= line-nb
 355                      (line-number-at-pos)
 356                      (line-number-at-pos (+ pos diff))))
 357           ;; After revert, the point must be in 'subdir' line.
 358           (should (equal "subdir" (dired-get-filename 'local t))))
 359       (delete-directory top-dir t))))
 360
 361
 362 (defmacro dired-test-with-temp-dirs (just-empty-dirs &rest body)
 363   "Helper macro for Bug#27940 test."
 364   (declare (indent 1) (debug body))
 365   (let ((dir (make-symbol "dir"))
 366         (ignore-funcs (make-symbol "ignore-funcs")))
 367     `(let* ((,dir (make-temp-file "bug27940" t))
 368             (dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts.
 369             (inhibit-message t)
 370             (default-directory ,dir))
 371        (dotimes (i 5) (make-directory (format "empty-dir-%d" i)))
 372        (unless ,just-empty-dirs
 373          (dotimes (i 5) (make-directory (format "non-empty-%d/foo" i) 'parents)))
 374        (make-directory "zeta-empty-dir")
 375        (unwind-protect
 376            (progn
 377              ,@body)
 378          (delete-directory ,dir t)
 379          (kill-buffer (current-buffer))))))
 380
 381 (ert-deftest dired-test-bug27940 ()
 382   "Test for https://debbugs.gnu.org/27940 ."
 383   ;; If just empty dirs we shouldn't be prompted.
 384   (dired-test-with-temp-dirs
 385    'just-empty-dirs
 386    (let (asked)
 387      (advice-add 'read-answer
 388                  :override
 389                  (lambda (_q _a) (setq asked t) "")
 390                  '((name . dired-test-bug27940-advice)))
 391      (dired default-directory)
 392      (dired-toggle-marks)
 393      (dired-do-delete nil)
 394      (unwind-protect
 395          (progn
 396            (should-not asked)
 397            (should-not (dired-get-marked-files))) ; All dirs deleted.
 398        (advice-remove 'read-answer 'dired-test-bug27940-advice))))
 399   ;; Answer yes
 400   (dired-test-with-temp-dirs
 401    nil
 402    (advice-add 'read-answer :override (lambda (_q _a) "yes")
 403                '((name . dired-test-bug27940-advice)))
 404    (dired default-directory)
 405    (dired-toggle-marks)
 406    (dired-do-delete nil)
 407    (unwind-protect
 408        (should-not (dired-get-marked-files)) ; All dirs deleted.
 409      (advice-remove 'read-answer 'dired-test-bug27940-advice)))
 410   ;; Answer no
 411   (dired-test-with-temp-dirs
 412    nil
 413    (advice-add 'read-answer :override (lambda (_q _a) "no")
 414                '((name . dired-test-bug27940-advice)))
 415    (dired default-directory)
 416    (dired-toggle-marks)
 417    (dired-do-delete nil)
 418    (unwind-protect
 419        (should (= 5 (length (dired-get-marked-files)))) ; Just the empty dirs deleted.
 420      (advice-remove 'read-answer 'dired-test-bug27940-advice)))
 421   ;; Answer all
 422   (dired-test-with-temp-dirs
 423    nil
 424    (advice-add 'read-answer :override (lambda (_q _a) "all")
 425                '((name . dired-test-bug27940-advice)))
 426    (dired default-directory)
 427    (dired-toggle-marks)
 428    (dired-do-delete nil)
 429    (unwind-protect
 430        (should-not (dired-get-marked-files)) ; All dirs deleted.
 431      (advice-remove 'read-answer 'dired-test-bug27940-advice)))
 432   ;; Answer quit
 433   (dired-test-with-temp-dirs
 434    nil
 435    (advice-add 'read-answer :override (lambda (_q _a) "quit")
 436                '((name . dired-test-bug27940-advice)))
 437    (dired default-directory)
 438    (dired-toggle-marks)
 439    (let ((inhibit-message t))
 440      (dired-do-delete nil))
 441    (unwind-protect
 442        (should (= 6 (length (dired-get-marked-files)))) ; All empty dirs but zeta-empty-dir deleted.
 443      (advice-remove 'read-answer 'dired-test-bug27940-advice))))
 444
 445
 446 (provide 'dired-tests)
 447 ;; dired-tests.el ends here