diff options
Diffstat (limited to 'test/lisp')
| -rw-r--r-- | test/lisp/auth-source-tests.el | 20 | ||||
| -rw-r--r-- | test/lisp/calendar/todo-mode-tests.el | 190 | ||||
| -rw-r--r-- | test/lisp/custom-tests.el | 87 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/backtrace-tests.el | 436 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/cl-print-tests.el | 178 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el | 9 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/edebug-tests.el | 29 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/ert-tests.el | 2 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/lisp-mode-tests.el | 23 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/package-tests.el | 31 | ||||
| -rw-r--r-- | test/lisp/emacs-lisp/subr-x-tests.el | 47 | ||||
| -rw-r--r-- | test/lisp/epg-tests.el | 38 | ||||
| -rw-r--r-- | test/lisp/filenotify-tests.el | 4 | ||||
| -rw-r--r-- | test/lisp/net/secrets-tests.el | 6 | ||||
| -rw-r--r-- | test/lisp/net/tramp-archive-tests.el | 18 | ||||
| -rw-r--r-- | test/lisp/net/tramp-tests.el | 102 | ||||
| -rw-r--r-- | test/lisp/progmodes/compile-tests.el | 46 | ||||
| -rw-r--r-- | test/lisp/shadowfile-tests.el | 945 | ||||
| -rw-r--r-- | test/lisp/wdired-tests.el | 129 |
19 files changed, 2248 insertions, 92 deletions
diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el index be516f2c40d..ca8a3eb78f0 100644 --- a/test/lisp/auth-source-tests.el +++ b/test/lisp/auth-source-tests.el @@ -344,5 +344,25 @@ "session" (format "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host))))) +(ert-deftest auth-source-delete () + (let* ((netrc-file (make-temp-file "auth-source-test" nil nil "\ +machine a1 port a2 user a3 password a4 +machine b1 port b2 user b3 password b4 +machine c1 port c2 user c3 password c4\n")) + (auth-sources (list netrc-file)) + (auth-source-do-cache nil) + (expected '((:host "a1" :port "a2" :user "a3" :secret "a4"))) + (parameters '(:max 1 :host t))) + (unwind-protect + (let ((found (apply #'auth-source-delete parameters))) + (dolist (f found) + (let ((s (plist-get f :secret))) + (setf f (plist-put f :secret + (if (functionp s) (funcall s) s))))) + ;; Note: The netrc backend doesn't delete anything, so + ;; this is actually the same as `auth-source-search'. + (should (equal found expected))) + (delete-file netrc-file)))) + (provide 'auth-source-tests) ;;; auth-source-tests.el ends here diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el index 159294f8162..325faeff514 100644 --- a/test/lisp/calendar/todo-mode-tests.el +++ b/test/lisp/calendar/todo-mode-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'todo-mode) (defvar todo-test-data-dir @@ -561,11 +562,12 @@ source file is different." ;; Headers in the todo file are still hidden. (should (equal (overlay-get (todo-get-overlay 'header) 'display) ""))))) -(defun todo-test--insert-item (item &optional priority) +(defun todo-test--insert-item (item &optional priority + _arg diary-type date-type time where) "Insert string ITEM into current category with priority PRIORITY. -Use defaults for all other item insertion parameters. This -provides a noninteractive API for todo-insert-item for use in -automatic testing." +The remaining arguments (except _ARG, which is ignored) specify +item insertion parameters. This provides a noninteractive API +for todo-insert-item for use in automatic testing." (cl-letf (((symbol-function 'read-from-minibuffer) (lambda (_prompt) item)) ((symbol-function 'read-number) ; For todo-set-item-priority @@ -581,6 +583,186 @@ automatic testing." (todo-test--insert-item item 1) (should (equal (overlay-get (todo-get-overlay 'header) 'display) ""))))) +(defun todo-test--done-items-separator (&optional eol) + "Set up test of command interaction with done items separator. +With non-nil argument EOL, return the position at the end of the +separator, otherwise, return the position at the beginning." + (todo-test--show 1) + (goto-char (point-max)) + ;; See comment about recentering in todo-test-raise-lower-priority. + (set-window-buffer nil (current-buffer)) + (todo-toggle-view-done-items) + ;; FIXME: Point should now be on the first done item, and in batch + ;; testing it is, so we have to move back one line to the done items + ;; separator; but for some reason, in the graphical test + ;; environment, it stays on the last empty line of the todo items + ;; section, so there we have to advance one character to the done + ;; items separator. + (if (display-graphic-p) + (forward-char) + (forward-line -1)) + (if eol (forward-char))) + +(ert-deftest todo-test-done-items-separator01-bol () + "Test item copying and here insertion at BOL of separator. +Both should be user errors." + (with-todo-test + (todo-test--done-items-separator) + (let* ((copy-err "Item copying is not valid here") + (here-err "Item insertion is not valid here") + (insert-item-test (lambda (where) + (should-error (todo-insert-item--basic + nil nil nil nil where))))) + (should (string= copy-err (cadr (funcall insert-item-test 'copy)))) + (should (string= here-err (cadr (funcall insert-item-test 'here))))))) + +(ert-deftest todo-test-done-items-separator01-eol () + "Test item copying and here insertion at EOL of separator. +Both should be user errors." + (with-todo-test + (todo-test--done-items-separator 'eol) + (let* ((copy-err "Item copying is not valid here") + (here-err "Item insertion is not valid here") + (insert-item-test (lambda (where) + (should-error (todo-insert-item--basic + nil nil nil nil where))))) + (should (string= copy-err (cadr (funcall insert-item-test 'copy)))) + (should (string= here-err (cadr (funcall insert-item-test 'here))))))) + +(ert-deftest todo-test-done-items-separator02-bol () + "Test item editing commands at BOL of done items separator. +They should all be noops." + (with-todo-test + (todo-test--done-items-separator) + (should-not (todo-item-done)) + (should-not (todo-raise-item-priority)) + (should-not (todo-lower-item-priority)) + (should-not (called-interactively-p #'todo-set-item-priority)) + (should-not (called-interactively-p #'todo-move-item)) + (should-not (called-interactively-p #'todo-delete-item)) + (should-not (called-interactively-p #'todo-edit-item)))) + +(ert-deftest todo-test-done-items-separator02-eol () + "Test item editing command at EOL of done items separator. +They should all be noops." + (with-todo-test + (todo-test--done-items-separator 'eol) + (should-not (todo-item-done)) + (should-not (todo-raise-item-priority)) + (should-not (todo-lower-item-priority)) + (should-not (called-interactively-p #'todo-set-item-priority)) + (should-not (called-interactively-p #'todo-move-item)) + (should-not (called-interactively-p #'todo-delete-item)) + (should-not (called-interactively-p #'todo-edit-item)))) + +(ert-deftest todo-test-done-items-separator03-bol () + "Test item marking at BOL of done items separator. +This should be a noop, adding no marks to the category." + (with-todo-test + (todo-test--done-items-separator) + (call-interactively #'todo-toggle-mark-item) + (should-not (assoc (todo-current-category) todo-categories-with-marks)))) + +(ert-deftest todo-test-done-items-separator03-eol () + "Test item marking at EOL of done items separator. +This should be a noop, adding no marks to the category." + (with-todo-test + (todo-test--done-items-separator 'eol) + (call-interactively #'todo-toggle-mark-item) + (should-not (assoc (todo-current-category) todo-categories-with-marks)))) + +(ert-deftest todo-test-done-items-separator04-bol () + "Test moving to previous item from BOL of done items separator. +This should move point to the last not done todo item." + (with-todo-test + (todo-test--done-items-separator) + (let ((last-item (save-excursion + ;; Move to empty line after last todo item. + (forward-line -1) + (todo-previous-item) + (todo-item-string)))) + (should (string= last-item (save-excursion + (todo-previous-item) + (todo-item-string))))))) + +(ert-deftest todo-test-done-items-separator04-eol () + "Test moving to previous item from EOL of done items separator. +This should move point to the last not done todo item." + (with-todo-test + (todo-test--done-items-separator 'eol) + (let ((last-item (save-excursion + ;; Move to empty line after last todo item. + (forward-line -1) + (todo-previous-item) + (todo-item-string)))) + (should (string= last-item (save-excursion + (todo-previous-item) + (todo-item-string))))))) + +(ert-deftest todo-test-done-items-separator05-bol () + "Test moving to next item from BOL of done items separator. +This should move point to the first done todo item." + (with-todo-test + (todo-test--done-items-separator) + (let ((first-done (save-excursion + ;; Move to empty line after last todo item. + (forward-line -1) + (todo-next-item) + (todo-item-string)))) + (should (string= first-done (save-excursion + (todo-next-item) + (todo-item-string))))))) + +(ert-deftest todo-test-done-items-separator05-eol () + "Test moving to next item from EOL of done items separator. +This should move point to the first done todo item." + (with-todo-test + (todo-test--done-items-separator 'eol) + (let ((first-done (save-excursion + ;; Move to empty line after last todo item. + (forward-line -1) + (todo-next-item) + (todo-item-string)))) + (should (string= first-done (save-excursion + (todo-next-item) + (todo-item-string))))))) + +;; Item highlighting uses hl-line-mode, which enables highlighting in +;; post-command-hook. For some reason, in the test environment, the +;; hook function is not automatically run, so after enabling item +;; highlighting, use ert-simulate-command around the next command, +;; which explicitly runs the hook function. +(ert-deftest todo-test-done-items-separator06-bol () + "Test enabling item highlighting at BOL of done items separator. +Subsequently moving to an item should show it highlighted." + (with-todo-test + (todo-test--done-items-separator) + (call-interactively #'todo-toggle-item-highlighting) + (ert-simulate-command '(todo-previous-item)) + (should (eq 'hl-line (get-char-property (point) 'face))))) + +(ert-deftest todo-test-done-items-separator06-eol () + "Test enabling item highlighting at EOL of done items separator. +Subsequently moving to an item should show it highlighted." + (with-todo-test + (todo-test--done-items-separator 'eol) + (todo-toggle-item-highlighting) + (forward-line -1) + (ert-simulate-command '(todo-previous-item)) + (should (eq 'hl-line (get-char-property (point) 'face))))) + +(ert-deftest todo-test-done-items-separator07 () + "Test item highlighting when crossing done items separator. +The highlighting should remain enabled." + (with-todo-test + (todo-test--done-items-separator) + (todo-previous-item) + (todo-toggle-item-highlighting) + (todo-next-item) ; Now on empty line above separator. + (forward-line) ; Now on separator. + (ert-simulate-command '(forward-line)) ; Now on first done item. + (should (eq 'hl-line (get-char-property (point) 'face))))) + (provide 'todo-mode-tests) ;;; todo-mode-tests.el ends here diff --git a/test/lisp/custom-tests.el b/test/lisp/custom-tests.el new file mode 100644 index 00000000000..96887f8f5fe --- /dev/null +++ b/test/lisp/custom-tests.el @@ -0,0 +1,87 @@ +;;; custom-tests.el --- tests for custom.el -*- lexical-binding: t -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) + +(ert-deftest custom-theme--load-path () + "Test `custom-theme--load-path' behavior." + (let ((tmpdir (file-name-as-directory (make-temp-file "custom-tests-" t)))) + (unwind-protect + ;; Create all temporary files under the same deletable parent. + (let ((temporary-file-directory tmpdir)) + ;; Path is empty. + (let ((custom-theme-load-path ())) + (should (null (custom-theme--load-path)))) + + ;; Path comprises non-existent file. + (let* ((name (make-temp-name tmpdir)) + (custom-theme-load-path (list name))) + (should (not (file-exists-p name))) + (should (null (custom-theme--load-path)))) + + ;; Path comprises existing file. + (let* ((file (make-temp-file "file")) + (custom-theme-load-path (list file))) + (should (file-exists-p file)) + (should (not (file-directory-p file))) + (should (null (custom-theme--load-path)))) + + ;; Path comprises existing directory. + (let* ((dir (make-temp-file "dir" t)) + (custom-theme-load-path (list dir))) + (should (file-directory-p dir)) + (should (equal (custom-theme--load-path) custom-theme-load-path))) + + ;; Expand `custom-theme-directory' path element. + (let ((custom-theme-load-path '(custom-theme-directory))) + (let ((custom-theme-directory (make-temp-name tmpdir))) + (should (not (file-exists-p custom-theme-directory))) + (should (null (custom-theme--load-path)))) + (let ((custom-theme-directory (make-temp-file "file"))) + (should (file-exists-p custom-theme-directory)) + (should (not (file-directory-p custom-theme-directory))) + (should (null (custom-theme--load-path)))) + (let ((custom-theme-directory (make-temp-file "dir" t))) + (should (file-directory-p custom-theme-directory)) + (should (equal (custom-theme--load-path) + (list custom-theme-directory))))) + + ;; Expand t path element. + (let ((custom-theme-load-path '(t))) + (let ((data-directory (make-temp-name tmpdir))) + (should (not (file-exists-p data-directory))) + (should (null (custom-theme--load-path)))) + (let ((data-directory tmpdir) + (themedir (expand-file-name "themes" tmpdir))) + (should (not (file-exists-p themedir))) + (should (null (custom-theme--load-path))) + (with-temp-file themedir) + (should (file-exists-p themedir)) + (should (not (file-directory-p themedir))) + (should (null (custom-theme--load-path))) + (delete-file themedir) + (make-directory themedir) + (should (file-directory-p themedir)) + (should (equal (custom-theme--load-path) (list themedir)))))) + (when (file-directory-p tmpdir) + (delete-directory tmpdir t))))) + +;;; custom-tests.el ends here diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el new file mode 100644 index 00000000000..edd45c770c5 --- /dev/null +++ b/test/lisp/emacs-lisp/backtrace-tests.el @@ -0,0 +1,436 @@ +;;; backtrace-tests.el --- Tests for backtraces -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Gemini Lasswell + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'backtrace) +(require 'ert) +(require 'ert-x) +(require 'seq) + +;; Delay evaluation of the backtrace-creating functions until +;; load so that the backtraces are the same whether this file +;; is compiled or not. + +(eval-and-compile + (defconst backtrace-tests--uncompiled-functions + '(progn + (defun backtrace-tests--make-backtrace (arg) + (backtrace-tests--setup-buffer)) + + (defun backtrace-tests--setup-buffer () + "Set up the current buffer in backtrace mode." + (backtrace-mode) + (setq backtrace-frames (backtrace-get-frames)) + (let ((this-index)) + ;; Discard all past `backtrace-tests-make-backtrace'. + (dotimes (index (length backtrace-frames)) + (when (eq (backtrace-frame-fun (nth index backtrace-frames)) + 'backtrace-tests--make-backtrace) + (setq this-index index))) + (setq backtrace-frames (seq-subseq backtrace-frames 0 (1+ this-index)))) + (backtrace-print)))) + + (eval backtrace-tests--uncompiled-functions)) + +(defun backtrace-tests--backtrace-lines () + (if debugger-stack-frame-as-list + '(" (backtrace-get-frames)\n" + " (setq backtrace-frames (backtrace-get-frames))\n" + " (backtrace-tests--setup-buffer)\n" + " (backtrace-tests--make-backtrace %s)\n") + '(" backtrace-get-frames()\n" + " (setq backtrace-frames (backtrace-get-frames))\n" + " backtrace-tests--setup-buffer()\n" + " backtrace-tests--make-backtrace(%s)\n"))) + +(defconst backtrace-tests--line-count (length (backtrace-tests--backtrace-lines))) + +(defun backtrace-tests--backtrace-lines-with-locals () + (let ((lines (backtrace-tests--backtrace-lines)) + (locals '(" [no locals]\n" + " [no locals]\n" + " [no locals]\n" + " arg = %s\n"))) + (apply #'append (cl-mapcar #'list lines locals)))) + +(defun backtrace-tests--result (value) + (format (apply #'concat (backtrace-tests--backtrace-lines)) + (cl-prin1-to-string value))) + +(defun backtrace-tests--result-with-locals (value) + (let ((str (cl-prin1-to-string value))) + (format (apply #'concat (backtrace-tests--backtrace-lines-with-locals)) + str str))) + +;; TODO check that debugger-batch-max-lines still works + +(defconst backtrace-tests--header "Test header\n") +(defun backtrace-tests--insert-header () + (insert backtrace-tests--header)) + +;;; Tests + +(ert-deftest backtrace-tests--variables () + "Backtrace buffers can show and hide local variables." + (ert-with-test-buffer (:name "variables") + (let ((results (concat backtrace-tests--header + (backtrace-tests--result 'value))) + (last-frame (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) 'value)) + (last-frame-with-locals + (format (apply #'concat (nthcdr (* 2 (1- backtrace-tests--line-count)) + (backtrace-tests--backtrace-lines-with-locals))) + 'value 'value))) + (backtrace-tests--make-backtrace 'value) + (setq backtrace-insert-header-function #'backtrace-tests--insert-header) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Go to the last frame. + (goto-char (point-max)) + (forward-line -1) + ;; Turn on locals for that frame. + (backtrace-toggle-locals) + (should (string= (backtrace-tests--get-substring (point) (point-max)) + last-frame-with-locals)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + (concat results + (format (car (last (backtrace-tests--backtrace-lines-with-locals))) + 'value)))) + ;; Turn off locals for that frame. + (backtrace-toggle-locals) + (should (string= (backtrace-tests--get-substring (point) (point-max)) + last-frame)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Turn all locals on. + (backtrace-toggle-locals '(4)) + (should (string= (backtrace-tests--get-substring (point) (point-max)) + last-frame-with-locals)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + (concat backtrace-tests--header + (backtrace-tests--result-with-locals 'value)))) + ;; Turn all locals off. + (backtrace-toggle-locals '(4)) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length last-frame))) + last-frame)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results))))) + +(ert-deftest backtrace-tests--backward-frame () + "`backtrace-backward-frame' moves backward to the start of a frame." + (ert-with-test-buffer (:name "backward") + (let ((results (concat backtrace-tests--header + (backtrace-tests--result nil)))) + (backtrace-tests--make-backtrace nil) + (setq backtrace-insert-header-function #'backtrace-tests--insert-header) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + + ;; Try to move backward from header. + (goto-char (+ (point-min) (/ (length backtrace-tests--header) 2))) + (let ((pos (point))) + (should-error (backtrace-backward-frame)) + (should (= pos (point)))) + + ;; Try to move backward from start of first line. + (forward-line) + (let ((pos (point))) + (should-error (backtrace-backward-frame)) + (should (= pos (point)))) + + ;; Move backward from middle of line. + (let ((start (point))) + (forward-char (/ (length (nth 0 (backtrace-tests--backtrace-lines))) 2)) + (backtrace-backward-frame) + (should (= start (point)))) + + ;; Move backward from end of buffer. + (goto-char (point-max)) + (backtrace-backward-frame) + (let* ((last (format (car (last (backtrace-tests--backtrace-lines))) nil)) + (len (length last))) + (should (string= (buffer-substring-no-properties (point) (+ (point) len)) + last))) + + ;; Move backward from start of line. + (backtrace-backward-frame) + (let* ((line (car (last (backtrace-tests--backtrace-lines) 2))) + (len (length line))) + (should (string= (buffer-substring-no-properties (point) (+ (point) len)) + line)))))) + +(ert-deftest backtrace-tests--forward-frame () + "`backtrace-forward-frame' moves forward to the start of a frame." + (ert-with-test-buffer (:name "forward") + (let* ((arg '(1 2 3)) + (results (concat backtrace-tests--header + (backtrace-tests--result arg))) + (first-line (nth 0 (backtrace-tests--backtrace-lines)))) + (backtrace-tests--make-backtrace arg) + (setq backtrace-insert-header-function #'backtrace-tests--insert-header) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Move forward from header. + (goto-char (+ (point-min) (/ (length backtrace-tests--header) 2))) + (backtrace-forward-frame) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length first-line))) + first-line)) + + (let ((start (point)) + (offset (/ (length first-line) 2)) + (second-line (nth 1 (backtrace-tests--backtrace-lines)))) + ;; Move forward from start of first frame. + (backtrace-forward-frame) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length second-line))) + second-line)) + ;; Move forward from middle of first frame. + (goto-char (+ start offset)) + (backtrace-forward-frame) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length second-line))) + second-line))) + ;; Try to move forward from middle of last frame. + (goto-char (- (point-max) + (/ 2 (length (car (last (backtrace-tests--backtrace-lines))))))) + (should-error (backtrace-forward-frame)) + ;; Try to move forward from end of buffer. + (goto-char (point-max)) + (should-error (backtrace-forward-frame))))) + +(ert-deftest backtrace-tests--single-and-multi-line () + "Forms in backtrace frames can be on a single line or on multiple lines." + (ert-with-test-buffer (:name "single-multi-line") + (let* ((arg '(lambda (x) ; Quote this so it isn't made into a closure. + (let ((number (1+ x))) + (+ x number)))) + (header-string "Test header: ") + (header (format "%s%s\n" header-string arg)) + (insert-header-function (lambda () + (insert header-string) + (insert (backtrace-print-to-string arg)) + (insert "\n"))) + (results (concat header (backtrace-tests--result arg))) + (last-line (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg)) + (last-line-locals (format (nth (1- (* 2 backtrace-tests--line-count)) + (backtrace-tests--backtrace-lines-with-locals)) + arg))) + + (backtrace-tests--make-backtrace arg) + (setq backtrace-insert-header-function insert-header-function) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Check pp and collapse for the form in the header. + (goto-char (point-min)) + (backtrace-tests--verify-single-and-multi-line header) + ;; Check pp and collapse for the last frame. + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-tests--verify-single-and-multi-line last-line) + ;; Check pp and collapse for local variables in the last line. + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-toggle-locals) + (forward-line) + (backtrace-tests--verify-single-and-multi-line last-line-locals)))) + +(defun backtrace-tests--verify-single-and-multi-line (line) + "Verify that `backtrace-single-line' and `backtrace-multi-line' work at point. +Point should be at the beginning of a line, and LINE should be a +string containing the text of the line at point. Assume that the +line contains the strings \"lambda\" and \"number\"." + (let ((pos (point))) + (backtrace-multi-line) + ;; Verify point is still at the start of the line. + (should (= pos (point)))) + + ;; Verify the form now spans multiple lines. + (let ((pos (point))) + (search-forward "number") + (should-not (= pos (point-at-bol)))) + ;; Collapse the form. + (backtrace-single-line) + ;; Verify that the form is now back on one line, + ;; and that point is at the same place. + (should (string= (backtrace-tests--get-substring + (- (point) 6) (point)) "number")) + (should-not (= (point) (point-at-bol))) + (should (string= (backtrace-tests--get-substring + (point-at-bol) (1+ (point-at-eol))) + line))) + +(ert-deftest backtrace-tests--print-circle () + "Backtrace buffers can toggle `print-circle' syntax." + (ert-with-test-buffer (:name "print-circle") + (let* ((print-circle nil) + (arg (let ((val (make-list 5 'a))) (nconc val val) val)) + (results (backtrace-tests--make-regexp + (backtrace-tests--result arg))) + (results-circle (regexp-quote (let ((print-circle t)) + (backtrace-tests--result arg)))) + (last-frame (backtrace-tests--make-regexp + (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg))) + (last-frame-circle (regexp-quote + (let ((print-circle t)) + (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg))))) + (backtrace-tests--make-backtrace arg) + (backtrace-print) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Go to the last frame. + (goto-char (point-max)) + (forward-line -1) + ;; Turn on print-circle for that frame. + (backtrace-toggle-print-circle) + (should (string-match-p last-frame-circle + (backtrace-tests--get-substring (point) (point-max)))) + ;; Turn off print-circle for the frame. + (backtrace-toggle-print-circle) + (should (string-match-p last-frame + (backtrace-tests--get-substring (point) (point-max)))) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Turn print-circle on for the buffer. + (backtrace-toggle-print-circle '(4)) + (should (string-match-p last-frame-circle + (backtrace-tests--get-substring (point) (point-max)))) + (should (string-match-p results-circle + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Turn print-circle off. + (backtrace-toggle-print-circle '(4)) + (should (string-match-p last-frame + (backtrace-tests--get-substring + (point) (+ (point) (length last-frame))))) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max))))))) + +(defun backtrace-tests--make-regexp (str) + "Make regexp from STR for `backtrace-tests--print-circle'. +Used for results of printing circular objects without +`print-circle' on. Look for #n in string STR where n is any +digit and replace with #[0-9]." + (let ((regexp (regexp-quote str))) + (with-temp-buffer + (insert regexp) + (goto-char (point-min)) + (while (re-search-forward "#[0-9]" nil t) + (replace-match "#[0-9]"))) + (buffer-string))) + +(ert-deftest backtrace-tests--expand-ellipsis () + "Backtrace buffers ellipsify large forms as buttons which expand the ellipses." + ;; make a backtrace with an ellipsis + ;; expand the ellipsis + (ert-with-test-buffer (:name "variables") + (let* ((print-level nil) + (print-length nil) + (backtrace-line-length 300) + (arg (make-list 40 (make-string 10 ?a))) + (results (backtrace-tests--result arg))) + (backtrace-tests--make-backtrace arg) + (backtrace-print) + + ;; There should be an ellipsis. Find and expand it. + (goto-char (point-min)) + (search-forward "...") + (backward-char) + (push-button) + + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results))))) + +(ert-deftest backtrace-tests--expand-ellipses () + "Backtrace buffers ellipsify large forms and can expand the ellipses." + (ert-with-test-buffer (:name "variables") + (let* ((print-level nil) + (print-length nil) + (backtrace-line-length 300) + (arg (let ((outer (make-list 40 (make-string 10 ?a))) + (nested (make-list 40 (make-string 10 ?b)))) + (setf (nth 39 nested) (make-list 40 (make-string 10 ?c))) + (setf (nth 39 outer) nested) + outer)) + (results (backtrace-tests--result-with-locals arg))) + + ;; Make a backtrace with local variables visible. + (backtrace-tests--make-backtrace arg) + (backtrace-print) + (backtrace-toggle-locals '(4)) + + ;; There should be two ellipses. + (goto-char (point-min)) + (should (search-forward "...")) + (should (search-forward "...")) + (should-error (search-forward "...")) + + ;; Expanding the last frame without argument should expand both + ;; ellipses, but the expansions will contain one ellipsis each. + (let ((buffer-len (- (point-max) (point-min)))) + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-expand-ellipses) + (should (> (- (point-max) (point-min)) buffer-len)) + (goto-char (point-min)) + (should (search-forward "...")) + (should (search-forward "...")) + (should-error (search-forward "..."))) + + ;; Expanding with argument should remove all ellipses. + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-expand-ellipses '(4)) + (goto-char (point-min)) + + (should-error (search-forward "...")) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results))))) + + +(ert-deftest backtrace-tests--to-string () + "Backtraces can be produced as strings." + (let ((frames (ert-with-test-buffer (:name nil) + (backtrace-tests--make-backtrace "string") + backtrace-frames))) + (should (string= (backtrace-to-string frames) + (backtrace-tests--result "string"))))) + +(defun backtrace-tests--get-substring (beg end) + "Return the visible text between BEG and END. +Strip the string properties because it makes failed test results +easier to read." + (substring-no-properties (filter-buffer-substring beg end))) + +(provide 'backtrace-tests) + +;;; backtrace-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el index 404d323d0c1..a469b5526c0 100644 --- a/test/lisp/emacs-lisp/cl-print-tests.el +++ b/test/lisp/emacs-lisp/cl-print-tests.el @@ -56,19 +56,30 @@ (let ((long-list (make-list 5 'a)) (long-vec (make-vector 5 'b)) (long-struct (cl-print-tests-con)) + (long-string (make-string 5 ?a)) (print-length 4)) (should (equal "(a a a a ...)" (cl-prin1-to-string long-list))) (should (equal "[b b b b ...]" (cl-prin1-to-string long-vec))) (should (equal "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)" - (cl-prin1-to-string long-struct))))) + (cl-prin1-to-string long-struct))) + (should (equal "\"aaaa...\"" (cl-prin1-to-string long-string))))) (ert-deftest cl-print-tests-4 () "CL printing observes `print-level'." - (let ((deep-list '(a (b (c (d (e)))))) - (deep-struct (cl-print-tests-con)) - (print-level 4)) + (let* ((deep-list '(a (b (c (d (e)))))) + (buried-vector '(a (b (c (d [e]))))) + (deep-struct (cl-print-tests-con)) + (buried-struct `(a (b (c (d ,deep-struct))))) + (buried-string '(a (b (c (d #("hello" 0 5 (cl-print-test t))))))) + (buried-simple-string '(a (b (c (d "hello"))))) + (print-level 4)) (setf (cl-print-tests-struct-a deep-struct) deep-list) (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string deep-list))) + (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-vector))) + (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-struct))) + (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-string))) + (should (equal "(a (b (c (d \"hello\"))))" + (cl-prin1-to-string buried-simple-string))) (should (equal "#s(cl-print-tests-struct :a (a (b (c ...))) :b nil :c nil :d nil :e nil)" (cl-prin1-to-string deep-struct))))) @@ -82,6 +93,129 @@ (should (equal "((quote a) (function b) (\\` ((\\, c) (\\,@ d))))" (cl-prin1-to-string quoted-stuff)))))) +(ert-deftest cl-print-tests-strings () + "CL printing prints strings and propertized strings." + (let* ((str1 "abcdefghij") + (str2 #("abcdefghij" 3 6 (bold t) 7 9 (italic t))) + (str3 #("abcdefghij" 0 10 (test t))) + (obj '(a b)) + ;; Since the byte compiler reuses string literals, + ;; and the put-text-property call is destructive, use + ;; copy-sequence to make a new string. + (str4 (copy-sequence "abcdefghij"))) + (put-text-property 0 5 'test obj str4) + (put-text-property 7 10 'test obj str4) + + (should (equal "\"abcdefghij\"" (cl-prin1-to-string str1))) + (should (equal "#(\"abcdefghij\" 3 6 (bold t) 7 9 (italic t))" + (cl-prin1-to-string str2))) + (should (equal "#(\"abcdefghij\" 0 10 (test t))" + (cl-prin1-to-string str3))) + (let ((print-circle nil)) + (should + (equal + "#(\"abcdefghij\" 0 5 (test (a b)) 7 10 (test (a b)))" + (cl-prin1-to-string str4)))) + (let ((print-circle t)) + (should + (equal + "#(\"abcdefghij\" 0 5 (test #1=(a b)) 7 10 (test #1#))" + (cl-prin1-to-string str4)))))) + +(ert-deftest cl-print-tests-ellipsis-cons () + "Ellipsis expansion works in conses." + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + '(0 1 2 3 4 5) "(0 1 2 3 ...)" "4 5") + (cl-print-tests-check-ellipsis-expansion + '(0 1 2 3 4 5 6 7 8 9) "(0 1 2 3 ...)" "4 5 6 7 ...") + (cl-print-tests-check-ellipsis-expansion + '(a (b (c (d (e))))) "(a (b (c ...)))" "(d (e))") + (cl-print-tests-check-ellipsis-expansion + (let ((x (make-list 6 'b))) + (setf (nthcdr 6 x) 'c) + x) + "(b b b b ...)" "b b . c"))) + +(ert-deftest cl-print-tests-ellipsis-vector () + "Ellipsis expansion works in vectors." + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + [0 1 2 3 4 5] "[0 1 2 3 ...]" "4 5") + (cl-print-tests-check-ellipsis-expansion + [0 1 2 3 4 5 6 7 8 9] "[0 1 2 3 ...]" "4 5 6 7 ...") + (cl-print-tests-check-ellipsis-expansion + [a [b [c [d [e]]]]] "[a [b [c ...]]]" "[d [e]]"))) + +(ert-deftest cl-print-tests-ellipsis-string () + "Ellipsis expansion works in strings." + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + "abcdefg" "\"abcd...\"" "efg") + (cl-print-tests-check-ellipsis-expansion + "abcdefghijk" "\"abcd...\"" "efgh...") + (cl-print-tests-check-ellipsis-expansion + '(1 (2 (3 #("abcde" 0 5 (test t))))) + "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))") + (cl-print-tests-check-ellipsis-expansion + #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t)) + "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ..."))) + +(ert-deftest cl-print-tests-ellipsis-struct () + "Ellipsis expansion works in structures." + (let ((print-length 4) + (print-level 3) + (struct (cl-print-tests-con))) + (cl-print-tests-check-ellipsis-expansion + struct "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)" ":e nil") + (let ((print-length 2)) + (cl-print-tests-check-ellipsis-expansion + struct "#s(cl-print-tests-struct :a nil :b nil ...)" ":c nil :d nil ...")) + (cl-print-tests-check-ellipsis-expansion + `(a (b (c ,struct))) + "(a (b (c ...)))" + "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)"))) + +(ert-deftest cl-print-tests-ellipsis-circular () + "Ellipsis expansion works with circular objects." + (let ((wide-obj (list 0 1 2 3 4)) + (deep-obj `(0 (1 (2 (3 (4)))))) + (print-length 4) + (print-level 3)) + (setf (nth 4 wide-obj) wide-obj) + (setf (car (cadadr (cadadr deep-obj))) deep-obj) + (let ((print-circle nil)) + (cl-print-tests-check-ellipsis-expansion-rx + wide-obj (regexp-quote "(0 1 2 3 ...)") "\\`#[0-9]\\'") + (cl-print-tests-check-ellipsis-expansion-rx + deep-obj (regexp-quote "(0 (1 (2 ...)))") "\\`(3 (#[0-9]))\\'")) + (let ((print-circle t)) + (cl-print-tests-check-ellipsis-expansion + wide-obj "#1=(0 1 2 3 ...)" "#1#") + (cl-print-tests-check-ellipsis-expansion + deep-obj "#1=(0 (1 (2 ...)))" "(3 (#1#))")))) + +(defun cl-print-tests-check-ellipsis-expansion (obj expected expanded) + (let* ((result (cl-prin1-to-string obj)) + (pos (next-single-property-change 0 'cl-print-ellipsis result)) + value) + (should pos) + (setq value (get-text-property pos 'cl-print-ellipsis result)) + (should (equal expected result)) + (should (equal expanded (with-output-to-string (cl-print-expand-ellipsis + value nil)))))) + +(defun cl-print-tests-check-ellipsis-expansion-rx (obj expected expanded) + (let* ((result (cl-prin1-to-string obj)) + (pos (next-single-property-change 0 'cl-print-ellipsis result)) + (value (get-text-property pos 'cl-print-ellipsis result))) + (should (string-match expected result)) + (should (string-match expanded (with-output-to-string + (cl-print-expand-ellipsis value nil)))))) + (ert-deftest cl-print-circle () (let ((x '(#1=(a . #1#) #1#))) (let ((print-circle nil)) @@ -99,5 +233,41 @@ (let ((print-circle t)) (should (equal "(0 . #1=(0 . #1#))" (cl-prin1-to-string x)))))) +(ert-deftest cl-print-tests-print-to-string-with-limit () + (let* ((thing10 (make-list 10 'a)) + (thing100 (make-list 100 'a)) + (thing10x10 (make-list 10 thing10)) + (nested-thing (let ((val 'a)) + (dotimes (_i 20) + (setq val (list val))) + val)) + ;; Make a consistent environment for this test. + (print-circle nil) + (print-level nil) + (print-length nil)) + + ;; Print something that fits in the space given. + (should (string= (cl-prin1-to-string thing10) + (cl-print-to-string-with-limit #'cl-prin1 thing10 100))) + + ;; Print something which needs to be abbreviated and which can be. + (should (< (length (cl-print-to-string-with-limit #'cl-prin1 thing100 100)) + 100 + (length (cl-prin1-to-string thing100)))) + + ;; Print something resistant to easy abbreviation. + (should (string= (cl-prin1-to-string thing10x10) + (cl-print-to-string-with-limit #'cl-prin1 thing10x10 100))) + + ;; Print something which should be abbreviated even if the limit is large. + (should (< (length (cl-print-to-string-with-limit #'cl-prin1 nested-thing 1000)) + (length (cl-prin1-to-string nested-thing)))) + + ;; Print with no limits. + (dolist (thing (list thing10 thing100 thing10x10 nested-thing)) + (let ((rep (cl-prin1-to-string thing))) + (should (string= rep (cl-print-to-string-with-limit #'cl-prin1 thing 0))) + (should (string= rep (cl-print-to-string-with-limit #'cl-prin1 thing nil))))))) + ;;; cl-print-tests.el ends here. diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el index e86c2f1c1e7..97dead057a9 100644 --- a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el +++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el @@ -41,7 +41,7 @@ (defun edebug-test-code-range (num) !start!(let ((index 0) (result nil)) - (while (< index num)!test! + (while !lt!(< index num)!test! (push index result)!loop! (cl-incf index))!end-loop! (nreverse result))) @@ -130,5 +130,12 @@ (let ((two 2) (three 3)) (cl-destructuring-bind (x . y) (cons two three) (+ x!x! y!y!)))) +(defun edebug-test-code-use-cl-macrolet (x) + (cl-macrolet ((wrap (func &rest args) + `(format "The result of applying %s to %s is %S" + ',func!func! ',args + ,(cons func args)))) + (wrap + 1 x))) + (provide 'edebug-test-code) ;;; edebug-test-code.el ends here diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 85f6bd47db2..7880aaf95bc 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -432,9 +432,11 @@ test and possibly others should be updated." (verify-keybinding "P" 'edebug-view-outside) ;; same as v (verify-keybinding "W" 'edebug-toggle-save-windows) (verify-keybinding "?" 'edebug-help) - (verify-keybinding "d" 'edebug-backtrace) + (verify-keybinding "d" 'edebug-pop-to-backtrace) (verify-keybinding "-" 'negative-argument) - (verify-keybinding "=" 'edebug-temp-display-freq-count))) + (verify-keybinding "=" 'edebug-temp-display-freq-count) + (should (eq (lookup-key backtrace-mode-map "n") 'backtrace-forward-frame)) + (should (eq (lookup-key backtrace-mode-map "s") 'backtrace-goto-source)))) (ert-deftest edebug-tests-stop-point-at-start-of-first-instrumented-function () "Edebug stops at the beginning of an instrumented function." @@ -913,5 +915,28 @@ test and possibly others should be updated." "g" (should (equal edebug-tests-@-result 5))))) +(ert-deftest edebug-tests-cl-macrolet () + "Edebug can instrument `cl-macrolet' expressions. (Bug#29919)" + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "use-cl-macrolet" '(10) t) + (edebug-tests-run-kbd-macro + "@ SPC SPC" + (edebug-tests-should-be-at "use-cl-macrolet" "func") + (edebug-tests-should-match-result-in-messages "+") + "g" + (should (equal edebug-tests-@-result "The result of applying + to (1 x) is 11"))))) + +(ert-deftest edebug-tests-backtrace-goto-source () + "Edebug can jump to instrumented source from its *Edebug-Backtrace* buffer." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "range" '(2) t) + (edebug-tests-run-kbd-macro + "@ SPC SPC" + (edebug-tests-should-be-at "range" "lt") + "dns" ; Pop to backtrace, next frame, goto source. + (edebug-tests-should-be-at "range" "start") + "g" + (should (equal edebug-tests-@-result '(0 1)))))) + (provide 'edebug-tests) ;;; edebug-tests.el ends here diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index cb957bd9fd6..1fe5b79ef36 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -376,7 +376,7 @@ This macro is used to test if macroexpansion in `should' works." (test (make-ert-test :body test-body)) (result (ert-run-test test))) (should (ert-test-failed-p result)) - (should (eq (nth 1 (car (ert-test-failed-backtrace result))) + (should (eq (backtrace-frame-fun (car (ert-test-failed-backtrace result))) 'signal)))) (ert-deftest ert-test-messages () diff --git a/test/lisp/emacs-lisp/lisp-mode-tests.el b/test/lisp/emacs-lisp/lisp-mode-tests.el index 8598d419788..30f606d3816 100644 --- a/test/lisp/emacs-lisp/lisp-mode-tests.el +++ b/test/lisp/emacs-lisp/lisp-mode-tests.el @@ -113,6 +113,29 @@ noindent\" 3 ;; we're indenting ends on the previous line. (should (equal (buffer-string) original))))) +(ert-deftest indent-sexp-go () + "Make sure `indent-sexp' doesn't stop after #s." + ;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=31984. + (with-temp-buffer + (emacs-lisp-mode) + (insert "#s(foo\nbar)\n") + (goto-char (point-min)) + (indent-sexp) + (should (equal (buffer-string) "\ +#s(foo + bar)\n")))) + +(ert-deftest indent-sexp-cant-go () + "`indent-sexp' shouldn't error before a sexp." + ;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=31984#32. + (with-temp-buffer + (emacs-lisp-mode) + (insert "(())") + (goto-char (1+ (point-min))) + ;; Paredit calls `indent-sexp' from this position. + (indent-sexp) + (should (equal (buffer-string) "(())")))) + (ert-deftest lisp-indent-region () "Test basics of `lisp-indent-region'." (with-temp-buffer diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index db6d103a2ef..f08bc92ff2a 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -112,7 +112,7 @@ upload-base) &rest body) "Set up temporary locations and variables for testing." - (declare (indent 1)) + (declare (indent 1) (debug (([&rest form]) body))) `(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t)) (process-environment (cons (format "HOME=%s" package-test-user-dir) process-environment)) @@ -158,6 +158,7 @@ (defmacro with-fake-help-buffer (&rest body) "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer." + (declare (debug body)) `(with-temp-buffer (help-mode) ;; Trick `help-buffer' into using the temp buffer. @@ -467,15 +468,23 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-signed () "Test verifying package signature." - (skip-unless (ignore-errors - (let ((homedir (make-temp-file "package-test" t))) - (unwind-protect - (let ((process-environment - (cons (format "HOME=%s" homedir) - process-environment))) - (epg-check-configuration - (epg-find-configuration 'OpenPGP))) - (delete-directory homedir t))))) + (skip-unless (let ((homedir (make-temp-file "package-test" t))) + (unwind-protect + (let ((process-environment + (cons (concat "HOME=" homedir) + process-environment))) + (epg-find-configuration + 'OpenPGP nil + ;; By default we require gpg2 2.1+ due to some + ;; practical problems with pinentry. But this + ;; test works fine with 2.0 as well. + (let ((prog-alist (copy-tree epg-config--program-alist))) + (setf (alist-get "gpg2" + (alist-get 'OpenPGP prog-alist) + nil nil #'equal) + "2.0") + prog-alist))) + (delete-directory homedir t)))) (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) (package-test-data-dir (expand-file-name "package-resources/signed" package-test-file-dir))) @@ -506,7 +515,7 @@ Must called from within a `tar-mode' buffer." (with-fake-help-buffer (describe-package 'signed-good) (goto-char (point-min)) - (should (re-search-forward "signed-good is an? \\(\\S-+\\) package." nil t)) + (should (re-search-forward "Package signed-good is \\(\\S-+\\)\\." nil t)) (should (string-equal (match-string-no-properties 1) "installed")) (should (re-search-forward "Status: Installed in ['`‘]signed-good-1.0/['’]." diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index f7f0ef384f6..81467bab2d4 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -532,6 +532,53 @@ (format "abs sum is: %s")) "abs sum is: 15"))) + +;; Substring tests + +(ert-deftest subr-x-test-string-trim-left () + "Test `string-trim-left' behavior." + (should (equal (string-trim-left "") "")) + (should (equal (string-trim-left " \t\n\r") "")) + (should (equal (string-trim-left " \t\n\ra") "a")) + (should (equal (string-trim-left "a \t\n\r") "a \t\n\r")) + (should (equal (string-trim-left "" "") "")) + (should (equal (string-trim-left "a" "") "a")) + (should (equal (string-trim-left "aa" "a*") "")) + (should (equal (string-trim-left "ba" "a*") "ba")) + (should (equal (string-trim-left "aa" "a*?") "aa")) + (should (equal (string-trim-left "aa" "a+?") "a"))) + +(ert-deftest subr-x-test-string-trim-right () + "Test `string-trim-right' behavior." + (should (equal (string-trim-right "") "")) + (should (equal (string-trim-right " \t\n\r") "")) + (should (equal (string-trim-right " \t\n\ra") " \t\n\ra")) + (should (equal (string-trim-right "a \t\n\r") "a")) + (should (equal (string-trim-right "" "") "")) + (should (equal (string-trim-right "a" "") "a")) + (should (equal (string-trim-right "aa" "a*") "")) + (should (equal (string-trim-right "ab" "a*") "ab")) + (should (equal (string-trim-right "aa" "a*?") ""))) + +(ert-deftest subr-x-test-string-remove-prefix () + "Test `string-remove-prefix' behavior." + (should (equal (string-remove-prefix "" "") "")) + (should (equal (string-remove-prefix "" "a") "a")) + (should (equal (string-remove-prefix "a" "") "")) + (should (equal (string-remove-prefix "a" "b") "b")) + (should (equal (string-remove-prefix "a" "a") "")) + (should (equal (string-remove-prefix "a" "aa") "a")) + (should (equal (string-remove-prefix "a" "ab") "b"))) + +(ert-deftest subr-x-test-string-remove-suffix () + "Test `string-remove-suffix' behavior." + (should (equal (string-remove-suffix "" "") "")) + (should (equal (string-remove-suffix "" "a") "a")) + (should (equal (string-remove-suffix "a" "") "")) + (should (equal (string-remove-suffix "a" "b") "b")) + (should (equal (string-remove-suffix "a" "a") "")) + (should (equal (string-remove-suffix "a" "aa") "a")) + (should (equal (string-remove-suffix "a" "ba") "b"))) (provide 'subr-x-tests) ;;; subr-x-tests.el ends here diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el index 7efe04bfc00..c1e98a6935e 100644 --- a/test/lisp/epg-tests.el +++ b/test/lisp/epg-tests.el @@ -32,17 +32,26 @@ (defconst epg-tests--config-program-alist ;; The default `epg-config--program-alist' requires gpg2 2.1 or - ;; greater due to some practical problems with pinentry. But the - ;; tests here all work fine with 2.0 as well. - (let ((prog-alist (copy-sequence epg-config--program-alist))) + ;; greater due to some practical problems with pinentry. But most + ;; tests here work fine with 2.0 as well. + (let ((prog-alist (copy-tree epg-config--program-alist))) (setf (alist-get "gpg2" (alist-get 'OpenPGP prog-alist) nil nil #'equal) "2.0") prog-alist)) -(defun epg-tests-find-usable-gpg-configuration (&optional _require-passphrase) - (epg-find-configuration 'OpenPGP 'no-cache epg-tests--config-program-alist)) +(defun epg-tests-find-usable-gpg-configuration + (&optional require-passphrase require-public-key) + ;; Clear config cache because we may be using a different + ;; program-alist. We do want to update the cache, so that + ;; `epg-make-context' can use our result. + (setq epg--configurations nil) + (epg-find-configuration 'OpenPGP nil + ;; The symmetric operations fail on Hydra + ;; with gpg 2.0. + (if (or (not require-passphrase) require-public-key) + epg-tests--config-program-alist))) (defun epg-tests-passphrase-callback (_c _k _d) ;; Need to create a copy here, since the string will be wiped out @@ -62,12 +71,14 @@ (format "GNUPGHOME=%s" epg-tests-home-directory)) process-environment))) (unwind-protect - (let ((context (epg-make-context 'OpenPGP))) + ;; GNUPGHOME is needed to find a usable gpg, so we can't + ;; check whether to skip any earlier (Bug#23561). + (let ((epg-config (or (epg-tests-find-usable-gpg-configuration + ,require-passphrase ,require-public-key) + (ert-skip "No usable gpg config"))) + (context (epg-make-context 'OpenPGP))) (setf (epg-context-program context) - (alist-get 'program - (epg-tests-find-usable-gpg-configuration - ,(if require-passphrase - `'require-passphrase)))) + (alist-get 'program epg-config)) (setf (epg-context-home-directory context) epg-tests-home-directory) ,(if require-passphrase @@ -96,7 +107,6 @@ (delete-directory epg-tests-home-directory t))))) (ert-deftest epg-decrypt-1 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) (with-epg-tests (:require-passphrase t) (should (equal "test" (epg-decrypt-string epg-tests-context "\ @@ -108,14 +118,12 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== -----END PGP MESSAGE-----"))))) (ert-deftest epg-roundtrip-1 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) (with-epg-tests (:require-passphrase t) (let ((cipher (epg-encrypt-string epg-tests-context "symmetric" nil))) (should (equal "symmetric" (epg-decrypt-string epg-tests-context cipher)))))) (ert-deftest epg-roundtrip-2 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) (with-epg-tests (:require-passphrase t :require-public-key t :require-secret-key t) @@ -126,7 +134,6 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== (epg-decrypt-string epg-tests-context cipher)))))) (ert-deftest epg-sign-verify-1 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) (with-epg-tests (:require-passphrase t :require-public-key t :require-secret-key t) @@ -140,7 +147,6 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== (should (eq 'good (epg-signature-status (car verify-result))))))) (ert-deftest epg-sign-verify-2 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) (with-epg-tests (:require-passphrase t :require-public-key t :require-secret-key t) @@ -156,7 +162,6 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== (should (eq 'good (epg-signature-status (car verify-result))))))) (ert-deftest epg-sign-verify-3 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) (with-epg-tests (:require-passphrase t :require-public-key t :require-secret-key t) @@ -171,7 +176,6 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== (should (eq 'good (epg-signature-status (car verify-result))))))) (ert-deftest epg-import-1 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) (with-epg-tests (:require-passphrase nil) (should (= 0 (length (epg-list-keys epg-tests-context)))) (should (= 0 (length (epg-list-keys epg-tests-context nil t))))) diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index 56403f43092..612ea8cd7f4 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -891,9 +891,9 @@ delivered." ;; Modify file. We wait for two seconds, in order to ;; have another timestamp. One second seems to be too - ;; short. + ;; short. And Cygwin sporadically requires more than two. (ert-with-message-capture captured-messages - (sleep-for 2) + (sleep-for (if (eq system-type 'cygwin) 3 2)) (write-region "foo bla" nil file-notify--test-tmpfile nil 'no-message) diff --git a/test/lisp/net/secrets-tests.el b/test/lisp/net/secrets-tests.el index 9aa79dab0eb..de3ce731bec 100644 --- a/test/lisp/net/secrets-tests.el +++ b/test/lisp/net/secrets-tests.el @@ -92,7 +92,8 @@ (should (secrets-open-session)) ;; There must be at least the collections "Login" and "session". - (should (member "Login" (secrets-list-collections))) + (should (or (member "Login" (secrets-list-collections)) + (member "login" (secrets-list-collections)))) (should (member "session" (secrets-list-collections))) ;; Create a random collection. This asks for a password @@ -160,7 +161,8 @@ ;; There shall be no items in the "session" collection. (should-not (secrets-list-items "session")) ;; There shall be items in the "Login" collection. - (should (secrets-list-items "Login")) + (should (or (secrets-list-items "Login") + (secrets-list-items "login"))) ;; Create a new item. (should (setq item-path (secrets-create-item "session" "foo" "secret"))) diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 0a8716be0d7..e7597864c6e 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -311,6 +311,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test07-file-exists-p () "Check `file-exist-p', `write-region' and `delete-file'." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) (unwind-protect @@ -333,6 +334,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test08-file-local-copy () "Check `file-local-copy'." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) (let (tmp-name) @@ -359,6 +361,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test09-insert-file-contents () "Check `insert-file-contents'." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) (let ((tmp-name (expand-file-name "bar/bar" tramp-archive-test-archive))) @@ -385,6 +388,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test11-copy-file () "Check `copy-file'." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) ;; Copy simple file. @@ -450,6 +454,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test15-copy-directory () "Check `copy-directory'." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) (let* ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) @@ -504,6 +509,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test16-directory-files () "Check `directory-files'." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) (let ((tmp-name tramp-archive-test-archive) @@ -527,6 +533,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test17-insert-directory () "Check `insert-directory'." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) (let (;; We test for the summary line. Keyword "total" could be localized. @@ -569,6 +576,7 @@ This checks also `file-name-as-directory', `file-name-directory', (ert-deftest tramp-archive-test18-file-attributes () "Check `file-attributes'. This tests also `file-readable-p' and `file-regular-p'." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) (let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) @@ -619,6 +627,7 @@ This tests also `file-readable-p' and `file-regular-p'." (ert-deftest tramp-archive-test19-directory-files-and-attributes () "Check `directory-files-and-attributes'." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) (let ((tmp-name (expand-file-name "bar" tramp-archive-test-archive)) @@ -644,6 +653,7 @@ This tests also `file-readable-p' and `file-regular-p'." (ert-deftest tramp-archive-test20-file-modes () "Check `file-modes'. This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) (let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) @@ -673,6 +683,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (ert-deftest tramp-archive-test21-file-links () "Check `file-symlink-p' and `file-truename'" + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) ;; We must use `file-truename' for the file archive, because it @@ -711,6 +722,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (ert-deftest tramp-archive-test26-file-name-completion () "Check `file-name-completion' and `file-name-all-completions'." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) (let ((tmp-name tramp-archive-test-archive)) @@ -802,8 +814,9 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (zerop (nth 1 fsi)) (zerop (nth 2 fsi)))))) -(ert-deftest tramp-archive-test43-auto-load () +(ert-deftest tramp-archive-test44-auto-load () "Check that `tramp-archive' autoloads properly." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) ;; Autoloading tramp-archive works since Emacs 27.1. (skip-unless (tramp-archive--test-emacs27-p)) @@ -832,8 +845,9 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument (format code file))))))))) -(ert-deftest tramp-archive-test43-delay-load () +(ert-deftest tramp-archive-test44-delay-load () "Check that `tramp-archive' is loaded lazily, only when needed." + :tags '(:expensive-test) (skip-unless tramp-archive-enabled) ;; Autoloading tramp-archive works since Emacs 27.1. (skip-unless (tramp-archive--test-emacs27-p)) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 5c5eff8798d..293a0054560 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2182,7 +2182,7 @@ This checks also `file-name-as-directory', `file-name-directory', (unwind-protect ;; FIXME: This fails on my QNAP server, see ;; /share/Web/owncloud/data/owncloud.log - (unless (tramp--test-owncloud-p) + (unless (tramp--test-nextcloud-p) (write-region "foo" nil source) (should (file-exists-p source)) (make-directory target) @@ -2205,7 +2205,7 @@ This checks also `file-name-as-directory', `file-name-directory', (unwind-protect ;; FIXME: This fails on my QNAP server, see ;; /share/Web/owncloud/data/owncloud.log - (unless (and (tramp--test-owncloud-p) + (unless (and (tramp--test-nextcloud-p) (or (not (file-remote-p source)) (not (file-remote-p target)))) (make-directory source) @@ -2231,7 +2231,7 @@ This checks also `file-name-as-directory', `file-name-directory', ;; FIXME: This fails on my QNAP server, see ;; /share/Web/owncloud/data/owncloud.log (unless - (and (tramp--test-owncloud-p) (not (file-remote-p source))) + (and (tramp--test-nextcloud-p) (not (file-remote-p source))) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -2320,7 +2320,7 @@ This checks also `file-name-as-directory', `file-name-directory', (unwind-protect ;; FIXME: This fails on my QNAP server, see ;; /share/Web/owncloud/data/owncloud.log - (unless (tramp--test-owncloud-p) + (unless (tramp--test-nextcloud-p) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -2344,7 +2344,7 @@ This checks also `file-name-as-directory', `file-name-directory', (unwind-protect ;; FIXME: This fails on my QNAP server, see ;; /share/Web/owncloud/data/owncloud.log - (unless (tramp--test-owncloud-p) + (unless (tramp--test-nextcloud-p) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -4427,10 +4427,10 @@ This does not support external Emacs calls." (string-equal "mock" (file-remote-p tramp-test-temporary-file-directory 'method))) -(defun tramp--test-owncloud-p () - "Check, whether the owncloud method is used." +(defun tramp--test-nextcloud-p () + "Check, whether the nextcloud method is used." (string-equal - "owncloud" (file-remote-p tramp-test-temporary-file-directory 'method))) + "nextcloud" (file-remote-p tramp-test-temporary-file-directory 'method))) (defun tramp--test-rsync-p () "Check, whether the rsync method is used. @@ -5056,6 +5056,8 @@ process sentinels. They shall not disturb each other." ;; This test is inspired by Bug#29163. (ert-deftest tramp-test43-auto-load () "Check that Tramp autoloads properly." + (skip-unless (tramp--test-enabled)) + (let ((default-directory (expand-file-name temporary-file-directory)) (code (format @@ -5166,42 +5168,52 @@ Since it unloads Tramp, it shall be the last test to run." ;; cannot test older Emacsen, therefore. (skip-unless (tramp--test-emacs26-p)) - (when (featurep 'tramp) - (unload-feature 'tramp 'force) - ;; No Tramp feature must be left. - (should-not (featurep 'tramp)) - (should-not (all-completions "tramp" (delq 'tramp-tests features))) - ;; `file-name-handler-alist' must be clean. - (should-not (all-completions "tramp" (mapcar 'cdr file-name-handler-alist))) - ;; There shouldn't be left a bound symbol, except buffer-local - ;; variables, and autoload functions. We do not regard our test - ;; symbols, and the Tramp unload hooks. - (mapatoms - (lambda (x) - (and (or (and (boundp x) (null (local-variable-if-set-p x))) - (and (functionp x) (null (autoloadp (symbol-function x))))) - (string-match "^tramp" (symbol-name x)) - (not (string-match "^tramp--?test" (symbol-name x))) - (not (string-match "unload-hook$" (symbol-name x))) - (ert-fail (format "`%s' still bound" x))))) - ;; The defstruct `tramp-file-name' and all its internal functions - ;; shall be purged. - (should-not (cl--find-class 'tramp-file-name)) - (mapatoms - (lambda (x) - (and (functionp x) - (string-match "tramp-file-name" (symbol-name x)) - (ert-fail (format "Structure function `%s' still exists" x))))) - ;; There shouldn't be left a hook function containing a Tramp - ;; function. We do not regard the Tramp unload hooks. - (mapatoms - (lambda (x) - (and (boundp x) - (string-match "-\\(hook\\|function\\)s?$" (symbol-name x)) - (not (string-match "unload-hook$" (symbol-name x))) - (consp (symbol-value x)) - (ignore-errors (all-completions "tramp" (symbol-value x))) - (ert-fail (format "Hook `%s' still contains Tramp function" x))))))) + ;; We have autoloaded objects from tramp.el and tramp-archive.el. + ;; In order to remove them, we first need to load both packages. + (require 'tramp) + (require 'tramp-archive) + (should (featurep 'tramp)) + (should (featurep 'tramp-archive)) + ;; This unloads also tramp-archive.el and tramp-theme.el if needed. + (unload-feature 'tramp 'force) + ;; No Tramp feature must be left. + (should-not (featurep 'tramp)) + (should-not (featurep 'tramp-archive)) + (should-not (featurep 'tramp-theme)) + (should-not + (all-completions + "tramp" (delq 'tramp-tests (delq 'tramp-archive-tests features)))) + ;; `file-name-handler-alist' must be clean. + (should-not (all-completions "tramp" (mapcar 'cdr file-name-handler-alist))) + ;; There shouldn't be left a bound symbol, except buffer-local + ;; variables, and autoload functions. We do not regard our test + ;; symbols, and the Tramp unload hooks. + (mapatoms + (lambda (x) + (and (or (and (boundp x) (null (local-variable-if-set-p x))) + (and (functionp x) (null (autoloadp (symbol-function x))))) + (string-match "^tramp" (symbol-name x)) + (not (string-match "^tramp\\(-archive\\)?--?test" (symbol-name x))) + (not (string-match "unload-hook$" (symbol-name x))) + (ert-fail (format "`%s' still bound" x))))) + ;; The defstruct `tramp-file-name' and all its internal functions + ;; shall be purged. + (should-not (cl--find-class 'tramp-file-name)) + (mapatoms + (lambda (x) + (and (functionp x) + (string-match "tramp-file-name" (symbol-name x)) + (ert-fail (format "Structure function `%s' still exists" x))))) + ;; There shouldn't be left a hook function containing a Tramp + ;; function. We do not regard the Tramp unload hooks. + (mapatoms + (lambda (x) + (and (boundp x) + (string-match "-\\(hook\\|function\\)s?$" (symbol-name x)) + (not (string-match "unload-hook$" (symbol-name x))) + (consp (symbol-value x)) + (ignore-errors (all-completions "tramp" (symbol-value x))) + (ert-fail (format "Hook `%s' still contains Tramp function" x)))))) (defun tramp-test-all (&optional interactive) "Run all tests for \\[tramp]." @@ -5222,7 +5234,7 @@ Since it unloads Tramp, it shall be the last test to run." ;; * Fix `tramp-test05-expand-file-name-relative' in `expand-file-name'. ;; * Fix `tramp-test06-directory-file-name' for `ftp'. ;; * Investigate, why `tramp-test11-copy-file' and `tramp-test12-rename-file' -;; do not work properly for `owncloud'. +;; do not work properly for `nextcloud'. ;; * Fix `tramp-test29-start-file-process' on MS Windows (`process-send-eof'?). ;; * Fix `tramp-test30-interrupt-process', timeout doesn't work reliably. ;; * Fix Bug#16928 in `tramp-test42-asynchronous-requests'. diff --git a/test/lisp/progmodes/compile-tests.el b/test/lisp/progmodes/compile-tests.el index a106030aea1..4e2dc86eae0 100644 --- a/test/lisp/progmodes/compile-tests.el +++ b/test/lisp/progmodes/compile-tests.el @@ -343,6 +343,29 @@ meaning a range of columns starting on LINE and ending on END-LINE, if that matched. TYPE can be left out, in which case any message type is accepted.") +(defconst compile-tests--grep-regexp-testcases + ;; Bug#32051. + '(("c:/Users/my.name/src/project\\src\\kbhit.hpp\0\ 29:#include <termios.h>" + 1 nil 29 "c:/Users/my.name/src/project\\src\\kbhit.hpp") + ("d:/gnu/emacs/branch/src/callproc.c\0\ 214:#ifdef DOS_NT" + 1 nil 214 "d:/gnu/emacs/branch/src/callproc.c") + ("/gnu/emacs/branch/src/callproc.c\0\ 214:#ifdef DOS_NT" + 1 nil 214 "/gnu/emacs/branch/src/callproc.c")) + "List of tests for `grep-regexp-list'. +The format is the same as `compile-tests--test-regexps-data', but +the match is expected to be the same when NUL bytes are replaced +with colon.") + +(defconst compile-tests--grep-regexp-tricky-testcases + ;; Bug#7378. + '(("./x11-libs---nx/3.4.0:0:C.30253.1289557929.792611.C/nx-3.4.0.exheres-0\0\ 42:some text" + 1 nil 42 "./x11-libs---nx/3.4.0:0:C.30253.1289557929.792611.C/nx-3.4.0.exheres-0") + ("2011-08-31_11:57:03_1\0\ 7:Date: Wed, 31 Aug 2011 11:57:03 +0000" + 1 nil 7 "2011-08-31_11:57:03_1")) + "List of tricky tests for `grep-regexp-list'. +Same as `compile-tests--grep-regexp-testcases', but these cases +can only work with the NUL byte to disambiguate colons.") + (defun compile--test-error-line (test) (erase-buffer) (setq compilation-locs (make-hash-table)) @@ -370,7 +393,8 @@ any message type is accepted.") (should (equal (car (nth 2 (compilation--loc->file-struct loc))) (or end-line line))) (when type - (should (equal type (compilation--message->type msg))))))) + (should (equal type (compilation--message->type msg))))) + msg)) (ert-deftest compile-test-error-regexps () "Test the `compilation-error-regexp-alist' regexps. @@ -379,4 +403,24 @@ The test data is in `compile-tests--test-regexps-data'." (font-lock-mode -1) (mapc #'compile--test-error-line compile-tests--test-regexps-data))) +(ert-deftest compile-test-grep-regexps () + "Test the `grep-regexp-alist' regexps. +The test data is in `compile-tests--grep-regexp-testcases'." + (with-temp-buffer + (grep-mode) + (setq buffer-read-only nil) + (font-lock-mode -1) + (dolist (testcase compile-tests--grep-regexp-testcases) + (let (msg1 msg2) + (setq msg1 (ert-info ((format "%S" testcase) :prefix "testcase: ") + (compile--test-error-line testcase))) + ;; Make sure replacing the NUL character with a colon still matches. + (setf (car testcase) (replace-regexp-in-string "\0" ":" (car testcase))) + (setq msg2 (ert-info ((format "%S" testcase) :prefix "testcase: ") + (compile--test-error-line testcase))) + (should (equal msg1 msg2)))) + (dolist (testcase compile-tests--grep-regexp-tricky-testcases) + (ert-info ((format "%S" testcase) :prefix "testcase: ") + (compile--test-error-line testcase))))) + ;;; compile-tests.el ends here diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el new file mode 100644 index 00000000000..22f7b2de6ed --- /dev/null +++ b/test/lisp/shadowfile-tests.el @@ -0,0 +1,945 @@ +;;; shadowfile-tests.el --- Tests of shadowfile + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `https://www.gnu.org/licenses/'. + +;;; Commentary: + +;; Some of the tests require access to a remote host files. Since +;; this could be problematic, a mock-up connection method "mock" is +;; used. Emulating a remote connection, it simply calls "sh -i". +;; Tramp's file name handlers still run, so this test is sufficient +;; except for connection establishing. + +;; If you want to test a real Tramp connection, set +;; $REMOTE_TEMPORARY_FILE_DIRECTORY to a suitable value in order to +;; overwrite the default value. If you want to skip tests accessing a +;; remote host, set this environment variable to "/dev/null" or +;; whatever is appropriate on your system. + +;; A whole test run can be performed calling the command `shadowfile-test-all'. + +;;; Code: + +(require 'ert) +(require 'shadowfile) +(require 'tramp) + +;; There is no default value on w32 systems, which could work out of the box. +(defconst shadow-test-remote-temporary-file-directory + (cond + ((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY")) + ((eq system-type 'windows-nt) null-device) + (t (add-to-list + 'tramp-methods + '("mock" + (tramp-login-program "sh") + (tramp-login-args (("-i"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (add-to-list + 'tramp-default-host-alist + `("\\`mock\\'" nil ,(system-name))) + ;; Emacs' Makefile sets $HOME to a nonexistent value. Needed in + ;; batch mode only, therefore. It cannot be + ;; `temporary-directory', because the tests with "~" would fail. + (unless (and (null noninteractive) (file-directory-p "~/")) + (setenv "HOME" invocation-directory)) + (format "/mock::%s" temporary-file-directory))) + "Temporary directory for Tramp tests.") + +(defconst shadow-test-info-file + (expand-file-name "shadows_test" temporary-file-directory) + "File to keep shadow information in during tests.") + +(defconst shadow-test-todo-file + (expand-file-name "shadow_todo_test" temporary-file-directory) + "File to store the list of uncopied shadows in during tests.") + +(ert-deftest shadow-test00-clusters () + "Check cluster definitions. +Per definition, all files are identical on the different hosts of +a cluster (or site). This is not tested here; it must be +guaranteed by the originator of a cluster definition." + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-unless (file-remote-p shadow-test-remote-temporary-file-directory)) + + (let ((text-quoting-style 'grave) ;; We inspect the *Messages* buffer! + (inhibit-message t) + (shadow-info-file shadow-test-info-file) + (shadow-todo-file shadow-test-todo-file) + shadow-clusters + cluster primary regexp mocked-input) + (unwind-protect + ;; We must mock `read-from-minibuffer' and `read-string', in + ;; order to avoid interactive arguments. + (cl-letf* (((symbol-function 'read-from-minibuffer) + (lambda (&rest args) (pop mocked-input))) + ((symbol-function 'read-string) + (lambda (&rest args) (pop mocked-input)))) + + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file)) + + ;; Define a cluster. + (setq cluster "cluster" + primary shadow-system-name + regexp (shadow-regexp-superquote primary) + mocked-input `(,cluster ,primary ,regexp)) + (call-interactively 'shadow-define-cluster) + (should + (string-equal + (shadow-cluster-name (shadow-get-cluster cluster)) cluster)) + (should + (string-equal + (shadow-cluster-primary (shadow-get-cluster cluster)) primary)) + (should + (string-equal + (shadow-cluster-regexp (shadow-get-cluster cluster)) regexp)) + (should-not (shadow-get-cluster "non-existent-cluster-name")) + + ;; Test `shadow-set-cluster' and `make-shadow-cluster'. + (shadow-set-cluster cluster primary regexp) + (should + (equal (shadow-get-cluster cluster) + (make-shadow-cluster + :name cluster :primary primary :regexp regexp))) + + ;; The primary must be either `shadow-system-name', or a remote file. + (setq ;; The second "cluster" is wrong. + mocked-input `(,cluster ,cluster ,primary ,regexp)) + (with-current-buffer (messages-buffer) + (narrow-to-region (point-max) (point-max))) + (call-interactively 'shadow-define-cluster) + (should + (string-match + (regexp-quote "Not a valid primary!") + (with-current-buffer (messages-buffer) (buffer-string)))) + ;; The first cluster definition is still valid. + (should + (string-equal + (shadow-cluster-name (shadow-get-cluster cluster)) cluster)) + (should + (string-equal + (shadow-cluster-primary (shadow-get-cluster cluster)) primary)) + (should + (string-equal + (shadow-cluster-regexp (shadow-get-cluster cluster)) regexp)) + + ;; The regexp must match the primary name. + (setq ;; The second "cluster" is wrong. + mocked-input `(,cluster ,primary ,cluster ,regexp)) + (with-current-buffer (messages-buffer) + (narrow-to-region (point-max) (point-max))) + (call-interactively 'shadow-define-cluster) + (should + (string-match + (regexp-quote "Regexp doesn't include the primary host!") + (with-current-buffer (messages-buffer) (buffer-string)))) + ;; The first cluster definition is still valid. + (should + (string-equal + (shadow-cluster-name (shadow-get-cluster cluster)) cluster)) + (should + (string-equal + (shadow-cluster-primary (shadow-get-cluster cluster)) primary)) + (should + (string-equal + (shadow-cluster-regexp (shadow-get-cluster cluster)) regexp)) + + ;; Redefine the cluster. + (setq primary + (file-remote-p shadow-test-remote-temporary-file-directory) + regexp (shadow-regexp-superquote primary) + mocked-input `(,cluster ,primary ,regexp)) + (call-interactively 'shadow-define-cluster) + (should + (string-equal + (shadow-cluster-name (shadow-get-cluster cluster)) cluster)) + (should + (string-equal + (shadow-cluster-primary (shadow-get-cluster cluster)) primary)) + (should + (string-equal + (shadow-cluster-regexp (shadow-get-cluster cluster)) regexp)) + + ;; Test `shadow-set-cluster' and `make-shadow-cluster'. + (shadow-set-cluster cluster primary regexp) + (should + (equal (shadow-get-cluster cluster) + (make-shadow-cluster + :name cluster :primary primary :regexp regexp)))) + + ;; Cleanup. + (with-current-buffer (messages-buffer) (widen)) + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file))))) + +(ert-deftest shadow-test01-sites () + "Check site definitions. +Per definition, all files are identical on the different hosts of +a cluster (or site). This is not tested here; it must be +guaranteed by the originator of a cluster definition." + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-unless (file-remote-p shadow-test-remote-temporary-file-directory)) + + (let ((shadow-info-file shadow-test-info-file) + (shadow-todo-file shadow-test-todo-file) + shadow-clusters + cluster1 cluster2 primary1 primary2 regexp1 regexp2 mocked-input) + (unwind-protect + ;; We must mock `read-from-minibuffer' and `read-string', in + ;; order to avoid interactive arguments. + (cl-letf* (((symbol-function 'read-from-minibuffer) + (lambda (&rest args) (pop mocked-input))) + ((symbol-function 'read-string) + (lambda (&rest args) (pop mocked-input)))) + + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file)) + + ;; Define a cluster. + (setq cluster1 "cluster1" + primary1 shadow-system-name + regexp1 (shadow-regexp-superquote primary1)) + (shadow-set-cluster cluster1 primary1 regexp1) + + ;; A site is either a cluster identification, or a primary host. + (should (string-equal cluster1 (shadow-site-name cluster1))) + (should (string-equal primary1 (shadow-name-site primary1))) + (should + (string-equal (format "/%s:" cluster1) (shadow-name-site cluster1))) + (should (string-equal (system-name) (shadow-site-name primary1))) + (should + (string-equal + (file-remote-p shadow-test-remote-temporary-file-directory) + (shadow-name-site + (file-remote-p shadow-test-remote-temporary-file-directory)))) + (should + (string-equal + (file-remote-p shadow-test-remote-temporary-file-directory) + (shadow-site-name + (file-remote-p shadow-test-remote-temporary-file-directory)))) + + (should (equal (shadow-site-cluster cluster1) + (shadow-get-cluster cluster1))) + (should (equal (shadow-site-cluster (shadow-name-site cluster1)) + (shadow-get-cluster cluster1))) + (should (equal (shadow-site-cluster primary1) + (shadow-get-cluster cluster1))) + (should (equal (shadow-site-cluster (shadow-site-name primary1)) + (shadow-get-cluster cluster1))) + (should (string-equal (shadow-site-primary cluster1) primary1)) + (should (string-equal (shadow-site-primary primary1) primary1)) + + ;; `shadow-read-site' accepts "cluster", "/cluster:", + ;; "system", "/system:". It shall reject bad site names. + (setq mocked-input + `(,cluster1 ,(shadow-name-site cluster1) + ,primary1 ,(shadow-site-name primary1) + ,shadow-system-name "" "bad" "/bad:")) + (should (string-equal (shadow-read-site) cluster1)) + (should (string-equal (shadow-read-site) (shadow-name-site cluster1))) + (should (string-equal (shadow-read-site) primary1)) + (should (string-equal (shadow-read-site) (shadow-site-name primary1))) + (should (string-equal (shadow-read-site) shadow-system-name)) + (should-not (shadow-read-site)) ; "" + (should-not (shadow-read-site)) ; "bad" + (should-not (shadow-read-site)) ; "/bad:" + (should-error (shadow-read-site)) ; no input at all + + ;; Define a second cluster. + (setq cluster2 "cluster2" + primary2 + (file-remote-p shadow-test-remote-temporary-file-directory) + regexp2 (format "^\\(%s\\|%s\\)$" shadow-system-name primary2)) + (shadow-set-cluster cluster2 primary2 regexp2) + + ;; `shadow-site-match' shall know all different kind of site names. + (should (shadow-site-match cluster1 cluster1)) + (should (shadow-site-match primary1 primary1)) + (should (shadow-site-match cluster1 primary1)) + (should (shadow-site-match primary1 cluster1)) + (should (shadow-site-match cluster2 cluster2)) + (should (shadow-site-match primary2 primary2)) + (should (shadow-site-match cluster2 primary2)) + (should (shadow-site-match primary2 cluster2)) + + ;; The regexp of `cluster2' matches the primary of + ;; `cluster1'. Not vice versa. + (should (shadow-site-match cluster2 cluster1)) + (should-not (shadow-site-match cluster1 cluster2)) + + ;; If we use the primaries of a cluster, it doesn't match. + (should-not + (shadow-site-match (shadow-site-primary cluster2) cluster1)) + (should-not + (shadow-site-match (shadow-site-primary cluster1) cluster2))) + + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file))))) + +(ert-deftest shadow-test02-files () + "Check file manipulation functions." + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-unless (file-remote-p shadow-test-remote-temporary-file-directory)) + + (let ((shadow-info-file shadow-test-info-file) + (shadow-todo-file shadow-test-todo-file) + shadow-clusters + cluster primary regexp file hup) + (unwind-protect + (progn + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file)) + + ;; Define a cluster. + (setq cluster "cluster" + primary shadow-system-name + regexp (shadow-regexp-superquote primary) + file (make-temp-name + (expand-file-name + "shadowfile-tests" temporary-file-directory))) + (shadow-set-cluster cluster primary regexp) + + ;; The constant structure to compare with. + (setq hup (make-tramp-file-name :host (system-name) :localname file)) + + ;; The structure a local file is transformed in. + (should (equal (shadow-parse-name file) hup)) + (should (equal (shadow-parse-name (concat "/" cluster ":" file)) hup)) + (should (equal (shadow-parse-name (concat primary file)) hup)) + + ;; A local file name is kept. + (should + (string-equal (shadow-local-file file) file)) + ;; A file on this cluster is also local. + (should + (string-equal + (shadow-local-file (concat "/" cluster ":" file)) file)) + ;; A file on the primary host is also local. + (should + (string-equal (shadow-local-file (concat primary file)) file)) + + ;; Redefine the cluster. + (setq primary + (file-remote-p shadow-test-remote-temporary-file-directory) + regexp (shadow-regexp-superquote primary)) + (shadow-set-cluster cluster primary regexp) + + ;; The structure of the local file is still the same. + (should (equal (shadow-parse-name file) hup)) + ;; The cluster name must be used. + (setf (tramp-file-name-host hup) cluster) + (should (equal (shadow-parse-name (concat "/" cluster ":" file)) hup)) + ;; The structure of a remote file is different. + (should + (equal (shadow-parse-name (concat primary file)) + (tramp-dissect-file-name (concat primary file)))) + + ;; A local file is still local. + (should (shadow-local-file file)) + ;; A file on this cluster is not local. + (should-not (shadow-local-file (concat "/" cluster ":" file))) + ;; A file on the primary host is not local. + (should-not (shadow-local-file (concat primary file))) + ;; There's no error on wrong FILE. + (should-not (shadow-local-file nil))) + + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file))))) + +(ert-deftest shadow-test03-expand-cluster-in-file-name () + "Check canonical file name of a cluster or site." + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-unless (file-remote-p shadow-test-remote-temporary-file-directory)) + + (let ((shadow-info-file shadow-test-info-file) + (shadow-todo-file shadow-test-todo-file) + shadow-clusters + cluster primary regexp file1 file2) + (unwind-protect + (progn + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file)) + + ;; Define a cluster. + (setq cluster "cluster" + primary shadow-system-name + regexp (shadow-regexp-superquote primary)) + (shadow-set-cluster cluster primary regexp) + + (setq file1 + (make-temp-name + (expand-file-name "shadowfile-tests" temporary-file-directory)) + file2 + (make-temp-name + (expand-file-name + "shadowfile-tests" + shadow-test-remote-temporary-file-directory))) + + ;; A local file name is kept. + (should + (string-equal (shadow-expand-cluster-in-file-name file1) file1)) + ;; A remote file is kept. + (should + (string-equal (shadow-expand-cluster-in-file-name file2) file2)) + ;; A cluster name is expanded to the primary name. + (should + (string-equal + (shadow-expand-cluster-in-file-name (format "/%s:%s" cluster file1)) + (shadow-expand-cluster-in-file-name (concat primary file1)))) + ;; A primary name is expanded if it is a local file name. + (should + (string-equal + (shadow-expand-cluster-in-file-name (concat primary file1)) file1)) + + ;; Redefine the cluster. + (setq primary + (file-remote-p shadow-test-remote-temporary-file-directory) + regexp (shadow-regexp-superquote primary)) + (shadow-set-cluster cluster primary regexp) + + ;; A cluster name is expanded to the primary name. + (should + (string-equal + (shadow-expand-cluster-in-file-name (format "/%s:%s" cluster file1)) + (shadow-expand-cluster-in-file-name (concat primary file1)))) + ;; A primary name is not expanded if it isn't is a local file name. + (should + (string-equal + (shadow-expand-cluster-in-file-name (concat primary file1)) + (concat primary file1)))) + + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file))))) + +(ert-deftest shadow-test04-contract-file-name () + "Check canonical file name of a cluster or site." + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-unless (file-remote-p shadow-test-remote-temporary-file-directory)) + + (let ((shadow-info-file shadow-test-info-file) + (shadow-todo-file shadow-test-todo-file) + shadow-clusters + cluster primary regexp file) + (unwind-protect + (progn + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file)) + + ;; Define a cluster. + (setq cluster "cluster" + primary shadow-system-name + regexp (shadow-regexp-superquote primary) + file (make-temp-name + (expand-file-name + "shadowfile-tests" temporary-file-directory))) + (shadow-set-cluster cluster primary regexp) + + ;; The cluster name is prepended for local files. + (should + (string-equal + (shadow-contract-file-name file) (concat "/cluster:" file))) + ;; A cluster file name is preserved. + (should + (string-equal + (shadow-contract-file-name (concat "/cluster:" file)) + (concat "/cluster:" file))) + ;; `shadow-system-name' is mapped to the cluster. + (should + (string-equal + (shadow-contract-file-name (concat shadow-system-name file)) + (concat "/cluster:" file))) + + ;; Redefine the cluster. + (setq primary + (file-remote-p shadow-test-remote-temporary-file-directory) + regexp (shadow-regexp-superquote primary)) + (shadow-set-cluster cluster primary regexp) + + ;; A remote file name is mapped to the cluster. + (should + (string-equal + (shadow-contract-file-name + (concat + (file-remote-p shadow-test-remote-temporary-file-directory) file)) + (concat "/cluster:" file)))) + + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file))))) + +(ert-deftest shadow-test05-file-match () + "Check `shadow-same-site' and `shadow-file-match'." + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-unless (file-remote-p shadow-test-remote-temporary-file-directory)) + + (let ((shadow-info-file shadow-test-info-file) + (shadow-todo-file shadow-test-todo-file) + shadow-clusters + cluster primary regexp file) + (unwind-protect + (progn + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file)) + + ;; Define a cluster. + (setq cluster "cluster" + primary shadow-system-name + regexp (shadow-regexp-superquote primary) + file (make-temp-name + (expand-file-name + "shadowfile-tests" temporary-file-directory))) + (shadow-set-cluster cluster primary regexp) + + (should (shadow-same-site (shadow-parse-name "/cluster:") file)) + (should + (shadow-same-site (shadow-parse-name shadow-system-name) file)) + (should (shadow-same-site (shadow-parse-name file) file)) + + (should + (shadow-file-match + (shadow-parse-name (concat "/cluster:" file)) file)) + (should + (shadow-file-match + (shadow-parse-name (concat shadow-system-name file)) file)) + (should (shadow-file-match (shadow-parse-name file) file)) + + ;; Redefine the cluster. + (setq primary + (file-remote-p shadow-test-remote-temporary-file-directory) + regexp (shadow-regexp-superquote primary)) + (shadow-set-cluster cluster primary regexp) + + (should + (shadow-file-match + (shadow-parse-name + (concat + (file-remote-p shadow-test-remote-temporary-file-directory) + file)) + file))) + + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file))))) + +(ert-deftest shadow-test06-literal-groups () + "Check literal group definitions." + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-unless (file-remote-p shadow-test-remote-temporary-file-directory)) + + (let ((shadow-info-file shadow-test-info-file) + (shadow-todo-file shadow-test-todo-file) + shadow-clusters shadow-literal-groups + cluster1 cluster2 primary regexp file1 file2 mocked-input) + (unwind-protect + ;; We must mock `read-from-minibuffer' and `read-string', in + ;; order to avoid interactive arguments. + (cl-letf* (((symbol-function 'read-from-minibuffer) + (lambda (&rest args) (pop mocked-input))) + ((symbol-function 'read-string) + (lambda (&rest args) (pop mocked-input)))) + + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file)) + + ;; Define clusters. + (setq cluster1 "cluster1" + primary shadow-system-name + regexp (shadow-regexp-superquote primary)) + (shadow-set-cluster cluster1 primary regexp) + + (setq cluster2 "cluster2" + primary + (file-remote-p shadow-test-remote-temporary-file-directory) + regexp (format "^\\(%s\\|%s\\)$" shadow-system-name primary)) + (shadow-set-cluster cluster2 primary regexp) + + ;; Define a literal group. + (setq file1 + (make-temp-name + (expand-file-name "shadowfile-tests" temporary-file-directory)) + file2 + (make-temp-name + (expand-file-name + "shadowfile-tests" + shadow-test-remote-temporary-file-directory)) + mocked-input `(,cluster1 ,file1 ,cluster2 ,file2 ,(kbd "RET"))) + (with-temp-buffer + (setq-local buffer-file-name file1) + (call-interactively 'shadow-define-literal-group)) + + ;; `shadow-literal-groups' is a list of lists. + (should (consp shadow-literal-groups)) + (should (consp (car shadow-literal-groups))) + (should-not (cdr shadow-literal-groups)) + + (should (member (format "/%s:%s" cluster1 (file-local-name file1)) + (car shadow-literal-groups))) + (should (member (format "/%s:%s" cluster2 (file-local-name file2)) + (car shadow-literal-groups)))) + + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file))))) + +(ert-deftest shadow-test07-regexp-groups () + "Check regexp group definitions." + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-unless (file-remote-p shadow-test-remote-temporary-file-directory)) + + (let ((shadow-info-file shadow-test-info-file) + (shadow-todo-file shadow-test-todo-file) + shadow-clusters shadow-regexp-groups + cluster1 cluster2 primary regexp file mocked-input) + (unwind-protect + ;; We must mock `read-from-minibuffer' and `read-string', in + ;; order to avoid interactive arguments. + (cl-letf* (((symbol-function 'read-from-minibuffer) + (lambda (&rest args) (pop mocked-input))) + ((symbol-function 'read-string) + (lambda (&rest args) (pop mocked-input)))) + + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file)) + + ;; Define clusters. + (setq cluster1 "cluster1" + primary shadow-system-name + regexp (shadow-regexp-superquote primary)) + (shadow-set-cluster cluster1 primary regexp) + + (setq cluster2 "cluster2" + primary + (file-remote-p shadow-test-remote-temporary-file-directory) + regexp (format "^\\(%s\\|%s\\)$" shadow-system-name primary)) + (shadow-set-cluster cluster2 primary regexp) + + ;; Define a regexp group. + (setq file + (make-temp-name + (expand-file-name "shadowfile-tests" temporary-file-directory)) + mocked-input `(,(shadow-regexp-superquote file) + ,cluster1 ,cluster2 ,(kbd "RET"))) + (with-temp-buffer + (setq-local buffer-file-name nil) + (call-interactively 'shadow-define-regexp-group)) + + ;; `shadow-regexp-groups' is a list of lists. + (should (consp shadow-regexp-groups)) + (should (consp (car shadow-regexp-groups))) + (should-not (cdr shadow-regexp-groups)) + + (should + (member + (concat + (shadow-site-primary cluster1) (shadow-regexp-superquote file)) + (car shadow-regexp-groups))) + (should + (member + (concat + (shadow-site-primary cluster2) (shadow-regexp-superquote file)) + (car shadow-regexp-groups)))) + + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file))))) + +(ert-deftest shadow-test08-shadow-todo () + "Check that needed shadows are added to todo." + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-unless (file-remote-p shadow-test-remote-temporary-file-directory)) + (skip-unless (file-writable-p shadow-test-remote-temporary-file-directory)) + + (let ((backup-inhibited t) + (shadow-info-file shadow-test-info-file) + (shadow-todo-file shadow-test-todo-file) + (shadow-inhibit-message t) + shadow-clusters shadow-literal-groups shadow-regexp-groups + shadow-files-to-copy + cluster1 cluster2 primary regexp file) + (unwind-protect + (condition-case err + (progn + (require 'trace) + (dolist (elt (all-completions "shadow-" obarray 'functionp)) + (trace-function-background (intern elt))) + (trace-function-background 'save-buffer) + (dolist (elt write-file-functions) + (trace-function-background elt)) + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file)) + + (message "Point 1") + ;; Define clusters. + (setq cluster1 "cluster1" + primary shadow-system-name + regexp (shadow-regexp-superquote primary)) + (shadow-set-cluster cluster1 primary regexp) + + (setq cluster2 "cluster2" + primary + (file-remote-p shadow-test-remote-temporary-file-directory) + regexp (shadow-regexp-superquote primary)) + (shadow-set-cluster cluster2 primary regexp) + + (message "Point 2") + ;; Define a literal group. + (setq file + (make-temp-name + (expand-file-name "shadowfile-tests" temporary-file-directory)) + shadow-literal-groups + `((,(concat "/cluster1:" file) ,(concat "/cluster2:" file)))) + + (message "Point 3") + ;; Save file from "cluster1" definition. + (with-temp-buffer + (setq buffer-file-name file) + (insert "foo") + (save-buffer)) + (message "%s" file) + (message "%s" (shadow-contract-file-name (concat "/cluster2:" file))) + (message "%s" shadow-files-to-copy) + (should + (member + (cons file (shadow-contract-file-name (concat "/cluster2:" file))) + shadow-files-to-copy)) + + (message "Point 4") + ;; Save file from "cluster2" definition. + (with-temp-buffer + (message "Point 4.1") + (message "%s" file) + (message "%s" (shadow-site-primary cluster2)) + (setq buffer-file-name (concat (shadow-site-primary cluster2) file)) + (message "Point 4.2") + (insert "foo") + (message "%s" buffer-file-name) + (message "%s" write-file-functions) + (setenv "BUG_32226" "1") + (save-buffer)) + (setenv "BUG_32226") + (message "Point 4.3") + (message "%s" (shadow-site-primary cluster2)) + (message "%s" (shadow-contract-file-name (concat "/cluster1:" file))) + (message "%s" shadow-files-to-copy) + (should + (member + (cons + (concat (shadow-site-primary cluster2) file) + (shadow-contract-file-name (concat "/cluster1:" file))) + shadow-files-to-copy)) + + (message "Point 5") + ;; Define a regexp group. + (setq shadow-files-to-copy nil + shadow-regexp-groups + `((,(concat (shadow-site-primary cluster1) + (shadow-regexp-superquote file)) + ,(concat (shadow-site-primary cluster2) + (shadow-regexp-superquote file))))) + + (message "Point 6") + ;; Save file from "cluster1" definition. + (with-temp-buffer + (setq buffer-file-name file) + (insert "foo") + (save-buffer)) + (should + (member + (cons file (shadow-contract-file-name (concat "/cluster2:" file))) + shadow-files-to-copy)) + + (message "Point 7") + ;; Save file from "cluster2" definition. + (with-temp-buffer + (setq buffer-file-name (concat (shadow-site-primary cluster2) file)) + (insert "foo") + (save-buffer)) + (should + (member + (cons + (concat (shadow-site-primary cluster2) file) + (shadow-contract-file-name (concat "/cluster1:" file))) + shadow-files-to-copy))) + (error (message "Error: %s" err) (signal (car err) (cdr err)))) + + (setenv "BUG_32226") + (untrace-all) + (message "%s" (with-current-buffer trace-buffer (buffer-string))) + + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file)) + (ignore-errors + (when (file-exists-p file) + (delete-file file))) + (ignore-errors + (when (file-exists-p (concat (shadow-site-primary cluster2) file)) + (delete-file (concat (shadow-site-primary cluster2) file))))))) + +(ert-deftest shadow-test09-shadow-copy-files () + "Check that needed shadow files are copied." + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-unless (file-remote-p shadow-test-remote-temporary-file-directory)) + + (let ((backup-inhibited t) + (shadow-info-file shadow-test-info-file) + (shadow-todo-file shadow-test-todo-file) + (shadow-inhibit-message t) + (shadow-noquery t) + shadow-clusters shadow-files-to-copy + cluster1 cluster2 primary regexp file mocked-input) + (unwind-protect + (progn + ;; Cleanup. + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file)) + (when (buffer-live-p shadow-todo-buffer) + (with-current-buffer shadow-todo-buffer (erase-buffer))) + + ;; Define clusters. + (setq cluster1 "cluster1" + primary shadow-system-name + regexp (shadow-regexp-superquote primary)) + (shadow-set-cluster cluster1 primary regexp) + + (setq cluster2 "cluster2" + primary + (file-remote-p shadow-test-remote-temporary-file-directory) + regexp (shadow-regexp-superquote primary)) + (shadow-set-cluster cluster2 primary regexp) + + ;; Define files to copy. + (setq file + (make-temp-name + (expand-file-name "shadowfile-tests" temporary-file-directory)) + shadow-literal-groups + `((,(concat "/cluster1:" file) ,(concat "/cluster2:" file))) + shadow-regexp-groups + `((,(concat (shadow-site-primary cluster1) + (shadow-regexp-superquote file)) + ,(concat (shadow-site-primary cluster2) + (shadow-regexp-superquote file)))) + mocked-input `(,(concat (shadow-site-primary cluster2) file) + ,file)) + + ;; Save files. + (with-temp-buffer + (setq buffer-file-name file) + (insert "foo") + (save-buffer)) + (with-temp-buffer + (setq buffer-file-name (concat (shadow-site-primary cluster2) file)) + (insert "foo") + (save-buffer)) + + ;; We must mock `write-region', in order to check proper + ;; action. + (add-function + :before (symbol-function 'write-region) + (lambda (&rest args) + (when (and (buffer-file-name) mocked-input) + (should (equal (buffer-file-name) (pop mocked-input))))) + '((name . "write-region-mock"))) + + ;; Copy the files. + (shadow-copy-files 'noquery) + (should-not shadow-files-to-copy) + (with-current-buffer shadow-todo-buffer + (goto-char (point-min)) + (should + (looking-at (regexp-quote "(setq shadow-files-to-copy nil)"))))) + + ;; Cleanup. + (remove-function (symbol-function 'write-region) "write-region-mock") + (when (file-exists-p shadow-info-file) + (delete-file shadow-info-file)) + (when (file-exists-p shadow-todo-file) + (delete-file shadow-todo-file)) + (ignore-errors + (when (file-exists-p file) + (delete-file file))) + (ignore-errors + (when (file-exists-p (concat (shadow-site-primary cluster2) file)) + (delete-file (concat (shadow-site-primary cluster2) file))))))) + +(defun shadowfile-test-all (&optional interactive) + "Run all tests for \\[shadowfile]." + (interactive "p") + (if interactive + (ert-run-tests-interactively "^shadowfile-") + (ert-run-tests-batch "^shadowfile-"))) + +(let ((shadow-info-file shadow-test-info-file) + (shadow-todo-file shadow-test-todo-file)) + (shadow-initialize)) + +(provide 'shadowfile-tests) +;;; shadowfile-tests.el ends here diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el new file mode 100644 index 00000000000..b4ef4ab2486 --- /dev/null +++ b/test/lisp/wdired-tests.el @@ -0,0 +1,129 @@ +;;; wdired-tests.el --- tests for wdired.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'dired) +(require 'wdired) + +(defvar dired-query) ; Pacify byte compiler. + +(ert-deftest wdired-test-bug32173-01 () + "Test using non-nil wdired-use-interactive-rename. +Partially modifying a file name should succeed." + (let* ((test-dir (make-temp-file "test-dir-" t)) + (test-file (concat (file-name-as-directory test-dir) "foo.c")) + (replace "bar") + (new-file (replace-regexp-in-string "foo" replace test-file)) + (wdired-use-interactive-rename t)) + (write-region "" nil test-file nil 'silent) + (advice-add 'dired-query ; Don't ask confirmation to overwrite a file. + :override + (lambda (_sym _prompt &rest _args) (setq dired-query t)) + '((name . "advice-dired-query"))) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert replace) + (wdired-finish-edit) + (should (equal (dired-file-name-at-point) new-file))) + (if buf (kill-buffer buf)) + (delete-directory test-dir t))))) + +(ert-deftest wdired-test-bug32173-02 () + "Test using non-nil wdired-use-interactive-rename. +Aborting an edit should leaving original file name unchanged." + (let* ((test-dir (make-temp-file "test-dir-" t)) + (test-file (concat (file-name-as-directory test-dir) "foo.c")) + (wdired-use-interactive-rename t)) + (write-region "" nil test-file nil 'silent) + ;; Make dired-do-create-files-regexp a noop to mimic typing C-g + ;; at its prompt before wdired-finish-edit returns. + (advice-add 'dired-do-create-files-regexp + :override + (lambda (&rest _) (ignore)) + '((name . "advice-dired-do-create-files-regexp"))) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert "bar") + (wdired-finish-edit) + (should (equal (dired-get-filename) test-file))) + (if buf (kill-buffer buf)) + (delete-directory test-dir t))))) + +(ert-deftest wdired-test-symlink-name () + "Test the file name of a symbolic link. +The Dired and WDired functions returning the name should include +only the name before the link arrow." + (let* ((test-dir (make-temp-file "test-dir-" t)) + (link-name "foo")) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (make-symbolic-link "./bar/baz" link-name) + (revert-buffer) + (let* ((file-name (dired-get-filename)) + (dir-part (file-name-directory file-name)) + (lf-name (concat dir-part link-name))) + (should (equal file-name lf-name)) + (dired-toggle-read-only) + (should (equal (wdired-get-filename) lf-name)) + (dired-toggle-read-only))) + (if buf (kill-buffer buf)) + (delete-directory test-dir t))))) + +(ert-deftest wdired-test-unfinished-edit-01 () + "Test editing a file name without saving the change. +Finding the new name should be possible while still in +wdired-mode." + :expected-result (if (< emacs-major-version 27) :failed :passed) + (let* ((test-dir (make-temp-file "test-dir-" t)) + (test-file (concat (file-name-as-directory test-dir) "foo.c")) + (replace "bar") + (new-file (replace-regexp-in-string "foo" replace test-file))) + (write-region "" nil test-file nil 'silent) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert replace) + (should (equal (dired-get-filename) new-file)))) + (when buf + (with-current-buffer buf + ;; Prevent kill-buffer-query-functions from chiming in. + (set-buffer-modified-p nil) + (kill-buffer buf))) + (delete-directory test-dir t)))) + + +(provide 'wdired-tests) +;;; wdired-tests.el ends here |