diff options
Diffstat (limited to 'test/lisp')
80 files changed, 6609 insertions, 760 deletions
diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el index 1187700b84d..facf097815e 100644 --- a/test/lisp/abbrev-tests.el +++ b/test/lisp/abbrev-tests.el @@ -38,6 +38,12 @@ (abbrev-table-put ert-test-abbrevs :ert-test "ert-test-value") ert-test-abbrevs) +(defun setup-test-abbrev-table-with-props () + (defvar ert-test-abbrevs nil) + (define-abbrev-table 'ert-test-abbrevs '(("fb" "fooBar" nil :case-fixed t))) + (abbrev-table-put ert-test-abbrevs :ert-test "ert-test-value") + ert-test-abbrevs) + (ert-deftest abbrev-table-p-test () (should-not (abbrev-table-p 42)) (should-not (abbrev-table-p "aoeu")) @@ -230,6 +236,17 @@ (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs))) (delete-file temp-test-file))) +(ert-deftest read-write-abbrev-file-test-with-props () + "Test reading and writing abbrevs from file" + (let ((temp-test-file (make-temp-file "ert-abbrev-test")) + (ert-test-abbrevs (setup-test-abbrev-table-with-props))) + (write-abbrev-file temp-test-file) + (clear-abbrev-table ert-test-abbrevs) + (should (abbrev-table-empty-p ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "fooBar" (abbrev-expansion "fb" ert-test-abbrevs))) + (delete-file temp-test-file))) + (ert-deftest abbrev-edit-save-to-file-test () "Test saving abbrev definitions in buffer to file" (defvar ert-save-test-table nil) diff --git a/test/lisp/auth-source-pass-tests.el b/test/lisp/auth-source-pass-tests.el index 0e441ac01b1..b30419f44b0 100644 --- a/test/lisp/auth-source-pass-tests.el +++ b/test/lisp/auth-source-pass-tests.el @@ -73,102 +73,113 @@ This function is intended to be set to `auth-source-debug`." (auth-source-pass--debug-log nil)) ,@body))) +(ert-deftest auth-source-pass-any-host () + (auth-source-pass--with-store '(("foo" ("port" . "foo-port") ("host" . "foo-user")) + ("bar")) + (should-not (auth-source-pass-search :host t)))) + +(ert-deftest auth-source-pass-undefined-host () + (auth-source-pass--with-store '(("foo" ("port" . "foo-port") ("host" . "foo-user")) + ("bar")) + (should-not (auth-source-pass-search :host nil)))) + + (ert-deftest auth-source-pass-find-match-matching-at-entry-name () (auth-source-pass--with-store '(("foo")) - (should (equal (auth-source-pass--find-match "foo" nil) + (should (equal (auth-source-pass--find-match "foo" nil nil) "foo")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-part () (auth-source-pass--with-store '(("foo")) - (should (equal (auth-source-pass--find-match "https://foo" nil) + (should (equal (auth-source-pass--find-match "https://foo" nil nil) "foo")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-ignoring-user () (auth-source-pass--with-store '(("foo")) - (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil) + (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil nil) "foo")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-with-user () (auth-source-pass--with-store '(("SomeUser@foo")) - (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil) + (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil nil) "SomeUser@foo")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-prefer-full () (auth-source-pass--with-store '(("SomeUser@foo") ("foo")) - (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil) + (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil nil) "SomeUser@foo")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-prefer-full-reversed () (auth-source-pass--with-store '(("foo") ("SomeUser@foo")) - (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil) + (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil nil) "SomeUser@foo")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-without-subdomain () (auth-source-pass--with-store '(("bar.com")) - (should (equal (auth-source-pass--find-match "foo.bar.com" nil) + (should (equal (auth-source-pass--find-match "foo.bar.com" nil nil) "bar.com")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-without-subdomain-with-user () (auth-source-pass--with-store '(("someone@bar.com")) - (should (equal (auth-source-pass--find-match "foo.bar.com" "someone") + (should (equal (auth-source-pass--find-match "foo.bar.com" "someone" nil) "someone@bar.com")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-without-subdomain-with-bad-user () (auth-source-pass--with-store '(("someoneelse@bar.com")) - (should (equal (auth-source-pass--find-match "foo.bar.com" "someone") + (should (equal (auth-source-pass--find-match "foo.bar.com" "someone" nil) nil)))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-without-subdomain-prefer-full () (auth-source-pass--with-store '(("bar.com") ("foo.bar.com")) - (should (equal (auth-source-pass--find-match "foo.bar.com" nil) + (should (equal (auth-source-pass--find-match "foo.bar.com" nil nil) "foo.bar.com")))) (ert-deftest auth-source-pass-dont-match-at-folder-name () (auth-source-pass--with-store '(("foo.bar.com/foo")) - (should (equal (auth-source-pass--find-match "foo.bar.com" nil) + (should (equal (auth-source-pass--find-match "foo.bar.com" nil nil) nil)))) +(ert-deftest auth-source-pass-find-match-matching-extracting-user-from-host () + (auth-source-pass--with-store '(("foo.com/bar")) + (should (equal (auth-source-pass--find-match "https://bar@foo.com" nil nil) + "foo.com/bar")))) + (ert-deftest auth-source-pass-search-with-user-first () (auth-source-pass--with-store '(("foo") ("user@foo")) - (should (equal (auth-source-pass--find-match "foo" "user") + (should (equal (auth-source-pass--find-match "foo" "user" nil) "user@foo")) (auth-source-pass--should-have-message-containing "Found 1 match"))) (ert-deftest auth-source-pass-give-priority-to-desired-user () (auth-source-pass--with-store '(("foo") ("subdir/foo" ("user" . "someone"))) - (should (equal (auth-source-pass--find-match "foo" "someone") + (should (equal (auth-source-pass--find-match "foo" "someone" nil) "subdir/foo")) (auth-source-pass--should-have-message-containing "Found 2 matches") (auth-source-pass--should-have-message-containing "matching user field"))) (ert-deftest auth-source-pass-give-priority-to-desired-user-reversed () (auth-source-pass--with-store '(("foo" ("user" . "someone")) ("subdir/foo")) - (should (equal (auth-source-pass--find-match "foo" "someone") + (should (equal (auth-source-pass--find-match "foo" "someone" nil) "foo")) (auth-source-pass--should-have-message-containing "Found 2 matches") (auth-source-pass--should-have-message-containing "matching user field"))) (ert-deftest auth-source-pass-return-first-when-several-matches () (auth-source-pass--with-store '(("foo") ("subdir/foo")) - (should (equal (auth-source-pass--find-match "foo" nil) + (should (equal (auth-source-pass--find-match "foo" nil nil) "foo")) (auth-source-pass--should-have-message-containing "Found 2 matches") (auth-source-pass--should-have-message-containing "the first one"))) (ert-deftest auth-source-pass-make-divansantana-happy () (auth-source-pass--with-store '(("host.com")) - (should (equal (auth-source-pass--find-match "smtp.host.com" "myusername@host.co.za") + (should (equal (auth-source-pass--find-match "smtp.host.com" "myusername@host.co.za" nil) "host.com")))) -(ert-deftest auth-source-pass-hostname () - (should (equal (auth-source-pass--hostname "https://foo.bar") "foo.bar")) - (should (equal (auth-source-pass--hostname "http://foo.bar") "foo.bar")) - (should (equal (auth-source-pass--hostname "https://SomeUser@foo.bar") "foo.bar"))) - -(ert-deftest auth-source-pass-hostname-with-user () - (should (equal (auth-source-pass--hostname-with-user "https://foo.bar") "foo.bar")) - (should (equal (auth-source-pass--hostname-with-user "http://foo.bar") "foo.bar")) - (should (equal (auth-source-pass--hostname-with-user "https://SomeUser@foo.bar") "SomeUser@foo.bar"))) +(ert-deftest auth-source-pass-find-host-without-port () + (auth-source-pass--with-store '(("host.com")) + (should (equal (auth-source-pass--find-match "host.com:8888" "someuser" nil) + "host.com")))) (defmacro auth-source-pass--with-store-find-foo (store &rest body) "Use STORE while executing BODY. \"foo\" is the matched entry." @@ -197,14 +208,25 @@ This function is intended to be set to `auth-source-debug`." (should (equal (plist-get result :port) 512)) (should (equal (plist-get result :user) "anuser"))))) +(ert-deftest auth-source-pass-build-result-passes-full-host-to-find-match () + (let (passed-host) + (cl-letf (((symbol-function 'auth-source-pass--find-match) + (lambda (host _user _port) (setq passed-host host)))) + (auth-source-pass--build-result "https://user@host.com:123" nil nil) + (should (equal passed-host "https://user@host.com:123")) + (auth-source-pass--build-result "https://user@host.com" nil nil) + (should (equal passed-host "https://user@host.com")) + (auth-source-pass--build-result "user@host.com" nil nil) + (should (equal passed-host "user@host.com")) + (auth-source-pass--build-result "user@host.com:443" nil nil) + (should (equal passed-host "user@host.com:443"))))) + (ert-deftest auth-source-pass-only-return-entries-that-can-be-open () (cl-letf (((symbol-function 'auth-source-pass-entries) - (lambda () '("foo.site.com" "bar.site.com" - "mail/baz.site.com/scott"))) + (lambda () '("foo.site.com" "bar.site.com" "mail/baz.site.com/scott"))) ((symbol-function 'auth-source-pass--entry-valid-p) ;; only foo.site.com and "mail/baz.site.com/scott" are valid - (lambda (entry) (member entry '("foo.site.com" - "mail/baz.site.com/scott"))))) + (lambda (entry) (member entry '("foo.site.com" "mail/baz.site.com/scott"))))) (should (equal (auth-source-pass--find-all-by-entry-name "foo.site.com" "someuser") '("foo.site.com"))) (should (equal (auth-source-pass--find-all-by-entry-name "bar.site.com" "someuser") @@ -222,6 +244,13 @@ This function is intended to be set to `auth-source-debug`." (should (auth-source-pass--entry-valid-p "foo")) (should-not (auth-source-pass--entry-valid-p "bar")))) +(ert-deftest auth-source-pass-can-start-from-auth-source-search () + (auth-source-pass--with-store '(("gitlab.com" ("user" . "someone"))) + (auth-source-pass-enable) + (let ((result (car (auth-source-search :host "gitlab.com")))) + (should (equal (plist-get result :user) "someone")) + (should (equal (plist-get result :host) "gitlab.com"))))) + (provide 'auth-source-pass-tests) ;;; auth-source-pass-tests.el ends here diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el index 90caac8e4a2..ca8a3eb78f0 100644 --- a/test/lisp/auth-source-tests.el +++ b/test/lisp/auth-source-tests.el @@ -29,9 +29,7 @@ (require 'ert) (require 'cl-lib) (require 'auth-source) - -(defvar secrets-enabled t - "Enable the secrets backend to test its features.") +(require 'secrets) (defun auth-source-ensure-ignored-backend (source) (auth-source-validate-backend source '((:source . "") @@ -308,6 +306,44 @@ (should (equal found-as-string (concat testname ": " needed))))) (delete-file netrc-file))) +(ert-deftest auth-source-test-secrets-create-secret () + (skip-unless secrets-enabled) + ;; The "session" collection is temporary for the lifetime of the + ;; Emacs process. Therefore, we don't care to delete it. + (let ((auth-sources '((:source (:secrets "session")))) + (auth-source-save-behavior t) + (host (md5 (concat (prin1-to-string process-environment) + (current-time-string)))) + (passwd (md5 (concat (prin1-to-string process-environment) + (current-time-string) (current-time-string)))) + auth-info auth-passwd) + ;; Redefine `read-*' in order to avoid interactive input. + (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd)) + ((symbol-function 'read-string) + (lambda (_prompt _initial _history default) default))) + (setq auth-info + (car (auth-source-search + :max 1 :host host :require '(:user :secret) :create t)))) + (should (functionp (plist-get auth-info :save-function))) + (funcall (plist-get auth-info :save-function)) + + ;; Check, that the item has been created indeed. + (auth-source-forget+ :host t) + (setq auth-info (car (auth-source-search :host host)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (should (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (string-equal auth-passwd passwd)) + + ;; Cleanup. + ;; Should use `auth-source-delete' when implemented for :secrets backend. + (secrets-delete-item + "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 diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 8f375b63a69..9710600f169 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -161,12 +161,13 @@ This expects `auto-revert--messages' to be bound by :tags '(:expensive-test) (let ((tmpfile (make-temp-file "auto-revert-test")) - buf) + buf desc) (unwind-protect (progn (write-region "any text" nil tmpfile nil 'no-message) (setq buf (find-file-noselect tmpfile)) (with-current-buffer buf + (should-not auto-revert-notify-watch-descriptor) (should (string-equal (buffer-string) "any text")) ;; `buffer-stale--default-function' checks for ;; `verify-visited-file-modtime'. We must ensure that @@ -174,12 +175,16 @@ This expects `auto-revert--messages' to be bound by (sleep-for 1) (auto-revert-mode 1) (should auto-revert-mode) + (setq desc auto-revert-notify-watch-descriptor) ;; Remove file while reverting. We simulate this by ;; modifying `before-revert-hook'. (add-hook 'before-revert-hook - (lambda () (delete-file buffer-file-name)) + (lambda () + ;; Temporarily. + (message "%s deleted" buffer-file-name) + (delete-file buffer-file-name)) nil t) (ert-with-message-capture auto-revert--messages @@ -192,7 +197,7 @@ This expects `auto-revert--messages' to be bound by (should (string-match "any text" (buffer-string))) ;; With w32notify, the 'stopped' events are not sent. (or (eq file-notify--library 'w32notify) - (should-not auto-revert-use-notify)) + (should-not auto-revert-notify-watch-descriptor)) ;; Once the file has been recreated, the buffer shall be ;; reverted. @@ -203,6 +208,11 @@ This expects `auto-revert--messages' to be bound by (auto-revert--wait-for-revert buf)) ;; Check, that the buffer has been reverted. (should (string-match "another text" (buffer-string))) + ;; When file notification is used, it must be reenabled + ;; after recreation of the file. We cannot expect that + ;; the descriptor is the same, so we just check the + ;; existence. + (should (eq (null desc) (null auto-revert-notify-watch-descriptor))) ;; An empty file shall still be reverted. (ert-with-message-capture auto-revert--messages diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el index 159294f8162..015fbaccf4d 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,271 @@ 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 () ; bug#32343 + "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 () ; bug#32343 + "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 () ; bug#32343 + "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 () ; bug#32343 + "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 () ; bug#32343 + "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 () ; bug#32343 + "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 () ; bug#32343 + "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 () ; bug#32343 + "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 () ; bug#32343 + "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 () ; bug#32343 + "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 () ; bug#32343 + "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 () ; bug#32343 + "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 () ; bug#32343 + "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))))) + +(ert-deftest todo-test-current-file-in-edit-mode () ; bug#32437 + "Test the value of todo-current-todo-file in todo-edit-mode." + (with-todo-test + (todo-test--show 1) + ;; The preceding calls todo-mode but does not run pre-command-hook + ;; in the test environment, thus failing to set + ;; todo-global-current-todo-file, which is needed for the test + ;; after todo-edit-item--text. So force the hook function to run. + (ert-simulate-command '(todo-mode)) + (let ((curfile todo-current-todo-file)) + (should (equal curfile todo-test-file-1)) + (todo-edit-item--text 'multiline) + (should (equal todo-current-todo-file curfile)) + (todo-edit-quit) + (todo-edit-file) + (should (equal todo-current-todo-file curfile)) + (todo-edit-quit)) + (todo-find-archive) + (let ((curfile todo-current-todo-file)) + (should (equal curfile todo-test-archive-1)) + (todo-edit-file) + (should (equal todo-current-todo-file curfile))))) + +(ert-deftest todo-test-edit-quit () ; bug#32437 + "Test result of exiting todo-edit-mode on a whole file. +Exiting should return to the same todo-mode or todo-archive-mode +buffer from which the editing command was invoked." + (with-todo-test + (todo-test--show 1) + (let ((buf (current-buffer))) + (todo-edit-file) + (todo-edit-quit) + (should (eq (current-buffer) buf)) + (should (eq major-mode 'todo-mode)) + (todo-find-archive) + (let ((buf (current-buffer))) + (todo-edit-file) + (todo-edit-quit) + (should (eq (current-buffer) buf)) + (should (eq major-mode 'todo-archive-mode)))))) + +(defun todo-test--add-file (file cat) + "Add file FILE with category CAT to todo-files and show it. +This provides a noninteractive API for todo-add-file for use in +automatic testing." + (let ((file0 (file-truename (concat todo-test-data-dir file ".todo"))) + todo-add-item-if-new-category) ; Don't need an item in cat. + (cl-letf (((symbol-function 'todo-read-file-name) + (lambda (_prompt) file0)) + ((symbol-function 'todo-read-category) + (lambda (_prompt &optional _match-type _file) (cons cat file0)))) + (call-interactively 'todo-add-file) ; Interactive to call todo-show. + (todo-add-category file0 cat)))) + +(defun todo-test--delete-file () + "Delete current todo file without prompting." + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (_prompt) t))) + (todo-delete-file))) + +(ert-deftest todo-test-add-and-delete-file () ; bug#32627 + "Test adding a new todo file and then deleting it. +Calling todo-show should display the last current todo file, not +necessarily the new file. After deleting the new file, todo-show +should display the previously current (or default) todo file." + (with-todo-test + (todo-show) + (should (equal todo-current-todo-file todo-test-file-1)) + (let* ((file (concat todo-directory "todo-test-2.todo")) + (file-nb (file-name-base file)) + (cat "cat21")) + (todo-test--add-file file-nb cat) ; Add new file and show it. + (should (equal todo-current-todo-file file)) + (todo-quit) ; Quitting todo-mode displays previous buffer. + (should (equal todo-current-todo-file todo-test-file-1)) + (switch-to-buffer "*scratch*") + (todo-show) ; Show the last current todo-file (not the new one). + (should (equal todo-current-todo-file todo-test-file-1)) + (switch-to-buffer (get-file-buffer file)) ; Back to new file. + (should (equal todo-current-todo-file file)) + (todo-test--delete-file) + (todo-show) ; Back to old file. + (should (equal todo-current-todo-file todo-test-file-1)) + (delete-file (concat file "~"))))) + (provide 'todo-mode-tests) ;;; todo-mode-tests.el ends here diff --git a/test/lisp/char-fold-tests.el b/test/lisp/char-fold-tests.el index eb8dec74d65..364975317f2 100644 --- a/test/lisp/char-fold-tests.el +++ b/test/lisp/char-fold-tests.el @@ -117,16 +117,14 @@ (char-fold-to-regexp string))) (with-temp-buffer (save-excursion (insert string)) - (let ((time (time-to-seconds (current-time)))) + (let ((time (time-to-seconds))) ;; Our initial implementation of case-folding in char-folding ;; created a lot of redundant paths in the regexp. Because of ;; that, if a really long string "almost" matches, the regexp ;; engine took a long time to realize that it doesn't match. (should-not (char-fold-search-forward (concat string "c") nil 'noerror)) ;; Ensure it took less than a second. - (should (< (- (time-to-seconds (current-time)) - time) - 1)))))) + (should (< (- (time-to-seconds) time) 1)))))) (provide 'char-fold-tests) ;;; char-fold-tests.el ends here diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el index 64898888ba8..eab2709cea9 100644 --- a/test/lisp/comint-tests.el +++ b/test/lisp/comint-tests.el @@ -36,9 +36,10 @@ "Enter same passphrase again: " ; ssh-keygen "Passphrase for key root@GNU.ORG: " ; plink "[sudo] password for user:" ; Ubuntu sudo + "[sudo] user 的密码：" ; localized "Password (again):" "Enter password:" - "Mot de Passe:" ; localized + "Mot de Passe :" ; localized (Bug#29729) "Passwort:") ; localized "List of strings that should match `comint-password-prompt-regexp'.") 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/dired-aux-tests.el b/test/lisp/dired-aux-tests.el index f7935cd38b9..daf60f760e0 100644 --- a/test/lisp/dired-aux-tests.el +++ b/test/lisp/dired-aux-tests.el @@ -20,7 +20,7 @@ ;;; Code: (require 'ert) (require 'dired-aux) - +(eval-when-compile (require 'cl-lib)) (ert-deftest dired-test-bug27496 () "Test for https://debbugs.gnu.org/27496 ." @@ -40,5 +40,80 @@ (should-not (dired-do-shell-command "ls ? ./`?`" nil files))) (delete-file foo)))) +;; Auxiliar macro for `dired-test-bug28834': it binds +;; `dired-create-destination-dirs' to CREATE-DIRS and execute BODY. +;; If YES-OR-NO is non-nil, it binds `yes-or-no-p' to +;; to avoid the prompt. +(defmacro with-dired-bug28834-test (create-dirs yes-or-no &rest body) + (declare (debug (form symbolp body))) + (let ((foo (make-symbol "foo"))) + `(let* ((,foo (make-temp-file "foo" 'dir)) + (dired-create-destination-dirs ,create-dirs)) + (setq from (make-temp-file "from")) + (setq to-cp + (expand-file-name + "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo)))) + (setq to-mv + (expand-file-name + "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo)))) + (unwind-protect + (if ,yes-or-no + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (_prompt) (eq ,yes-or-no 'yes)))) + ,@body) + ,@body) + ;; clean up + (delete-directory ,foo 'recursive) + (delete-file from))))) + +(ert-deftest dired-test-bug28834 () + "test for https://debbugs.gnu.org/28834 ." + (let (from to-cp to-mv) + ;; `dired-create-destination-dirs' set to 'always. + (with-dired-bug28834-test + 'always nil + (dired-copy-file-recursive from to-cp nil) + (should (file-exists-p to-cp)) + (dired-rename-file from to-mv nil) + (should (file-exists-p to-mv))) + ;; `dired-create-destination-dirs' set to nil. + (with-dired-bug28834-test + nil nil + (should-error (dired-copy-file-recursive from to-cp nil)) + (should-error (dired-rename-file from to-mv nil))) + ;; `dired-create-destination-dirs' set to 'ask. + (with-dired-bug28834-test + 'ask 'yes ; Answer `yes' + (dired-copy-file-recursive from to-cp nil) + (should (file-exists-p to-cp)) + (dired-rename-file from to-mv nil) + (should (file-exists-p to-mv))) + (with-dired-bug28834-test + 'ask 'no ; Answer `no' + (should-error (dired-copy-file-recursive from to-cp nil)) + (should-error (dired-rename-file from to-mv nil))))) + +(ert-deftest dired-test-bug30624 () + "test for https://debbugs.gnu.org/30624 ." + (cl-letf* ((target-dir (make-temp-file "target" 'dir)) + ((symbol-function 'dired-mark-read-file-name) + (lambda (&rest _) target-dir)) + (inhibit-message t)) + ;; Delete target-dir: `dired-do-create-files' must recreate it. + (delete-directory target-dir) + (let ((file1 (make-temp-file "bug30624_file1")) + (file2 (make-temp-file "bug30624_file2")) + (dired-create-destination-dirs 'always) + (buf (dired temporary-file-directory))) + (unwind-protect + (progn + (dired-revert) + (dired-mark-files-regexp "bug30624_file") + (should (dired-do-create-files 'copy 'dired-copy-file "Copy" nil))) + (delete-directory target-dir 'recursive) + (mapc #'delete-file `(,file1 ,file2)) + (kill-buffer buf))))) + + (provide 'dired-aux-tests) ;; dired-aux-tests.el ends here diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el index bb0e1bc3880..49ae4bc0400 100644 --- a/test/lisp/dired-tests.el +++ b/test/lisp/dired-tests.el @@ -210,12 +210,12 @@ (concat (file-name-as-directory test-dir) (file-name-as-directory "test-subdir")))) (push (dired-find-file) buffers) - (let ((pt2 (point))) ; Point is on test-file. - (switch-to-buffer buf) - ;; Sanity check: point should now be back on the subdirectory. - (should (eq (point) pt1)) - (push (dired test-dir) buffers) - (should (eq (point) pt1)))) + ;; Point is on test-file. + (switch-to-buffer buf) + ;; Sanity check: point should now be back on the subdirectory. + (should (eq (point) pt1)) + (push (dired test-dir) buffers) + (should (eq (point) pt1))) (dolist (buf buffers) (when (buffer-live-p buf) (kill-buffer buf))) (delete-directory test-dir t)))) @@ -224,7 +224,7 @@ "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#61 ." (let ((test-dir (make-temp-file "test-dir-" t)) (dired-auto-revert-buffer t) - test-subdir1 test-subdir2 allbufs) + allbufs) (unwind-protect (progn (with-current-buffer (find-file-noselect test-dir) @@ -294,9 +294,9 @@ (ert-deftest dired-test-bug27899 () "Test for https://debbugs.gnu.org/27899 ." - (let* ((dir (expand-file-name "src" source-directory)) - (buf (dired (list dir "cygw32.c" "alloc.c" "w32xfns.c" "xdisp.c"))) - (orig dired-hide-details-mode)) + (dired (list (expand-file-name "src" source-directory) + "cygw32.c" "alloc.c" "w32xfns.c" "xdisp.c")) + (let ((orig dired-hide-details-mode)) (dired-goto-file (expand-file-name "cygw32.c")) (forward-line 0) (unwind-protect @@ -362,8 +362,7 @@ (defmacro dired-test-with-temp-dirs (just-empty-dirs &rest body) "Helper macro for Bug#27940 test." (declare (indent 1) (debug body)) - (let ((dir (make-symbol "dir")) - (ignore-funcs (make-symbol "ignore-funcs"))) + (let ((dir (make-symbol "dir"))) `(let* ((,dir (make-temp-file "bug27940" t)) (dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts. (inhibit-message t) diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index 8a13c8c7b2c..7e94dfa496c 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -114,14 +114,30 @@ mode extra-desc)) () - ,(format "With |%s|, try input %c at point %d. \ -Should %s |%s| and point at %d" + ,(format "Electricity test in a `%s' buffer.\n +Start with point at %d in a %d-char-long buffer +like this one: + + |%s| (buffer start and end are denoted by `|') +%s +%s +Now press the key for: %c + +The buffer's contents should %s: + + |%s| + +, and point should be at %d." + mode + (1+ pos) + (length fixture) fixture + (if fixture-fn (format "\nNow call this:\n\n%s" + (pp-to-string fixture-fn)) "") + (if bindings (format "\nEnsure the following bindings:\n\n%s" + (pp-to-string bindings)) "") char - (1+ pos) - (if (string= fixture expected-string) - "stay" - "become") + (if (string= fixture expected-string) "stay" "become") (replace-regexp-in-string "\n" "\\\\n" expected-string) expected-point) (electric-pair-test-for ,fixture @@ -375,6 +391,16 @@ baz\"\"" :bindings '((electric-pair-skip-whitespace . chomp)) :test-in-comments nil) + +;; A test failure introduced by some changes in CC mode. Hopefully CC +;; mode will sort this out eventually, using some new e-p-m machinery. +;; See +;; https://lists.gnu.org/archive/html/emacs-devel/2018-06/msg00535.html +(setf + (ert-test-expected-result-type + (ert-get-test 'electric-pair-whitespace-chomping-2-at-point-4-in-c++-mode-in-strings)) + :failed) + (define-electric-pair-test whitespace-chomping-dont-cross-comments " ( \n\t\t\n ) " "--)------" :expected-string " () \n\t\t\n ) " :expected-point 4 @@ -617,6 +643,12 @@ baz\"\"" :fixture-fn #'electric-quote-local-mode :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-disabled + "" "\"" :expected-string "\"" :expected-point 2 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-backtick "" "`" :expected-string "`" :expected-point 2 :modes '(text-mode) @@ -638,6 +670,13 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-bob + "" "\"" :expected-string "“" :expected-point 2 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-bol-single "a\n" "--'" :expected-string "a\n‘" :expected-point 4 :modes '(text-mode) @@ -652,6 +691,13 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-bol + "a\n" "--\"" :expected-string "a\n“" :expected-point 4 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-after-space-single " " "-'" :expected-string " ‘" :expected-point 3 :modes '(text-mode) @@ -666,6 +712,13 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-after-space + " " "-\"" :expected-string " “" :expected-point 3 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-after-letter-single "a" "-'" :expected-string "a’" :expected-point 3 :modes '(text-mode) @@ -680,6 +733,13 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-after-letter + "a" "-\"" :expected-string "a”" :expected-point 3 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-after-paren-single "(" "-'" :expected-string "(‘" :expected-point 3 :modes '(text-mode) @@ -694,6 +754,38 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-after-paren + "(" "-\"" :expected-string "(“" :expected-point 3 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + +(define-electric-pair-test electric-quote-replace-double-no-context-single + " " "-'" :expected-string " ’" :expected-point 3 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + +(define-electric-pair-test electric-quote-replace-double-escaped-open + "foo \\" "-----\"" :expected-string "foo \\“" + :expected-point 7 :modes '(emacs-lisp-mode c-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t) + (electric-quote-comment . t) + (electric-quote-string . t)) + :test-in-comments t :test-in-strings t :test-in-code nil) + +(define-electric-pair-test electric-quote-replace-double-escaped-close + "foo \\“foo\\" "----------\"" :expected-string "foo \\“foo\\”" + :expected-point 12 :modes '(emacs-lisp-mode c-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t) + (electric-quote-comment . t) + (electric-quote-string . t)) + :test-in-comments t :test-in-strings t :test-in-code nil) + ;; Simulate ‘markdown-mode’: it sets both ‘comment-start’ and ;; ‘comment-use-syntax’, but derives from ‘text-mode’. (define-electric-pair-test electric-quote-markdown-in-text 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/benchmark-tests.el b/test/lisp/emacs-lisp/benchmark-tests.el index 8de7818bdbf..26bd3ff08a8 100644 --- a/test/lisp/emacs-lisp/benchmark-tests.el +++ b/test/lisp/emacs-lisp/benchmark-tests.el @@ -23,29 +23,37 @@ (require 'ert) (ert-deftest benchmark-tests () - (let (str t-long t-short) - (should (consp (benchmark-run nil (1+ 0)))) - (should (consp (benchmark-run 1 (1+ 0)))) + (let (str t-long t-short m) + (should (consp (benchmark-run nil (setq m (1+ 0))))) + (should (consp (benchmark-run 1 (setq m (1+ 0))))) (should (stringp (benchmark nil (1+ 0)))) (should (stringp (benchmark 1 (1+ 0)))) - (should (consp (benchmark-run-compiled nil (1+ 0)))) + (should (consp (benchmark-run-compiled (1+ 0)))) (should (consp (benchmark-run-compiled 1 (1+ 0)))) ;; First test is heavier, must need longer time. - (should (> (car (benchmark-run nil + (let ((count1 0) + (count2 0) + (repeat 2)) + (ignore (benchmark-run (setq count1 (1+ count1)))) + (ignore (benchmark-run repeat (setq count2 (1+ count2)))) + (should (> count2 count1))) + (should (> (car (benchmark-run (let ((n 100000)) (while (> n 1) (setq n (1- n)))))) - (car (benchmark-run nil (1+ 0))))) - (should (> (car (benchmark-run nil + (car (benchmark-run (setq m (1+ 0)))))) + (should (> (car (benchmark-run (let ((n 100000)) (while (> n 1) (setq n (1- n)))))) - (car (benchmark-run nil (1+ 0))))) - (should (> (car (benchmark-run-compiled nil + (car (benchmark-run (setq m (1+ 0)))))) + (should (> (car (benchmark-run-compiled (let ((n 100000)) (while (> n 1) (setq n (1- n)))))) - (car (benchmark-run-compiled nil (1+ 0))))) + (car (benchmark-run-compiled (1+ 0))))) (setq str (benchmark nil '(let ((n 100000)) (while (> n 1) (setq n (1- n)))))) (string-match "Elapsed time: \\([0-9.]+\\)" str) (setq t-long (string-to-number (match-string 1 str))) (setq str (benchmark nil '(1+ 0))) (string-match "Elapsed time: \\([0-9.]+\\)" str) (setq t-short (string-to-number (match-string 1 str))) - (should (> t-long t-short)))) + (should (> t-long t-short)) + ;; Silence compiler. + m)) ;;; benchmark-tests.el ends here. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index f93c3bdc40f..ba625490960 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -27,6 +27,7 @@ (require 'ert) (require 'cl-lib) +(require 'bytecomp) ;;; Code: (defconst byte-opt-testsuite-arith-data @@ -38,8 +39,7 @@ (let ((a 3) (b 2) (c 1.0)) (/ a b c)) (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (+ a -1 b)) (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (- a 1 (- b))) - ;; This fails. Should it be a bug? - ;; (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) + (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) (let ((a 1.0)) (* a 0)) (let ((a 1.0)) (* a 2.0 0)) (let ((a 1.0)) (/ 0 a)) @@ -244,6 +244,9 @@ (let ((a 3) (b 2) (c 1.0)) (/ a b c 0)) (let ((a 3) (b 2) (c 1.0)) (/ a b c 1)) (let ((a 3) (b 2) (c 1.0)) (/ a b c -1)) + + (let ((a t)) (logand 0 a)) + ;; Test switch bytecode (let ((a 3)) (cond ((eq a 1) 'one) ((eq a 2) 'two) ((eq a 3) 'three) (t t))) (let ((a 'three)) (cond ((eq a 'one) 1) ((eq a 2) 'two) ((eq a 'three) 3) @@ -541,23 +544,17 @@ literals (Bug#20852)." (ert-deftest bytecomp-tests--old-style-backquotes () "Check that byte compiling warns about old-style backquotes." - (should (boundp 'lread--old-style-backquotes)) (bytecomp-tests--with-temp-file source (write-region "(` (a b))" nil source) (bytecomp-tests--with-temp-file destination (let* ((byte-compile-dest-file-function (lambda (_) destination)) - (byte-compile-error-on-warn t) - (byte-compile-debug t) - (err (should-error (byte-compile-file source)))) - (should (equal (cdr err) - (list "!! The file uses old-style backquotes !! -This functionality has been obsolete for more than 10 years already -and will be removed soon. See (elisp)Backquote in the manual."))))))) + (byte-compile-debug t) + (err (should-error (byte-compile-file source)))) + (should (equal (cdr err) '("Old-style backquotes detected!"))))))) (ert-deftest bytecomp-tests-function-put () "Check `function-put' operates during compilation." - (should (boundp 'lread--old-style-backquotes)) (bytecomp-tests--with-temp-file source (dolist (form '((function-put 'bytecomp-tests--foo 'foo 1) (function-put 'bytecomp-tests--foo 'bar 2) @@ -582,6 +579,38 @@ and will be removed soon. See (elisp)Backquote in the manual."))))))) (goto-char (point-min)) (should-not (search-forward "Warning" nil t)))) +(ert-deftest bytecomp-test-featurep-warnings () + (let ((byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) + (unwind-protect + (progn + (with-temp-buffer + (insert "\ +\(defun foo () + (an-undefined-function)) + +\(defun foo1 () + (if (featurep 'xemacs) + (some-undefined-function-if))) + +\(defun foo2 () + (and (featurep 'xemacs) + (some-undefined-function-and))) + +\(defun foo3 () + (if (not (featurep 'emacs)) + (some-undefined-function-not))) + +\(defun foo4 () + (or (featurep 'emacs) + (some-undefined-function-or))) +") + (byte-compile-from-buffer (current-buffer))) + (with-current-buffer byte-compile-log-buffer + (should (search-forward "an-undefined-function" nil t)) + (should-not (search-forward "some-undefined-function" nil t)))) + (if (buffer-live-p byte-compile-log-buffer) + (kill-buffer byte-compile-log-buffer))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el new file mode 100644 index 00000000000..d14847ce45e --- /dev/null +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -0,0 +1,40 @@ +;;; cconv-tests.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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +(require 'ert) + +(ert-deftest cconv-convert-lambda-lifted () + "Bug#30872." + (should + (equal (funcall + (byte-compile + '#'(lambda (handle-fun arg) + (let* ((subfun + #'(lambda (params) + (ignore handle-fun) + (funcall #'(lambda () (setq params 42))) + params))) + (funcall subfun arg)))) + nil 99) + 42))) + +(provide 'cconv-tests) +;; cconv-tests.el ends here. diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 26bc6188738..f100e8c6c5f 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -201,6 +201,10 @@ :b :a :a 42) '(42 :a)))) +(ert-deftest cl-lib-empty-keyargs () + (should-error (funcall (cl-function (lambda (&key) 1)) + :b 1))) + (cl-defstruct (mystruct (:constructor cl-lib--con-1 (&aux (abc 1))) (:constructor cl-lib--con-2 (&optional def) "Constructor docstring.")) @@ -512,6 +516,17 @@ (ert-deftest cl-lib-symbol-macrolet-2 () (should (equal (cl-lib-symbol-macrolet-4+5) (+ 4 5)))) + +(ert-deftest cl-lib-symbol-macrolet-hide () + ;; bug#26325, bug#26073 + (should (equal (let ((y 5)) + (cl-symbol-macrolet ((x y)) + (list x + (let ((x 6)) (list x y)) + (cl-letf ((x 6)) (list x y)) + (apply (lambda (x) (+ x 1)) (list 8))))) + '(5 (6 5) (6 6) 9)))) + (defun cl-lib-tests--dummy-function () ;; Dummy function to see if the file is compiled. t) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index f0bde7af397..6e9fb44b4b0 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -497,4 +497,20 @@ collection clause." vconcat (vector (1+ x))) [2 3 4 5 6]))) +(ert-deftest cl-macs-loop-for-as-equals-and () + "Test for https://debbugs.gnu.org/29799 ." + (let ((arr (make-vector 3 0))) + (should (equal '((0 0) (1 1) (2 2)) + (cl-loop for k below 3 for x = k and z = (elt arr k) + collect (list k x)))))) + + +(ert-deftest cl-defstruct/builtin-type () + (should-error + (macroexpand '(cl-defstruct hash-table)) + :type 'wrong-type-argument) + (should-error + (macroexpand '(cl-defstruct (hash-table (:predicate hash-table-p)))) + :type 'wrong-type-argument)) + ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-preloaded-tests.el b/test/lisp/emacs-lisp/cl-preloaded-tests.el new file mode 100644 index 00000000000..9d5feee396a --- /dev/null +++ b/test/lisp/emacs-lisp/cl-preloaded-tests.el @@ -0,0 +1,33 @@ +;;; cl-preloaded-tests.el --- unit tests for cl-preloaded.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. +;; Author: Philipp Stephani <phst@google.com> + +;; 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Unit tests for lisp/emacs-lisp/cl-preloaded.el. + +;;; Code: + +(ert-deftest cl-struct-define/builtin-type () + (should-error + (cl-struct-define 'hash-table nil nil 'record nil nil + 'cl-preloaded-tests-tag 'cl-preloaded-tests nil) + :type 'wrong-type-argument)) + +;;; cl-preloaded-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/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index c6da9e15fa3..52014aea01e 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -326,7 +326,7 @@ ) (ert-deftest eieio-test-method-order-list-9 () - (should (eitest-Jd "test"))) + (should (eitest-Jd))) ;;; call-next-method with replacement arguments across a simple class hierarchy. ;; @@ -372,7 +372,7 @@ (ert-deftest eieio-test-method-order-list-10 () (let ((eieio-test-call-next-method-arguments nil)) - (CNM-M (CNM-2 "") '(INIT)) + (CNM-M (CNM-2) '(INIT)) (should (equal (eieio-test-arguments-for 'CNM-0) '(CNM-1-1 CNM-2 INIT))) (should (equal (eieio-test-arguments-for 'CNM-1-1) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el index eae69c89eb2..f5c25e64912 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -107,7 +107,7 @@ This is usually a symbol that starts with `:'." (ert-deftest eieio-test-persist-simple-1 () (let ((persist-simple-1 - (persist-simple "simple 1" :slot1 'goose :slot2 "testing" + (persist-simple :slot1 'goose :slot2 "testing" :file (concat default-directory "test-ps1.pt")))) (should persist-simple-1) @@ -141,7 +141,7 @@ Assume SLOTVALUE is a symbol of some sort." (ert-deftest eieio-test-persist-printer () (let ((persist-:printer-1 - (persist-:printer "persist" :slot1 'goose :slot2 "testing" + (persist-:printer :slot1 'goose :slot2 "testing" :file (concat default-directory "test-ps2.pt")))) (should persist-:printer-1) (persist-test-save-and-compare persist-:printer-1) @@ -178,8 +178,7 @@ persistent class.") (ert-deftest eieio-test-non-persistent-as-slot () (let ((persist-wos (persistent-with-objs-slot - "persist wos 1" - :pnp (persist-not-persistent "pnp 1" :slot1 3) + :pnp (persist-not-persistent :slot1 3) :file (concat default-directory "test-ps3.pt")))) (persist-test-save-and-compare persist-wos) @@ -205,8 +204,7 @@ persistent class.") (ert-deftest eieio-test-non-persistent-as-slot-child () (let ((persist-woss (persistent-with-objs-slot-subs - "persist woss 1" - :pnp (persist-not-persistent-subclass "pnps 1" :slot1 3) + :pnp (persist-not-persistent-subclass :slot1 3) :file (concat default-directory "test-ps4.pt")))) (persist-test-save-and-compare persist-woss) @@ -228,7 +226,7 @@ persistent class.") (ert-deftest eieio-test-multiple-class-slot () (let ((persist - (persistent-multiclass-slot "random string" + (persistent-multiclass-slot :slot1 (persistent-random-class) :slot2 (persist-not-persistent) :slot3 (persistent-random-class) @@ -249,10 +247,9 @@ persistent class.") (ert-deftest eieio-test-slot-with-list-of-objects () (let ((persist-wols (persistent-with-objs-list-slot - "persist wols 1" - :pnp (list (persist-not-persistent "pnp 1" :slot1 3) - (persist-not-persistent "pnp 2" :slot1 4) - (persist-not-persistent "pnp 3" :slot1 5)) + :pnp (list (persist-not-persistent :slot1 3) + (persist-not-persistent :slot1 4) + (persist-not-persistent :slot1 5)) :file (concat default-directory "test-ps5.pt")))) (persist-test-save-and-compare persist-wols) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index 5ba094c0072..74c76609b87 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -689,7 +689,7 @@ Do not override for `prot-2'." (defvar eitest-II2 nil) (defvar eitest-II3 nil) (ert-deftest eieio-test-29-instance-inheritor () - (setq eitest-II1 (II "II Test.")) + (setq eitest-II1 (II)) (oset eitest-II1 slot2 'cat) (setq eitest-II2 (clone eitest-II1 "eitest-II2 Test.")) (oset eitest-II2 slot1 'moose) diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index e92b4342748..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 () @@ -496,48 +496,6 @@ This macro is used to test if macroexpansion in `should' works." ;;; Tests for utility functions. -(ert-deftest ert-test-proper-list-p () - (should (ert--proper-list-p '())) - (should (ert--proper-list-p '(1))) - (should (ert--proper-list-p '(1 2))) - (should (ert--proper-list-p '(1 2 3))) - (should (ert--proper-list-p '(1 2 3 4))) - (should (not (ert--proper-list-p 'a))) - (should (not (ert--proper-list-p '(1 . a)))) - (should (not (ert--proper-list-p '(1 2 . a)))) - (should (not (ert--proper-list-p '(1 2 3 . a)))) - (should (not (ert--proper-list-p '(1 2 3 4 . a)))) - (let ((a (list 1))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2))) - (setf (cdr (last a)) (cdr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) (cdr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cdr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) (cddr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cddr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cl-cdddr a)) - (should (not (ert--proper-list-p a))))) - (ert-deftest ert-test-parse-keys-and-body () (should (equal (ert--parse-keys-and-body '(foo)) '(nil (foo)))) (should (equal (ert--parse-keys-and-body '(:bar foo)) '((:bar foo) nil))) diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el new file mode 100644 index 00000000000..7d1a128694c --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el @@ -0,0 +1,76 @@ +;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'. + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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/>. + +;;; Commentary: + +;; Dummy major-mode for testing `faceup', a regression test system for +;; font-lock keywords (syntax highlighting rules for Emacs). +;; +;; This mode use `syntax-propertize' to set the `syntax-table' +;; property on "<" and ">" in "<TEXT>" to make them act like +;; parentheses. +;; +;; This mode also sets the `help-echo' property on the text WARNING, +;; the effect is that Emacs displays a tooltip when you move your +;; mouse on to the text. + +;;; Code: + +(defvar faceup-test-mode-syntax-table + (make-syntax-table) + "Syntax table for `faceup-test-mode'.") + +(defvar faceup-test-font-lock-keywords + '(("\\_<WARNING\\_>" + (0 (progn + (add-text-properties (match-beginning 0) + (match-end 0) + '(help-echo "Baloon tip: Fly smoothly!")) + font-lock-warning-face)))) + "Highlight rules for `faceup-test-mode'.") + +(defun faceup-test-syntax-propertize (start end) + (goto-char start) + (funcall + (syntax-propertize-rules + ("\\(<\\)\\([^<>\n]*\\)\\(>\\)" + (1 "() ") + (3 ")( "))) + start end)) + +(defmacro faceup-test-define-prog-mode (mode name &rest args) + "Define a major mode for a programming language. +If `prog-mode' is defined, inherit from it." + (declare (indent defun)) + `(define-derived-mode + ,mode ,(and (fboundp 'prog-mode) 'prog-mode) + ,name ,@args)) + +(faceup-test-define-prog-mode faceup-test-mode "faceup-test" + "Dummy major mode for testing `faceup', a test system for font-lock." + (set (make-local-variable 'syntax-propertize-function) + #'faceup-test-syntax-propertize) + (setq font-lock-defaults '(faceup-test-font-lock-keywords nil))) + +(provide 'faceup-test-mode) + +;;; faceup-test-mode.el ends here diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el new file mode 100644 index 00000000000..0558bd12e5f --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el @@ -0,0 +1,32 @@ +;;; faceup-test-this-file-directory.el --- Support file for faceup tests + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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/>. + +;;; Commentary: + +;; Support file for `faceup-test-basics.el'. This file is used to test +;; `faceup-this-file-directory' in various contexts. + +;;; Code: + +(defvar faceup-test-this-file-directory (faceup-this-file-directory)) + +;;; faceup-test-this-file-directory.el ends here diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt new file mode 100644 index 00000000000..d971f364c2d --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt @@ -0,0 +1,15 @@ +This is a test of `faceup', a regression test system for font-lock +keywords. It should use major mode `faceup-test-mode'. + +WARNING: The first word on this line should use +`font-lock-warning-face', and a tooltip should be displayed if the +mouse pointer is moved over it. + +In this mode "<" and ">" are parentheses, but only when on the same +line without any other "<" and ">" characters between them. +<OK> <NOT <OK> > +< +NOT OK +> + +test1.txt ends here. diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup new file mode 100644 index 00000000000..7d4938adf17 --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup @@ -0,0 +1,15 @@ +This is a test of `faceup', a regression test system for font-lock +keywords. It should use major mode `faceup-test-mode'. + +«(help-echo):"Baloon tip: Fly smoothly!":«w:WARNING»»: The first word on this line should use +`font-lock-warning-face', and a tooltip should be displayed if the +mouse pointer is moved over it. + +In this mode «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» are parentheses, but only when on the same +line without any other «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» characters between them. +«(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» <NOT «(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» > +< +NOT OK +> + +test1.txt ends here. diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el new file mode 100644 index 00000000000..f910a1d732a --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el @@ -0,0 +1,269 @@ +;;; faceup-test-basics.el --- Tests for the `faceup' package. + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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/>. + +;;; Commentary: + +;; Basic tests for the `faceup' package. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'faceup) + +(ert-deftest faceup-functions () + "Test primitive functions." + (should (equal (faceup-normalize-face-property '()) '())) + (should (equal (faceup-normalize-face-property 'a) '(a))) + (should (equal (faceup-normalize-face-property '(a)) '(a))) + (should (equal (faceup-normalize-face-property '(:x t)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(:x t a)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(:x t a b)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(a :x t)) '(a (:x t)))) + (should (equal (faceup-normalize-face-property '(a b :x t)) + '(a b (:x t)))) + + (should (equal (faceup-normalize-face-property '(:x t :y nil)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(:x t :y nil a)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(:x t :y nil a b)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(a :x t :y nil)) + '(a (:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(a b :x t :y nil)) + '(a b (:y nil) (:x t))))) + + +(ert-deftest faceup-markup-basics () + (should (equal (faceup-markup-string "") "")) + (should (equal (faceup-markup-string "test") "test"))) + +(ert-deftest faceup-markup-escaping () + (should (equal (faceup-markup-string "«") "««")) + (should (equal (faceup-markup-string "«A«B«C«") "««A««B««C««")) + (should (equal (faceup-markup-string "»") "«»")) + (should (equal (faceup-markup-string "»A»B»C»") "«»A«»B«»C«»"))) + +(ert-deftest faceup-markup-plain () + ;; UU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face underline))) + "AB«U:CD»EF"))) + +(ert-deftest faceup-markup-plain-full-text () + ;; UUUUUU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 0 6 (face underline))) + "«U:ABCDEF»"))) + +(ert-deftest faceup-markup-anonymous-face () + ;; AA + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (:underline t)))) + "AB«:(:underline t):CD»EF"))) + +(ert-deftest faceup-markup-anonymous-face-2keys () + ;; AA + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (:foo t :bar nil)))) + "AB«:(:foo t):«:(:bar nil):CD»»EF")) + ;; Plist in list. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face ((:foo t :bar nil))))) + "AB«:(:foo t):«:(:bar nil):CD»»EF")) + ;; Two plists. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face ((:foo t) (:bar nil))))) + "AB«:(:bar nil):«:(:foo t):CD»»EF"))) + +(ert-deftest faceup-markup-anonymous-nested () + ;; AA + ;; IIII + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face ((:foo t))) + 2 4 (face ((:bar t) (:foo t))) + 4 5 (face ((:foo t))))) + "A«:(:foo t):B«:(:bar t):CD»E»F"))) + +(ert-deftest faceup-markup-nested () + ;; UU + ;; IIII + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (underline italic)) + 4 5 (face italic))) + "A«I:B«U:CD»E»F"))) + +(ert-deftest faceup-markup-overlapping () + ;; UUU + ;; III + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (underline italic)) + 4 5 (face underline))) + "A«I:B«U:CD»»«U:E»F")) + ;; III + ;; UUU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (italic underline)) + 4 5 (face underline))) + "A«I:B»«U:«I:CD»E»F"))) + +(ert-deftest faceup-markup-multi-face () + ;; More than one face at the same location. + ;; + ;; The property to the front takes precedence, it is rendered as the + ;; innermost parenthesis pair. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (underline italic)))) + "AB«I:«U:CD»»EF")) + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (italic underline)))) + "AB«U:«I:CD»»EF")) + ;; Equal ranges, full text. + (should (equal (faceup-markup-string + #("ABCDEF" 0 6 (face (underline italic)))) + "«I:«U:ABCDEF»»")) + ;; Ditto, with stray markup characters. + (should (equal (faceup-markup-string + #("AB«CD»EF" 0 8 (face (underline italic)))) + "«I:«U:AB««CD«»EF»»"))) + +(ert-deftest faceup-markup-multi-property () + (let ((faceup-properties '(alpha beta gamma))) + ;; One property. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (alpha (a l p h a)))) + "AB«(alpha):(a l p h a):CD»EF")) + + ;; Two properties, inner enclosed. + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGHIJ"))) + (set-text-properties 2 8 '(alpha (a l p h a)) s) + (font-lock-append-text-property 4 6 'beta '(b e t a) s) + s)) + "AB«(alpha):(a l p h a):CD«(beta):(b e t a):EF»GH»IJ")) + + ;; Two properties, same end + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGH"))) + (set-text-properties 2 6 '(alpha (a)) s) + (add-text-properties 4 6 '(beta (b)) s) + s)) + "AB«(alpha):(a):CD«(beta):(b):EF»»GH")) + + ;; Two properties, overlap. + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGHIJ"))) + (set-text-properties 2 6 '(alpha (a)) s) + (add-text-properties 4 8 '(beta (b)) s) + s)) + "AB«(alpha):(a):CD«(beta):(b):EF»»«(beta):(b):GH»IJ")))) + + +(ert-deftest faceup-clean () + "Test the clean features of `faceup'." + (should (equal (faceup-clean-string "") "")) + (should (equal (faceup-clean-string "test") "test")) + (should (equal (faceup-clean-string "AB«U:CD»EF") "ABCDEF")) + (should (equal (faceup-clean-string "«U:ABCDEF»") "ABCDEF")) + (should (equal (faceup-clean-string "A«I:B«U:CD»E»F") "ABCDEF")) + (should (equal (faceup-clean-string "A«I:B«U:CD»»«U:E»F") "ABCDEF")) + (should (equal (faceup-clean-string "AB«I:«U:CD»»EF") "ABCDEF")) + (should (equal (faceup-clean-string "«I:«U:ABCDEF»»") "ABCDEF")) + (should (equal (faceup-clean-string "«(foo)I:ABC»DEF") "ABCDEF")) + (should (equal (faceup-clean-string "«:(:foo t):ABC»DEF") "ABCDEF")) + ;; Escaped markup characters. + (should (equal (faceup-clean-string "««") "«")) + (should (equal (faceup-clean-string "«»") "»")) + (should (equal (faceup-clean-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF"))) + + +(ert-deftest faceup-render () + "Test the render features of `faceup'." + (should (equal (faceup-render-string "") "")) + (should (equal (faceup-render-string "««") "«")) + (should (equal (faceup-render-string "«»") "»")) + (should (equal (faceup-render-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF"))) + + +(defvar faceup-test-resources-directory + (concat (file-name-directory + (substring (faceup-this-file-directory) 0 -1)) + "faceup-resources/") + "The `faceup-resources' directory.") + + +(defvar faceup-test-this-file-directory nil + "The result of `faceup-this-file-directory' in various contexts. + +This is set by the file test support file +`faceup-test-this-file-directory.el'.") + + +(ert-deftest faceup-directory () + "Test `faceup-this-file-directory'." + (let ((file (concat faceup-test-resources-directory + "faceup-test-this-file-directory.el")) + (load-file-name nil)) + ;; Test normal load. + (makunbound 'faceup-test-this-file-directory) + (load file nil :nomessage) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)) + ;; Test `eval-buffer'. + (makunbound 'faceup-test-this-file-directory) + (save-excursion + (find-file file) + (eval-buffer)) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)) + ;; Test `eval-defun'. + (makunbound 'faceup-test-this-file-directory) + (save-excursion + (find-file file) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + ;; Note: In batch mode, this prints the result of the + ;; evaluation. Unfortunately, this is hard to fix. + (eval-defun nil) + (forward-sexp)))) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)))) + +(provide 'faceup-test-basics) + +;;; faceup-test-basics.el ends here diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el new file mode 100644 index 00000000000..8df38bcc8a9 --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el @@ -0,0 +1,63 @@ +;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode. + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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/>. + +;;; Commentary: + +;; Self test of `faceup' with a major mode that sets both the +;; `syntax-table' and the `echo-help' property. +;; +;; This file can also be seen as a blueprint of test cases for real +;; major modes. + +;;; Code: + +(require 'faceup) + +;; Note: The byte compiler needs the value to load `faceup-test-mode', +;; hence the `eval-and-compile'. +(eval-and-compile + (defvar faceup-test-files-dir (faceup-this-file-directory) + "The directory of this file.")) + +(require 'faceup-test-mode + (concat faceup-test-files-dir + "../faceup-resources/" + "faceup-test-mode.el")) + +(defun faceup-test-files-check-one (file) + "Test that FILE is fontified as the .faceup file describes. + +FILE is interpreted as relative to this source directory." + (let ((faceup-properties '(face syntax-table help-echo))) + (faceup-test-font-lock-file 'faceup-test-mode + (concat + faceup-test-files-dir + "../faceup-resources/" + file)))) +(faceup-defexplainer faceup-test-files-check-one) + +(ert-deftest faceup-files () + (should (faceup-test-files-check-one "files/test1.txt"))) + +(provide 'faceup-test-files) + +;;; faceup-test-files.el ends here diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index 9bf8413e159..bca3efa550b 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -292,3 +292,13 @@ identical output. (i 0) (j (setq i (1+ i)))) (iter-yield i)))))))) + +(ert-deftest iter-lambda-variable-shadowing () + "`iter-lambda' forms which have local variable shadowing (Bug#26073)." + (should (equal (iter-next + (funcall (iter-lambda () + (let ((it 1)) + (iter-yield (funcall + (lambda (it) (- it)) + (1+ it))))))) + -2))) diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 62fba58919f..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. @@ -414,7 +415,7 @@ Must called from within a `tar-mode' buffer." (with-fake-help-buffer (describe-package '5x5) (goto-char (point-min)) - (should (search-forward "5x5 is a built-in package." nil t)) + (should (search-forward "5x5 is built-in." nil t)) ;; Don't assume the descriptions are in any particular order. (save-excursion (should (search-forward "Status: Built-in." nil t))) (save-excursion (should (search-forward "Summary: simple little puzzle game" nil t))) @@ -428,7 +429,7 @@ Must called from within a `tar-mode' buffer." (with-fake-help-buffer (describe-package 'simple-single) (goto-char (point-min)) - (should (search-forward "simple-single is an installed package." nil t)) + (should (search-forward "Package simple-single is installed." nil t)) (save-excursion (should (re-search-forward "Status: Installed in ['`‘]simple-single-1.3/['’] (unsigned)." nil t))) (save-excursion (should (search-forward "Version: 1.3" nil t))) (save-excursion (should (search-forward "Summary: A single-file package with no dependencies" nil t))) @@ -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-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))) @@ -484,14 +493,16 @@ Must called from within a `tar-mode' buffer." (package-import-keyring keyring) (package-refresh-contents) (let ((package-check-signature 'allow-unsigned)) - (should (package-install 'signed-good)) + (should (progn (package-install 'signed-good) 'noerror)) (should-error (package-install 'signed-bad))) + (package-delete (car (alist-get 'signed-good package-alist))) (let ((package-check-signature t)) - (should (package-install 'signed-good)) + (should (progn (package-install 'signed-good) 'noerror)) (should-error (package-install 'signed-bad))) + (package-delete (car (alist-get 'signed-good package-alist))) (let ((package-check-signature nil)) - (should (package-install 'signed-good)) - (should (package-install 'signed-bad))) + (should (progn (package-install 'signed-good) 'noerror)) + (should (progn (package-install 'signed-bad) 'noerror))) ;; Check if the installed package status is updated. (let ((buf (package-list-packages))) (package-menu-refresh) @@ -504,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 c9618f3c37f..81467bab2d4 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -148,34 +148,34 @@ "Test `if-let' with falsie bindings." (should (equal (if-let* ((a nil)) - (list a b c) + "yes" "no") "no")) (should (equal (if-let* ((a nil) (b 2) (c 3)) - (list a b c) + "yes" "no") "no")) (should (equal (if-let* ((a 1) (b nil) (c 3)) - (list a b c) + "yes" "no") "no")) (should (equal (if-let* ((a 1) (b 2) (c nil)) - (list a b c) + "yes" "no") "no")) (should (equal (let (z) (if-let* (z (a 1) (b 2) (c 3)) - (list a b c) + "yes" "no")) "no")) (should (equal (let (d) (if-let* ((a 1) (b 2) (c 3) d) - (list a b c) + "yes" "no")) "no"))) @@ -312,34 +312,28 @@ "Test `when-let' with falsie bindings." (should (equal (when-let* ((a nil)) - (list a b c) "no") nil)) (should (equal (when-let* ((a nil) (b 2) (c 3)) - (list a b c) "no") nil)) (should (equal (when-let* ((a 1) (b nil) (c 3)) - (list a b c) "no") nil)) (should (equal (when-let* ((a 1) (b 2) (c nil)) - (list a b c) "no") nil)) (should (equal (let (z) (when-let* (z (a 1) (b 2) (c 3)) - (list a b c) "no")) nil)) (should (equal (let (d) (when-let* ((a 1) (b 2) (c 3) d) - (list a b c) "no")) nil))) @@ -538,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/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el index cacdef9cb42..69ef5b596be 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -53,7 +53,6 @@ ;; ==== constants-bug-25316 ==== "Testcover doesn't splotch constants." -:expected-result :failed ;; ==== (defconst testcover-testcase-const "apples") (defun testcover-testcase-zero () 0) @@ -76,7 +75,6 @@ ;; ==== customize-defcustom-bug-25326 ==== "Testcover doesn't prevent testing of defcustom values." -:expected-result :failed ;; ==== (defgroup testcover-testcase nil "Test case for testcover" @@ -135,7 +133,6 @@ ;; ==== 1-value-symbol-bug-25316 ==== "Wrapping a form with 1value prevents splotching." -:expected-result :failed ;; ==== (defun testcover-testcase-always-zero (num) (- num%%% num%%%)%%%) @@ -229,8 +226,7 @@ (should-not (testcover-testcase-cc nil)) ;; ==== quotes-within-backquotes-bug-25316 ==== -"Forms to instrument are found within quotes within backquotes." -:expected-result :failed +"Forms to analyze are found within quotes within backquotes." ;; ==== (defun testcover-testcase-make-list () (list 'defun 'defvar)) @@ -296,7 +292,6 @@ ;; ==== backquote-1value-bug-24509 ==== "Commas within backquotes are recognized as non-1value." -:expected-result :failed ;; ==== (defmacro testcover-testcase-lambda (&rest body) `(lambda () ,@body)) @@ -320,7 +315,6 @@ ;; ==== pcase-bug-24688 ==== "Testcover copes with condition-case within backquoted list." -:expected-result :failed ;; ==== (defun testcover-testcase-pcase (form) (pcase form%%% @@ -335,7 +329,6 @@ ;; ==== defun-in-backquote-bug-11307-and-24743 ==== "Testcover handles defun forms within backquoted list." -:expected-result :failed ;; ==== (defmacro testcover-testcase-defun (name &rest body) (declare (debug (symbolp def-body))) @@ -348,7 +341,6 @@ ;; ==== closure-1value-bug ==== "Testcover does not mark closures as 1value." -:expected-result :failed ;; ==== ;; -*- lexical-binding:t -*- (setq testcover-testcase-foo nil) @@ -365,7 +357,6 @@ ;; ==== by-value-vs-by-reference-bug-25351 ==== "An object created by a 1value expression may be modified by other code." -:expected-result :failed ;; ==== (defun testcover-testcase-ab () (list 'a 'b)) @@ -386,7 +377,7 @@ (should-error (testcover-testcase-thing 3)) ;; ==== dotted-backquote ==== -"Testcover correctly instruments dotted backquoted lists." +"Testcover can analyze code inside dotted backquoted lists." ;; ==== (defun testcover-testcase-dotted-bq (flag extras) (let* ((bq @@ -396,9 +387,16 @@ (should (equal '(a b c) (testcover-testcase-dotted-bq nil '(d e)))) (should (equal '(a b c d e) (testcover-testcase-dotted-bq t '(d e)))) +;; ==== quoted-backquote ==== +"Testcover correctly handles the quoted backquote symbol." +;; ==== +(defun testcover-testcase-special-symbols () + (list '\` '\, '\,@)) + +(should (equal '(\` \, \,@) (testcover-testcase-special-symbols))) + ;; ==== backquoted-vector-bug-25316 ==== -"Testcover reinstruments within backquoted vectors." -:expected-result :failed +"Testcover can analyze code within backquoted vectors." ;; ==== (defun testcover-testcase-vec (a b c) `[,a%%% ,(list b%%% c%%%)%%%]%%%) @@ -413,9 +411,15 @@ (should (equal '([[4 5] 6]) (testcover-testcase-vec-in-list 4 5 6))) (should (equal '([100]) (testcover-testcase-vec-arg 100))) +;; ==== dotted-list-in-vector-bug-30909 ==== +"Testcover can analyze dotted pairs within vectors." +;; ==== +(defun testcover-testcase-vectors-with-dotted-pairs () + (equal [(1 . "x")] [(1 2 . "y")])%%%) +(should-not (testcover-testcase-vectors-with-dotted-pairs)) + ;; ==== vector-in-macro-spec-bug-25316 ==== -"Testcover reinstruments within vectors." -:expected-result :failed +"Testcover can analyze code inside vectors." ;; ==== (defmacro testcover-testcase-nth-case (arg vec) (declare (indent 1) @@ -435,7 +439,6 @@ ;; ==== mapcar-is-not-compose ==== "Mapcar with 1value arguments is not 1value." -:expected-result :failed ;; ==== (defvar testcover-testcase-num 0) (defun testcover-testcase-add-num (n) @@ -450,10 +453,10 @@ ;; ==== function-with-edebug-spec-bug-25316 ==== "Functions can have edebug specs too. -See c-make-font-lock-search-function for an example in the Emacs -sources. The other issue is that it's ok to use quote in an -edebug spec, so testcover needs to cope with that." -:expected-result :failed +See `c-make-font-lock-search-function' for an example in the +Emacs sources. `c-make-font-lock-search-function''s Edebug spec +also contains a quote. See comment in `testcover-analyze-coverage' +regarding the odd-looking coverage result for the quoted form." ;; ==== (defun testcover-testcase-make-function (forms) `(lambda (flag) (if flag 0 ,@forms%%%))%%%) @@ -462,7 +465,7 @@ edebug spec, so testcover needs to cope with that." (("quote" (&rest def-form)))) (defun testcover-testcase-thing () - (testcover-testcase-make-function '((+ 1 (+ 2 (+ 3 (+ 4 5))))))%%%) + (testcover-testcase-make-function '(!!!(+ 1 !!!(+ 2 !!!(+ 3 !!!(+ 4 5)%%%)%%%)%%%)%%%))%%%) (defun testcover-testcase-use-thing () (funcall (testcover-testcase-thing)%%% nil)%%%) @@ -470,7 +473,7 @@ edebug spec, so testcover needs to cope with that." (should (equal (testcover-testcase-use-thing) 15)) ;; ==== backquoted-dotted-alist ==== -"Testcover can instrument a dotted alist constructed with backquote." +"Testcover can analyze a dotted alist constructed with backquote." ;; ==== (defun testcover-testcase-make-alist (expr entries) `((0 . ,expr%%%) . ,entries%%%)%%%) @@ -494,10 +497,18 @@ edebug spec, so testcover needs to cope with that." "Testcover captures and ignores circular list errors." ;; ==== (defun testcover-testcase-cyc1 (a) - (let ((ls (make-list 10 a%%%))) - (nconc ls ls) - ls)) + (let ((ls (make-list 10 a%%%)%%%)) + (nconc ls%%% ls%%%) + ls)) ; The lack of a mark here is due to an ignored circular list error. (testcover-testcase-cyc1 1) (testcover-testcase-cyc1 1) +(defun testcover-testcase-cyc2 (a b) + (let ((ls1 (make-list 10 a%%%)%%%) + (ls2 (make-list 10 b))) + (nconc ls2 ls2) + (nconc ls1%%% ls2) + ls1)) +(testcover-testcase-cyc2 1 2) +(testcover-testcase-cyc2 1 4) ;; testcases.el ends here. diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index be48aa443b6..6c76421d38b 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -124,14 +124,12 @@ arguments for `testcover-start'." (save-current-buffer (set-buffer (find-file-noselect tempfile)) ;; Fail the test if the debugger tries to become active, - ;; which will happen if Testcover's reinstrumentation - ;; leaves an edebug-enter in the code. This will also - ;; prevent debugging these tests using Edebug. - (cl-letf (((symbol-function #'edebug-enter) + ;; which can happen if Testcover fails to attach itself + ;; correctly. Note that this will prevent debugging + ;; these tests using Edebug. + (cl-letf (((symbol-function #'edebug-default-enter) (lambda (&rest _args) - (ert-fail - (concat "Debugger invoked during test run " - "(possible edebug-enter not replaced)"))))) + (ert-fail "Debugger invoked during test run")))) (dolist (byte-compile '(t nil)) (testcover-tests-unmarkup-region (point-min) (point-max)) (unwind-protect diff --git a/test/lisp/emacs-lisp/text-property-search-tests.el b/test/lisp/emacs-lisp/text-property-search-tests.el new file mode 100644 index 00000000000..5ea6b5372e1 --- /dev/null +++ b/test/lisp/emacs-lisp/text-property-search-tests.el @@ -0,0 +1,113 @@ +;;; text-property-search-tests.el --- Testing text-property-search + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen <larsi@gnus.org> +;; Keywords: + +;; 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: + +;; + +;;; Code: + +(require 'ert) +(require 'text-property-search) +(require 'cl-lib) + +(defun text-property-setup () + (insert "This is " + (propertize "bold1" 'face 'bold) + " and this is " + (propertize "italic1" 'face 'italic) + (propertize "bold2" 'face 'bold) + (propertize "italic2" 'face 'italic) + " at the end") + (goto-char (point-min))) + +(defmacro with-test (form result &optional point) + `(with-temp-buffer + (text-property-setup) + (when ,point + (goto-char ,point)) + (should + (equal + (cl-loop for match = ,form + while match + collect (buffer-substring (prop-match-beginning match) + (prop-match-end match))) + ,result)))) + +(ert-deftest text-property-search-forward-bold-t () + (with-test (text-property-search-forward 'face 'bold t) + '("bold1" "bold2"))) + +(ert-deftest text-property-search-forward-bold-nil () + (with-test (text-property-search-forward 'face 'bold nil) + '("This is " " and this is italic1" "italic2 at the end"))) + +(ert-deftest text-property-search-forward-nil-t () + (with-test (text-property-search-forward 'face nil t) + '("This is " " and this is " " at the end"))) + +(ert-deftest text-property-search-forward-nil-nil () + (with-test (text-property-search-forward 'face nil nil) + '("bold1" "italic1" "bold2" "italic2"))) + +(ert-deftest text-property-search-forward-partial-bold-t () + (with-test (text-property-search-forward 'face 'bold t) + '("old1" "bold2") + 10)) + +(ert-deftest text-property-search-forward-partial-non-current-bold-t () + (with-test (text-property-search-forward 'face 'bold t t) + '("bold2") + 10)) + + +(ert-deftest text-property-search-backward-bold-t () + (with-test (text-property-search-backward 'face 'bold t) + '("bold2" "bold1") + (point-max))) + +(ert-deftest text-property-search-backward-bold-nil () + (with-test (text-property-search-backward 'face 'bold nil) + '( "italic2 at the end" " and this is italic1" "This is ") + (point-max))) + +(ert-deftest text-property-search-backward-nil-t () + (with-test (text-property-search-backward 'face nil t) + '(" at the end" " and this is " "This is ") + (point-max))) + +(ert-deftest text-property-search-backward-nil-nil () + (with-test (text-property-search-backward 'face nil nil) + '("italic2" "bold2" "italic1" "bold1") + (point-max))) + +(ert-deftest text-property-search-backward-partial-bold-t () + (with-test (text-property-search-backward 'face 'bold t) + '("b" "bold1") + 35)) + +(ert-deftest text-property-search-backward-partial-non-current-bold-t () + (with-test (text-property-search-backward 'face 'bold t t) + '("bold1") + 35)) + +(provide 'text-property-search-tests) + +;;; text-property-search-tests.el ends here diff --git a/test/lisp/emacs-lisp/thunk-tests.el b/test/lisp/emacs-lisp/thunk-tests.el index 4cc19f90d6c..b24e8d1fdb7 100644 --- a/test/lisp/emacs-lisp/thunk-tests.el +++ b/test/lisp/emacs-lisp/thunk-tests.el @@ -51,5 +51,55 @@ (thunk-force thunk) (should (= x 1)))) + + +;; thunk-let tests + +(ert-deftest thunk-let-basic-test () + "Test whether bindings are established." + (should (equal (thunk-let ((x 1) (y 2)) (+ x y)) 3))) + +(ert-deftest thunk-let*-basic-test () + "Test whether bindings are established." + (should (equal (thunk-let* ((x 1) (y (+ 1 x))) (+ x y)) 3))) + +(ert-deftest thunk-let-bound-vars-cant-be-set-test () + "Test whether setting a `thunk-let' bound variable fails." + (should-error + (eval '(thunk-let ((x 1)) (let ((y 7)) (setq x (+ x y)) (* 10 x))) t))) + +(ert-deftest thunk-let-laziness-test () + "Test laziness of `thunk-let'." + (should + (equal (let ((x-evalled nil) + (y-evalled nil)) + (thunk-let ((x (progn (setq x-evalled t) (+ 1 2))) + (y (progn (setq y-evalled t) (+ 3 4)))) + (let ((evalled-y y)) + (list x-evalled y-evalled evalled-y)))) + (list nil t 7)))) + +(ert-deftest thunk-let*-laziness-test () + "Test laziness of `thunk-let*'." + (should + (equal (let ((x-evalled nil) + (y-evalled nil) + (z-evalled nil) + (a-evalled nil)) + (thunk-let* ((x (progn (setq x-evalled t) (+ 1 1))) + (y (progn (setq y-evalled t) (+ x 1))) + (z (progn (setq z-evalled t) (+ y 1))) + (a (progn (setq a-evalled t) (+ z 1)))) + (let ((evalled-z z)) + (list x-evalled y-evalled z-evalled a-evalled evalled-z)))) + (list t t t nil 4)))) + +(ert-deftest thunk-let-bad-binding-test () + "Test whether a bad binding causes an error when expanding." + (should-error (macroexpand '(thunk-let ((x 1 1)) x))) + (should-error (macroexpand '(thunk-let (27) x))) + (should-error (macroexpand '(thunk-let x x)))) + + (provide 'thunk-tests) ;;; thunk-tests.el ends here diff --git a/test/lisp/emacs-lisp/timer-tests.el b/test/lisp/emacs-lisp/timer-tests.el index 65e5dc9bde9..fa92c1b64aa 100644 --- a/test/lisp/emacs-lisp/timer-tests.el +++ b/test/lisp/emacs-lisp/timer-tests.el @@ -39,4 +39,9 @@ (if (fboundp 'debug-timer-check) (should (debug-timer-check)) t)) +(ert-deftest timer-test-multiple-of-time () + (should (equal + (timer-next-integral-multiple-of-time '(0 0 0 1) (1+ (ash 1 53))) + (list (ash 1 (- 53 16)) 1 0 0)))) + ;;; timer-tests.el ends here diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el index 0fe15017dd0..c1e98a6935e 100644 --- a/test/lisp/epg-tests.el +++ b/test/lisp/epg-tests.el @@ -30,8 +30,28 @@ (expand-file-name "data/epg" (getenv "EMACS_TEST_DIRECTORY")) "Directory containing epg test data.") -(defun epg-tests-find-usable-gpg-configuration (&optional _require-passphrase) - (epg-find-configuration 'OpenPGP 'no-cache)) +(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 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 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 @@ -51,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 @@ -85,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 "\ @@ -97,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) @@ -115,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) @@ -129,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) @@ -145,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) @@ -160,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/eshell/em-ls-tests.el b/test/lisp/eshell/em-ls-tests.el index 1ce832f1dcc..c5c9eac3249 100644 --- a/test/lisp/eshell/em-ls-tests.el +++ b/test/lisp/eshell/em-ls-tests.el @@ -26,6 +26,7 @@ (require 'ert) (require 'em-ls) +(require 'dired) (ert-deftest em-ls-test-bug27631 () "Test for https://debbugs.gnu.org/27631 ." diff --git a/test/lisp/eshell/esh-opt-tests.el b/test/lisp/eshell/esh-opt-tests.el new file mode 100644 index 00000000000..13b522b389e --- /dev/null +++ b/test/lisp/eshell/esh-opt-tests.el @@ -0,0 +1,124 @@ +;;; tests/esh-opt-tests.el --- esh-opt test suite + +;; 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'esh-opt) + +(ert-deftest esh-opt-process-args-test () + "Unit tests which verify correct behavior of `eshell--process-args'." + (should + (equal '(t) + (eshell--process-args + "sudo" + '("-a") + '((?a "all" nil show-all ""))))) + (should + (equal '(nil) + (eshell--process-args + "sudo" + '("-g") + '((?a "all" nil show-all ""))))) + (should + (equal '("root" "world") + (eshell--process-args + "sudo" + '("-u" "root" "world") + '((?u "user" t user "execute a command as another USER"))))) + (should + (equal '(nil "emerge" "-uDN" "world") + (eshell--process-args + "sudo" + '("emerge" "-uDN" "world") + '((?u "user" t user "execute a command as another USER") + :parse-leading-options-only)))) + (should + (equal '("root" "emerge" "-uDN" "world") + (eshell--process-args + "sudo" + '("-u" "root" "emerge" "-uDN" "world") + '((?u "user" t user "execute a command as another USER") + :parse-leading-options-only)))) + (should + (equal '("world" "emerge") + (eshell--process-args + "sudo" + '("-u" "root" "emerge" "-uDN" "world") + '((?u "user" t user "execute a command as another USER")))))) + +(ert-deftest test-eshell-eval-using-options () + "Tests for `eshell-eval-using-options'." + (eshell-eval-using-options + "sudo" '("-u" "root" "whoami") + '((?u "user" t user "execute a command as another USER") + :parse-leading-options-only) + (should (equal user "root"))) + (eshell-eval-using-options + "sudo" '("--user" "root" "whoami") + '((?u "user" t user "execute a command as another USER") + :parse-leading-options-only) + (should (equal user "root"))) + + (eshell-eval-using-options + "sudo" '("emerge" "-uDN" "world") + '((?u "user" t user "execute a command as another USER")) + (should (equal user "world"))) + (eshell-eval-using-options + "sudo" '("emerge" "-uDN" "world") + '((?u "user" t user "execute a command as another USER") + :parse-leading-options-only) + (should (eq user nil))) + + (eshell-eval-using-options + "ls" '("-I" "*.txt" "/dev/null") + '((?I "ignore" t ignore-pattern + "do not list implied entries matching pattern")) + (should (equal ignore-pattern "*.txt"))) + + (eshell-eval-using-options + "ls" '("-l" "/dev/null") + '((?l nil long-listing listing-style + "use a long listing format")) + (should (eql listing-style 'long-listing))) + (eshell-eval-using-options + "ls" '("/dev/null") + '((?l nil long-listing listing-style + "use a long listing format")) + (should (eq listing-style nil))) + + (eshell-eval-using-options + "ls" '("/dev/null" "-h") + '((?h "human-readable" 1024 human-readable + "print sizes in human readable format")) + (should (eql human-readable 1024))) + (eshell-eval-using-options + "ls" '("/dev/null" "--human-readable") + '((?h "human-readable" 1024 human-readable + "print sizes in human readable format")) + (should (eql human-readable 1024))) + (eshell-eval-using-options + "ls" '("/dev/null") + '((?h "human-readable" 1024 human-readable + "print sizes in human readable format")) + (should (eq human-readable nil)))) + +(provide 'esh-opt-tests) + +;;; esh-opt-tests.el ends here diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index feb1f19cb5c..612ea8cd7f4 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -57,9 +57,10 @@ 'tramp-default-host-alist `("\\`mock\\'" nil ,(system-name))) ;; Emacs' Makefile sets $HOME to a nonexistent value. Needed in - ;; batch mode only, therefore. + ;; batch mode only, therefore. `temporary-file-directory' might + ;; be quoted, so we unquote it just in case. (unless (and (null noninteractive) (file-directory-p "~/")) - (setenv "HOME" temporary-file-directory)) + (setenv "HOME" (file-name-unquote temporary-file-directory))) (format "/mock::%s" temporary-file-directory))) "Temporary directory for Tramp tests.") @@ -566,35 +567,42 @@ delivered." (skip-unless (file-notify--test-local-enabled)) (unwind-protect - (progn - ;; Check file creation, change and deletion. It doesn't work - ;; for kqueue, because we don't use an implicit directory - ;; monitor. - (unless (string-equal (file-notify--test-library) "kqueue") - (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) - (should - (setq file-notify--test-desc - (file-notify-add-watch - file-notify--test-tmpfile - '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events - (cond - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal - (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created deleted stopped))) - ;; cygwin does not raise a `changed' event. - ((eq system-type 'cygwin) - '(created deleted stopped)) - (t '(created changed deleted stopped))) - (write-region - "another text" nil file-notify--test-tmpfile nil 'no-message) - (file-notify--test-read-event) - (delete-file file-notify--test-tmpfile)) - (file-notify-rm-watch file-notify--test-desc)) + ;; Check file creation, change and deletion. It doesn't work + ;; for kqueue, because we don't use an implicit directory + ;; monitor. + (unless (string-equal (file-notify--test-library) "kqueue") + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; gvfs-monitor-dir on cygwin does not detect the + ;; `created' event reliably. + ((string-equal + (file-notify--test-library) "gvfs-monitor-dir.exe") + '((deleted stopped) + (created deleted stopped))) + ;; cygwin does not raise a `changed' event. + ((eq system-type 'cygwin) + '(created deleted stopped)) + (t '(created changed deleted stopped))) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (delete-file file-notify--test-tmpfile)) + (file-notify-rm-watch file-notify--test-desc) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + (progn ;; Check file change and deletion. (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) @@ -619,163 +627,191 @@ delivered." (delete-file file-notify--test-tmpfile)) (file-notify-rm-watch file-notify--test-desc) - ;; Check file creation, change and deletion when watching a - ;; directory. There must be a `stopped' event when deleting - ;; the directory. - (let ((file-notify--test-tmpdir - (make-temp-file "file-notify-test-parent" t))) - (should - (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) - file-notify--test-desc - (file-notify-add-watch - file-notify--test-tmpdir - '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events - (cond - ;; w32notify does not raise `deleted' and `stopped' - ;; events for the watched directory. - ((string-equal (file-notify--test-library) "w32notify") - '(created changed deleted)) - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal - (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created deleted stopped))) - ;; There are two `deleted' events, for the file and for - ;; the directory. Except for cygwin and kqueue. And - ;; cygwin does not raise a `changed' event. - ((eq system-type 'cygwin) - '(created deleted stopped)) - ((string-equal (file-notify--test-library) "kqueue") - '(created changed deleted stopped)) - (t '(created changed deleted deleted stopped))) - (write-region - "any text" nil file-notify--test-tmpfile nil 'no-message) - (file-notify--test-read-event) - (delete-directory file-notify--test-tmpdir 'recursive)) - (file-notify-rm-watch file-notify--test-desc)) - - ;; Check copy of files inside a directory. - (let ((file-notify--test-tmpdir - (make-temp-file "file-notify-test-parent" t))) - (should - (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) - file-notify--test-tmpfile1 (file-notify--test-make-temp-name) - file-notify--test-desc - (file-notify-add-watch - file-notify--test-tmpdir - '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events - (cond - ;; w32notify does not distinguish between `changed' and - ;; `attribute-changed'. It does not raise `deleted' - ;; and `stopped' events for the watched directory. - ((string-equal (file-notify--test-library) "w32notify") - '(created changed created changed - changed changed changed - deleted deleted)) - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal - (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created created deleted stopped))) - ;; There are three `deleted' events, for two files and - ;; for the directory. Except for cygwin and kqueue. - ((eq system-type 'cygwin) - '(created created changed changed deleted stopped)) - ((string-equal (file-notify--test-library) "kqueue") - '(created changed created changed deleted stopped)) - (t '(created changed created changed - deleted deleted deleted stopped))) - (write-region - "any text" nil file-notify--test-tmpfile nil 'no-message) - (file-notify--test-read-event) - (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1) - ;; The next two events shall not be visible. - (file-notify--test-read-event) - (set-file-modes file-notify--test-tmpfile 000) - (file-notify--test-read-event) - (set-file-times file-notify--test-tmpfile '(0 0)) - (file-notify--test-read-event) - (delete-directory file-notify--test-tmpdir 'recursive)) - (file-notify-rm-watch file-notify--test-desc)) - - ;; Check rename of files inside a directory. - (let ((file-notify--test-tmpdir - (make-temp-file "file-notify-test-parent" t))) - (should - (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) - file-notify--test-tmpfile1 (file-notify--test-make-temp-name) - file-notify--test-desc - (file-notify-add-watch - file-notify--test-tmpdir - '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events - (cond - ;; w32notify does not raise `deleted' and `stopped' - ;; events for the watched directory. - ((string-equal (file-notify--test-library) "w32notify") - '(created changed renamed deleted)) - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal - (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created deleted stopped))) - ;; There are two `deleted' events, for the file and for - ;; the directory. Except for cygwin and kqueue. And - ;; cygwin raises `created' and `deleted' events instead - ;; of a `renamed' event. - ((eq system-type 'cygwin) - '(created created deleted deleted stopped)) - ((string-equal (file-notify--test-library) "kqueue") - '(created changed renamed deleted stopped)) - (t '(created changed renamed deleted deleted stopped))) - (write-region - "any text" nil file-notify--test-tmpfile nil 'no-message) - (file-notify--test-read-event) - (rename-file file-notify--test-tmpfile file-notify--test-tmpfile1) - ;; After the rename, we won't get events anymore. - (file-notify--test-read-event) - (delete-directory file-notify--test-tmpdir 'recursive)) - (file-notify-rm-watch file-notify--test-desc)) - - ;; Check attribute change. Does not work for cygwin. - (unless (eq system-type 'cygwin) - (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; Check file creation, change and deletion when watching a + ;; directory. There must be a `stopped' event when deleting the + ;; directory. + (let ((file-notify--test-tmpdir + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpdir + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not raise `deleted' and `stopped' + ;; events for the watched directory. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed deleted)) + ;; gvfs-monitor-dir on cygwin does not detect the + ;; `created' event reliably. + ((string-equal + (file-notify--test-library) "gvfs-monitor-dir.exe") + '((deleted stopped) + (created deleted stopped))) + ;; There are two `deleted' events, for the file and for + ;; the directory. Except for cygwin and kqueue. And + ;; cygwin does not raise a `changed' event. + ((eq system-type 'cygwin) + '(created deleted stopped)) + ((string-equal (file-notify--test-library) "kqueue") + '(created changed deleted stopped)) + (t '(created changed deleted deleted stopped))) (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) - (should - (setq file-notify--test-desc - (file-notify-add-watch - file-notify--test-tmpfile - '(attribute-change) #'file-notify--test-event-handler))) - (file-notify--test-with-events - (cond - ;; w32notify does not distinguish between `changed' and - ;; `attribute-changed'. Under MS Windows 7, we get - ;; four `changed' events, and under MS Windows 10 just - ;; two. Strange. - ((string-equal (file-notify--test-library) "w32notify") - '((changed changed) - (changed changed changed changed))) - ;; For kqueue and in the remote case, `write-region' - ;; raises also an `attribute-changed' event. - ((or (string-equal (file-notify--test-library) "kqueue") - (file-remote-p temporary-file-directory)) - '(attribute-changed attribute-changed attribute-changed)) - (t '(attribute-changed attribute-changed))) - (write-region - "any text" nil file-notify--test-tmpfile nil 'no-message) - (file-notify--test-read-event) - (set-file-modes file-notify--test-tmpfile 000) - (file-notify--test-read-event) - (set-file-times file-notify--test-tmpfile '(0 0)) - (file-notify--test-read-event) - (delete-file file-notify--test-tmpfile)) - (file-notify-rm-watch file-notify--test-desc)) + (file-notify--test-read-event) + (delete-directory file-notify--test-tmpdir 'recursive)) + (file-notify-rm-watch file-notify--test-desc) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; Check copy of files inside a directory. + (let ((file-notify--test-tmpdir + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpdir + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not distinguish between `changed' and + ;; `attribute-changed'. It does not raise `deleted' and + ;; `stopped' events for the watched directory. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed created changed + changed changed changed + deleted deleted)) + ;; gvfs-monitor-dir on cygwin does not detect the + ;; `created' event reliably. + ((string-equal + (file-notify--test-library) "gvfs-monitor-dir.exe") + '((deleted stopped) + (created created deleted stopped))) + ;; There are three `deleted' events, for two files and + ;; for the directory. Except for cygwin and kqueue. + ((eq system-type 'cygwin) + '(created created changed changed deleted stopped)) + ((string-equal (file-notify--test-library) "kqueue") + '(created changed created changed deleted stopped)) + (t '(created changed created changed + deleted deleted deleted stopped))) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1) + ;; The next two events shall not be visible. + (file-notify--test-read-event) + (set-file-modes file-notify--test-tmpfile 000) + (file-notify--test-read-event) + (set-file-times file-notify--test-tmpfile '(0 0)) + (file-notify--test-read-event) + (delete-directory file-notify--test-tmpdir 'recursive)) + (file-notify-rm-watch file-notify--test-desc) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; Check rename of files inside a directory. + (let ((file-notify--test-tmpdir + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpdir + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not raise `deleted' and `stopped' + ;; events for the watched directory. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed renamed deleted)) + ;; gvfs-monitor-dir on cygwin does not detect the + ;; `created' event reliably. + ((string-equal + (file-notify--test-library) "gvfs-monitor-dir.exe") + '((deleted stopped) + (created deleted stopped))) + ;; There are two `deleted' events, for the file and for + ;; the directory. Except for cygwin and kqueue. And + ;; cygwin raises `created' and `deleted' events instead + ;; of a `renamed' event. + ((eq system-type 'cygwin) + '(created created deleted deleted stopped)) + ((string-equal (file-notify--test-library) "kqueue") + '(created changed renamed deleted stopped)) + (t '(created changed renamed deleted deleted stopped))) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (rename-file file-notify--test-tmpfile file-notify--test-tmpfile1) + ;; After the rename, we won't get events anymore. + (file-notify--test-read-event) + (delete-directory file-notify--test-tmpdir 'recursive)) + (file-notify-rm-watch file-notify--test-desc) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; Check attribute change. Does not work for cygwin. + (unless (eq system-type 'cygwin) + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(attribute-change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not distinguish between `changed' and + ;; `attribute-changed'. Under MS Windows 7, we get four + ;; `changed' events, and under MS Windows 10 just two. + ;; Strange. + ((string-equal (file-notify--test-library) "w32notify") + '((changed changed) + (changed changed changed changed))) + ;; For kqueue and in the remote case, `write-region' + ;; raises also an `attribute-changed' event. + ((or (string-equal (file-notify--test-library) "kqueue") + (file-remote-p temporary-file-directory)) + '(attribute-changed attribute-changed attribute-changed)) + (t '(attribute-changed attribute-changed))) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (set-file-modes file-notify--test-tmpfile 000) + (file-notify--test-read-event) + (set-file-times file-notify--test-tmpfile '(0 0)) + (file-notify--test-read-event) + (delete-file file-notify--test-tmpfile)) + (file-notify-rm-watch file-notify--test-desc) ;; The environment shall be cleaned up. (file-notify--test-cleanup-p)) @@ -849,15 +885,15 @@ delivered." ;; Stop file notification. Autorevert shall still work via polling. (file-notify-rm-watch auto-revert-notify-watch-descriptor) (file-notify--wait-for-events - timeout (null auto-revert-use-notify)) - (should-not auto-revert-use-notify) + timeout (null auto-revert-notify-watch-descriptor)) + (should auto-revert-use-notify) (should-not auto-revert-notify-watch-descriptor) ;; 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) @@ -867,7 +903,10 @@ delivered." (string-match (format-message "Reverting buffer `%s'." (buffer-name buf)) captured-messages)) - (should (string-match "foo bla" (buffer-string))))) + (should (string-match "foo bla" (buffer-string)))) + + ;; Stop autorevert, in order to cleanup descriptor. + (auto-revert-mode -1)) ;; The environment shall be cleaned up. (file-notify--test-cleanup-p)) @@ -1013,7 +1052,7 @@ delivered." (file-notify--test-timeout) (not (file-notify-valid-p file-notify--test-desc))) (should-not (file-notify-valid-p file-notify--test-desc)) - (delete-directory file-notify--test-tmpfile t) + (delete-directory file-notify--test-tmpfile 'recursive) ;; The environment shall be cleaned up. (file-notify--test-cleanup-p)) @@ -1033,7 +1072,7 @@ delivered." (should (file-notify-valid-p file-notify--test-desc)) ;; After deleting the directory, the descriptor must not be ;; valid anymore. - (delete-directory file-notify--test-tmpfile t) + (delete-directory file-notify--test-tmpfile 'recursive) (file-notify--wait-for-events (file-notify--test-timeout) (not (file-notify-valid-p file-notify--test-desc))) @@ -1090,14 +1129,16 @@ delivered." ;; w32notify fires both `deleted' and `renamed' events. ((string-equal (file-notify--test-library) "w32notify") (let (r) - (dotimes (_i n r) - (setq r (append '(deleted renamed) r))))) + (dotimes (_i n) + (setq r (append '(deleted renamed) r))) + r)) ;; cygwin fires `changed' and `deleted' events, sometimes ;; in random order. ((eq system-type 'cygwin) (let (r) - (dotimes (_i n (cons :random r)) - (setq r (append '(changed deleted) r))))) + (dotimes (_i n) + (setq r (append '(changed deleted) r))) + (cons :random r))) (t (make-list n 'renamed))) (let ((source-file-list source-file-list) (target-file-list target-file-list)) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index d51f8bb9f80..3b192ee8727 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -21,6 +21,10 @@ (require 'ert) (require 'nadvice) +(eval-when-compile (require 'cl-lib)) +(require 'bytecomp) ; `byte-compiler-base-file-name'. +(require 'dired) ; `dired-uncache'. +(require 'filenotify) ; `file-notify-add-watch'. ;; Set to t if the local variable was set, `query' if the query was ;; triggered. @@ -153,6 +157,9 @@ form.") (ert-deftest files-test-bug-18141 () "Test for https://debbugs.gnu.org/18141 ." (skip-unless (executable-find "gzip")) + ;; If called interactively, environment variable + ;; $EMACS_TEST_DIRECTORY does not exist. + (skip-unless (file-exists-p files-test-bug-18141-file)) (let ((tempfile (make-temp-file "files-test-bug-18141" nil ".gz"))) (unwind-protect (progn @@ -255,14 +262,29 @@ be $HOME." (concat "/:/:" subdir))))) (delete-directory dir 'recursive)))) +(ert-deftest files-tests-file-name-non-special-quote-unquote () + (let (;; Just in case it is quoted, who knows. + (temporary-file-directory (file-name-unquote temporary-file-directory))) + (should-not (file-name-quoted-p temporary-file-directory)) + (should (file-name-quoted-p (file-name-quote temporary-file-directory))) + (should (equal temporary-file-directory + (file-name-unquote + (file-name-quote temporary-file-directory)))) + ;; It does not hurt to quote/unquote a file several times. + (should (equal (file-name-quote temporary-file-directory) + (file-name-quote + (file-name-quote temporary-file-directory)))) + (should (equal (file-name-unquote temporary-file-directory) + (file-name-unquote + (file-name-unquote temporary-file-directory)))))) + (ert-deftest files-tests--file-name-non-special--subprocess () "Check that Bug#25949 is fixed." (skip-unless (executable-find "true")) - (let ((defdir (if (memq system-type '(ms-dos windows-nt)) "/:c:/" "/:/"))) - (should (eq (let ((default-directory defdir)) (process-file "true")) 0)) - (should (processp (let ((default-directory defdir)) - (start-file-process "foo" nil "true")))) - (should (eq (let ((default-directory defdir)) (shell-command "true")) 0)))) + (let ((default-directory (file-name-quote temporary-file-directory))) + (should (zerop (process-file "true"))) + (should (processp (start-file-process "foo" nil "true"))) + (should (zerop (shell-command "true"))))) (defmacro files-tests--with-advice (symbol where function &rest body) (declare (indent 3)) @@ -277,7 +299,7 @@ be $HOME." (advice-remove #',symbol ,function))))) (defmacro files-tests--with-temp-file (name &rest body) - (declare (indent 1)) + (declare (indent 1) (debug (symbolp body))) (cl-check-type name symbol) `(let ((,name (make-temp-file "emacs"))) (unwind-protect @@ -297,8 +319,10 @@ be invoked with the right arguments." (let* ((buffer-visiting-file (current-buffer)) (actual-args ()) (log (lambda (&rest args) (push args actual-args)))) - (insert-file-contents (concat "/:" temp-file-name) :visit) + (insert-file-contents (file-name-quote temp-file-name) :visit) (should (stringp buffer-file-name)) + (should (file-name-quoted-p buffer-file-name)) + ;; The following is not true for remote files. (should (string-prefix-p "/:" buffer-file-name)) (should (consp (visited-file-modtime))) (should (equal (find-file-name-handler buffer-file-name @@ -325,6 +349,766 @@ be invoked with the right arguments." `((verify-visited-file-modtime ,buffer-visiting-file) (verify-visited-file-modtime nil)))))))) +(cl-defmacro files-tests--with-temp-non-special + ((name non-special-name &optional dir-flag) &rest body) + "Run tests with quoted file name. +NAME is the symbol which contains the name of a created temporary +file. NON-SPECIAL-NAME is another symbol, which contains the +temporary file name with quoted file name syntax. If DIR-FLAG is +non-nil, a temporary directory is created instead. +After evaluating BODY, the temporary file or directory is deleted." + (declare (indent 1) (debug ((symbolp symbolp &optional form) body))) + (cl-check-type name symbol) + (cl-check-type non-special-name symbol) + `(let* ((temporary-file-directory (file-truename temporary-file-directory)) + (,name (make-temp-file "files-tests" ,dir-flag)) + (,non-special-name (file-name-quote ,name))) + (unwind-protect + (progn ,@body) + (when (file-exists-p ,name) + (if ,dir-flag (delete-directory ,name t) + (delete-file ,name))) + (when (file-exists-p ,non-special-name) + (if ,dir-flag (delete-directory ,non-special-name t) + (delete-file ,non-special-name)))))) + +(defconst files-tests--special-file-name-extension ".special" + "Trailing string for test file name handler.") + +(defconst files-tests--special-file-name-regexp + (concat (regexp-quote files-tests--special-file-name-extension) "\\'") + "Regular expression for test file name handler.") + +(defun files-tests--special-file-name-handler (operation &rest args) + "File name handler for files with extension \".special\"." + (let ((arg args) + ;; Avoid cyclic call. + (file-name-handler-alist + (delete + (rassoc + 'files-tests--special-file-name-handler file-name-handler-alist) + file-name-handler-alist))) + ;; Remove trailing "\\.special\\'" from arguments, if they are not quoted. + (while arg + (when (and (stringp (car arg)) + (not (file-name-quoted-p (car arg))) + (string-match files-tests--special-file-name-regexp (car arg))) + (setcar arg (replace-match "" nil nil (car arg)))) + (setq arg (cdr arg))) + ;; Call it. + (apply operation args))) + +(cl-defmacro files-tests--with-temp-non-special-and-file-name-handler + ((name non-special-name &optional dir-flag) &rest body) + "Run tests with quoted file name, see `files-tests--with-temp-non-special'. +Both file names in NAME and NON-SPECIAL-NAME have the extension +\".special\". The created temporary file or directory does not have +that extension. +A file name handler is added which is activated for files with +that extension. It simply removes the extension from file names. +It is expected, that this file name handler works only for +unquoted file names." + (declare (indent 1) (debug ((symbolp symbolp &optional form) body))) + (cl-check-type name symbol) + (cl-check-type non-special-name symbol) + `(let* ((temporary-file-directory (file-truename temporary-file-directory)) + (file-name-handler-alist + `((,files-tests--special-file-name-regexp + . files-tests--special-file-name-handler) + . ,file-name-handler-alist)) + (,name (concat + (make-temp-file "files-tests" ,dir-flag) + files-tests--special-file-name-extension)) + (,non-special-name (file-name-quote ,name))) + (unwind-protect + (progn ,@body) + (when (file-exists-p ,name) + (if ,dir-flag (delete-directory ,name t) + (delete-file ,name))) + (when (file-exists-p ,non-special-name) + (if ,dir-flag (delete-directory ,non-special-name t) + (delete-file ,non-special-name)))))) + +(defun files-tests--new-name (name part) + (let (file-name-handler-alist) + (concat (file-name-sans-extension name) part (file-name-extension name t)))) + +(ert-deftest files-tests-file-name-non-special-access-file () + (files-tests--with-temp-non-special (tmpfile nospecial) + ;; Both versions of the file name work. + (should-not (access-file tmpfile "test")) + (should-not (access-file nospecial "test"))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (access-file tmpfile "test")) + ;; The quoted file name does not work. + (should-error (access-file nospecial "test")))) + +(ert-deftest files-tests-file-name-non-special-add-name-to-file () + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((newname (files-tests--new-name nospecial "add-name"))) + ;; Both versions work. + (add-name-to-file tmpfile newname) + (should (file-exists-p newname)) + (delete-file newname) + (add-name-to-file nospecial newname) + (should (file-exists-p newname)) + (delete-file newname))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((newname (files-tests--new-name tmpfile "add-name"))) + ;; Using an unquoted file name works. + (add-name-to-file tmpfile newname) + (should (file-exists-p newname)) + (delete-file newname)) + (let ((newname (files-tests--new-name nospecial "add-name"))) + (add-name-to-file tmpfile newname) + (should (file-exists-p newname)) + (delete-file newname) + ;; The quoted special file name does not work. + (should-error (add-name-to-file nospecial newname))))) + +(ert-deftest files-tests-file-name-non-special-byte-compiler-base-file-name () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (byte-compiler-base-file-name nospecial) + (byte-compiler-base-file-name tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (byte-compiler-base-file-name nospecial) tmpfile)) + (should-not (equal (byte-compiler-base-file-name tmpfile) tmpfile)))) + +(ert-deftest files-tests-file-name-non-special-copy-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (let ((newname (files-tests--new-name + (directory-file-name nospecial-dir) "copy-dir"))) + (copy-directory nospecial-dir newname) + (should (file-directory-p newname)) + (delete-directory newname) + (should-not (file-directory-p newname)))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (let ((newname (files-tests--new-name + (directory-file-name nospecial-dir) "copy-dir"))) + (should-error (copy-directory nospecial-dir newname)) + (delete-directory newname)))) + +(ert-deftest files-tests-file-name-non-special-copy-file () + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((newname + (files-tests--new-name (directory-file-name nospecial) "copy-file"))) + (copy-file nospecial newname) + (should (file-exists-p newname)) + (delete-file newname) + (should-not (file-exists-p newname)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((newname + (files-tests--new-name (directory-file-name nospecial) "copy-file"))) + (should-error (copy-file nospecial newname))))) + +(ert-deftest files-tests-file-name-non-special-delete-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (delete-directory nospecial-dir)) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-error (delete-directory nospecial-dir)))) + +(ert-deftest files-tests-file-name-non-special-delete-file () + (files-tests--with-temp-non-special (tmpfile nospecial) + (delete-file nospecial)) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (delete-file nospecial) + (should (file-exists-p tmpfile)))) + +(ert-deftest files-tests-file-name-non-special-diff-latest-backup-file () + (files-tests--with-temp-non-special (tmpfile nospecial) + (write-region "foo" nil (make-backup-file-name tmpfile)) + (should (equal (diff-latest-backup-file nospecial) + (diff-latest-backup-file tmpfile))) + (delete-file (diff-latest-backup-file nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (write-region "foo" nil (make-backup-file-name tmpfile)) + (should-not (equal (diff-latest-backup-file nospecial) + (diff-latest-backup-file tmpfile))) + (delete-file (diff-latest-backup-file nospecial)))) + +(ert-deftest files-tests-file-name-non-special-directory-file-name () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (should (equal (directory-file-name nospecial-dir) + (file-name-quote (directory-file-name tmpdir))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-not (equal (directory-file-name nospecial-dir) + (file-name-quote (directory-file-name tmpdir)))))) + +(ert-deftest files-tests-file-name-non-special-directory-files () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (should (equal (directory-files nospecial-dir) + (directory-files tmpdir)))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-error (directory-files nospecial-dir)))) + +(defun files-tests-file-attributes-equal (attr1 attr2) + ;; Element 4 is access time, which may be changed by the act of + ;; checking the attributes. + (setf (nth 4 attr1) nil) + (setf (nth 4 attr2) nil) + ;; Element 9 is unspecified. + (setf (nth 9 attr1) nil) + (setf (nth 9 attr2) nil) + (equal attr1 attr2)) + +(ert-deftest files-tests-file-name-non-special-directory-files-and-attributes () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (cl-loop for (file1 . attr1) in (directory-files-and-attributes nospecial-dir) + for (file2 . attr2) in (directory-files-and-attributes tmpdir) + do + (should (equal file1 file2)) + (should (files-tests-file-attributes-equal attr1 attr2)))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-error (directory-files-and-attributes nospecial-dir)))) + +(ert-deftest files-tests-file-name-non-special-dired-compress-handler () + ;; `dired-compress-file' can get confused by filenames with ":" in + ;; them, which causes this to fail on `windows-nt' systems. + (when (string-match-p ":" (expand-file-name temporary-file-directory)) + (ert-skip "FIXME: `dired-compress-file' unreliable when filenames contain `:'.")) + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((compressed (dired-compress-file nospecial))) + (when compressed + ;; FIXME: Should it return a still-quoted name? + (should (file-equal-p nospecial (dired-compress-file compressed)))))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (dired-compress-file nospecial)))) + +(ert-deftest files-tests-file-name-non-special-dired-uncache () + ;; FIXME: This is not a real test. We need cached values, and check + ;; whether they disappear. + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (dired-uncache nospecial-dir)) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (dired-uncache nospecial-dir))) + +(ert-deftest files-tests-file-name-non-special-expand-file-name () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (expand-file-name nospecial) nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (expand-file-name nospecial) nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-accessible-directory-p () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (should (file-accessible-directory-p nospecial-dir))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-not (file-accessible-directory-p nospecial-dir)))) + +(ert-deftest files-tests-file-name-non-special-file-acl () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-acl nospecial) (file-acl tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-acl nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-attributes () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (files-tests-file-attributes-equal + (file-attributes nospecial) (file-attributes tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-attributes nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-directory-p () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (should (file-directory-p nospecial-dir))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-not (file-directory-p nospecial-dir)))) + +(ert-deftest files-tests-file-name-non-special-file-equal-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (file-equal-p nospecial tmpfile)) + (should (file-equal-p tmpfile nospecial)) + (should (file-equal-p nospecial nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (file-equal-p (file-name-unquote nospecial) tmpfile)) + (should (file-equal-p tmpfile (file-name-unquote nospecial))) + ;; File `nospecial' does not exist, so it cannot be compared. + (should-not (file-equal-p nospecial nospecial)) + (write-region "foo" nil nospecial) + (should (file-equal-p nospecial nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-executable-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should-not (file-executable-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-executable-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-exists-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (file-exists-p tmpfile)) + (should (file-exists-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (file-exists-p tmpfile)) + (should-not (file-exists-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-in-directory-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((nospecial-tempdir (file-name-quote temporary-file-directory))) + (should (file-in-directory-p nospecial temporary-file-directory)) + (should (file-in-directory-p tmpfile nospecial-tempdir)) + (should (file-in-directory-p nospecial nospecial-tempdir)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((nospecial-tempdir (file-name-quote temporary-file-directory))) + (should (file-in-directory-p nospecial temporary-file-directory)) + (should (file-in-directory-p tmpfile nospecial-tempdir)) + (should (file-in-directory-p nospecial nospecial-tempdir))))) + +(ert-deftest files-tests-file-name-non-special-file-local-copy () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should-not (file-local-copy nospecial))) ; Already local. + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-local-copy nospecial)))) ; Already local. + +(ert-deftest files-tests-file-name-non-special-file-modes () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-modes nospecial) (file-modes tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (equal (file-modes nospecial) (file-modes tmpfile))))) + +(ert-deftest files-tests-file-name-non-special-file-name-all-completions () + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((nospecial-tempdir (file-name-quote temporary-file-directory)) + (tmpdir temporary-file-directory) + (file (file-name-nondirectory tmpfile)) + (nospecial-file (file-name-nondirectory nospecial))) + (should (string-equal file nospecial-file)) + (should (equal (file-name-all-completions + nospecial-file nospecial-tempdir) + (file-name-all-completions file tmpdir))) + (should (equal (file-name-all-completions file nospecial-tempdir) + (file-name-all-completions file tmpdir))) + (should (equal (file-name-all-completions nospecial-file tmpdir) + (file-name-all-completions file tmpdir))))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((nospecial-tempdir (file-name-quote temporary-file-directory)) + (tmpdir temporary-file-directory) + (file (file-name-nondirectory tmpfile)) + (nospecial-file (file-name-nondirectory nospecial))) + (should-not (string-equal file nospecial-file)) + (should-not (equal (file-name-all-completions + nospecial-file nospecial-tempdir) + (file-name-all-completions file tmpdir))) + (should (equal (file-name-all-completions file nospecial-tempdir) + (file-name-all-completions file tmpdir))) + (should (equal (file-name-all-completions nospecial-file tmpdir) + (file-name-all-completions file tmpdir)))))) + +(ert-deftest files-tests-file-name-non-special-file-name-as-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (should (equal (file-name-as-directory nospecial-dir) + (file-name-quote (file-name-as-directory tmpdir))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-not (equal (file-name-as-directory nospecial-dir) + (file-name-quote (file-name-as-directory tmpdir)))))) + +(ert-deftest files-tests-file-name-non-special-file-name-case-insensitive-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-name-case-insensitive-p nospecial) + (file-name-case-insensitive-p tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (file-name-case-insensitive-p nospecial) + (file-name-case-insensitive-p tmpfile))))) + +(ert-deftest files-tests-file-name-non-special-file-name-completion () + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((nospecial-tempdir (file-name-quote temporary-file-directory)) + (tmpdir temporary-file-directory) + (file (file-name-nondirectory tmpfile)) + (nospecial-file (file-name-nondirectory nospecial))) + (should (string-equal file nospecial-file)) + (should (equal (file-name-completion nospecial-file nospecial-tempdir) + (file-name-completion file tmpdir))) + (should (equal (file-name-completion file nospecial-tempdir) + (file-name-completion file tmpdir))) + (should (equal (file-name-completion nospecial-file tmpdir) + (file-name-completion file tmpdir))))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((nospecial-tempdir (file-name-quote temporary-file-directory)) + (tmpdir temporary-file-directory) + (file (file-name-nondirectory tmpfile)) + (nospecial-file (file-name-nondirectory nospecial))) + (should-not (string-equal file nospecial-file)) + (should-not (equal (file-name-completion nospecial-file nospecial-tempdir) + (file-name-completion file tmpdir))) + (should (equal (file-name-completion file nospecial-tempdir) + (file-name-completion file tmpdir))) + (should (equal (file-name-completion nospecial-file tmpdir) + (file-name-completion file tmpdir)))))) + +(ert-deftest files-tests-file-name-non-special-file-name-directory () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-name-directory nospecial) + (file-name-quote temporary-file-directory)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (file-name-directory nospecial) + (file-name-quote temporary-file-directory))))) + +(ert-deftest files-tests-file-name-non-special-file-name-nondirectory () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-name-nondirectory nospecial) + (file-name-nondirectory tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (equal (file-name-nondirectory nospecial) + (file-name-nondirectory tmpfile))))) + +(ert-deftest files-tests-file-name-non-special-file-name-sans-versions () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-name-sans-versions nospecial) nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (file-name-sans-versions nospecial) nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-newer-than-file-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should-not (file-newer-than-file-p nospecial tmpfile)) + (should-not (file-newer-than-file-p tmpfile nospecial)) + (should-not (file-newer-than-file-p nospecial nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-newer-than-file-p nospecial tmpfile)) + (should (file-newer-than-file-p tmpfile nospecial)) + (should-not (file-newer-than-file-p nospecial nospecial)))) + +(ert-deftest files-tests-file-name-non-special-notify-handlers () + (skip-unless file-notify--library) + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((watch (file-notify-add-watch nospecial '(change) #'ignore))) + (should (file-notify-valid-p watch)) + (file-notify-rm-watch watch) + (should-not (file-notify-valid-p watch)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((watch (file-notify-add-watch nospecial '(change) #'ignore))) + (should (file-notify-valid-p watch)) + (file-notify-rm-watch watch) + (should-not (file-notify-valid-p watch))))) + +(ert-deftest files-tests-file-name-non-special-file-ownership-preserved-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-ownership-preserved-p nospecial) + (file-ownership-preserved-p tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (file-ownership-preserved-p nospecial) + (file-ownership-preserved-p tmpfile))))) + +(ert-deftest files-tests-file-name-non-special-file-readable-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (file-readable-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-readable-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-regular-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (file-regular-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-regular-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-remote-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should-not (file-remote-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-remote-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-selinux-context () + (files-tests--with-temp-non-special (tmpfile nospecial) + (unless (equal (file-selinux-context tmpfile) '(nil nil nil nil)) + (should (equal (file-selinux-context nospecial) + (file-selinux-context tmpfile))))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (unless (equal (file-selinux-context tmpfile) '(nil nil nil nil)) + (should-not (equal (file-selinux-context nospecial) + (file-selinux-context tmpfile)))))) + +(ert-deftest files-tests-file-name-non-special-file-symlink-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should-not (file-symlink-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-symlink-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-truename () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal nospecial (file-truename nospecial)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal nospecial (file-truename nospecial))))) + +(ert-deftest files-tests-file-name-non-special-file-writable-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (file-writable-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (file-writable-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-find-backup-file-name () + (let (version-control delete-old-versions + (kept-old-versions (default-toplevel-value 'kept-old-versions)) + (kept-new-versions (default-toplevel-value 'kept-new-versions))) + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (find-backup-file-name nospecial) + (mapcar #'file-name-quote + (find-backup-file-name tmpfile))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpfile nospecial) + (should-not (equal (find-backup-file-name nospecial) + (mapcar #'file-name-quote + (find-backup-file-name tmpfile))))))) + +(ert-deftest files-tests-file-name-non-special-get-file-buffer () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should-not (get-file-buffer nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (get-file-buffer nospecial)))) + +(ert-deftest files-tests-file-name-non-special-insert-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (should (equal (with-temp-buffer + (insert-directory nospecial-dir "") + (buffer-string)) + (with-temp-buffer + (insert-directory tmpdir "") + (buffer-string))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-error (with-temp-buffer (insert-directory nospecial-dir ""))))) + +(ert-deftest files-tests-file-name-non-special-insert-file-contents () + (files-tests--with-temp-non-special (tmpfile nospecial) + (with-temp-buffer + (insert-file-contents nospecial) + (should (zerop (buffer-size))))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-error (with-temp-buffer (insert-file-contents nospecial))))) + +(ert-deftest files-tests-file-name-non-special-load () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (load nospecial nil t))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (load nospecial nil t)))) + +(ert-deftest files-tests-file-name-non-special-make-auto-save-file-name () + (files-tests--with-temp-non-special (tmpfile nospecial) + (save-current-buffer + (should (equal (prog2 (set-buffer (find-file-noselect nospecial)) + (make-auto-save-file-name) + (kill-buffer)) + (prog2 (set-buffer (find-file-noselect tmpfile)) + (make-auto-save-file-name) + (kill-buffer)))))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (save-current-buffer + (should-not (equal (prog2 (set-buffer (find-file-noselect nospecial)) + (make-auto-save-file-name) + (kill-buffer)) + (prog2 (set-buffer (find-file-noselect tmpfile)) + (make-auto-save-file-name) + (kill-buffer))))))) + +(ert-deftest files-tests-file-name-non-special-make-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (let ((default-directory nospecial-dir)) + (make-directory "dir") + (should (file-directory-p "dir")) + (delete-directory "dir"))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (let ((default-directory nospecial-dir)) + (should-error (make-directory "dir"))))) + +(ert-deftest files-tests-file-name-non-special-make-directory-internal () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (let ((default-directory nospecial-dir)) + (make-directory-internal "dir") + (should (file-directory-p "dir")) + (delete-directory "dir"))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (let ((default-directory nospecial-dir)) + (should-error (make-directory-internal "dir"))))) + +(ert-deftest files-tests-file-name-non-special-make-nearby-temp-file () + (let* ((default-directory (file-name-quote temporary-file-directory)) + (near-tmpfile (make-nearby-temp-file "file"))) + (should (file-exists-p near-tmpfile)) + (delete-file near-tmpfile))) + +(ert-deftest files-tests-file-name-non-special-make-symbolic-link () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (files-tests--with-temp-non-special (tmpfile nospecial) + (let* ((linkname (expand-file-name "link" tmpdir)) + (may-symlink (ignore-errors (make-symbolic-link tmpfile linkname) + t))) + (when may-symlink + (should (file-symlink-p linkname)) + (delete-file linkname) + (let ((linkname (expand-file-name "link" nospecial-dir))) + (make-symbolic-link tmpfile linkname) + (should (file-symlink-p linkname)) + (delete-file linkname)))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpfile nospecial) + (let* ((linkname (expand-file-name "link" tmpdir)) + (may-symlink (ignore-errors (make-symbolic-link tmpfile linkname) + t))) + (when may-symlink + (should (file-symlink-p linkname)) + (delete-file linkname) + (let ((linkname (expand-file-name "link" nospecial-dir))) + (should-error (make-symbolic-link tmpfile linkname)))))))) + +;; See `files-tests--file-name-non-special--subprocess'. +;; (ert-deftest files-tests-file-name-non-special-process-file ()) + +(ert-deftest files-tests-file-name-non-special-rename-file () + (files-tests--with-temp-non-special (tmpfile nospecial) + (rename-file nospecial (files-tests--new-name nospecial "x")) + (rename-file (files-tests--new-name nospecial "x") nospecial) + (rename-file tmpfile (files-tests--new-name nospecial "x")) + (rename-file (files-tests--new-name nospecial "x") nospecial) + (rename-file nospecial (files-tests--new-name tmpfile "x")) + (rename-file (files-tests--new-name nospecial "x") nospecial)) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-error (rename-file nospecial (files-tests--new-name nospecial "x"))) + (rename-file tmpfile (files-tests--new-name nospecial "x")) + (rename-file (files-tests--new-name nospecial "x") nospecial) + (rename-file nospecial (files-tests--new-name tmpfile "x")) + (should-error (rename-file (files-tests--new-name nospecial "x") nospecial)) + (delete-file (files-tests--new-name tmpfile "x")) + (delete-file (files-tests--new-name nospecial "x")))) + +(ert-deftest files-tests-file-name-non-special-set-file-acl () + (files-tests--with-temp-non-special (tmpfile nospecial) + (set-file-acl nospecial (file-acl nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (set-file-acl nospecial (file-acl nospecial)))) + +(ert-deftest files-tests-file-name-non-special-set-file-modes () + (files-tests--with-temp-non-special (tmpfile nospecial) + (set-file-modes nospecial (file-modes nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-error (set-file-modes nospecial (file-modes nospecial))))) + +(ert-deftest files-tests-file-name-non-special-set-file-selinux-context () + (files-tests--with-temp-non-special (tmpfile nospecial) + (unless (equal (file-selinux-context tmpfile) '(nil nil nil nil)) + (set-file-selinux-context nospecial (file-selinux-context nospecial)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (unless (equal (file-selinux-context tmpfile) '(nil nil nil nil)) + (should-error + (set-file-selinux-context nospecial (file-selinux-context nospecial)))))) + +(ert-deftest files-tests-file-name-non-special-set-file-times () + (files-tests--with-temp-non-special (tmpfile nospecial) + (set-file-times nospecial)) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-error (set-file-times nospecial)))) + +(ert-deftest files-tests-file-name-non-special-set-visited-file-modtime () + (files-tests--with-temp-non-special (tmpfile nospecial) + (save-current-buffer + (set-buffer (find-file-noselect nospecial)) + (set-visited-file-modtime) + (kill-buffer))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (save-current-buffer + (set-buffer (find-file-noselect nospecial)) + (set-visited-file-modtime) + (kill-buffer)))) + +(ert-deftest files-tests-file-name-non-special-shell-command () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (with-temp-buffer + (let ((default-directory nospecial-dir)) + (shell-command (concat (shell-quote-argument + (concat invocation-directory invocation-name)) + " --version") + (current-buffer)) + (goto-char (point-min)) + (should (search-forward emacs-version nil t))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (with-temp-buffer + (let ((default-directory nospecial-dir)) + (should-error + (shell-command (concat (shell-quote-argument + (concat invocation-directory invocation-name)) + " --version") + (current-buffer))))))) + +(ert-deftest files-tests-file-name-non-special-start-file-process () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (with-temp-buffer + (let ((default-directory nospecial-dir)) + (let ((proc (start-file-process + "emacs" (current-buffer) + (concat invocation-directory invocation-name) + "--version"))) + (accept-process-output proc) + (goto-char (point-min)) + (should (search-forward emacs-version nil t)) + ;; Don't stop the test run with a query, as the subprocess + ;; may or may not be dead by the time we reach here. + (set-process-query-on-exit-flag proc nil))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (with-temp-buffer + (let ((default-directory nospecial-dir)) + (should-error (start-file-process + "emacs" (current-buffer) + (concat invocation-directory invocation-name) + "--version")))))) + +(ert-deftest files-tests-file-name-non-special-substitute-in-file-name () + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((process-environment (cons "FOO=foo" process-environment)) + (nospecial-foo (files-tests--new-name nospecial "$FOO"))) + ;; The "/:" prevents substitution. + (equal (substitute-in-file-name nospecial-foo) nospecial-foo))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((process-environment (cons "FOO=foo" process-environment)) + (nospecial-foo (files-tests--new-name nospecial "$FOO"))) + ;; The "/:" prevents substitution. + (equal (substitute-in-file-name nospecial-foo) nospecial-foo)))) + +(ert-deftest files-tests-file-name-non-special-temporary-file-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (let ((default-directory nospecial-dir)) + (equal (temporary-file-directory) temporary-file-directory))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (let ((default-directory nospecial-dir)) + (equal (temporary-file-directory) temporary-file-directory)))) + +(ert-deftest files-tests-file-name-non-special-unhandled-file-name-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (equal (unhandled-file-name-directory nospecial-dir) + (file-name-as-directory tmpdir))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (equal (unhandled-file-name-directory nospecial-dir) + (file-name-as-directory tmpdir)))) + +(ert-deftest files-tests-file-name-non-special-vc-registered () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (vc-registered nospecial) (vc-registered tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (vc-registered nospecial) (vc-registered tmpfile))))) + +;; See test `files-tests--file-name-non-special--buffers'. +;; (ert-deftest files-tests-file-name-non-special-verify-visited-file-modtime ()) + +(ert-deftest files-tests-file-name-non-special-write-region () + (files-tests--with-temp-non-special (tmpfile nospecial) + (with-temp-buffer + (write-region nil nil nospecial nil :visit))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (with-temp-buffer + (write-region nil nil nospecial nil :visit)))) + (ert-deftest files-tests--insert-directory-wildcard-in-dir-p () (let ((alist (list (cons "/home/user/*/.txt" (cons "/home/user/" "*/.txt")) (cons "/home/user/.txt" nil) @@ -373,7 +1157,8 @@ consider the buffer saved, without prompting for a file name (Bug#28412)." (let ((read-file-name-function (lambda (&rest _ignore) - (error "Prompting for file name")))) + (error "Prompting for file name"))) + require-final-newline) ;; With contents function, and no file. (with-temp-buffer (setq write-contents-functions (lambda () t)) diff --git a/test/lisp/gnus/gnus-tests.el b/test/lisp/gnus/gnus-tests.el index e149dccc258..fe1fc184147 100644 --- a/test/lisp/gnus/gnus-tests.el +++ b/test/lisp/gnus/gnus-tests.el @@ -26,8 +26,6 @@ ;;; Code: ;; registry.el is required by gnus-registry.el but this way we're explicit. -(eval-when-compile (require 'cl)) - (require 'registry) (require 'gnus-registry) diff --git a/test/lisp/gnus/message-tests.el b/test/lisp/gnus/message-tests.el index ec1f2470204..7fa0fe9b0e9 100644 --- a/test/lisp/gnus/message-tests.el +++ b/test/lisp/gnus/message-tests.el @@ -29,6 +29,8 @@ (require 'ert) (require 'ert-x) +(require 'cl-lib) + (ert-deftest message-mode-propertize () (with-temp-buffer (unwind-protect @@ -97,6 +99,60 @@ (should (string= stripped-was (message-strip-subject-trailing-was with-was))))))) +(ert-deftest message-all-recipients () + (ert-with-test-buffer (:name "message") + (insert "To: Person 1 <p1@p1.org>, Person 2 <p2@p2.org>\n") + (insert "Cc: Person 3 <p3@p3.org>, Person 4 <p4@p4.org>\n") + (insert "Bcc: Person 5 <p5@p5.org>, Person 6 <p6@p6.org>\n") + (should (equal (message-all-recipients) + '(("Person 1" "p1@p1.org") + ("Person 2" "p2@p2.org") + ("Person 3" "p3@p3.org") + ("Person 4" "p4@p4.org") + ("Person 5" "p5@p5.org") + ("Person 6" "p6@p6.org")))))) + +(ert-deftest message-all-epg-keys-available-p () + (skip-unless (epg-check-configuration (epg-find-configuration 'OpenPGP))) + (let ((person1 '("Person 1" "p1@p1.org")) + (person2 '("Person 2" "p2@p2.org")) + (person3 '("Person 3" "p3@p3.org")) + (recipients nil) + (keyring '("p1@p1.org" "p2@p2.org"))) + (cl-letf (((symbol-function 'epg-list-keys) + (lambda (_ email) (cl-find email keyring :test #'string=))) + ((symbol-function 'message-all-recipients) + (lambda () recipients))) + + (setq recipients (list)) + (should (message-all-epg-keys-available-p)) + + (setq recipients (list person1)) + (should (message-all-epg-keys-available-p)) + + (setq recipients (list person1 person2)) + (should (message-all-epg-keys-available-p)) + + (setq recipients (list person3)) + (should-not (message-all-epg-keys-available-p)) + + (setq recipients (list person1 person3)) + (should-not (message-all-epg-keys-available-p)) + + (setq recipients (list person3 person1)) + (should-not (message-all-epg-keys-available-p)) + + (setq recipients (list person1 person2 person3)) + (should-not (message-all-epg-keys-available-p))))) + +(ert-deftest message-alter-repeat-address () + (should (equal (message--alter-repeat-address + "Lars Ingebrigtsen <larsi@gnus.org>") + "Lars Ingebrigtsen <larsi@gnus.org>")) + + (should (equal (message--alter-repeat-address + "\"larsi@gnus.org\" <larsi@gnus.org>") + "larsi@gnus.org"))) (provide 'message-mode-tests) diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 5fd788c03fc..7e726eb7e8b 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -81,6 +81,11 @@ Return first line of the output of (describe-function-1 FUNC)." (result (help-fns-tests--describe-function 'search-forward-regexp))) (should (string-match regexp result)))) +(ert-deftest help-fns-test-dangling-alias () + "Make sure we don't burp on bogus aliases." + (let ((f (make-symbol "bogus-alias"))) + (define-obsolete-function-alias f 'help-fns-test--undefined-function "past") + (describe-symbol f))) ;;; Test describe-function over functions with funny names (defun abc\\\[universal-argument\]b\`c\'d\\e\"f (x) diff --git a/test/lisp/hi-lock-tests.el b/test/lisp/hi-lock-tests.el index 40d76ee9de5..4c639b03dca 100644 --- a/test/lisp/hi-lock-tests.el +++ b/test/lisp/hi-lock-tests.el @@ -29,7 +29,7 @@ (with-temp-buffer (insert "a A b B\n") (cl-letf (((symbol-function 'completing-read) - (lambda (prompt coll x y z hist defaults) + (lambda (_prompt _coll _x _y _z _hist defaults) (car defaults)))) (dotimes (_ 2) (let ((face (hi-lock-read-face-name))) @@ -41,7 +41,7 @@ (with-temp-buffer (insert "foo bar") (cl-letf (((symbol-function 'completing-read) - (lambda (prompt coll x y z hist defaults) + (lambda (_prompt _coll _x _y _z _hist defaults) (car defaults)))) (hi-lock-set-pattern "9999" (hi-lock-read-face-name)) ; No match (hi-lock-set-pattern "foo" (hi-lock-read-face-name))) diff --git a/test/lisp/htmlfontify-tests.el b/test/lisp/htmlfontify-tests.el index 908c888af54..002415cadfe 100644 --- a/test/lisp/htmlfontify-tests.el +++ b/test/lisp/htmlfontify-tests.el @@ -36,7 +36,7 @@ available (Bug#25468)." (should (equal (let ((process-environment (cons "SHELL=/does/not/exist" process-environment))) (call-process - (expand-file-name (invocation-name) (invocation-directory)) + (expand-file-name invocation-name invocation-directory) nil nil nil "--quick" "--batch" (concat "--load=" (locate-library "htmlfontify")))) diff --git a/test/lisp/info-xref-tests.el b/test/lisp/info-xref-tests.el index 7532befae0a..1fcbb385791 100644 --- a/test/lisp/info-xref-tests.el +++ b/test/lisp/info-xref-tests.el @@ -144,4 +144,21 @@ text. (format "%s.info" (file-name-sans-extension tempfile2))))))) +(ert-deftest info-xref-test-emacs-manuals () + "Test that all internal links in the Emacs manuals work." + :tags '(:expensive-test) + (require 'info) + (let ((default-directory (car (Info-default-dirs))) + (Info-directory-list '("."))) + (skip-unless (file-readable-p "emacs.info")) + (info-xref-check-all) + (with-current-buffer info-xref-output-buffer + (goto-char (point-max)) + (should (search-backward "done" nil t)) + (should (string-match-p + " [0-9]\\{3,\\} good, 0 bad" + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))))))) + + ;;; info-xref.el ends here diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el new file mode 100644 index 00000000000..7dd7224726b --- /dev/null +++ b/test/lisp/international/ccl-tests.el @@ -0,0 +1,229 @@ +;; 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'ccl) +(require 'seq) + + +(ert-deftest shift () + ;; shift left +ve 5628 #x00000000000015fc + (should (= (ash 5628 8) 1440768)) ; #x000000000015fc00 + (should (= (lsh 5628 8) 1440768)) ; #x000000000015fc00 + + ;; shift left -ve -5628 #x3fffffffffffea04 + (should (= (ash -5628 8) -1440768)) ; #x3fffffffffea0400 + (should (= (lsh -5628 8) -1440768)) ; #x3fffffffffea0400 + + ;; shift right +ve 5628 #x00000000000015fc + (should (= (ash 5628 -8) 21)) ; #x0000000000000015 + (should (= (lsh 5628 -8) 21)) ; #x0000000000000015 + + ;; shift right -ve -5628 #x3fffffffffffea04 + (should (= (ash -5628 -8) -22)) ; #x3fffffffffffffea + (should (= (lsh -5628 -8) + (ash (- -5628 (ash most-negative-fixnum 1)) -8) + (ash (logand (ash -5628 -1) most-positive-fixnum) -7)))) + +;; CCl program from `pgg-parse-crc24' in lisp/obsolete/pgg-parse.el +(defconst prog-pgg-source + '(1 + ((loop + (read r0) (r1 ^= r0) (r2 ^= 0) + (r5 = 0) + (loop + (r1 <<= 1) + (r1 += ((r2 >> 15) & 1)) + (r2 <<= 1) + (if (r1 & 256) + ((r1 ^= 390) (r2 ^= 19707))) + (if (r5 < 7) + ((r5 += 1) + (repeat)))) + (repeat))))) + +(defconst prog-pgg-code + [1 30 14 114744 114775 0 161 131127 1 148217 15 82167 + 1 1848 131159 1 1595 5 256 114743 390 114775 19707 + 1467 16 7 183 1 -5628 -7164 22]) + +(defconst prog-pgg-dump +"Out-buffer must be as large as in-buffer. +Main-body: + 2:[read-register] read r0 (0 remaining) + 3:[set-assign-expr-register] r1 ^= r0 + 4:[set-assign-expr-const] r2 ^= 0 + 6:[set-short-const] r5 = 0 + 7:[set-assign-expr-const] r1 <<= 1 + 9:[set-expr-const] r7 = r2 >> 15 + 11:[set-assign-expr-const] r7 &= 1 + 13:[set-assign-expr-register] r1 += r7 + 14:[set-assign-expr-const] r2 <<= 1 + 16:[jump-cond-expr-const] if !(r1 & 256), jump to 23(+7) + 19:[set-assign-expr-const] r1 ^= 390 + 21:[set-assign-expr-const] r2 ^= 19707 + 23:[jump-cond-expr-const] if !(r5 < 7), jump to 29(+6) + 26:[set-assign-expr-const] r5 += 1 + 28:[jump] jump to 7(-21) + 29:[jump] jump to 2(-27) +At EOF: + 30:[end] end +") + +(ert-deftest ccl-compile-pgg () + (should (equal (ccl-compile prog-pgg-source) prog-pgg-code))) + +(ert-deftest ccl-dump-pgg () + (with-temp-buffer + (ccl-dump prog-pgg-code) + (should (equal (buffer-string) prog-pgg-dump)))) + +(ert-deftest pgg-parse-crc24 () + ;; Compiler + (require 'pgg) + (should (equal pgg-parse-crc24 prog-pgg-code)) + ;; Interpreter + (should (equal (pgg-parse-crc24-string "foo") (concat [#x4f #xc2 #x55]))) + (should (equal (pgg-parse-crc24-string "bar") (concat [#x51 #xd9 #x53]))) + (should (equal (pgg-parse-crc24-string "baz") (concat [#xf0 #x58 #x6a])))) + +(ert-deftest pgg-parse-crc24-dump () + ;; Disassembler + (require 'pgg) + (with-temp-buffer + (ccl-dump pgg-parse-crc24) + (should (equal (buffer-string) prog-pgg-dump)))) + +;;---------------------------------------------------------------------------- +;; Program from 'midikbd-decoder in midi-kbd-0.2.el GNU ELPA package +(defconst prog-midi-source + '(2 + (loop + (loop + ;; central message receiver loop here. + ;; When it exits, the command to deal with is in r0 + ;; Any arguments are in r1 and r2 + ;; r3 contains: 0 if no arguments are accepted + ;; 1 if 1 argument can be accepted + ;; 2 if 2 arguments can be accepted + ;; 3 if the first of two arguments has been accepted + ;; Arguments are read into r1 and r2. + ;; r4 contains the current running status byte if any. + (read-if (r0 < #x80) + (branch r3 + (repeat) + ((r1 = r0) (r0 = r4) (break)) + ((r1 = r0) (r3 = 3) (repeat)) + ((r2 = r0) (r3 = 2) (r0 = r4) (break)))) + (if (r0 >= #xf8) ; real time message + (break)) + (if (r0 < #xf0) ; channel command + ((r4 = r0) + (if ((r0 & #xe0) == #xc0) + ;; program change and channel pressure take only 1 argument + (r3 = 1) + (r3 = 2)) + (repeat))) + ;; system common message, we swallow those for now + (r3 = 0) + (repeat)) + (if ((r0 & #xf0) == #x90) + (if (r2 == 0) ; Some Midi devices use velocity 0 + ; for switching notes off, + ; so translate into note-off + ; and fall through + (r0 -= #x10) + ((r0 &= #xf) + (write 0) + (write r0 r1 r2) + (repeat)))) + (if ((r0 & #xf0) == #x80) + ((r0 &= #xf) + (write 1) + (write r0 r1 r2) + (repeat))) + (repeat)))) + +(defconst prog-midi-code + [2 72 4893 16 128 1133 5 6 9 12 16 -2556 32 1024 6660 32 865 + -4092 64 609 1024 4868 795 20 248 3844 3099 16 240 128 82169 + 224 1275 18 192 353 260 609 -9468 97 -9980 82169 240 4091 + 18 144 1371 18 0 16407 16 1796 81943 15 20 529 305 81 -14588 + 82169 240 2555 18 128 81943 15 276 529 305 81 -17660 -17916 22]) + +(defconst prog-midi-dump +(concat "Out-buffer must be 2 times bigger than in-buffer. +Main-body: + 2:[read-jump-cond-expr-const] read r0, if !(r0 < 128), jump to 22(+20) + 5:[branch] jump to array[r3] of length 4 + 11 12 15 18 22 "" + 11:[jump] jump to 2(-9) + 12:[set-register] r1 = r0 + 13:[set-register] r0 = r4 + 14:[jump] jump to 41(+27) + 15:[set-register] r1 = r0 + 16:[set-short-const] r3 = 3 + 17:[jump] jump to 2(-15) + 18:[set-register] r2 = r0 + 19:[set-short-const] r3 = 2 + 20:[set-register] r0 = r4 + 21:[jump] jump to 41(+20) + 22:[jump-cond-expr-const] if !(r0 >= 248), jump to 26(+4) + 25:[jump] jump to 41(+16) + 26:[jump-cond-expr-const] if !(r0 < 240), jump to 39(+13) + 29:[set-register] r4 = r0 + 30:[set-expr-const] r7 = r0 & 224 + 32:[jump-cond-expr-const] if !(r7 == 192), jump to 37(+5) + 35:[set-short-const] r3 = 1 + 36:[jump] jump to 38(+2) + 37:[set-short-const] r3 = 2 + 38:[jump] jump to 2(-36) + 39:[set-short-const] r3 = 0 + 40:[jump] jump to 2(-38) + 41:[set-expr-const] r7 = r0 & 240 + 43:[jump-cond-expr-const] if !(r7 == 144), jump to 59(+16) + 46:[jump-cond-expr-const] if !(r2 == 0), jump to 52(+6) + 49:[set-assign-expr-const] r0 -= 16 + 51:[jump] jump to 59(+8) + 52:[set-assign-expr-const] r0 &= 15 + 54:[write-const-string] write char \"\x00\" + 55:[write-register] write r0 (2 remaining) + 56:[write-register] write r1 (1 remaining) + 57:[write-register] write r2 (0 remaining) + 58:[jump] jump to 2(-56) + 59:[set-expr-const] r7 = r0 & 240 + 61:[jump-cond-expr-const] if !(r7 == 128), jump to 71(+10) + 64:[set-assign-expr-const] r0 &= 15 + 66:[write-const-string] write char \"\x01\" + 67:[write-register] write r0 (2 remaining) + 68:[write-register] write r1 (1 remaining) + 69:[write-register] write r2 (0 remaining) + 70:[jump] jump to 2(-68) + 71:[jump] jump to 2(-69) +At EOF: + 72:[end] end +")) + +(ert-deftest ccl-compile-midi () + (should (equal (ccl-compile prog-midi-source) prog-midi-code))) + +(ert-deftest ccl-dump-midi () + (with-temp-buffer + (ccl-dump prog-midi-code) + (should (equal (buffer-string) prog-midi-dump)))) diff --git a/test/lisp/json-tests.el b/test/lisp/json-tests.el index ea562e8b134..84039c09cee 100644 --- a/test/lisp/json-tests.el +++ b/test/lisp/json-tests.el @@ -325,5 +325,72 @@ Point is moved to beginning of the buffer." (with-temp-buffer (should-error (json-encode (current-buffer)) :type 'json-error))) +;;; Pretty-print + +(defun json-tests-equal-pretty-print (original &optional expected) + "Abort current test if pretty-printing ORIGINAL does not yield EXPECTED. + +Both ORIGINAL and EXPECTED should be strings. If EXPECTED is +nil, ORIGINAL should stay unchanged by pretty-printing." + (with-temp-buffer + (insert original) + (json-pretty-print-buffer) + (should (equal (buffer-string) (or expected original))))) + +(ert-deftest test-json-pretty-print-string () + (json-tests-equal-pretty-print "\"\"") + (json-tests-equal-pretty-print "\"foo\"")) + +(ert-deftest test-json-pretty-print-atom () + (json-tests-equal-pretty-print "true") + (json-tests-equal-pretty-print "false") + (json-tests-equal-pretty-print "null")) + +(ert-deftest test-json-pretty-print-number () + (json-tests-equal-pretty-print "123") + (json-tests-equal-pretty-print "0.123")) + +(ert-deftest test-json-pretty-print-object () + ;; empty (regression test for bug#24252) + (json-tests-equal-pretty-print + "{}" + "{\n}") + ;; one pair + (json-tests-equal-pretty-print + "{\"key\":1}" + "{\n \"key\": 1\n}") + ;; two pairs + (json-tests-equal-pretty-print + "{\"key1\":1,\"key2\":2}" + "{\n \"key1\": 1,\n \"key2\": 2\n}") + ;; embedded object + (json-tests-equal-pretty-print + "{\"foo\":{\"key\":1}}" + "{\n \"foo\": {\n \"key\": 1\n }\n}") + ;; embedded array + (json-tests-equal-pretty-print + "{\"key\":[1,2]}" + "{\n \"key\": [\n 1,\n 2\n ]\n}")) + +(ert-deftest test-json-pretty-print-array () + ;; empty + (json-tests-equal-pretty-print "[]") + ;; one item + (json-tests-equal-pretty-print + "[1]" + "[\n 1\n]") + ;; two items + (json-tests-equal-pretty-print + "[1,2]" + "[\n 1,\n 2\n]") + ;; embedded object + (json-tests-equal-pretty-print + "[{\"key\":1}]" + "[\n {\n \"key\": 1\n }\n]") + ;; embedded array + (json-tests-equal-pretty-print + "[[1,2]]" + "[\n [\n 1,\n 2\n ]\n]")) + (provide 'json-tests) ;;; json-tests.el ends here diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el new file mode 100644 index 00000000000..1a84c30e33d --- /dev/null +++ b/test/lisp/jsonrpc-tests.el @@ -0,0 +1,254 @@ +;;; jsonrpc-tests.el --- tests for jsonrpc.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: João Távora <joaotavora@gmail.com> +;; Maintainer: João Távora <joaotavora@gmail.com> +;; Keywords: tests + +;; 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: + +;; About "deferred" tests, `jsonrpc--test-client' has a flag that we +;; test in its `jsonrpc-connection-ready-p' API method. It holds any +;; `jsonrpc-request's and `jsonrpc-async-request's explicitly passed +;; `:deferred'. After clearing the flag, the held requests are +;; actually sent to the server in the next opportunity (when receiving +;; or sending something to the server). + +;;; Code: + +(require 'ert) +(require 'jsonrpc) +(require 'eieio) + +(defclass jsonrpc--test-endpoint (jsonrpc-process-connection) + ((scp :accessor jsonrpc--shutdown-complete-p))) + +(defclass jsonrpc--test-client (jsonrpc--test-endpoint) + ((hold-deferred :initform t :accessor jsonrpc--hold-deferred))) + +(defun jsonrpc--call-with-emacsrpc-fixture (fn) + "Do work for `jsonrpc--with-emacsrpc-fixture'. Call FN." + (let* (listen-server endpoint) + (unwind-protect + (progn + (setq listen-server + (make-network-process + :name "Emacs RPC server" :server t :host "localhost" + :service (if (version<= emacs-version "26.1") + 44444 + ;; 26.1 can automatically find ports if + ;; one passes 0 here. + 0) + :log (lambda (listen-server client _message) + (push + (make-instance + 'jsonrpc--test-endpoint + :name (process-name client) + :process client + :request-dispatcher + (lambda (_endpoint method params) + (unless (memq method '(+ - * / vconcat append + sit-for ignore)) + (signal 'jsonrpc-error + `((jsonrpc-error-message + . "Sorry, this isn't allowed") + (jsonrpc-error-code . -32601)))) + (apply method (append params nil))) + :on-shutdown + (lambda (conn) + (setf (jsonrpc--shutdown-complete-p conn) t))) + (process-get listen-server 'handlers))))) + (setq endpoint + (make-instance + 'jsonrpc--test-client + "Emacs RPC client" + :process + (open-network-stream "JSONRPC test tcp endpoint" + nil "localhost" + (process-contact listen-server + :service)) + :on-shutdown + (lambda (conn) + (setf (jsonrpc--shutdown-complete-p conn) t)))) + (funcall fn endpoint)) + (unwind-protect + (when endpoint + (kill-buffer (jsonrpc--events-buffer endpoint)) + (jsonrpc-shutdown endpoint)) + (when listen-server + (cl-loop do (delete-process listen-server) + while (progn (accept-process-output nil 0.1) + (process-live-p listen-server)) + do (jsonrpc--message + "test listen-server is still running, waiting")) + (cl-loop for handler in (process-get listen-server 'handlers) + do (ignore-errors (jsonrpc-shutdown handler))) + (mapc #'kill-buffer + (mapcar #'jsonrpc--events-buffer + (process-get listen-server 'handlers)))))))) + +(cl-defmacro jsonrpc--with-emacsrpc-fixture ((endpoint-sym) &body body) + `(jsonrpc--call-with-emacsrpc-fixture (lambda (,endpoint-sym) ,@body))) + +(ert-deftest returns-3 () + "A basic test for adding two numbers in our test RPC." + (jsonrpc--with-emacsrpc-fixture (conn) + (should (= 3 (jsonrpc-request conn '+ [1 2]))))) + +(ert-deftest errors-with--32601 () + "Errors with -32601" + (jsonrpc--with-emacsrpc-fixture (conn) + (condition-case err + (progn + (jsonrpc-request conn 'delete-directory "~/tmp") + (ert-fail "A `jsonrpc-error' should have been signalled!")) + (jsonrpc-error + (should (= -32601 (cdr (assoc 'jsonrpc-error-code (cdr err))))))))) + +(ert-deftest signals-an--32603-JSONRPC-error () + "Signals an -32603 JSONRPC error." + (jsonrpc--with-emacsrpc-fixture (conn) + (condition-case err + (progn + (jsonrpc-request conn '+ ["a" 2]) + (ert-fail "A `jsonrpc-error' should have been signalled!")) + (jsonrpc-error + (should (= -32603 (cdr (assoc 'jsonrpc-error-code (cdr err))))))))) + +(ert-deftest times-out () + "Request for 3-sec sit-for with 1-sec timeout times out." + (jsonrpc--with-emacsrpc-fixture (conn) + (should-error + (jsonrpc-request conn 'sit-for [3] :timeout 1)))) + +(ert-deftest doesnt-time-out () + :tags '(:expensive-test) + "Request for 1-sec sit-for with 2-sec timeout succeeds." + (jsonrpc--with-emacsrpc-fixture (conn) + (jsonrpc-request conn 'sit-for [1] :timeout 2))) + +(ert-deftest stretching-it-but-works () + "Vector of numbers or vector of vector of numbers are serialized." + (jsonrpc--with-emacsrpc-fixture (conn) + ;; (vconcat [1 2 3] [3 4 5]) => [1 2 3 3 4 5] which can be + ;; serialized. + (should (equal + [1 2 3 3 4 5] + (jsonrpc-request conn 'vconcat [[1 2 3] [3 4 5]]))))) + +(ert-deftest json-el-cant-serialize-this () + "Can't serialize a response that is half-vector/half-list." + (jsonrpc--with-emacsrpc-fixture (conn) + (should-error + ;; (append [1 2 3] [3 4 5]) => (1 2 3 . [3 4 5]), which can't be + ;; serialized + (jsonrpc-request conn 'append [[1 2 3] [3 4 5]])))) + +(cl-defmethod jsonrpc-connection-ready-p + ((conn jsonrpc--test-client) what) + (and (cl-call-next-method) + (or (not (string-match "deferred" what)) + (not (jsonrpc--hold-deferred conn))))) + +(ert-deftest deferred-action-toolate () + :tags '(:expensive-test) + "Deferred request fails because noone clears the flag." + (jsonrpc--with-emacsrpc-fixture (conn) + (should-error + (jsonrpc-request conn '+ [1 2] + :deferred "deferred-testing" :timeout 0.5) + :type 'jsonrpc-error) + (should + (= 3 (jsonrpc-request conn '+ [1 2] + :timeout 0.5))))) + +(ert-deftest deferred-action-intime () + :tags '(:expensive-test) + "Deferred request barely makes it after event clears a flag." + ;; Send an async request, which returns immediately. However the + ;; success fun which sets the flag only runs after some time. + (jsonrpc--with-emacsrpc-fixture (conn) + (jsonrpc-async-request conn + 'sit-for [0.5] + :success-fn + (lambda (_result) + (setf (jsonrpc--hold-deferred conn) nil))) + ;; Now wait for an answer to this request, which should be sent as + ;; soon as the previous one is answered. + (should + (= 3 (jsonrpc-request conn '+ [1 2] + :deferred "deferred" + :timeout 1))))) + +(ert-deftest deferred-action-complex-tests () + :tags '(:expensive-test) + "Test a more complex situation with deferred requests." + (jsonrpc--with-emacsrpc-fixture (conn) + (let (n-deferred-1 + n-deferred-2 + second-deferred-went-through-p) + ;; This returns immediately + (jsonrpc-async-request + conn + 'sit-for [0.1] + :success-fn + (lambda (_result) + ;; this only gets runs after the "first deferred" is stashed. + (setq n-deferred-1 + (hash-table-count (jsonrpc--deferred-actions conn))))) + (should-error + ;; This stashes the request and waits. It will error because + ;; no-one clears the "hold deferred" flag. + (jsonrpc-request conn 'ignore ["first deferred"] + :deferred "first deferred" + :timeout 0.5) + :type 'jsonrpc-error) + ;; The error means the deferred actions stash is now empty + (should (zerop (hash-table-count (jsonrpc--deferred-actions conn)))) + ;; Again, this returns immediately. + (jsonrpc-async-request + conn + 'sit-for [0.1] + :success-fn + (lambda (_result) + ;; This gets run while "third deferred" below is waiting for + ;; a reply. Notice that we clear the flag in time here. + (setq n-deferred-2 (hash-table-count (jsonrpc--deferred-actions conn))) + (setf (jsonrpc--hold-deferred conn) nil))) + ;; This again stashes a request and returns immediately. + (jsonrpc-async-request conn 'ignore ["second deferred"] + :deferred "second deferred" + :timeout 1 + :success-fn + (lambda (_result) + (setq second-deferred-went-through-p t))) + ;; And this also stashes a request, but waits. Eventually the + ;; flag is cleared in time and both requests go through. + (jsonrpc-request conn 'ignore ["third deferred"] + :deferred "third deferred" + :timeout 1) + ;; Wait another 0.5 secs just in case the success handlers of + ;; one of these last two requests didn't quite have a chance to + ;; run (Emacs 25.2 apparentely needs this). + (accept-process-output nil 0.5) + (should second-deferred-went-through-p) + (should (eq 1 n-deferred-1)) + (should (eq 2 n-deferred-2)) + (should (eq 0 (hash-table-count (jsonrpc--deferred-actions conn))))))) + +(provide 'jsonrpc-tests) +;;; jsonrpc-tests.el ends here diff --git a/test/lisp/ls-lisp-tests.el b/test/lisp/ls-lisp-tests.el index d16ffa3acdb..91e8b0b7011 100644 --- a/test/lisp/ls-lisp-tests.el +++ b/test/lisp/ls-lisp-tests.el @@ -26,6 +26,7 @@ ;;; Code: (require 'ert) (require 'ls-lisp) +(require 'dired) (ert-deftest ls-lisp-unload () "Test for https://debbugs.gnu.org/xxxxx ." diff --git a/test/lisp/mouse-tests.el b/test/lisp/mouse-tests.el index 639ccf78a9f..909ba64a724 100644 --- a/test/lisp/mouse-tests.el +++ b/test/lisp/mouse-tests.el @@ -27,24 +27,22 @@ (ert-deftest bug23288-use-return-value () "If `mouse-on-link-p' returns a string, its first character is used." - (cl-letf ((last-input-event '(down-mouse-1 nil 1)) - (unread-command-events '((mouse-1 nil 1))) + (cl-letf ((unread-command-events '((down-mouse-1 nil 1) (mouse-1 nil 1))) (mouse-1-click-follows-link t) (mouse-1-click-in-non-selected-windows t) ((symbol-function 'mouse-on-link-p) (lambda (_pos) "abc"))) - (should-not (mouse--down-1-maybe-follows-link)) - (should (equal unread-command-events '(?a))))) + (should (eq 'down-mouse-1 (car-safe (aref (read-key-sequence "") 0)))) + (should (eq ?a (aref (read-key-sequence "") 0))))) (ert-deftest bug23288-translate-to-mouse-2 () "If `mouse-on-link-p' doesn't return a string or vector, translate `mouse-1' events into `mouse-2' events." - (cl-letf ((last-input-event '(down-mouse-1 nil 1)) - (unread-command-events '((mouse-1 nil 1))) + (cl-letf ((unread-command-events '((down-mouse-1 nil 1) (mouse-1 nil 1))) (mouse-1-click-follows-link t) (mouse-1-click-in-non-selected-windows t) ((symbol-function 'mouse-on-link-p) (lambda (_pos) t))) - (should-not (mouse--down-1-maybe-follows-link)) - (should (equal unread-command-events '((mouse-2 nil 1)))))) + (should (eq 'down-mouse-1 (car-safe (aref (read-key-sequence "") 0)))) + (should (eq 'mouse-2 (car-safe (aref (read-key-sequence "") 0)))))) (ert-deftest bug26816-mouse-frame-movement () "Mouse moves relative to frame." diff --git a/test/lisp/net/gnutls-tests.el b/test/lisp/net/gnutls-tests.el index c5bfe439d17..326e2416495 100644 --- a/test/lisp/net/gnutls-tests.el +++ b/test/lisp/net/gnutls-tests.el @@ -26,7 +26,7 @@ ;;; Code: (require 'ert) -(require 'cl) +(require 'cl-lib) (require 'gnutls) (require 'hex-util) @@ -46,22 +46,22 @@ (defvar gnutls-tests-tested-macs (when (gnutls-available-p) - (remove-duplicates - (append (mapcar 'cdr gnutls-tests-internal-macs-upcased) - (mapcar 'car (gnutls-macs)))))) + (cl-remove-duplicates + (append (mapcar #'cdr gnutls-tests-internal-macs-upcased) + (mapcar #'car (gnutls-macs)))))) (defvar gnutls-tests-tested-digests (when (gnutls-available-p) - (remove-duplicates - (append (mapcar 'cdr gnutls-tests-internal-macs-upcased) - (mapcar 'car (gnutls-digests)))))) + (cl-remove-duplicates + (append (mapcar #'cdr gnutls-tests-internal-macs-upcased) + (mapcar #'car (gnutls-digests)))))) (defvar gnutls-tests-tested-ciphers (when (gnutls-available-p) - (remove-duplicates - ; these cause FPEs or SEGVs - (remove-if (lambda (e) (memq e '(ARCFOUR-128))) - (mapcar 'car (gnutls-ciphers)))))) + (cl-remove-duplicates + ;; these cause FPEs or SEGVs + (cl-remove-if (lambda (e) (memq e '(ARCFOUR-128))) + (mapcar #'car (gnutls-ciphers)))))) (defvar gnutls-tests-mondo-strings (list @@ -154,7 +154,7 @@ ("0cc175b9c0f1b6a831c399e269772661" "a" MD5) ("a9993e364706816aba3e25717850c26c9cd0d89d" "abc" SHA1) ("a9993e364706816aba3e25717850c26c9cd0d89d" "abc" "SHA1"))) ; check string ID for digest - (destructuring-bind (hash input mac) test + (pcase-let ((`(,hash ,input ,mac) test)) (let ((plist (cdr (assq mac macs))) result resultb) (gnutls-tests-message "%s %S" mac plist) @@ -178,7 +178,7 @@ ("81568ba71fa2c5f33cc84bf362466988f98eba3735479100b4e8908acad87ac4" "more and more data goes into a file to exceed the buffer size" "very long key goes here to exceed the key size" SHA256) ("4bc830005783a73b8112f4bd5f4aa5f92e05b51e9b55c0cd6f9a7bee48371def" "more and more data goes into a file to exceed the buffer size" "" "SHA256") ; check string ID for HMAC ("4bc830005783a73b8112f4bd5f4aa5f92e05b51e9b55c0cd6f9a7bee48371def" "more and more data goes into a file to exceed the buffer size" "" SHA256))) - (destructuring-bind (hash input key mac) test + (pcase-let ((`(,hash ,input ,key ,mac) test)) (let ((plist (cdr (assq mac macs))) result) (gnutls-tests-message "%s %S" mac plist) @@ -214,7 +214,7 @@ (let ((keys '("mykey" "mykey2")) (inputs gnutls-tests-mondo-strings) (ivs '("" "-abc123-" "init" "ini2")) - (ciphers (remove-if + (ciphers (cl-remove-if (lambda (c) (plist-get (cdr (assq c (gnutls-ciphers))) :cipher-aead-capable)) gnutls-tests-tested-ciphers))) @@ -252,7 +252,7 @@ "auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data " "AUTH data and more data to go over the block limit!" "AUTH data and more data to go over the block limit")) - (ciphers (remove-if + (ciphers (cl-remove-if (lambda (c) (or (null (plist-get (cdr (assq c (gnutls-ciphers))) :cipher-aead-capable)))) gnutls-tests-tested-ciphers)) diff --git a/test/lisp/net/secrets-tests.el b/test/lisp/net/secrets-tests.el new file mode 100644 index 00000000000..de3ce731bec --- /dev/null +++ b/test/lisp/net/secrets-tests.el @@ -0,0 +1,275 @@ +;;; secrets-tests.el --- Tests of Secret Service API + +;; 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/'. + +;;; Code: + +(require 'ert) +(require 'secrets) +(require 'notifications) + +;; We do not want chatty messages. +(setq secrets-debug nil) + +(ert-deftest secrets-test00-availability () + "Test availability of Secret Service API." + :expected-result (if secrets-enabled :passed :failed) + (should secrets-enabled) + (should (dbus-ping :session secrets-service)) + + ;; Exit. + (secrets--test-close-all-sessions)) + +(defun secrets--test-get-all-sessions () + "Return all object paths for existing secrets sessions." + (let ((session-path (concat secrets-path "/session"))) + (delete + session-path + (dbus-introspect-get-all-nodes :session secrets-service session-path)))) + +(defun secrets--test-close-all-sessions () + "Close all secrets sessions which are bound to this Emacs." + (secrets-close-session) + ;; We loop over all other sessions. If a session does not belong to + ;; us, a `dbus-error' is fired, which we ignore. + (dolist (path (secrets--test-get-all-sessions)) + (dbus-ignore-errors + (dbus-call-method + :session secrets-service path secrets-interface-session "Close")))) + +(defun secrets--test-delete-all-session-items () + "Delete all items of collection \"session\" bound to this Emacs." + (dolist (item (secrets-list-items "session")) + (secrets-delete-item "session" item))) + +(ert-deftest secrets-test01-sessions () + "Test opening / closing a secrets session." + (skip-unless secrets-enabled) + (skip-unless (secrets-empty-path secrets-session-path)) + + (unwind-protect + (progn + ;; Simple opening / closing of a session. + (should (secrets-open-session)) + (should-not (secrets-empty-path secrets-session-path)) + (should (secrets-close-session)) + (should (secrets-empty-path secrets-session-path)) + + ;; Reopening a new session. + (should (string-equal (secrets-open-session) (secrets-open-session))) + (should (string-equal secrets-session-path (secrets-open-session))) + (should-not + (string-equal (secrets-open-session) (secrets-open-session 'reopen))) + (should-not + (string-equal secrets-session-path (secrets-open-session 'reopen)))) + + ;; Exit. + (should (secrets-close-session)) + (secrets--test-close-all-sessions))) + +(ert-deftest secrets-test02-collections () + "Test creation / deletion a secrets collections." + (skip-unless secrets-enabled) + (skip-unless (secrets-empty-path secrets-session-path)) + + (unwind-protect + (progn + (should (secrets-open-session)) + + ;; There must be at least the collections "Login" and "session". + (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 + ;; outside our control, so we make it in the interactive case + ;; only. + (unless noninteractive + (let ((collection (md5 (concat (prin1-to-string process-environment) + (current-time-string)))) + (alias (secrets-get-alias "default"))) + (notifications-notify + :title (symbol-name (ert-test-name (ert-running-test))) + :body "Please enter the password \"secret\" twice") + ;; The optional argument ALIAS does not seem to work. + (should (secrets-create-collection collection)) + (should (member collection (secrets-list-collections))) + + ;; We reset the alias. The temporary collection "session" + ;; is not accepted. + (secrets-set-alias collection "default") + (should (string-equal (secrets-get-alias "default") collection)) + + ;; Delete alias. + (secrets-delete-alias "default") + (should-not (secrets-get-alias "default")) + + ;; Lock / unlock the collection. + (secrets-lock-collection collection) + (should + (secrets-get-collection-property + (secrets-collection-path collection) "Locked")) + (notifications-notify + :title (symbol-name (ert-test-name (ert-running-test))) + :body "Please enter the password \"secret\"") + (secrets-unlock-collection collection) + (should-not + (secrets-get-collection-property + (secrets-collection-path collection) "Locked")) + + ;; Delete the collection. The alias disappears as well. + (secrets-set-alias collection "default") + (secrets-delete-collection collection) + (should-not (secrets-get-alias "default")) + + ;; Reset alias. + (when alias + (secrets-set-alias alias "default") + (should (string-equal (secrets-get-alias "default") alias)))))) + + ;; Exit. + (should (secrets-close-session)) + (secrets--test-close-all-sessions))) + +(ert-deftest secrets-test03-items () + "Test creation / deletion a secret item." + (skip-unless secrets-enabled) + (skip-unless (secrets-empty-path secrets-session-path)) + + (unwind-protect + (let (item-path) + (should (secrets-open-session)) + + ;; Cleanup. There could be items in the "session" collection. + (secrets--test-delete-all-session-items) + + ;; There shall be no items in the "session" collection. + (should-not (secrets-list-items "session")) + ;; There shall be items in the "Login" collection. + (should (or (secrets-list-items "Login") + (secrets-list-items "login"))) + + ;; Create a new item. + (should (setq item-path (secrets-create-item "session" "foo" "secret"))) + (dolist (item `("foo" ,item-path)) + (should (string-equal (secrets-get-secret "session" item) "secret"))) + + ;; Create another item with same label. + (should (secrets-create-item "session" "foo" "geheim")) + (should (equal (secrets-list-items "session") '("foo" "foo"))) + + ;; Create an item with attributes. + (should + (setq item-path + (secrets-create-item + "session" "bar" "secret" + :method "sudo" :user "joe" :host "remote-host"))) + (dolist (item `("bar" ,item-path)) + (should + (string-equal (secrets-get-attribute "session" item :method) "sudo")) + ;; The attributes are collected in reverse order. + ;; :xdg:schema is added silently. + (should + (equal + (secrets-get-attributes "session" item) + '((:xdg:schema . "org.freedesktop.Secret.Generic") + (:host . "remote-host") (:user . "joe") (:method . "sudo"))))) + + ;; Create an item with another schema. + (should + (setq item-path + (secrets-create-item + "session" "baz" "secret" :xdg:schema "org.gnu.Emacs.foo"))) + (dolist (item `("baz" ,item-path)) + (should + (equal + (secrets-get-attributes "session" item) + '((:xdg:schema . "org.gnu.Emacs.foo"))))) + + ;; Delete them. + (dolist (item (secrets-list-items "session")) + (secrets-delete-item "session" item)) + (should-not (secrets-list-items "session"))) + + ;; Exit. + (secrets--test-delete-all-session-items) + (should (secrets-close-session)) + (secrets--test-close-all-sessions))) + +(ert-deftest secrets-test04-search () + "Test searching of secret items." + (skip-unless secrets-enabled) + (skip-unless (secrets-empty-path secrets-session-path)) + + (unwind-protect + (progn + (should (secrets-open-session)) + + ;; Cleanup. There could be items in the "session" collection. + (secrets--test-delete-all-session-items) + + ;; There shall be no items in the "session" collection. + (should-not (secrets-list-items "session")) + + ;; Create some items. + (should + (secrets-create-item + "session" "foo" "secret" + :method "sudo" :user "joe" :host "remote-host")) + (should + (secrets-create-item + "session" "bar" "secret" + :method "sudo" :user "smith" :host "remote-host")) + (should + (secrets-create-item + "session" "baz" "secret" + :method "ssh" :user "joe" :host "other-host")) + + ;; Search the items. `secrets-search-items' uses + ;; `secrets-search-item-paths' internally, it is sufficient to + ;; test only one of them. + (should-not (secrets-search-item-paths "session" :user "john")) + (should-not (secrets-search-items "session" :user "john")) + (should-not + (secrets-search-items "session" :xdg:schema "org.gnu.Emacs.foo")) + (should + (equal + (sort (secrets-search-items "session" :user "joe") 'string-lessp) + '("baz" "foo"))) + (should + (equal + (secrets-search-items "session":method "sudo" :user "joe") '("foo"))) + (should + (equal + (sort (secrets-search-items "session") 'string-lessp) + '("bar" "baz" "foo")))) + + ;; Exit. + (secrets--test-delete-all-session-items) + (should (secrets-close-session)) + (secrets--test-close-all-sessions))) + +(defun secrets-test-all (&optional interactive) + "Run all tests for \\[secrets]." + (interactive "p") + (funcall + (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) + "^secrets")) + +(provide 'secrets-tests) +;;; secrets-tests.el ends here diff --git a/test/lisp/net/tramp-archive-resources/foo.iso/foo b/test/lisp/net/tramp-archive-resources/foo.iso/foo new file mode 100644 index 00000000000..257cc5642cb --- /dev/null +++ b/test/lisp/net/tramp-archive-resources/foo.iso/foo @@ -0,0 +1 @@ +foo diff --git a/test/lisp/net/tramp-archive-resources/foo.tar.gz b/test/lisp/net/tramp-archive-resources/foo.tar.gz Binary files differnew file mode 100644 index 00000000000..0d2e9878dd7 --- /dev/null +++ b/test/lisp/net/tramp-archive-resources/foo.tar.gz diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el new file mode 100644 index 00000000000..e7597864c6e --- /dev/null +++ b/test/lisp/net/tramp-archive-tests.el @@ -0,0 +1,948 @@ +;;; tramp-archive-tests.el --- Tests of file archive access -*- lexical-binding:t -*- + +;; Copyright (C) 2017-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/'. + +;;; Code: + +;; The `tramp-archive-testnn-*' tests correspond to the respective +;; tests in tramp-tests.el. + +(require 'ert) +(require 'tramp-archive) + +(defconst tramp-archive-test-resource-directory + (let ((default-directory + (if load-in-progress + (file-name-directory load-file-name) + default-directory))) + (cond + ((file-accessible-directory-p (expand-file-name "resources")) + (expand-file-name "resources")) + ((file-accessible-directory-p (expand-file-name "tramp-archive-resources")) + (expand-file-name "tramp-archive-resources")))) + "The resources directory test files are located in.") + +(defconst tramp-archive-test-file-archive + (file-truename + (expand-file-name "foo.tar.gz" tramp-archive-test-resource-directory)) + "The test file archive.") + +(defconst tramp-archive-test-archive + (file-name-as-directory tramp-archive-test-file-archive) + "The test archive.") + +(defconst tramp-archive-test-directory + (file-truename + (expand-file-name "foo.iso" tramp-archive-test-resource-directory)) + "A directory file name, which looks like an archive.") + +(setq password-cache-expiry nil + tramp-verbose 0 + tramp-cache-read-persistent-data t ;; For auth-sources. + tramp-copy-size-limit nil + tramp-message-show-message nil + tramp-persistency-file-name nil) + +(defun tramp-archive--test-make-temp-name () + "Return a temporary file name for test. +The temporary file is not created." + (expand-file-name + (make-temp-name "tramp-archive-test") temporary-file-directory)) + +(defun tramp-archive--test-delete (tmpfile) + "Delete temporary file or directory TMPFILE. +This needs special support, because archive file names, which are +the origin of the temporary TMPFILE, have no write permissions." + (unless (file-writable-p (file-name-directory tmpfile)) + (set-file-modes + (file-name-directory tmpfile) + (logior (file-modes (file-name-directory tmpfile)) #o0700))) + (set-file-modes tmpfile #o0700) + (if (file-regular-p tmpfile) + (delete-file tmpfile) + (mapc + 'tramp-archive--test-delete + (directory-files tmpfile 'full directory-files-no-dot-files-regexp)) + (delete-directory tmpfile))) + +(defun tramp-archive--test-emacs26-p () + "Check for Emacs version >= 26.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 26)) + +(defun tramp-archive--test-emacs27-p () + "Check for Emacs version >= 27.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 27)) + +(ert-deftest tramp-archive-test00-availability () + "Test availability of archive file name functions." + :expected-result (if tramp-archive-enabled :passed :failed) + (should + (and + tramp-archive-enabled + (file-exists-p tramp-archive-test-file-archive) + (tramp-archive-file-name-p tramp-archive-test-archive)))) + +(ert-deftest tramp-archive-test01-file-name-syntax () + "Check archive file name syntax." + (should-not (tramp-archive-file-name-p tramp-archive-test-file-archive)) + (should (tramp-archive-file-name-p tramp-archive-test-archive)) + (should + (string-equal + (tramp-archive-file-name-archive tramp-archive-test-archive) + tramp-archive-test-file-archive)) + (should + (string-equal + (tramp-archive-file-name-localname tramp-archive-test-archive) "/")) + (should (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo"))) + (should + (string-equal + (tramp-archive-file-name-localname + (concat tramp-archive-test-archive "foo")) + "/foo")) + (should + (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo/bar"))) + (should + (string-equal + (tramp-archive-file-name-localname + (concat tramp-archive-test-archive "foo/bar")) + "/foo/bar")) + ;; A file archive inside a file archive. + (should + (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar"))) + (should + (string-equal + (tramp-archive-file-name-archive + (concat tramp-archive-test-archive "baz.tar")) + tramp-archive-test-file-archive)) + (should + (string-equal + (tramp-archive-file-name-localname + (concat tramp-archive-test-archive "baz.tar")) + "/baz.tar")) + (should + (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar/"))) + (should + (string-equal + (tramp-archive-file-name-archive + (concat tramp-archive-test-archive "baz.tar/")) + (concat tramp-archive-test-archive "baz.tar"))) + (should + (string-equal + (tramp-archive-file-name-localname + (concat tramp-archive-test-archive "baz.tar/")) + "/"))) + +(ert-deftest tramp-archive-test02-file-name-dissect () + "Check archive file name components." + (skip-unless tramp-archive-enabled) + + (with-parsed-tramp-archive-file-name tramp-archive-test-archive nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + (should + (string-equal + host + (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (should-not port) + (should (string-equal localname "/")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; Localname. + (with-parsed-tramp-archive-file-name + (concat tramp-archive-test-archive "foo") nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + (should + (string-equal + host + (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (should-not port) + (should (string-equal localname "/foo")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; File archive in file archive. + (let* ((tramp-archive-test-file-archive + (concat tramp-archive-test-archive "baz.tar")) + (tramp-archive-test-archive + (file-name-as-directory tramp-archive-test-file-archive)) + (tramp-methods (cons `(,tramp-archive-method) tramp-methods)) + (tramp-gvfs-methods tramp-archive-all-gvfs-methods)) + (unwind-protect + (with-parsed-tramp-archive-file-name + (expand-file-name "bar" tramp-archive-test-archive) nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + ;; We reimplement the logic of tramp-archive.el here. Don't + ;; know, whether it is worth the test. + (should + (string-equal + host + (url-hexify-string + (concat + (tramp-gvfs-url-file-name + (tramp-make-tramp-file-name + tramp-archive-method + ;; User and Domain. + nil nil + ;; Host. + (url-hexify-string + (concat + "file://" + ;; `directory-file-name' does not leave file archive + ;; boundaries. So we must cut the trailing slash + ;; ourselves. + (substring + (file-name-directory tramp-archive-test-file-archive) 0 -1))) + nil "/")) + (file-name-nondirectory tramp-archive-test-file-archive))))) + (should-not port) + (should (string-equal localname "/bar")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test05-expand-file-name () + "Check `expand-file-name'." + (should + (string-equal + (expand-file-name "/foo.tar/path/./file") "/foo.tar/path/file")) + (should + (string-equal (expand-file-name "/foo.tar/path/../file") "/foo.tar/file")) + ;; `expand-file-name' does not care "~/" in archive file names. + (should + (string-equal (expand-file-name "/foo.tar/~/file") "/foo.tar/~/file")) + ;; `expand-file-name' does not care file archive boundaries. + (should (string-equal (expand-file-name "/foo.tar/./file") "/foo.tar/file")) + (should (string-equal (expand-file-name "/foo.tar/../file") "/file"))) + +;; This test is inspired by Bug#30293. +(ert-deftest tramp-archive-test05-expand-file-name-non-archive-directory () + "Check existing directories with archive file name syntax. +They shall still be supported" + (should (file-directory-p tramp-archive-test-directory)) + ;; `tramp-archive-file-name-p' tests only for file name syntax. It + ;; doesn't test, whether it is really a file archive. + (should + (tramp-archive-file-name-p + (file-name-as-directory tramp-archive-test-directory))) + (should + (file-directory-p (file-name-as-directory tramp-archive-test-directory))) + (should + (file-exists-p (expand-file-name "foo" tramp-archive-test-directory)))) + +(ert-deftest tramp-archive-test06-directory-file-name () + "Check `directory-file-name'. +This checks also `file-name-as-directory', `file-name-directory', +`file-name-nondirectory' and `unhandled-file-name-directory'." + (skip-unless tramp-archive-enabled) + + (should + (string-equal + (directory-file-name "/foo.tar/path/to/file") "/foo.tar/path/to/file")) + (should + (string-equal + (directory-file-name "/foo.tar/path/to/file/") "/foo.tar/path/to/file")) + ;; `directory-file-name' does not leave file archive boundaries. + (should (string-equal (directory-file-name "/foo.tar/") "/foo.tar/")) + + (should + (string-equal + (file-name-as-directory "/foo.tar/path/to/file") "/foo.tar/path/to/file/")) + (should + (string-equal + (file-name-as-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/")) + (should (string-equal (file-name-as-directory "/foo.tar/") "/foo.tar/")) + (should (string-equal (file-name-as-directory "/foo.tar") "/foo.tar/")) + + (should + (string-equal + (file-name-directory "/foo.tar/path/to/file") "/foo.tar/path/to/")) + (should + (string-equal + (file-name-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/")) + (should (string-equal (file-name-directory "/foo.tar/") "/foo.tar/")) + + (should + (string-equal (file-name-nondirectory "/foo.tar/path/to/file") "file")) + (should + (string-equal (file-name-nondirectory "/foo.tar/path/to/file/") "")) + (should (string-equal (file-name-nondirectory "/foo.tar/") "")) + + (should-not + (unhandled-file-name-directory "/foo.tar/path/to/file"))) + +(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 + (let ((default-directory tramp-archive-test-archive)) + (should (file-exists-p tramp-archive-test-file-archive)) + (should (file-exists-p tramp-archive-test-archive)) + (should (file-exists-p "foo.txt")) + (should (file-exists-p "foo.lnk")) + (should (file-exists-p "bar")) + (should (file-exists-p "bar/bar")) + (should-error + (write-region "foo" nil "baz") + :type 'file-error) + (should-error + (delete-file "baz") + :type 'file-error)) + + ;; Cleanup. + (tramp-archive-cleanup-hash))) + +(ert-deftest tramp-archive-test08-file-local-copy () + "Check `file-local-copy'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + (let (tmp-name) + (unwind-protect + (progn + (should + (setq tmp-name + (file-local-copy + (expand-file-name "bar/bar" tramp-archive-test-archive)))) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "bar\n"))) + ;; Error case. + (tramp-archive--test-delete tmp-name) + (should-error + (setq tmp-name + (file-local-copy + (expand-file-name "what" tramp-archive-test-archive))) + :type tramp-file-missing)) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name)) + (tramp-archive-cleanup-hash)))) + +(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))) + (unwind-protect + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "bar\n")) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "bar\nbar\n")) + ;; Insert partly. + (insert-file-contents tmp-name nil 1 3) + (should (string-equal (buffer-string) "arbar\nbar\n")) + ;; Replace. + (insert-file-contents tmp-name nil nil nil 'replace) + (should (string-equal (buffer-string) "bar\n")) + ;; Error case. + (should-error + (insert-file-contents + (expand-file-name "what" tramp-archive-test-archive)) + :type tramp-file-missing)) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test11-copy-file () + "Check `copy-file'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + ;; Copy simple file. + (let ((tmp-name1 (expand-file-name "bar/bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name))) + (unwind-protect + (progn + (copy-file tmp-name1 tmp-name2) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "bar\n"))) + (should-error + (copy-file tmp-name1 tmp-name2) + :type 'file-already-exists) + (copy-file tmp-name1 tmp-name2 'ok) + ;; The file archive is not writable. + (should-error + (copy-file tmp-name2 tmp-name1 'ok) + :type 'file-error)) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash))) + + ;; Copy directory to existing directory. + (let ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name))) + (unwind-protect + (progn + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + ;; Directory `tmp-name2' exists already, so we must use + ;; `file-name-as-directory'. + (copy-file tmp-name1 (file-name-as-directory tmp-name2)) + (should + (file-exists-p + (expand-file-name + (concat (file-name-nondirectory tmp-name1) "/bar") tmp-name2)))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash))) + + ;; Copy directory/file to non-existing directory. + (let ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name))) + (unwind-protect + (progn + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + (copy-file + tmp-name1 + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name2)) + (should + (file-exists-p + (expand-file-name + (concat (file-name-nondirectory tmp-name1) "/bar") tmp-name2)))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash)))) + +(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)) + (tmp-name2 (tramp-archive--test-make-temp-name)) + (tmp-name3 (expand-file-name + (file-name-nondirectory tmp-name1) tmp-name2)) + (tmp-name4 (expand-file-name "bar" tmp-name2)) + (tmp-name5 (expand-file-name "bar" tmp-name3))) + + ;; Copy complete directory. + (unwind-protect + (progn + ;; Copy empty directory. + (copy-directory tmp-name1 tmp-name2) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name4)) + ;; Target directory does exist already. + ;; This has been changed in Emacs 26.1. + (when (tramp-archive--test-emacs26-p) + (should-error + (copy-directory tmp-name1 tmp-name2) + :type 'file-error)) + (tramp-archive--test-delete tmp-name4) + (copy-directory tmp-name1 (file-name-as-directory tmp-name2)) + (should (file-directory-p tmp-name3)) + (should (file-exists-p tmp-name5))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash)) + + ;; Copy directory contents. + (unwind-protect + (progn + ;; Copy empty directory. + (copy-directory tmp-name1 tmp-name2 nil 'parents 'contents) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name4)) + ;; Target directory does exist already. + (tramp-archive--test-delete tmp-name4) + (copy-directory + tmp-name1 (file-name-as-directory tmp-name2) + nil 'parents 'contents) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name4)) + (should-not (file-directory-p tmp-name3)) + (should-not (file-exists-p tmp-name5))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash)))) + +(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) + (files '("." ".." "bar" "baz.tar" "foo.hrd" "foo.lnk" "foo.txt"))) + (unwind-protect + (progn + (should (file-directory-p tmp-name)) + (should (equal (directory-files tmp-name) files)) + (should (equal (directory-files tmp-name 'full) + (mapcar (lambda (x) (concat tmp-name x)) files))) + (should (equal (directory-files + tmp-name nil directory-files-no-dot-files-regexp) + (delete "." (delete ".." files)))) + (should (equal (directory-files + tmp-name 'full directory-files-no-dot-files-regexp) + (mapcar (lambda (x) (concat tmp-name x)) + (delete "." (delete ".." files)))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(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. + (process-environment + (append '("LANG=C" "LANGUAGE=C" "LC_ALL=C") process-environment))) + (unwind-protect + (progn + ;; Due to Bug#29423, this works only since for Emacs 26.1. + (when nil ;; TODO (tramp-archive--test-emacs26-p) + (with-temp-buffer + (insert-directory tramp-archive-test-archive nil) + (goto-char (point-min)) + (should + (looking-at-p (regexp-quote tramp-archive-test-archive))))) + (with-temp-buffer + (insert-directory tramp-archive-test-archive "-al") + (goto-char (point-min)) + (should + (looking-at-p + (format "^.+ %s$" (regexp-quote tramp-archive-test-archive))))) + (with-temp-buffer + (insert-directory + (file-name-as-directory tramp-archive-test-archive) + "-al" nil 'full-directory-p) + (goto-char (point-min)) + (should + (looking-at-p + (concat + ;; There might be a summary line. + "\\(total.+[[:digit:]]+\n\\)?" + ;; We don't know in which order the files appear. + (format + "\\(.+ %s\\( ->.+\\)?\n\\)\\{%d\\}" + (regexp-opt (directory-files tramp-archive-test-archive)) + (length (directory-files tramp-archive-test-archive)))))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(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)) + (tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive)) + (tmp-name3 (expand-file-name "bar" tramp-archive-test-archive)) + attr) + (unwind-protect + (progn + (should (file-exists-p tmp-name1)) + (should (file-readable-p tmp-name1)) + (should (file-regular-p tmp-name1)) + + ;; We do not test inodes and device numbers. + (setq attr (file-attributes tmp-name1)) + (should (consp attr)) + (should (null (car attr))) + (should (numberp (nth 1 attr))) ;; Link. + (should (numberp (nth 2 attr))) ;; Uid. + (should (numberp (nth 3 attr))) ;; Gid. + ;; Last access time. + (should (stringp (current-time-string (nth 4 attr)))) + ;; Last modification time. + (should (stringp (current-time-string (nth 5 attr)))) + ;; Last status change time. + (should (stringp (current-time-string (nth 6 attr)))) + (should (numberp (nth 7 attr))) ;; Size. + (should (stringp (nth 8 attr))) ;; Modes. + + (setq attr (file-attributes tmp-name1 'string)) + (should (stringp (nth 2 attr))) ;; Uid. + (should (stringp (nth 3 attr))) ;; Gid. + + ;; Symlink. + (should (file-exists-p tmp-name2)) + (should (file-symlink-p tmp-name2)) + (setq attr (file-attributes tmp-name2)) + (should (string-equal (car attr) (file-name-nondirectory tmp-name1))) + + ;; Directory. + (should (file-exists-p tmp-name3)) + (should (file-readable-p tmp-name3)) + (should-not (file-regular-p tmp-name3)) + (setq attr (file-attributes tmp-name3)) + (should (eq (car attr) t))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(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)) + attr) + (unwind-protect + (progn + (should (file-directory-p tmp-name)) + (setq attr (directory-files-and-attributes tmp-name)) + (should (consp attr)) + (dolist (elt attr) + (should + (equal (file-attributes (expand-file-name (car elt) tmp-name)) + (cdr elt)))) + (setq attr (directory-files-and-attributes tmp-name 'full)) + (dolist (elt attr) + (should (equal (file-attributes (car elt)) (cdr elt)))) + (setq attr (directory-files-and-attributes tmp-name nil "^b")) + (should (equal (mapcar 'car attr) '("bar")))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(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)) + (tmp-name2 (expand-file-name "bar" tramp-archive-test-archive))) + (unwind-protect + (progn + (should (file-exists-p tmp-name1)) + ;; `set-file-modes' is not implemented. + (should-error + (set-file-modes tmp-name1 #o777) + :type 'file-error) + (should (= (file-modes tmp-name1) #o400)) + (should-not (file-executable-p tmp-name1)) + (should-not (file-writable-p tmp-name1)) + + (should (file-exists-p tmp-name2)) + ;; `set-file-modes' is not implemented. + (should-error + (set-file-modes tmp-name2 #o777) + :type 'file-error) + (should (= (file-modes tmp-name2) #o500)) + (should (file-executable-p tmp-name2)) + (should-not (file-writable-p tmp-name2))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(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 + ;; could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-archive-test-archive (file-truename tramp-archive-test-archive)) + (tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) + (tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive))) + + (unwind-protect + (progn + (should (file-exists-p tmp-name1)) + (should (string-equal tmp-name1 (file-truename tmp-name1))) + ;; `make-symbolic-link' is not implemented. + (should-error + (make-symbolic-link tmp-name1 tmp-name2) + :type 'file-error) + (should (file-symlink-p tmp-name2)) + (should + (string-equal + ;; This is "/foo.txt". + (with-parsed-tramp-archive-file-name tmp-name1 nil localname) + ;; `file-symlink-p' returns "foo.txt". Wer must expand, therefore. + (with-parsed-tramp-archive-file-name + (expand-file-name + (file-symlink-p tmp-name2) tramp-archive-test-archive) + nil + localname))) + (should-not (string-equal tmp-name2 (file-truename tmp-name2))) + (should + (string-equal (file-truename tmp-name1) (file-truename tmp-name2))) + (should (file-equal-p tmp-name1 tmp-name2))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(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)) + (unwind-protect + (progn + ;; Local files. + (should (equal (file-name-completion "fo" tmp-name) "foo.")) + (should (equal (file-name-completion "foo.txt" tmp-name) t)) + (should (equal (file-name-completion "b" tmp-name) "ba")) + (should-not (file-name-completion "a" tmp-name)) + (should + (equal + (file-name-completion "b" tmp-name 'file-directory-p) "bar/")) + (should + (equal + (sort (file-name-all-completions "fo" tmp-name) 'string-lessp) + '("foo.hrd" "foo.lnk" "foo.txt"))) + (should + (equal + (sort (file-name-all-completions "b" tmp-name) 'string-lessp) + '("bar/" "baz.tar"))) + (should-not (file-name-all-completions "a" tmp-name)) + ;; `completion-regexp-list' restricts the completion to + ;; files which match all expressions in this list. + (let ((completion-regexp-list + `(,directory-files-no-dot-files-regexp "b"))) + (should + (equal (file-name-completion "" tmp-name) "ba")) + (should + (equal + (sort (file-name-all-completions "" tmp-name) 'string-lessp) + '("bar/" "baz.tar"))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +;; The functions were introduced in Emacs 26.1. +(ert-deftest tramp-archive-test38-make-nearby-temp-file () + "Check `make-nearby-temp-file' and `temporary-file-directory'." + (skip-unless tramp-archive-enabled) + ;; Since Emacs 26.1. + (skip-unless + (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory))) + + ;; `make-nearby-temp-file' and `temporary-file-directory' exists + ;; since Emacs 26.1. We don't want to see compiler warnings for + ;; older Emacsen. + (let ((default-directory tramp-archive-test-archive) + tmp-file) + ;; The file archive shall know a temporary file directory. It is + ;; not in the archive itself. + (should + (stringp (with-no-warnings (with-no-warnings (temporary-file-directory))))) + (should-not + (tramp-archive-file-name-p (with-no-warnings (temporary-file-directory)))) + + ;; A temporary file or directory shall not be located in the + ;; archive itself. + (setq tmp-file + (with-no-warnings (make-nearby-temp-file "tramp-archive-test"))) + (should (file-exists-p tmp-file)) + (should (file-regular-p tmp-file)) + (should-not (tramp-archive-file-name-p tmp-file)) + (delete-file tmp-file) + (should-not (file-exists-p tmp-file)) + + (setq tmp-file + (with-no-warnings (make-nearby-temp-file "tramp-archive-test" 'dir))) + (should (file-exists-p tmp-file)) + (should (file-directory-p tmp-file)) + (should-not (tramp-archive-file-name-p tmp-file)) + (delete-directory tmp-file) + (should-not (file-exists-p tmp-file)))) + +(ert-deftest tramp-archive-test41-file-system-info () + "Check that `file-system-info' returns proper values." + (skip-unless tramp-archive-enabled) + ;; Since Emacs 27.1. + (skip-unless (fboundp 'file-system-info)) + + ;; `file-system-info' exists since Emacs 27. We don't want to see + ;; compiler warnings for older Emacsen. + (let ((fsi (with-no-warnings (file-system-info tramp-archive-test-archive)))) + (skip-unless fsi) + (should (and (consp fsi) + (= (length fsi) 3) + (numberp (nth 0 fsi)) + ;; FREE and AVAIL are always 0. + (zerop (nth 1 fsi)) + (zerop (nth 2 fsi)))))) + +(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)) + + ;; tramp-archive is neither loaded at Emacs startup, nor when + ;; loading a file like "/mock::foo" (which loads Tramp). + (let ((default-directory (expand-file-name temporary-file-directory)) + (code + "(progn \ + (message \"tramp-archive loaded: %%s %%s\" \ + (featurep 'tramp) (featurep 'tramp-archive)) \ + (file-attributes %S \"/\") \ + (message \"tramp-archive loaded: %%s %%s\" \ + (featurep 'tramp) (featurep 'tramp-archive)))")) + (dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo"))) + (should + (string-match + (format + "tramp-archive loaded: nil nil[[:ascii:]]+tramp-archive loaded: t %s" + (tramp-archive-file-name-p file)) + (shell-command-to-string + (format + "%s -batch -Q -L %s --eval %s" + (shell-quote-argument + (expand-file-name invocation-name invocation-directory)) + (mapconcat 'shell-quote-argument load-path " -L ") + (shell-quote-argument (format code file))))))))) + +(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)) + + ;; tramp-archive is neither loaded at Emacs startup, nor when + ;; loading a file like "/foo.tar". It is loaded only when + ;; `tramp-archive-enabled' is t. + (let ((default-directory (expand-file-name temporary-file-directory)) + (code + "(progn \ + (setq tramp-archive-enabled %s) \ + (message \"tramp-archive loaded: %%s\" \ + (featurep 'tramp-archive)) \ + (file-attributes %S \"/\") \ + (message \"tramp-archive loaded: %%s\" \ + (featurep 'tramp-archive)) \ + (file-attributes %S \"/\") \ + (message \"tramp-archive loaded: %%s\" \ + (featurep 'tramp-archive)))")) + ;; tramp-archive doesn't load when `tramp-archive-enabled' is nil. + (dolist (tae '(t nil)) + (should + (string-match + (format + "tramp-archive loaded: nil[[:ascii:]]+tramp-archive loaded: nil[[:ascii:]]+tramp-archive loaded: %s" + tae) + (shell-command-to-string + (format + "%s -batch -Q -L %s --eval %s" + (shell-quote-argument + (expand-file-name invocation-name invocation-directory)) + (mapconcat 'shell-quote-argument load-path " -L ") + (shell-quote-argument + (format + code tae tramp-archive-test-file-archive + (concat tramp-archive-test-archive "foo")))))))))) + +(ert-deftest tramp-archive-test99-libarchive-tests () + "Run tests of libarchive test files." + :tags '(:expensive-test :unstable) + (skip-unless tramp-archive-enabled) + ;; We do not want to run unless chosen explicitly. This test makes + ;; sense only in my local environment. Michael Albinus. + (skip-unless + (equal + (ert--stats-selector ert--current-run-stats) + (ert-test-name (ert-running-test)))) + + (url-handler-mode) + (unwind-protect + (dolist (dir + '("~/Downloads" "/sftp::~/Downloads" "/ssh::~/Downloads" + "http://ftp.debian.org/debian/pool/main/c/coreutils")) + (dolist + (file + '("coreutils_8.26-3_amd64.deb" + "coreutils_8.26-3ubuntu3_amd64.deb")) + (setq file (expand-file-name file dir)) + (when (file-exists-p file) + (setq file (expand-file-name "control.tar.gz/control" file)) + (message "%s" file) + (should (file-attributes (file-name-as-directory file)))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)) + + (unwind-protect + (dolist (dir '("" "/sftp::" "/ssh::")) + (dolist + (file + (apply + 'append + (mapcar + (lambda (x) (directory-files (concat dir x) 'full "uu\\'" 'sort)) + '("~/src/libarchive-3.2.2/libarchive/test" + "~/src/libarchive-3.2.2/cpio/test" + "~/src/libarchive-3.2.2/tar/test")))) + (setq file (file-name-as-directory file)) + (cond + ((not (tramp-archive-file-name-p file)) + (message "skipped: %s" file)) + ((file-attributes file) + (message "%s" file)) + (t (message "failed: %s" file))) + (tramp-archive-cleanup-hash))) + + ;; Cleanup. + (tramp-archive-cleanup-hash))) + +(defun tramp-archive-test-all (&optional interactive) + "Run all tests for \\[tramp-archive]." + (interactive "p") + (funcall + (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) + "^tramp-archive")) + +(provide 'tramp-archive-tests) +;;; tramp-archive-tests.el ends here diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 8f810818af1..55884f30a7e 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -33,7 +33,7 @@ ;; remote host, set this environment variable to "/dev/null" or ;; whatever is appropriate on your system. -;; For slow remote connections, `tramp-test41-asynchronous-requests' +;; For slow remote connections, `tramp-test42-asynchronous-requests' ;; might be too heavy. Setting $REMOTE_PARALLEL_PROCESSES to a proper ;; value less than 10 could help. @@ -52,14 +52,23 @@ (declare-function tramp-find-executable "tramp-sh") (declare-function tramp-get-remote-path "tramp-sh") -(declare-function tramp-get-remote-stat "tramp-sh") (declare-function tramp-get-remote-perl "tramp-sh") +(declare-function tramp-get-remote-stat "tramp-sh") +(declare-function tramp-method-out-of-band-p "tramp-sh") +(declare-function tramp-smb-get-localname "tramp-smb") (defvar auto-save-file-name-transforms) (defvar tramp-copy-size-limit) (defvar tramp-persistency-file-name) (defvar tramp-remote-process-environment) -;; Suppress nasty messages. -(fset 'shell-command-sentinel 'ignore) + +;; Beautify batch mode. +(when noninteractive + ;; Suppress nasty messages. + (fset 'shell-command-sentinel 'ignore) + ;; We do not want to be interrupted. + (eval-after-load 'tramp-gvfs + '(fset 'tramp-gvfs-handler-askquestion + (lambda (_message _choices) '(t nil 0))))) ;; There is no default value on w32 systems, which could work out of the box. (defconst tramp-test-temporary-file-directory @@ -84,7 +93,8 @@ (format "/mock::%s" temporary-file-directory))) "Temporary directory for Tramp tests.") -(setq password-cache-expiry nil +(setq auth-source-save-behavior nil + password-cache-expiry nil tramp-verbose 0 tramp-cache-read-persistent-data t ;; For auth-sources. tramp-copy-size-limit nil @@ -95,11 +105,6 @@ (when (getenv "EMACS_HYDRA_CI") (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) -(defvar tramp--test-expensive-test - (null - (string-equal (getenv "SELECTOR") "(quote (not (tag :expensive-test)))")) - "Whether expensive tests are run.") - (defvar tramp--test-enabled-checked nil "Cached result of `tramp--test-enabled'. If the function did run, the value is a cons cell, the `cdr' @@ -127,6 +132,13 @@ being the result.") ;; Return result. (cdr tramp--test-enabled-checked)) +(defsubst tramp--test-expensive-test () + "Whether expensive tests are run." + (ert-select-tests + (ert--stats-selector ert--current-run-stats) + (list (make-ert-test :name (ert-test-name (ert-running-test)) + :body nil :tags '(:expensive-test))))) + (defun tramp--test-make-temp-name (&optional local quoted) "Return a temporary file name for test. If LOCAL is non-nil, a local file name is returned. @@ -179,6 +191,16 @@ handled properly. BODY shall not contain a timeout." (tramp-backtrace (tramp-dissect-file-name tramp-test-temporary-file-directory)))) +(defmacro tramp--test-print-duration (message &rest body) + "Run BODY and print a message with duration, prompted by MESSAGE." + (declare (indent 1) (debug (stringp body))) + `(let ((start (current-time))) + (unwind-protect + (progn ,@body) + (tramp--test-message + "%s %f sec" + ,message (float-time (time-subtract (current-time) start)))))) + (ert-deftest tramp-test00-availability () "Test availability of Tramp functions." :expected-result (if (tramp--test-enabled) :passed :failed) @@ -229,6 +251,9 @@ handled properly. BODY shall not contain a timeout." ;; No strings. (should-not (tramp-tramp-file-p nil)) (should-not (tramp-tramp-file-p 'symbol)) + ;; No newline or linefeed. + (should-not (tramp-tramp-file-p "/method::file\nname")) + (should-not (tramp-tramp-file-p "/method::file\rname")) ;; Ange-ftp syntax. (should-not (tramp-tramp-file-p "/host:")) (should-not (tramp-tramp-file-p "/user@host:")) @@ -242,6 +267,12 @@ handled properly. BODY shall not contain a timeout." (should-not (tramp-tramp-file-p "/::")) (should-not (tramp-tramp-file-p "/:@:")) (should-not (tramp-tramp-file-p "/:[]:")) + ;; When `tramp-mode' is nil, Tramp is not activated. + (let (tramp-mode) + (should-not (tramp-tramp-file-p "/method:user@host:"))) + ;; `tramp-ignored-file-name-regexp' suppresses Tramp. + (let ((tramp-ignored-file-name-regexp "^/method:user@host:")) + (should-not (tramp-tramp-file-p "/method:user@host:"))) ;; Methods shall be at least two characters on MS Windows, except ;; the default method. (let ((system-type 'windows-nt)) @@ -365,7 +396,10 @@ handled properly. BODY shall not contain a timeout." "Check remote file name components." (let ((tramp-default-method "default-method") (tramp-default-user "default-user") - (tramp-default-host "default-host")) + (tramp-default-host "default-host") + tramp-default-method-alist + tramp-default-user-alist + tramp-default-host-alist) ;; Expand `tramp-default-user' and `tramp-default-host'. (should (string-equal (file-remote-p "/method::") @@ -715,7 +749,55 @@ handled properly. BODY shall not contain a timeout." "|method3:user3@host3:/path/to/file") 'hop) (format "%s:%s@%s|%s:%s@%s|" - "method1" "user1" "host1" "method2" "user2" "host2"))))) + "method1" "user1" "host1" "method2" "user2" "host2"))) + + ;; Expand `tramp-default-method-alist'. + (add-to-list 'tramp-default-method-alist '("host1" "user1" "method1")) + (add-to-list 'tramp-default-method-alist '("host2" "user2" "method2")) + (add-to-list 'tramp-default-method-alist '("host3" "user3" "method3")) + (should + (string-equal + (file-remote-p + (concat + "/-:user1@host1" + "|-:user2@host2" + "|-:user3@host3:/path/to/file")) + (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s:" + "-" "user1" "host1" + "-" "user2" "host2" + "method3" "user3" "host3"))) + + ;; Expand `tramp-default-user-alist'. + (add-to-list 'tramp-default-user-alist '("method1" "host1" "user1")) + (add-to-list 'tramp-default-user-alist '("method2" "host2" "user2")) + (add-to-list 'tramp-default-user-alist '("method3" "host3" "user3")) + (should + (string-equal + (file-remote-p + (concat + "/method1:host1" + "|method2:host2" + "|method3:host3:/path/to/file")) + (format "/%s:%s|%s:%s|%s:%s@%s:" + "method1" "host1" + "method2" "host2" + "method3" "user3" "host3"))) + + ;; Expand `tramp-default-host-alist'. + (add-to-list 'tramp-default-host-alist '("method1" "user1" "host1")) + (add-to-list 'tramp-default-host-alist '("method2" "user2" "host2")) + (add-to-list 'tramp-default-host-alist '("method3" "user3" "host3")) + (should + (string-equal + (file-remote-p + (concat + "/method1:user1@" + "|method2:user2@" + "|method3:user3@:/path/to/file")) + (format "/%s:%s@|%s:%s@|%s:%s@%s:" + "method1" "user1" + "method2" "user2" + "method3" "user3" "host3"))))) (ert-deftest tramp-test02-file-name-dissect-simplified () "Check simplified file name components." @@ -723,6 +805,8 @@ handled properly. BODY shall not contain a timeout." (let ((tramp-default-method "default-method") (tramp-default-user "default-user") (tramp-default-host "default-host") + tramp-default-user-alist + tramp-default-host-alist (syntax tramp-syntax)) (unwind-protect (progn @@ -970,7 +1054,39 @@ handled properly. BODY shall not contain a timeout." "|user3@host3:/path/to/file") 'hop) (format "%s@%s|%s@%s|" - "user1" "host1" "user2" "host2")))) + "user1" "host1" "user2" "host2"))) + + ;; Expand `tramp-default-user-alist'. + (add-to-list 'tramp-default-user-alist '(nil "host1" "user1")) + (add-to-list 'tramp-default-user-alist '(nil "host2" "user2")) + (add-to-list 'tramp-default-user-alist '(nil "host3" "user3")) + (should + (string-equal + (file-remote-p + (concat + "/host1" + "|host2" + "|host3:/path/to/file")) + (format "/%s|%s|%s@%s:" + "host1" + "host2" + "user3" "host3"))) + + ;; Expand `tramp-default-host-alist'. + (add-to-list 'tramp-default-host-alist '(nil "user1" "host1")) + (add-to-list 'tramp-default-host-alist '(nil "user2" "host2")) + (add-to-list 'tramp-default-host-alist '(nil "user3" "host3")) + (should + (string-equal + (file-remote-p + (concat + "/user1@" + "|user2@" + "|user3@:/path/to/file")) + (format "/%s@|%s@|%s@%s:" + "user1" + "user2" + "user3" "host3")))) ;; Exit. (tramp-change-syntax syntax)))) @@ -981,6 +1097,9 @@ handled properly. BODY shall not contain a timeout." (let ((tramp-default-method "default-method") (tramp-default-user "default-user") (tramp-default-host "default-host") + tramp-default-method-alist + tramp-default-user-alist + tramp-default-host-alist (syntax tramp-syntax)) (unwind-protect (progn @@ -1538,7 +1657,55 @@ handled properly. BODY shall not contain a timeout." "|method3/user3@host3]/path/to/file") 'hop) (format "%s/%s@%s|%s/%s@%s|" - "method1" "user1" "host1" "method2" "user2" "host2")))) + "method1" "user1" "host1" "method2" "user2" "host2"))) + + ;; Expand `tramp-default-method-alist'. + (add-to-list 'tramp-default-method-alist '("host1" "user1" "method1")) + (add-to-list 'tramp-default-method-alist '("host2" "user2" "method2")) + (add-to-list 'tramp-default-method-alist '("host3" "user3" "method3")) + (should + (string-equal + (file-remote-p + (concat + "/[/user1@host1" + "|/user2@host2" + "|/user3@host3]/path/to/file")) + (format "/[/%s@%s|/%s@%s|%s/%s@%s]" + "user1" "host1" + "user2" "host2" + "method3" "user3" "host3"))) + + ;; Expand `tramp-default-user-alist'. + (add-to-list 'tramp-default-user-alist '("method1" "host1" "user1")) + (add-to-list 'tramp-default-user-alist '("method2" "host2" "user2")) + (add-to-list 'tramp-default-user-alist '("method3" "host3" "user3")) + (should + (string-equal + (file-remote-p + (concat + "/[method1/host1" + "|method2/host2" + "|method3/host3]/path/to/file")) + (format "/[%s/%s|%s/%s|%s/%s@%s]" + "method1" "host1" + "method2" "host2" + "method3" "user3" "host3"))) + + ;; Expand `tramp-default-host-alist'. + (add-to-list 'tramp-default-host-alist '("method1" "user1" "host1")) + (add-to-list 'tramp-default-host-alist '("method2" "user2" "host2")) + (add-to-list 'tramp-default-host-alist '("method3" "user3" "host3")) + (should + (string-equal + (file-remote-p + (concat + "/[method1/user1@" + "|method2/user2@" + "|method3/user3@]/path/to/file")) + (format "/[%s/%s@|%s/%s@|%s/%s@%s]" + "method1" "user1" + "method2" "user2" + "method3" "user3" "host3")))) ;; Exit. (tramp-change-syntax syntax)))) @@ -1567,41 +1734,103 @@ handled properly. BODY shall not contain a timeout." ;; Default values in tramp-smb.el. (should (string-equal (file-remote-p "/smb::" 'user) nil))) +;; The following test is inspired by Bug#30946. +(ert-deftest tramp-test03-file-name-host-rules () + "Check host name rules for host-less methods." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + ;; `user-error' has appeared in Emacs 24.3. + (skip-unless (fboundp 'user-error)) + + ;; Host names must match rules in case the command template of a + ;; method doesn't use them. + (dolist (m '("su" "sg" "sudo" "doas" "ksu")) + (let ((vec (tramp-dissect-file-name tramp-test-temporary-file-directory)) + tramp-connection-properties tramp-default-proxies-alist) + (ignore-errors (tramp-cleanup-connection vec nil 'keep-password)) + ;; Single hop. The host name must match `tramp-local-host-regexp'. + (should-error + (find-file (format "/%s:foo:" m)) + :type 'user-error) + ;; Multi hop. The host name must match the previous hop. + (should-error + (find-file + (format + "%s|%s:foo:" + (substring (file-remote-p tramp-test-temporary-file-directory) 0 -1) + m)) + :type + (if (tramp-method-out-of-band-p vec 0) 'file-error 'user-error))))) + +(ert-deftest tramp-test03-file-name-method-rules () + "Check file name rules for some methods." + (skip-unless (tramp--test-enabled)) + + ;; Samba does not support file names with periods followed by + ;; spaces, and trailing periods or spaces. + (when (tramp-smb-file-name-p tramp-test-temporary-file-directory) + (dolist (file '("foo." "foo. bar" "foo ")) + (should-error + (tramp-smb-get-localname + (tramp-dissect-file-name + (expand-file-name file tramp-test-temporary-file-directory))) + :type 'file-error)))) + (ert-deftest tramp-test04-substitute-in-file-name () "Check `substitute-in-file-name'." - (should (string-equal (substitute-in-file-name "/method:host://foo") "/foo")) + (should (string-equal (substitute-in-file-name "/method:host:///foo") "/foo")) (should (string-equal - (substitute-in-file-name "/method:host:/path//foo") "/method:host:/foo")) + (substitute-in-file-name "/method:host://foo") "/method:host:/foo")) (should (string-equal (substitute-in-file-name "/method:host:/path///foo") "/foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path//foo") "/method:host:/foo")) ;; Quoting local part. (should (string-equal - (substitute-in-file-name "/method:host:/://foo") "/method:host:/://foo")) + (substitute-in-file-name "/method:host:/:///foo") "/method:host:/:///foo")) (should (string-equal - (substitute-in-file-name "/method:host:/:/path//foo") - "/method:host:/:/path//foo")) + (substitute-in-file-name "/method:host:/://foo") "/method:host:/://foo")) (should (string-equal (substitute-in-file-name "/method:host:/:/path///foo") "/method:host:/:/path///foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/:/path//foo") + "/method:host:/:/path//foo")) (should + (string-equal (substitute-in-file-name "/method:host://~foo") "/~foo")) + (should (string-equal - (substitute-in-file-name "/method:host:/path/~/foo") "/method:host:~/foo")) + (substitute-in-file-name "/method:host:/~foo") "/method:host:/~foo")) + (should + (string-equal (substitute-in-file-name "/method:host:/path//~foo") "/~foo")) + ;; (substitute-in-file-name "/path/~foo") expands only for a local + ;; user "foo" to "/~foo"". Otherwise, it doesn't expand. (should - (string-equal (substitute-in-file-name "/method:host:/path//~/foo") "~/foo")) + (string-equal + (substitute-in-file-name + "/method:host:/path/~foo") "/method:host:/path/~foo")) ;; Quoting local part. (should (string-equal - (substitute-in-file-name "/method:host:/:/path/~/foo") - "/method:host:/:/path/~/foo")) + (substitute-in-file-name "/method:host:/://~foo") "/method:host:/://~foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/:/~foo") "/method:host:/:/~foo")) (should (string-equal - (substitute-in-file-name "/method:host:/:/path//~/foo") - "/method:host:/:/path//~/foo")) + (substitute-in-file-name + "/method:host:/:/path//~foo") "/method:host:/:/path//~foo")) + (should + (string-equal + (substitute-in-file-name + "/method:host:/:/path/~foo") "/method:host:/:/path/~foo")) (let (process-environment) (should @@ -1661,6 +1890,7 @@ handled properly. BODY shall not contain a timeout." ;; Mark as failed until bug has been fixed. :expected-result :failed (skip-unless (tramp--test-enabled)) + ;; These are the methods the test doesn't fail. (when (or (tramp--test-adb-p) (tramp--test-gvfs-p) (tramp-smb-file-name-p tramp-test-temporary-file-directory)) @@ -1709,6 +1939,14 @@ This checks also `file-name-as-directory', `file-name-directory', (file-name-directory "/method:host:/path/to/file/") "/method:host:/path/to/file/")) (should + (string-equal (file-name-directory "/method:host:file") "/method:host:")) + (should + (string-equal + (file-name-directory "/method:host:path/") "/method:host:path/")) + (should + (string-equal + (file-name-directory "/method:host:path/to") "/method:host:path/")) + (should (string-equal (file-name-nondirectory "/method:host:/path/to/file") "file")) (should (string-equal (file-name-nondirectory "/method:host:/path/to/file/") "")) @@ -1743,7 +1981,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `file-exist-p', `write-region' and `delete-file'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (should-not (file-exists-p tmp-name)) (write-region "foo" nil tmp-name) @@ -1755,7 +1993,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `file-local-copy'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) tmp-name2) (unwind-protect @@ -1787,7 +2025,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `insert-file-contents'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (with-temp-buffer @@ -1815,7 +2053,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `write-region'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -1905,7 +2143,7 @@ This checks also `file-name-as-directory', `file-name-directory', (skip-unless (tramp--test-enabled)) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p)) + (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) @@ -1930,9 +2168,10 @@ This checks also `file-name-as-directory', `file-name-directory', (with-temp-buffer (insert-file-contents target) (should (string-equal (buffer-string) "foo"))) - (should-error - (copy-file source target) - :type 'file-already-exists) + (when (tramp--test-expensive-test) + (should-error + (copy-file source target) + :type 'file-already-exists)) (copy-file source target 'ok)) ;; Cleanup. @@ -1941,13 +2180,15 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Copy file to directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless (tramp--test-nextcloud-p) (write-region "foo" nil source) (should (file-exists-p source)) (make-directory target) (should (file-directory-p target)) ;; This has been changed in Emacs 26.1. - (when (tramp--test-emacs26-p) + (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p)) (should-error (copy-file source target) :type 'file-already-exists)) @@ -1962,7 +2203,11 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Copy directory to existing directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless (and (tramp--test-nextcloud-p) + (or (not (file-remote-p source)) + (not (file-remote-p target)))) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -1983,7 +2228,10 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Copy directory/file to non-existing directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless + (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)) @@ -2007,7 +2255,7 @@ This checks also `file-name-as-directory', `file-name-directory', (skip-unless (tramp--test-enabled)) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p)) + (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) @@ -2035,9 +2283,10 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (buffer-string) "foo"))) (write-region "foo" nil source) (should (file-exists-p source)) - (should-error - (rename-file source target) - :type 'file-already-exists) + (when (tramp--test-expensive-test) + (should-error + (rename-file source target) + :type 'file-already-exists)) (rename-file source target 'ok) (should-not (file-exists-p source))) @@ -2053,7 +2302,7 @@ This checks also `file-name-as-directory', `file-name-directory', (make-directory target) (should (file-directory-p target)) ;; This has been changed in Emacs 26.1. - (when (tramp--test-emacs26-p) + (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p)) (should-error (rename-file source target) :type 'file-already-exists)) @@ -2069,7 +2318,9 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Rename directory to existing directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless (tramp--test-nextcloud-p) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -2091,7 +2342,9 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Rename directory/file to non-existing directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless (tramp--test-nextcloud-p) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -2116,7 +2369,7 @@ This checks also `file-name-as-directory', `file-name-directory', This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo/bar" tmp-name1))) (unwind-protect @@ -2139,7 +2392,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `delete-directory'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) ;; Delete empty directory. (make-directory tmp-name) @@ -2159,7 +2412,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `copy-directory'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (expand-file-name @@ -2225,7 +2478,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `directory-files'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "bla" tmp-name1)) (tmp-name3 (expand-file-name "foo" tmp-name1))) @@ -2258,7 +2511,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `file-expand-wildcards'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo" tmp-name1)) (tmp-name3 (expand-file-name "bar" tmp-name1)) @@ -2322,7 +2575,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `insert-directory'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 (expand-file-name "foo" tmp-name1)) @@ -2383,7 +2636,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Since Emacs 26.1. (skip-unless (fboundp 'insert-directory-wildcard-in-dir-p)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 @@ -2500,7 +2753,7 @@ This tests also `file-readable-p', `file-regular-p' and `file-ownership-preserved-p'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. @@ -2607,7 +2860,7 @@ This tests also `file-readable-p', `file-regular-p' and "Check `directory-files-and-attributes'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) ;; `directory-files-and-attributes' contains also values for ;; "../". Ensure that this doesn't change during tests, for ;; example due to handling temporary files. @@ -2653,7 +2906,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -2673,15 +2926,27 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) +;; Method "smb" could run into "NT_STATUS_REVISION_MISMATCH" error. +(defmacro tramp--test-ignore-add-name-to-file-error (&rest body) + "Run BODY, ignoring \"error with add-name-to-file\" file error." + (declare (indent defun) (debug t)) + `(condition-case err + (progn ,@body) + ((error quit debug) + (unless (and (eq (car err) 'file-error) + (string-match "^error with add-name-to-file" + (error-message-string err))) + (signal (car err) (cdr err)))))) + (ert-deftest tramp-test21-file-links () "Check `file-symlink-p'. This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) - ;; The semantics has changed heavily in Emacs 26.1. We cannot test + ;; The semantics have changed heavily in Emacs 26.1. We cannot test ;; older Emacsen, therefore. (skip-unless (tramp--test-emacs26-p)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. @@ -2705,14 +2970,16 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (if quoted 'tramp-compat-file-name-unquote 'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2))) - (should-error - (make-symbolic-link tmp-name1 tmp-name2) - :type 'file-already-exists) - ;; A number means interactive case. - (cl-letf (((symbol-function 'yes-or-no-p) 'ignore)) + (when (tramp--test-expensive-test) (should-error - (make-symbolic-link tmp-name1 tmp-name2 0) + (make-symbolic-link tmp-name1 tmp-name2) :type 'file-already-exists)) + (when (tramp--test-expensive-test) + ;; A number means interactive case. + (cl-letf (((symbol-function 'yes-or-no-p) 'ignore)) + (should-error + (make-symbolic-link tmp-name1 tmp-name2 0) + :type 'file-already-exists))) (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) (make-symbolic-link tmp-name1 tmp-name2 0) (should @@ -2747,9 +3014,10 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (string-equal tmp-name1 (file-symlink-p tmp-name3)))) ;; Check directory as newname. (make-directory tmp-name4) - (should-error - (make-symbolic-link tmp-name1 tmp-name4) - :type 'file-already-exists) + (when (tramp--test-expensive-test) + (should-error + (make-symbolic-link tmp-name1 tmp-name4) + :type 'file-already-exists)) (make-symbolic-link tmp-name1 (file-name-as-directory tmp-name4)) (should (string-equal @@ -2771,38 +3039,40 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Check `add-name-to-file'. (unwind-protect - (unless (tramp-smb-file-name-p tramp-test-temporary-file-directory) - (write-region "foo" nil tmp-name1) - (should (file-exists-p tmp-name1)) - (add-name-to-file tmp-name1 tmp-name2) - (should (file-regular-p tmp-name2)) - (should-error + (when (tramp--test-expensive-test) + (tramp--test-ignore-add-name-to-file-error + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) (add-name-to-file tmp-name1 tmp-name2) - :type 'file-already-exists) - ;; A number means interactive case. - (cl-letf (((symbol-function 'yes-or-no-p) 'ignore)) - (should-error - (add-name-to-file tmp-name1 tmp-name2 0) - :type 'file-already-exists)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) + (should (file-regular-p tmp-name2)) + (should-error + (add-name-to-file tmp-name1 tmp-name2) + :type 'file-already-exists) + ;; A number means interactive case. + (cl-letf (((symbol-function 'yes-or-no-p) 'ignore)) + (should-error + (add-name-to-file tmp-name1 tmp-name2 0) + :type 'file-already-exists)) + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) (add-name-to-file tmp-name1 tmp-name2 0) (should (file-regular-p tmp-name2))) - (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) - (should-not (file-symlink-p tmp-name2)) - (should (file-regular-p tmp-name2)) - ;; `tmp-name3' is a local file name. - (should-error - (add-name-to-file tmp-name1 tmp-name3) - :type 'file-error) - ;; Check directory as newname. - (make-directory tmp-name4) - (should-error - (add-name-to-file tmp-name1 tmp-name4) - :type 'file-already-exists) - (add-name-to-file tmp-name1 (file-name-as-directory tmp-name4)) - (should - (file-regular-p - (expand-file-name (file-name-nondirectory tmp-name1) tmp-name4)))) + (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) + (should-not (file-symlink-p tmp-name2)) + (should (file-regular-p tmp-name2)) + ;; `tmp-name3' is a local file name. + (should-error + (add-name-to-file tmp-name1 tmp-name3) + :type 'file-error) + ;; Check directory as newname. + (make-directory tmp-name4) + (should-error + (add-name-to-file tmp-name1 tmp-name4) + :type 'file-already-exists) + (add-name-to-file tmp-name1 (file-name-as-directory tmp-name4)) + (should + (file-regular-p + (expand-file-name + (file-name-nondirectory tmp-name1) tmp-name4))))) ;; Cleanup. (ignore-errors @@ -2882,12 +3152,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (string-equal (file-truename tmp-name2) (file-truename tmp-name3))) - (should-error - (with-temp-buffer (insert-file-contents tmp-name2)) - :type tramp-file-missing) - (should-error - (with-temp-buffer (insert-file-contents tmp-name3)) - :type tramp-file-missing) + (when (tramp--test-expensive-test) + (should-error + (with-temp-buffer (insert-file-contents tmp-name2)) + :type tramp-file-missing)) + (when (tramp--test-expensive-test) + (should-error + (with-temp-buffer (insert-file-contents tmp-name3)) + :type tramp-file-missing)) ;; `directory-files' does not show symlinks to ;; non-existing targets in the "smb" case. So we remove ;; the symlinks manually. @@ -2900,32 +3172,41 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Detect cyclic symbolic links. (unwind-protect - (tramp--test-ignore-make-symbolic-link-error - (make-symbolic-link tmp-name2 tmp-name1) - (should (file-symlink-p tmp-name1)) - (make-symbolic-link tmp-name1 tmp-name2) - (should (file-symlink-p tmp-name2)) - (should-error (file-truename tmp-name1) :type 'file-error)) + (when (tramp--test-expensive-test) + (tramp--test-ignore-make-symbolic-link-error + (make-symbolic-link tmp-name2 tmp-name1) + (should (file-symlink-p tmp-name1)) + (if (tramp-smb-file-name-p tramp-test-temporary-file-directory) + ;; The symlink command of `smbclient' detects the + ;; cycle already. + (should-error + (make-symbolic-link tmp-name1 tmp-name2) + :type 'file-error) + (make-symbolic-link tmp-name1 tmp-name2) + (should (file-symlink-p tmp-name2)) + (should-error (file-truename tmp-name1) :type 'file-error)))) ;; Cleanup. (ignore-errors (delete-file tmp-name1) (delete-file tmp-name2))) - ;; `file-truename' shall preserve trailing link of directories. - (unless (file-symlink-p tramp-test-temporary-file-directory) - (let* ((dir1 (directory-file-name tramp-test-temporary-file-directory)) - (dir2 (file-name-as-directory dir1))) - (should (string-equal (file-truename dir1) (expand-file-name dir1))) - (should - (string-equal (file-truename dir2) (expand-file-name dir2)))))))) + ;; `file-truename' shall preserve trailing slash of directories. + (let* ((dir1 + (directory-file-name + (funcall + (if quoted 'tramp-compat-file-name-quote 'identity) + tramp-test-temporary-file-directory))) + (dir2 (file-name-as-directory dir1))) + (should (string-equal (file-truename dir1) (expand-file-name dir1))) + (should (string-equal (file-truename dir2) (expand-file-name dir2))))))) (ert-deftest tramp-test22-file-times () "Check `set-file-times' and `file-newer-than-file-p'." (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name nil quoted))) @@ -2938,11 +3219,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; `current-time'. Therefore, we use '(0 1). We skip the ;; test, if the remote handler is not able to set the ;; correct time. - (skip-unless (set-file-times tmp-name1 '(0 1))) + (skip-unless (set-file-times tmp-name1 (seconds-to-time 1))) ;; Dumb remote shells without perl(1) or stat(1) are not ;; able to return the date correctly. They say "don't know". (unless (equal (nth 5 (file-attributes tmp-name1)) '(0 0)) - (should (equal (nth 5 (file-attributes tmp-name1)) '(0 1))) + (should + (equal (nth 5 (file-attributes tmp-name1)) (seconds-to-time 1))) (write-region "bla" nil tmp-name2) (should (file-exists-p tmp-name2)) (should (file-newer-than-file-p tmp-name2 tmp-name1)) @@ -2959,7 +3241,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `set-visited-file-modtime' and `verify-visited-file-modtime'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -2982,7 +3264,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (file-acl tramp-test-temporary-file-directory)) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p)) + (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) @@ -3060,7 +3342,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." '(nil nil nil nil)))) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p)) + (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) @@ -3208,7 +3490,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (unwind-protect (dolist (syntax - (if tramp--test-expensive-test + (if (tramp--test-expensive-test) (tramp-syntax-values) `(,orig-syntax))) (tramp-change-syntax syntax) (let ;; This is needed for the `simplified' syntax. @@ -3259,7 +3541,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-change-syntax orig-syntax)))) (dolist (n-e '(nil t)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((non-essential n-e) (tmp-name (tramp--test-make-temp-name nil quoted))) @@ -3321,7 +3603,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `load'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -3346,7 +3628,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name (tramp--test-make-temp-name nil quoted)) (fnnd (file-name-nondirectory tmp-name)) (default-directory tramp-test-temporary-file-directory) @@ -3392,7 +3674,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name nil quoted)) kill-buffer-query-functions proc) @@ -3484,7 +3766,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) (default-directory tramp-test-temporary-file-directory) ;; Suppress nasty messages. @@ -3740,13 +4022,55 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (put 'explicit-shell-file-name 'permanent-local nil) (kill-buffer "*shell*")))) -(ert-deftest tramp-test34-vc-registered () +;; `exec-path' was introduced in Emacs 27.1. `executable-find' has +;; changed the number of parameters, so we use `apply' for older +;; Emacsen. +(ert-deftest tramp-test34-exec-path () + "Check `exec-path' and `executable-find'." + (skip-unless (tramp--test-enabled)) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + ;; Since Emacs 27.1. + (skip-unless (fboundp 'exec-path)) + + (let ((tmp-name (tramp--test-make-temp-name)) + (default-directory tramp-test-temporary-file-directory)) + (unwind-protect + (progn + (should (consp (with-no-warnings (exec-path)))) + ;; Last element is the `exec-directory'. + (should + (string-equal + (car (last (with-no-warnings (exec-path)))) + (file-remote-p default-directory 'localname))) + ;; The shell "sh" shall always exist. + (should (apply 'executable-find '("sh" remote))) + ;; Since the last element in `exec-path' is the current + ;; directory, an executable file in that directory will be + ;; found. + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (set-file-modes tmp-name #o777) + (should (file-executable-p tmp-name)) + (should + (string-equal + (apply + 'executable-find `(,(file-name-nondirectory tmp-name) remote)) + (file-remote-p tmp-name 'localname))) + (should-not + (apply + 'executable-find + `(,(concat (file-name-nondirectory tmp-name) "foo") remote)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +(ert-deftest tramp-test35-vc-registered () "Check `vc-registered'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((default-directory tramp-test-temporary-file-directory) (tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo" tmp-name1)) @@ -3810,11 +4134,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) -(ert-deftest tramp-test35-make-auto-save-file-name () +(ert-deftest tramp-test36-make-auto-save-file-name () "Check `make-auto-save-file-name'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted))) @@ -3901,11 +4225,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (ignore-errors (delete-file tmp-name1)) (ignore-errors (delete-directory tmp-name2 'recursive)))))) -(ert-deftest tramp-test36-find-backup-file-name () +(ert-deftest tramp-test37-find-backup-file-name () "Check `find-backup-file-name'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) ;; These settings are not used by Tramp, so we ignore them. @@ -4012,7 +4336,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (ignore-errors (delete-directory tmp-name2 'recursive)))))) ;; The functions were introduced in Emacs 26.1. -(ert-deftest tramp-test37-make-nearby-temp-file () +(ert-deftest tramp-test38-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." (skip-unless (tramp--test-enabled)) ;; Since Emacs 26.1. @@ -4104,6 +4428,11 @@ This does not support external Emacs calls." (string-equal "mock" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-nextcloud-p () + "Check, whether the nextcloud method is used." + (string-equal + "nextcloud" (file-remote-p tramp-test-temporary-file-directory 'method))) + (defun tramp--test-rsync-p () "Check, whether the rsync method is used. This does not support special file names." @@ -4142,7 +4471,7 @@ This requires restrictions of file name syntax." (defun tramp--test-check-files (&rest files) "Run a simple but comprehensive test over every file in FILES." ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p)) + (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This @@ -4275,9 +4604,10 @@ This requires restrictions of file name syntax." (should-not (file-exists-p file1)))) ;; Check, that environment variables are set correctly. - (when (and tramp--test-expensive-test (tramp--test-sh-p)) + (when (and (tramp--test-expensive-test) (tramp--test-sh-p)) (dolist (elt files) (let ((envvar (concat "VAR_" (upcase (md5 elt)))) + (elt (encode-coding-string elt coding-system-for-read)) (default-directory tramp-test-temporary-file-directory) (process-environment process-environment)) (setenv envvar elt) @@ -4299,50 +4629,55 @@ This requires restrictions of file name syntax." (ignore-errors (delete-directory tmp-name2 'recursive)))))) (defun tramp--test-special-characters () - "Perform the test in `tramp-test38-special-characters*'." + "Perform the test in `tramp-test39-special-characters*'." ;; Newlines, slashes and backslashes in file names are not ;; supported. So we don't test. And we don't test the tab ;; character on Windows or Cygwin, because the backslash is ;; interpreted as a path separator, preventing "\t" from being ;; expanded to <TAB>. - (tramp--test-check-files - (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) - "foo bar baz" - (if (or (tramp--test-adb-p) - (tramp--test-docker-p) - (eq system-type 'cygwin)) - " foo bar baz " - " foo\tbar baz\t")) - "$foo$bar$$baz$" - "-foo-bar-baz-" - "%foo%bar%baz%" - "&foo&bar&baz&" - (unless (or (tramp--test-ftp-p) - (tramp--test-gvfs-p) - (tramp--test-windows-nt-or-smb-p)) - "?foo?bar?baz?") - (unless (or (tramp--test-ftp-p) - (tramp--test-gvfs-p) - (tramp--test-windows-nt-or-smb-p)) - "*foo*bar*baz*") - (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) - "'foo'bar'baz'" - "'foo\"bar'baz\"") - "#foo~bar#baz~" - (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) - "!foo!bar!baz!" - "!foo|bar!baz|") - (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) - ";foo;bar;baz;" - ":foo;bar:baz;") - (unless (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) - "<foo>bar<baz>") - "(foo)bar(baz)" - (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]") - "{foo}bar{baz}")) + (let ((files + (list + (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) + "foo bar baz" + (if (or (tramp--test-adb-p) + (tramp--test-docker-p) + (eq system-type 'cygwin)) + " foo bar baz " + " foo\tbar baz\t")) + "$foo$bar$$baz$" + "-foo-bar-baz-" + "%foo%bar%baz%" + "&foo&bar&baz&" + (unless (or (tramp--test-ftp-p) + (tramp--test-gvfs-p) + (tramp--test-windows-nt-or-smb-p)) + "?foo?bar?baz?") + (unless (or (tramp--test-ftp-p) + (tramp--test-gvfs-p) + (tramp--test-windows-nt-or-smb-p)) + "*foo*bar*baz*") + (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) + "'foo'bar'baz'" + "'foo\"bar'baz\"") + "#foo~bar#baz~" + (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) + "!foo!bar!baz!" + "!foo|bar!baz|") + (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) + ";foo;bar;baz;" + ":foo;bar:baz;") + (unless (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) + "<foo>bar<baz>") + "(foo)bar(baz)" + (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]") + "{foo}bar{baz}"))) + ;; Simplify test in order to speed up. + (apply 'tramp--test-check-files + (if (tramp--test-expensive-test) + files (list (mapconcat 'identity files "")))))) ;; These tests are inspired by Bug#17238. -(ert-deftest tramp-test38-special-characters () +(ert-deftest tramp-test39-special-characters () "Check special characters in file names." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) @@ -4350,7 +4685,7 @@ This requires restrictions of file name syntax." (tramp--test-special-characters)) -(ert-deftest tramp-test38-special-characters-with-stat () +(ert-deftest tramp-test39-special-characters-with-stat () "Check special characters in file names. Use the `stat' command." :tags '(:expensive-test) @@ -4368,7 +4703,7 @@ Use the `stat' command." tramp-connection-properties))) (tramp--test-special-characters))) -(ert-deftest tramp-test38-special-characters-with-perl () +(ert-deftest tramp-test39-special-characters-with-perl () "Check special characters in file names. Use the `perl' command." :tags '(:expensive-test) @@ -4389,7 +4724,7 @@ Use the `perl' command." tramp-connection-properties))) (tramp--test-special-characters))) -(ert-deftest tramp-test38-special-characters-with-ls () +(ert-deftest tramp-test39-special-characters-with-ls () "Check special characters in file names. Use the `ls' command." :tags '(:expensive-test) @@ -4412,7 +4747,7 @@ Use the `ls' command." (tramp--test-special-characters))) (defun tramp--test-utf8 () - "Perform the test in `tramp-test39-utf8*'." + "Perform the test in `tramp-test40-utf8*'." (let* ((utf8 (if (and (eq system-type 'darwin) (memq 'utf-8-hfs (coding-system-list))) 'utf-8-hfs 'utf-8)) @@ -4420,14 +4755,34 @@ Use the `ls' command." (coding-system-for-write utf8) (file-name-coding-system (coding-system-change-eol-conversion utf8 'unix))) - (tramp--test-check-files - (unless (tramp--test-hpux-p) "Γυρίστε το Γαλαξία με Ώτο Στοπ") - (unless (tramp--test-hpux-p) - "أصبح بوسعك الآن تنزيل نسخة كاملة من موسوعة ويكيبيديا العربية لتصفحها بلا اتصال بالإنترنت") - "银河系漫游指南系列" - "Автостопом по гала́ктике"))) - -(ert-deftest tramp-test39-utf8 () + (apply + 'tramp--test-check-files + (append + (list + (unless (tramp--test-hpux-p) "Γυρίστε το Γαλαξία με Ώτο Στοπ") + (unless (tramp--test-hpux-p) + "أصبح بوسعك الآن تنزيل نسخة كاملة من موسوعة ويكيبيديا العربية لتصفحها بلا اتصال بالإنترنت") + "银河系漫游指南系列" + "Автостопом по гала́ктике" + ;; Use codepoints without a name. See Bug#31272. + "bung") + + (when (tramp--test-expensive-test) + (delete-dups + (mapcar + ;; Use all available language specific snippets. Filter out + ;; strings which use unencodable characters. + (lambda (x) + (and + (stringp (setq x (eval (get-language-info (car x) 'sample-text)))) + (not (unencodable-char-position + 0 (length x) file-name-coding-system nil x)) + ;; ?\n and ?/ shouldn't be part of any file name. ?\t, + ;; ?. and ?? do not work for "smb" method. + (replace-regexp-in-string "[\t\n/.?]" "" x))) + language-info-alist))))))) + +(ert-deftest tramp-test40-utf8 () "Check UTF8 encoding in file names and file contents." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-docker-p))) @@ -4437,7 +4792,7 @@ Use the `ls' command." (tramp--test-utf8)) -(ert-deftest tramp-test39-utf8-with-stat () +(ert-deftest tramp-test40-utf8-with-stat () "Check UTF8 encoding in file names and file contents. Use the `stat' command." :tags '(:expensive-test) @@ -4457,7 +4812,7 @@ Use the `stat' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test39-utf8-with-perl () +(ert-deftest tramp-test40-utf8-with-perl () "Check UTF8 encoding in file names and file contents. Use the `perl' command." :tags '(:expensive-test) @@ -4480,7 +4835,7 @@ Use the `perl' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test39-utf8-with-ls () +(ert-deftest tramp-test40-utf8-with-ls () "Check UTF8 encoding in file names and file contents. Use the `ls' command." :tags '(:expensive-test) @@ -4503,7 +4858,7 @@ Use the `ls' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test40-file-system-info () +(ert-deftest tramp-test41-file-system-info () "Check that `file-system-info' returns proper values." (skip-unless (tramp--test-enabled)) ;; Since Emacs 27.1. @@ -4525,18 +4880,21 @@ Use the `ls' command." (ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test))))) ;; This test is inspired by Bug#16928. -(ert-deftest tramp-test41-asynchronous-requests () +(ert-deftest tramp-test42-asynchronous-requests () "Check parallel asynchronous requests. Such requests could arrive from timers, process filters and process sentinels. They shall not disturb each other." - :tags '(:expensive-test) + :tags '(:expensive-test :unstable) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) ;; This test could be blocked on hydra. So we set a timeout of 300 ;; seconds, and we send a SIGUSR1 signal after 300 seconds. + ;; This clearly doesn't work though, because the test not + ;; infrequently hangs for hours until killed by the infrastructure. (with-timeout (300 (tramp--test-timeout-handler)) (define-key special-event-map [sigusr1] 'tramp--test-timeout-handler) + (tramp--test-instrument-test-case (if (getenv "EMACS_HYDRA_CI") 10 0) (let* (;; For the watchdog. (default-directory (expand-file-name temporary-file-directory)) (watchdog @@ -4555,10 +4913,11 @@ process sentinels. They shall not disturb each other." ;; Number of asynchronous processes for test. Tests on ;; some machines handle less parallel processes. (number-proc - (or - (ignore-errors - (string-to-number (getenv "REMOTE_PARALLEL_PROCESSES"))) - 10)) + (cond + ((ignore-errors + (string-to-number (getenv "REMOTE_PARALLEL_PROCESSES")))) + ((getenv "EMACS_HYDRA_CI") 5) + (t 10))) ;; On hydra, timings are bad. (timer-repeat (cond @@ -4588,11 +4947,16 @@ process sentinels. They shall not disturb each other." (default-directory tmp-name) (file (buffer-name (nth (random (length buffers)) buffers)))) + (tramp--test-message + "Start timer %s %s" file (current-time-string)) (funcall timer-operation file) ;; Adjust timer if it takes too much time. (when (> (- (float-time) time) timer-repeat) (setq timer-repeat (* 1.5 timer-repeat)) - (setf (timer--repeat-delay timer) timer-repeat))))))) + (setf (timer--repeat-delay timer) timer-repeat) + (tramp--test-message "Increase timer %s" timer-repeat)) + (tramp--test-message + "Stop timer %s %s" file (current-time-string))))))) ;; Create temporary buffers. The number of buffers ;; corresponds to the number of processes; it could be @@ -4619,6 +4983,8 @@ process sentinels. They shall not disturb each other." (set-process-filter proc (lambda (proc string) + (tramp--test-message + "Process filter %s %s %s" proc string (current-time-string)) (with-current-buffer (process-buffer proc) (insert string)) (unless (zerop (length string)) @@ -4628,6 +4994,8 @@ process sentinels. They shall not disturb each other." (set-process-sentinel proc (lambda (proc _state) + (tramp--test-message + "Process sentinel %s %s" proc (current-time-string)) (dired-uncache (process-get proc 'foo)) (should-not (file-attributes (process-get proc 'foo))))))) @@ -4641,6 +5009,8 @@ process sentinels. They shall not disturb each other." (proc (get-buffer-process buf)) (file (process-get proc 'foo)) (count (process-get proc 'bar))) + (tramp--test-message + "Start action %d %s %s" count buf (current-time-string)) ;; Regular operation prior process action. (dired-uncache file) (if (= count 0) @@ -4651,11 +5021,15 @@ process sentinels. They shall not disturb each other." (accept-process-output proc 0.1 nil 0) ;; Give the watchdog a chance. (read-event nil nil 0.01) + (tramp--test-message + "Continue action %d %s %s" count buf (current-time-string)) ;; Regular operation post process action. (dired-uncache file) (if (= count 2) (should-not (file-attributes file)) (should (file-attributes file))) + (tramp--test-message + "Stop action %d %s %s" count buf (current-time-string)) (process-put proc 'bar (1+ count)) (unless (process-live-p proc) (setq buffers (delq buf buffers)))))) @@ -4663,6 +5037,7 @@ process sentinels. They shall not disturb each other." ;; Checks. All process output shall exists in the ;; respective buffers. All created files shall be ;; deleted. + (tramp--test-message "Check %s" (current-time-string)) (dolist (buf buffers) (with-current-buffer buf (should (string-equal (format "%s\n" buf) (buffer-string))))) @@ -4677,11 +5052,13 @@ process sentinels. They shall not disturb each other." (ignore-errors (delete-process (get-buffer-process buf))) (ignore-errors (kill-buffer buf))) (ignore-errors (cancel-timer timer)) - (ignore-errors (delete-directory tmp-name 'recursive)))))) + (ignore-errors (delete-directory tmp-name 'recursive))))))) ;; This test is inspired by Bug#29163. -(ert-deftest tramp-test42-auto-load () +(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 @@ -4698,7 +5075,7 @@ process sentinels. They shall not disturb each other." (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test42-delay-load () +(ert-deftest tramp-test43-delay-load () "Check that Tramp is loaded lazily, only when needed." ;; The autoloaded Tramp objects are different since Emacs 26.1. We ;; cannot test older Emacsen, therefore. @@ -4731,7 +5108,7 @@ process sentinels. They shall not disturb each other." (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument (format code tm))))))))) -(ert-deftest tramp-test42-recursive-load () +(ert-deftest tramp-test43-recursive-load () "Check that Tramp does not fail due to recursive load." (skip-unless (tramp--test-enabled)) @@ -4755,7 +5132,7 @@ process sentinels. They shall not disturb each other." (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument code)))))))) -(ert-deftest tramp-test42-remote-load-path () +(ert-deftest tramp-test43-remote-load-path () "Check that Tramp autoloads its packages with remote `load-path'." ;; The autoloaded Tramp objects are different since Emacs 26.1. We ;; cannot test older Emacsen, therefore. @@ -4783,7 +5160,7 @@ process sentinels. They shall not disturb each other." (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test43-unload () +(ert-deftest tramp-test44-unload () "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) @@ -4792,42 +5169,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]." @@ -4844,11 +5231,14 @@ Since it unloads Tramp, it shall be the last test to run." ;; * file-name-case-insensitive-p ;; * Work on skipped tests. Make a comment, when it is impossible. +;; * Revisit expensive tests, once problems in `tramp-error' are solved. ;; * 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 `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-test41-asynchronous-requests'. +;; * Fix Bug#16928 in `tramp-test42-asynchronous-requests'. (provide 'tramp-tests) ;;; tramp-tests.el ends here diff --git a/test/lisp/progmodes/bat-mode-tests.el b/test/lisp/progmodes/bat-mode-tests.el index 4fa8de10c6b..5b824841d41 100644 --- a/test/lisp/progmodes/bat-mode-tests.el +++ b/test/lisp/progmodes/bat-mode-tests.el @@ -63,10 +63,11 @@ "Test fontification of iteration variables." (should (equal - (bat-test-fontify "echo %%a\necho %%~dp1\necho %%~$PATH:I") + (bat-test-fontify "echo %%a\necho %%~dp1\necho %%~$PATH:I\necho %%~1") "<span class=\"builtin\">echo</span> %%<span class=\"variable-name\">a</span> <span class=\"builtin\">echo</span> %%~dp<span class=\"variable-name\">1</span> -<span class=\"builtin\">echo</span> %%~$<span class=\"variable-name\">PATH</span>:<span class=\"variable-name\">I</span>"))) +<span class=\"builtin\">echo</span> %%~$<span class=\"variable-name\">PATH</span>:<span class=\"variable-name\">I</span> +<span class=\"builtin\">echo</span> %%~<span class=\"variable-name\">1</span>"))) (defun bat-test-fill-paragraph (str) "Return the result of invoking `fill-paragraph' on STR in a `bat-mode' buffer." diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el index 5118e302405..bba1f12e691 100644 --- a/test/lisp/progmodes/flymake-tests.el +++ b/test/lisp/progmodes/flymake-tests.el @@ -118,6 +118,7 @@ SEVERITY-PREDICATE is used to setup (flymake-goto-prev-error) (should (eq 'flymake-error (face-at-point))))) +(defvar ruby-mode-hook) (ert-deftest ruby-backend () "Test the ruby backend" (skip-unless (executable-find "ruby")) @@ -129,11 +130,14 @@ SEVERITY-PREDICATE is used to setup ;; for this particular yuckiness (abbreviated-home-dir nil)) (unwind-protect - (flymake-tests--with-flymake ("test.rb") - (flymake-goto-next-error) - (should (eq 'flymake-warning (face-at-point))) - (flymake-goto-next-error) - (should (eq 'flymake-error (face-at-point)))) + (let ((ruby-mode-hook + (lambda () + (setq flymake-diagnostic-functions '(ruby-flymake-simple))))) + (flymake-tests--with-flymake ("test.rb") + (flymake-goto-next-error) + (should (eq 'flymake-warning (face-at-point))) + (flymake-goto-next-error) + (should (eq 'flymake-error (face-at-point))))) (delete-directory tempdir t)))) (ert-deftest different-diagnostic-types () diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index 4955da02a25..0b9f8484c10 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -2004,6 +2004,12 @@ string (python-util-forward-comment -1) (point)))))) +(ert-deftest python-nav-end-of-statement-2 () + "Test the string overlap assertion (Bug#30964)." + (python-tests-with-temp-buffer + "'\n''\n" + (python-nav-end-of-statement))) + (ert-deftest python-nav-forward-statement-1 () (python-tests-with-temp-buffer " @@ -5352,6 +5358,15 @@ buffer with overlapping strings." (python-nav-end-of-statement))) (should (eolp)))) +;; After call `run-python' the buffer running the python process is current. +(ert-deftest python-tests--bug31398 () + "Test for https://debbugs.gnu.org/31398 ." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let ((buffer (process-buffer (run-python nil nil 'show)))) + (should (eq buffer (current-buffer))) + (pop-to-buffer (other-buffer)) + (run-python nil nil 'show) + (should (eq buffer (current-buffer))))) (provide 'python-tests) diff --git a/test/lisp/progmodes/ruby-mode-tests.el b/test/lisp/progmodes/ruby-mode-tests.el index b16698fba11..72d83affaef 100644 --- a/test/lisp/progmodes/ruby-mode-tests.el +++ b/test/lisp/progmodes/ruby-mode-tests.el @@ -705,13 +705,15 @@ VALUES-PLIST is a list with alternating index and value elements." (ert-deftest ruby-forward-sexp-skips-method-calls-with-keyword-names () (ruby-with-temp-buffer ruby-sexp-test-example - (goto-line 2) + (goto-char (point-min)) + (forward-line 1) (ruby-forward-sexp) (should (= 8 (line-number-at-pos))))) (ert-deftest ruby-backward-sexp-skips-method-calls-with-keyword-names () (ruby-with-temp-buffer ruby-sexp-test-example - (goto-line 8) + (goto-char (point-min)) + (forward-line 7) (end-of-line) (ruby-backward-sexp) (should (= 2 (line-number-at-pos))))) diff --git a/test/lisp/progmodes/tcl-tests.el b/test/lisp/progmodes/tcl-tests.el new file mode 100644 index 00000000000..061488636d0 --- /dev/null +++ b/test/lisp/progmodes/tcl-tests.el @@ -0,0 +1,77 @@ +;;; tcl-tests.el --- Test suite for tcl-mode + +;; 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'tcl) + +;; From bug#23565 +(ert-deftest tcl-mode-beginning-of-defun-1 () + (with-temp-buffer + (tcl-mode) + (insert "proc bad {{value \"\"}} {\n # do something\n}") + (should (beginning-of-defun)) + (should (= (point) (point-min))) + (end-of-defun) + (should (= (point) (point-max))))) + +;; From bug#23565 +(ert-deftest tcl-mode-beginning-of-defun-2 () + (with-temp-buffer + (tcl-mode) + (insert "proc good {{value}} {\n # do something\n}") + (should (beginning-of-defun)) + (should (= (point) (point-min))) + (end-of-defun) + (should (= (point) (point-max))))) + +(ert-deftest tcl-mode-function-name () + (with-temp-buffer + (tcl-mode) + (insert "proc notinthis {} {\n # nothing\n}\n\n") + (should-not (add-log-current-defun)))) + +(ert-deftest tcl-mode-function-name () + (with-temp-buffer + (tcl-mode) + (insert "proc simple {} {\n # nothing\n}") + (backward-char 3) + (should (equal "simple" (add-log-current-defun))))) + +(ert-deftest tcl-mode-function-name () + (with-temp-buffer + (tcl-mode) + (insert "proc inthis {} {\n # nothing\n") + (should (equal "inthis" (add-log-current-defun))))) + +;; From bug#32035 +(ert-deftest tcl-mode-namespace-indent () + (with-temp-buffer + (tcl-mode) + (let ((text "namespace eval Foo {\n variable foo\n}\n")) + (insert text) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) text))))) + +(provide 'tcl-tests) + +;;; tcl-tests.el ends here diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el index c9966e237fa..c773c9b396f 100644 --- a/test/lisp/ses-tests.el +++ b/test/lisp/ses-tests.el @@ -38,7 +38,7 @@ interactively." (dolist (c '((0 0 1) (1 0 (1+ A1)))) (apply 'ses-cell-set-formula c) (apply 'ses-calculate-cell (list (car c) (cadr c) nil))) - (should (eq A2 2))))) + (should (eq (bound-and-true-p A2) 2))))) (ert-deftest ses-tests-plain-formula () "Check that setting A1 to 1 and A2 to (1+ A1), makes A2 value @@ -49,13 +49,16 @@ equal to 2. This is done using interactive calls." (dolist (c '((0 0 1) (1 0 (1+ A1)))) (apply 'funcall-interactively 'ses-edit-cell c)) (ses-command-hook) - (should (eq A2 2))))) + (should (eq (bound-and-true-p A2) 2))))) ;; PLAIN CELL RENAMING TESTS ;; ====================================================================== +(defvar ses--foo) +(defvar ses--cells) + (ert-deftest ses-tests-lowlevel-renamed-cell () - "Check that renaming A1 to `foo' and setting `foo' to 1 and A2 to (1+ foo), makes A2 value equal to 2. + "Check that renaming A1 to `ses--foo' and setting `ses--foo' to 1 and A2 to (1+ ses--foo), makes A2 value equal to 2. This is done using low level functions, `ses-rename-cell' is not called but instead we use text replacement in the buffer previously passed in text mode." @@ -69,63 +72,63 @@ previously passed in text mode." (text-mode) (goto-char (point-min)) (while (re-search-forward "\\<A1\\>" nil t) - (replace-match "foo" t t)) + (replace-match "ses--foo" t t)) (ses-mode) (should-not (local-variable-p 'A1)) - (should (eq foo 1)) - (should (equal (ses-cell-formula 1 0) '(ses-safe-formula (1+ foo)))) - (should (eq A2 2))))) + (should (eq ses--foo 1)) + (should (equal (ses-cell-formula 1 0) '(ses-safe-formula (1+ ses--foo)))) + (should (eq (bound-and-true-p A2) 2))))) (ert-deftest ses-tests-renamed-cell () - "Check that renaming A1 to `foo' and setting `foo' to 1 and A2 -to (1+ foo), makes A2 value equal to 2." + "Check that renaming A1 to `ses--foo' and setting `ses--foo' to 1 and A2 +to (1+ ses--foo), makes A2 value equal to 2." (let ((ses-initial-size '(2 . 1))) (with-temp-buffer (ses-mode) - (ses-rename-cell 'foo (ses-get-cell 0 0)) - (dolist (c '((0 0 1) (1 0 (1+ foo)))) + (ses-rename-cell 'ses--foo (ses-get-cell 0 0)) + (dolist (c '((0 0 1) (1 0 (1+ ses--foo)))) (apply 'funcall-interactively 'ses-edit-cell c)) (ses-command-hook) (should-not (local-variable-p 'A1)) - (should (eq foo 1)) - (should (equal (ses-cell-formula 1 0) '(1+ foo))) - (should (eq A2 2))))) + (should (eq ses--foo 1)) + (should (equal (ses-cell-formula 1 0) '(1+ ses--foo))) + (should (eq (bound-and-true-p A2) 2))))) (ert-deftest ses-tests-renamed-cell-after-setting () "Check that setting A1 to 1 and A2 to (1+ A1), and then -renaming A1 to `foo' makes `foo' value equal to 2." +renaming A1 to `ses--foo' makes `ses--foo' value equal to 2." (let ((ses-initial-size '(2 . 1))) (with-temp-buffer (ses-mode) (dolist (c '((0 0 1) (1 0 (1+ A1)))) (apply 'funcall-interactively 'ses-edit-cell c)) (ses-command-hook); deferred recalc - (ses-rename-cell 'foo (ses-get-cell 0 0)) + (ses-rename-cell 'ses--foo (ses-get-cell 0 0)) (should-not (local-variable-p 'A1)) - (should (eq foo 1)) - (should (equal (ses-cell-formula 1 0) '(1+ foo))) - (should (eq A2 2))))) + (should (eq ses--foo 1)) + (should (equal (ses-cell-formula 1 0) '(1+ ses--foo))) + (should (eq (bound-and-true-p A2) 2))))) (ert-deftest ses-tests-renaming-cell-with-one-symbol-formula () "Check that setting A1 to 1 and A2 to A1, and then renaming A1 -to `foo' makes `foo' value equal to 1. Then set A1 to 2 and check -that `foo' becomes 2." +to `ses--foo' makes `ses--foo' value equal to 1. Then set A1 to 2 and check +that `ses--foo' becomes 2." (let ((ses-initial-size '(3 . 1))) (with-temp-buffer (ses-mode) (dolist (c '((0 0 1) (1 0 A1))) (apply 'funcall-interactively 'ses-edit-cell c)) (ses-command-hook); deferred recalc - (ses-rename-cell 'foo (ses-get-cell 0 0)) + (ses-rename-cell 'ses--foo (ses-get-cell 0 0)) (ses-command-hook); deferred recalc (should-not (local-variable-p 'A1)) - (should (eq foo 1)) - (should (equal (ses-cell-formula 1 0) 'foo)) - (should (eq A2 1)) + (should (eq ses--foo 1)) + (should (equal (ses-cell-formula 1 0) 'ses--foo)) + (should (eq (bound-and-true-p A2) 1)) (funcall-interactively 'ses-edit-cell 0 0 2) (ses-command-hook); deferred recalc - (should (eq A2 2)) - (should (eq foo 2))))) + (should (eq (bound-and-true-p A2) 2)) + (should (eq ses--foo 2))))) ;; ROW INSERTION TESTS @@ -144,32 +147,31 @@ to A2 and inserting a row, makes A2 value empty, and A3 equal to (ses-jump 'A2) (ses-insert-row 1) (ses-command-hook) - (should-not A2) - (should (eq A3 2))))) + (should-not (bound-and-true-p A2)) + (should (eq (bound-and-true-p A3) 2))))) -; (defvar ses-tests-trigger nil) +(defvar ses--bar) (ert-deftest ses-tests-renamed-cells-row-insertion () - "Check that setting A1 to 1 and A2 to (1+ A1), and then renaming A1 to `foo' and A2 to `bar' jumping -to `bar' and inserting a row, makes A2 value empty, and `bar' equal to + "Check that setting A1 to 1 and A2 to (1+ A1), and then renaming A1 to `ses--foo' and A2 to `ses--bar' jumping +to `ses--bar' and inserting a row, makes A2 value empty, and `ses--bar' equal to 2." - (setq ses-tests-trigger nil) (let ((ses-initial-size '(2 . 1))) (with-temp-buffer (ses-mode) (dolist (c '((0 0 1) (1 0 (1+ A1)))) (apply 'funcall-interactively 'ses-edit-cell c)) (ses-command-hook) - (ses-rename-cell 'foo (ses-get-cell 0 0)) + (ses-rename-cell 'ses--foo (ses-get-cell 0 0)) (ses-command-hook) - (ses-rename-cell 'bar (ses-get-cell 1 0)) + (ses-rename-cell 'ses--bar (ses-get-cell 1 0)) (ses-command-hook) - (should (eq bar 2)) - (ses-jump 'bar) + (should (eq ses--bar 2)) + (ses-jump 'ses--bar) (ses-insert-row 1) (ses-command-hook) - (should-not A2) - (should (eq bar 2))))) + (should-not (bound-and-true-p A2)) + (should (eq ses--bar 2))))) (provide 'ses-tests) diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el index d13b8599c65..417aa648edf 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -448,6 +448,17 @@ See Bug#21722." (call-interactively #'eval-expression) (should (equal (current-message) "66 (#o102, #x42, ?B)")))))) +(ert-deftest command-execute-prune-command-history () + "Check that Bug#31211 is fixed." + (let ((history-length 1) + (command-history ())) + (dotimes (_ (1+ history-length)) + (command-execute "" t)) + (should (= (length command-history) history-length)))) + + +;;; `line-number-at-pos' + (ert-deftest line-number-at-pos-in-widen-buffer () (let ((target-line 3)) (with-temp-buffer @@ -489,13 +500,12 @@ See Bug#21722." (should (equal pos (point)))))) (ert-deftest line-number-at-pos-when-passing-point () - (let (pos) - (with-temp-buffer - (insert "a\nb\nc\nd\n") - (should (equal (line-number-at-pos 1) 1)) - (should (equal (line-number-at-pos 3) 2)) - (should (equal (line-number-at-pos 5) 3)) - (should (equal (line-number-at-pos 7) 4))))) + (with-temp-buffer + (insert "a\nb\nc\nd\n") + (should (equal (line-number-at-pos 1) 1)) + (should (equal (line-number-at-pos 3) 2)) + (should (equal (line-number-at-pos 5) 3)) + (should (equal (line-number-at-pos 7) 4)))) ;;; Auto fill. @@ -511,5 +521,53 @@ See Bug#21722." (do-auto-fill) (should (string-equal (buffer-string) "foo bar")))) + +;;; Shell command. + +(ert-deftest simple-tests-async-shell-command-30280 () + "Test for https://debbugs.gnu.org/30280 ." + (let* ((async-shell-command-buffer 'new-buffer) + (async-shell-command-display-buffer nil) + (base "name") + (first (buffer-name (generate-new-buffer base))) + (second (generate-new-buffer-name base)) + ;; `save-window-excursion' doesn't restore frame configurations. + (pop-up-frames nil) + (inhibit-message t) + (emacs (expand-file-name invocation-name invocation-directory))) + (skip-unless (file-executable-p emacs)) + ;; Let `shell-command' create the buffer as needed. + (kill-buffer first) + (unwind-protect + (save-window-excursion + ;; One command has no output, the other does. + ;; Removing the -eval argument also yields no output, but + ;; then both commands exit simultaneously when + ;; `accept-process-output' is called on the second command. + (dolist (form '("(sleep-for 8)" "(message \"\")")) + (async-shell-command (format "%s -Q -batch -eval '%s'" + emacs form) + first)) + ;; First command should neither have nor display output. + (let* ((buffer (get-buffer first)) + (process (get-buffer-process buffer))) + (should (buffer-live-p buffer)) + (should process) + (should (zerop (buffer-size buffer))) + (should (not (get-buffer-window buffer)))) + ;; Second command should both have and display output. + (let* ((buffer (get-buffer second)) + (process (get-buffer-process buffer))) + (should (buffer-live-p buffer)) + (should process) + (should (accept-process-output process 4 nil t)) + (should (> (buffer-size buffer) 0)) + (should (get-buffer-window buffer)))) + (dolist (name (list first second)) + (let* ((buffer (get-buffer name)) + (process (and buffer (get-buffer-process buffer)))) + (when process (delete-process process)) + (when buffer (kill-buffer buffer))))))) + (provide 'simple-test) ;;; simple-test.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 430d719037f..86938d5dbe0 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -26,7 +26,6 @@ ;; ;;; Code: - (require 'ert) (eval-when-compile (require 'cl-lib)) @@ -307,6 +306,43 @@ cf. Bug#25477." (should (eq (string-to-char (symbol-name (gensym))) ?g)) (should (eq (string-to-char (symbol-name (gensym "X"))) ?X))) +(ert-deftest subr-tests--proper-list-p () + "Test `proper-list-p' behavior." + (dotimes (length 4) + ;; Proper and dotted lists. + (let ((list (make-list length 0))) + (should (= (proper-list-p list) length)) + (should (not (proper-list-p (nconc list 0))))) + ;; Circular lists. + (dotimes (n (1+ length)) + (let ((circle (make-list (1+ length) 0))) + (should (not (proper-list-p (nconc circle (nthcdr n circle)))))))) + ;; Atoms. + (should (not (proper-list-p 0))) + (should (not (proper-list-p ""))) + (should (not (proper-list-p []))) + (should (not (proper-list-p (make-bool-vector 0 nil)))) + (should (not (proper-list-p (make-symbol "a"))))) + +(ert-deftest subr-tests--assq-delete-all () + "Test `assq-delete-all' behavior." + (cl-flet ((new-list-fn + () + (list (cons 'a 1) (cons 'b 2) (cons 'c 3) 'd (cons "foo" "bar")))) + (should (equal (cdr (new-list-fn)) (assq-delete-all 'a (new-list-fn)))) + (should (equal (new-list-fn) (assq-delete-all 'd (new-list-fn)))) + (should (equal (new-list-fn) (assq-delete-all "foo" (new-list-fn)))))) + +(ert-deftest subr-tests--assoc-delete-all () + "Test `assoc-delete-all' behavior." + (cl-flet ((new-list-fn + () + (list (cons 'a 1) (cons 'b 2) (cons 'c 3) 'd (cons "foo" "bar")))) + (should (equal (cdr (new-list-fn)) (assoc-delete-all 'a (new-list-fn)))) + (should (equal (new-list-fn) (assoc-delete-all 'd (new-list-fn)))) + (should (equal (butlast (new-list-fn)) + (assoc-delete-all "foo" (new-list-fn)))))) + (ert-deftest shell-quote-argument-%-on-w32 () "Quoting of `%' in w32 shells isn't perfect. See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." diff --git a/test/lisp/term-tests.el b/test/lisp/term-tests.el index 7fd8d1293dc..ebf48d50a84 100644 --- a/test/lisp/term-tests.el +++ b/test/lisp/term-tests.el @@ -89,6 +89,13 @@ first line\r_next line\r\n")) "\e[2;1Hc" "\e[1;2Hb" "\e[1;1Ha") "" t)))) + (should (equal "abcde j" + (term-test-screen-from-input + 10 12 '("abcdefghij" + "\e[H" ;move back to point-min + "abcde" + " j")))) + ;; Relative positioning. (should (equal "ab\ncd" (term-test-screen-from-input @@ -124,6 +131,18 @@ line6\r 40 12 (list "\eAnSiTc /f" "oo/\n") 'default-directory) "/foo/")))) +(ert-deftest term-line-wrapping-then-motion () + "Make sure we reset the line-wrapping state after moving cursor. +A real-life example is the default zsh prompt which writes spaces +to the end of line (triggering line-wrapping state), and then +sends a carriage return followed by another space to overwrite +the first character of the line." + (let* ((width 10) + (strs (list "x" (make-string (1- width) ?_) + "\r_"))) + (should (equal (term-test-screen-from-input width 12 strs) + (make-string width ?_))))) + (ert-deftest term-to-margin () "Test cursor movement at the scroll margin. This is a reduced example from GNU nano's initial screen." @@ -144,7 +163,6 @@ This is a reduced example from GNU nano's initial screen." `("\e[1;3r" "\e[2;1H" ,x "\r\e[1A" ,y)) (concat y "\n" x))))) - (provide 'term-tests) ;;; term-tests.el ends here diff --git a/test/lisp/textmodes/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el index d4fb348326a..bfae1bf2f75 100644 --- a/test/lisp/textmodes/css-mode-tests.el +++ b/test/lisp/textmodes/css-mode-tests.el @@ -85,7 +85,7 @@ (insert "body { top: 0; }") (goto-char 7) (should (equal (css-current-defun-name) "body")) - (goto-char 18) + (goto-char 15) (should (equal (css-current-defun-name) "body")))) (ert-deftest css-test-current-defun-name-nested () @@ -244,6 +244,99 @@ (should (member "body" completions)) (should-not (member "article" completions))))) +(ert-deftest css-test-color-to-4-dpc () + (should (equal (css--color-to-4-dpc "#ffffff") + (css--color-to-4-dpc "#fff"))) + (should (equal (css--color-to-4-dpc "#aabbcc") + (css--color-to-4-dpc "#abc"))) + (should (equal (css--color-to-4-dpc "#fab") + "#ffffaaaabbbb")) + (should (equal (css--color-to-4-dpc "#fafbfc") + "#fafafbfbfcfc"))) + +(ert-deftest css-test-format-hex () + (should (equal (css--format-hex "#fff") "#fff")) + (should (equal (css--format-hex "#ffffff") "#fff")) + (should (equal (css--format-hex "#aabbcc") "#abc")) + (should (equal (css--format-hex "#12ff34") "#12ff34")) + (should (equal (css--format-hex "#aabbccdd") "#abcd")) + (should (equal (css--format-hex "#aabbccde") "#aabbccde")) + (should (equal (css--format-hex "#abcdef") "#abcdef"))) + +(ert-deftest css-test-named-color-to-hex () + (dolist (item '(("black" "#000") + ("white" "#fff") + ("salmon" "#fa8072"))) + (with-temp-buffer + (css-mode) + (insert (nth 0 item)) + (css--named-color-to-hex) + (should (equal (buffer-string) (nth 1 item)))))) + +(ert-deftest css-test-format-rgba-alpha () + (should (equal (css--format-rgba-alpha 0) "0")) + (should (equal (css--format-rgba-alpha 0.0) "0")) + (should (equal (css--format-rgba-alpha 0.00001) "0")) + (should (equal (css--format-rgba-alpha 1) "1")) + (should (equal (css--format-rgba-alpha 1.0) "1")) + (should (equal (css--format-rgba-alpha 1.00001) "1")) + (should (equal (css--format-rgba-alpha 0.10000) "0.1")) + (should (equal (css--format-rgba-alpha 0.100001) "0.1")) + (should (equal (css--format-rgba-alpha 0.2524334) "0.25"))) + +(ert-deftest css-test-hex-to-rgb () + (dolist (item '(("#000" "rgb(0, 0, 0)") + ("#000000" "rgb(0, 0, 0)") + ("#fff" "rgb(255, 255, 255)") + ("#ffffff" "rgb(255, 255, 255)") + ("#ffffff80" "rgba(255, 255, 255, 0.5)") + ("#fff0" "rgba(255, 255, 255, 0)") + ("#fff8" "rgba(255, 255, 255, 0.53)") + ("#ffff" "rgba(255, 255, 255, 1)"))) + (with-temp-buffer + (css-mode) + (insert (nth 0 item)) + (css--hex-to-rgb) + (should (equal (buffer-string) (nth 1 item)))))) + +(ert-deftest css-test-rgb-to-named-color-or-hex () + (dolist (item '(("rgb(0, 0, 0)" "black") + ("rgb(255, 255, 255)" "white") + ("rgb(255, 255, 240)" "ivory") + ("rgb(18, 52, 86)" "#123456") + ("rgba(18, 52, 86, 0.5)" "#12345680") + ("rgba(18, 52, 86, 50%)" "#12345680") + ("rgba(50%, 50%, 50%, 50%)" "#80808080"))) + (with-temp-buffer + (css-mode) + (insert (nth 0 item)) + (css--rgb-to-named-color-or-hex) + (should (equal (buffer-string) (nth 1 item)))))) + +(ert-deftest css-test-cycle-color-format () + (with-temp-buffer + (css-mode) + (insert "black") + (css-cycle-color-format) + (should (equal (buffer-string) "#000")) + (css-cycle-color-format) + (should (equal (buffer-string) "rgb(0, 0, 0)")) + (css-cycle-color-format) + (should (equal (buffer-string) "black")))) + +(ert-deftest css-test-join-nested-selectors () + (should (equal (css--join-nested-selectors '("div" "&:hover")) + "div:hover")) + (should + (equal (css--join-nested-selectors '("a" "&::before, &::after")) + "a::before, a::after")) + (should + (equal (css--join-nested-selectors + '("article" "& > .front-page" "& h1, & h2")) + "article > .front-page h1, article > .front-page h2")) + (should (equal (css--join-nested-selectors '(".link" "& + &")) + ".link + .link"))) + (ert-deftest css-mdn-symbol-guessing () (dolist (item '(("@med" "ia" "@media") ("@keyframes " "{" "@keyframes") @@ -263,11 +356,11 @@ (ert-deftest css-test-rgb-parser () (with-temp-buffer (css-mode) - (dolist (input '("255, 0, 127" - "255, /* comment */ 0, 127" - "255 0 127" - "255, 0, 127, 0.75" - "255 0 127 / 0.75" + (dolist (input '("255, 0, 128" + "255, /* comment */ 0, 128" + "255 0 128" + "255, 0, 128, 0.75" + "255 0 128 / 0.75" "100%, 0%, 50%" "100%, 0%, 50%, 0.115" "100% 0% 50%" @@ -275,7 +368,7 @@ (erase-buffer) (save-excursion (insert input ")")) - (should (equal (css--rgb-color) "#ff007f"))))) + (should (equal (css--rgb-color) "#ff0080"))))) (ert-deftest css-test-hsl-parser () (with-temp-buffer @@ -301,6 +394,12 @@ (should (equal (css--hex-color "#aabbcc") "#aabbcc")) (should (equal (css--hex-color "#aabbccdd") "#aabbcc"))) +(ert-deftest css-test-hex-alpha () + (should (equal (css--hex-alpha "#abcd") "d")) + (should-not (css--hex-alpha "#abc")) + (should (equal (css--hex-alpha "#aabbccdd") "dd")) + (should-not (css--hex-alpha "#aabbcc"))) + (ert-deftest css-test-named-color () (dolist (text '("@mixin black" "@include black")) (with-temp-buffer diff --git a/test/lisp/textmodes/fill-tests.el b/test/lisp/textmodes/fill-tests.el new file mode 100644 index 00000000000..a2bcde44b99 --- /dev/null +++ b/test/lisp/textmodes/fill-tests.el @@ -0,0 +1,50 @@ +;;; fill-test.el --- ERT tests for fill.el -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. + +;; Author: Marcin Borkowski <mbork@mbork.pl> +;; Keywords: text, wp + +;; 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/>. + +;;; Commentary: + +;; This package defines tests for the filling feature, specifically +;; the `fill-polish-nobreak-p' function. + +;;; Code: + +(require 'ert) + +(ert-deftest fill-test-no-fill-polish-nobreak-p nil + "Tests of the `fill-polish-nobreak-p' function." + (with-temp-buffer + (insert "Abc d efg (h ijk).") + (setq fill-column 8) + (setq-local fill-nobreak-predicate '()) + (fill-paragraph) + (should (string= (buffer-string) "Abc d\nefg (h\nijk)."))) + (with-temp-buffer + (insert "Abc d efg (h ijk).") + (setq fill-column 8) + (setq-local fill-nobreak-predicate '(fill-polish-nobreak-p)) + (fill-paragraph) + (should (string= (buffer-string) "Abc\nd efg\n(h ijk).")))) + + +(provide 'fill-tests) + +;;; fill-tests.el ends here diff --git a/test/lisp/textmodes/sgml-mode-tests.el b/test/lisp/textmodes/sgml-mode-tests.el index 7ca6e676c64..6c0070ccb1e 100644 --- a/test/lisp/textmodes/sgml-mode-tests.el +++ b/test/lisp/textmodes/sgml-mode-tests.el @@ -131,5 +131,35 @@ The point is set to the beginning of the buffer." (sgml-delete-tag 1) (should (string= "Winter is comin'" (buffer-string))))) +(ert-deftest sgml-quote-works () + (let ((text "Foo<Bar> \"Baz\" 'Qux'\n")) + (with-temp-buffer + ;; Back and forth transformation. + (insert text) + (sgml-quote (point-min) (point-max)) + (should (string= "Foo<Bar> "Baz" 'Qux'\n" + (buffer-string))) + (sgml-quote (point-min) (point-max) t) + (should (string= text (buffer-string))) + + ;; The same text escaped differently. + (erase-buffer) + (insert "Foo<Bar> "Baz" 'Qux'\n") + (sgml-quote (point-min) (point-max) t) + (should (string= text (buffer-string))) + + ;; Lack of semicolon. + (erase-buffer) + (insert "&&") + (sgml-quote (point-min) (point-max) t) + (should (string= "&&" (buffer-string))) + + ;; Double quoting + (sgml-quote (point-min) (point-max)) + (sgml-quote (point-min) (point-max)) + (sgml-quote (point-min) (point-max) t) + (sgml-quote (point-min) (point-max) t) + (should (string= "&&" (buffer-string)))))) + (provide 'sgml-mode-tests) ;;; sgml-mode-tests.el ends here diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index 1d80519fe74..aa29924ac1a 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -65,7 +65,10 @@ ("http://example.com/ab)c" 4 url "http://example.com/ab)c") ;; URL markup, lacking schema ("<url:foo@example.com>" 1 url "mailto:foo@example.com") - ("<url:ftp.example.net/abc/>" 1 url "ftp://ftp.example.net/abc/")) + ("<url:ftp.example.net/abc/>" 1 url "ftp://ftp.example.net/abc/") + ;; UUID, only hex is allowed + ("01234567-89ab-cdef-ABCD-EF0123456789" 1 uuid "01234567-89ab-cdef-ABCD-EF0123456789") + ("01234567-89ab-cdef-ABCD-EF012345678G" 1 uuid nil)) "List of thing-at-point tests. Each list element should have the form diff --git a/test/lisp/thread-tests.el b/test/lisp/thread-tests.el new file mode 100644 index 00000000000..0d57d38779f --- /dev/null +++ b/test/lisp/thread-tests.el @@ -0,0 +1,96 @@ +;;; thread-tests.el --- Test suite for thread.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Gemini Lasswell <gazally@runbox.com> +;; Keywords: threads + +;; 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/>. + +;;; Commentary: + + +;;; Code: + +(require 'ert) +(require 'thread) + +;; Declare the functions used here in case Emacs has been configured +;; --without-threads. +(declare-function make-mutex "thread.c" (&optional name)) +(declare-function mutex-lock "thread.c" (mutex)) +(declare-function mutex-unlock "thread.c" (mutex)) +(declare-function make-thread "thread.c" (function &optional name)) +(declare-function thread-join "thread.c" (thread)) +(declare-function thread-yield "thread.c" ()) + +(defvar thread-tests-flag) +(defvar thread-tests-mutex (when (featurep 'threads) (make-mutex "mutex1"))) + +(defun thread-tests--thread-function () + (setq thread-tests-flag t) + (with-mutex thread-tests-mutex + (sleep-for 0.01))) + +(ert-deftest thread-tests-thread-list-send-error () + "A thread can be sent an error signal from the *Thread List* buffer." + (skip-unless (featurep 'threads)) + (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t))) + (with-mutex thread-tests-mutex + (setq thread-tests-flag nil) + (let ((thread (make-thread #'thread-tests--thread-function + "thread-tests-wait"))) + (while (not thread-tests-flag) + (thread-yield)) + (list-threads) + (goto-char (point-min)) + (re-search-forward + "^thread-tests.+[[:blank:]]+Blocked[[:blank:]]+.+mutex1.+?") + (thread-list-send-error-signal) + (should-error (thread-join thread)) + (list-threads) + (goto-char (point-min)) + (should-error (re-search-forward "thread-tests")))))) + +(ert-deftest thread-tests-thread-list-show-backtrace () + "Show a backtrace for another thread from the *Thread List* buffer." + (skip-unless (featurep 'threads)) + (let (thread) + (with-mutex thread-tests-mutex + (setq thread-tests-flag nil) + (setq thread + (make-thread #'thread-tests--thread-function "thread-tests-back")) + (while (not thread-tests-flag) + (thread-yield)) + (list-threads) + (goto-char (point-min)) + (re-search-forward + "^thread-tests.+[[:blank:]]+Blocked[[:blank:]]+.+mutex1.+?") + (thread-list-pop-to-backtrace) + (goto-char (point-min)) + (re-search-forward "thread-tests-back") + (re-search-forward "mutex-lock") + (re-search-forward "thread-tests--thread-function")) + (thread-join thread))) + +(ert-deftest thread-tests-list-threads-error-when-not-configured () + "Signal an error running `list-threads' if threads are not configured." + (skip-unless (not (featurep 'threads))) + (should-error (list-threads))) + +(provide 'thread-tests) + +;;; thread-tests.el ends here diff --git a/test/lisp/url/url-handlers-test.el b/test/lisp/url/url-handlers-test.el new file mode 100644 index 00000000000..5822e16a88a --- /dev/null +++ b/test/lisp/url/url-handlers-test.el @@ -0,0 +1,75 @@ +;;; url-handlers-test.el --- Test suite for url-handlers.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Nicolas Petton <nicolas@petton.fr> + +;; 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: + +;;; Code: + +(require 'ert) +(require 'url-handlers) + +(defmacro with-url-handler-mode (&rest body) + "Evaluate BODY with `url-handler-mode' turned on." + (declare (indent 0) (debug t)) + (let ((url-handler-mode-active (make-symbol "url-handler-mode-active"))) + `(let ((,url-handler-mode-active url-handler-mode)) + (unwind-protect + (progn + (unless ,url-handler-mode-active + (url-handler-mode)) + ,@body) + (unless ,url-handler-mode-active + (url-handler-mode -1)))))) + +(ert-deftest url-handlers-file-name-directory/preserve-url-types () + (with-url-handler-mode + (should (equal (file-name-directory "https://gnu.org/index.html") + "https://gnu.org/")) + (should (equal (file-name-directory "http://gnu.org/index.html") + "http://gnu.org/")) + (should (equal (file-name-directory "ftp://gnu.org/index.html") + "ftp://gnu.org/")))) + +(ert-deftest url-handlers-file-name-directory/should-not-handle-non-url-file-names () + (with-url-handler-mode + (should-not (equal (file-name-directory "not-uri://gnu.org") + "not-uri://gnu.org/")))) + +(ert-deftest url-handlers-file-name-directory/sub-directories () + (with-url-handler-mode + (should (equal (file-name-directory "https://foo/bar/baz/index.html") + "https://foo/bar/baz/")))) + +(ert-deftest url-handlers-file-name-directory/file-urls () + (with-url-handler-mode + (should (equal (file-name-directory "file:///foo/bar/baz.txt") + "file:///foo/bar/")) + (should (equal (file-name-directory "file:///") + "file:///")))) + +;; Regression test for bug#30444 +(ert-deftest url-handlers-file-name-directory/no-filename () + (with-url-handler-mode + (should (equal (file-name-directory "https://foo.org") + "https://foo.org/")) + (should (equal (file-name-directory "https://foo.org/") + "https://foo.org/")))) + +(provide 'url-handlers-test) +;;; url-handlers-test.el ends here diff --git a/test/lisp/url/url-util-tests.el b/test/lisp/url/url-util-tests.el index ee97d97dd34..2e2875a196b 100644 --- a/test/lisp/url/url-util-tests.el +++ b/test/lisp/url/url-util-tests.el @@ -46,6 +46,18 @@ ("key2" "val2") ("key1" "val1"))))) +(ert-deftest url-domain-tests () + (should (equal (url-domain (url-generic-parse-url "http://www.fsf.co.uk")) + "fsf.co.uk")) + (should (equal (url-domain (url-generic-parse-url "http://fsf.co.uk")) + "fsf.co.uk")) + (should (equal (url-domain (url-generic-parse-url "http://co.uk")) + nil)) + (should (equal (url-domain (url-generic-parse-url "http://www.fsf.com")) + "fsf.com")) + (should (equal (url-domain (url-generic-parse-url "http://192.168.0.1")) + nil))) + (provide 'url-util-tests) ;;; url-util-tests.el ends here diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el index 1e35f9f7cd3..7900e41b257 100644 --- a/test/lisp/vc/diff-mode-tests.el +++ b/test/lisp/vc/diff-mode-tests.el @@ -182,7 +182,7 @@ youthfulness (with-temp-buffer (cd temp-dir) (insert patch) - (beginning-of-buffer) + (goto-char (point-min)) (diff-apply-hunk) (diff-apply-hunk) (diff-apply-hunk)) diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 7fdf0626cd7..cd774d301df 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -109,7 +109,7 @@ (require 'ert) (require 'vc) -(declare-function w32-application-type "w32proc") +(declare-function w32-application-type "w32proc.c") ;; The working horses. diff --git a/test/lisp/xdg-tests.el b/test/lisp/xdg-tests.el index 40f5802854d..ad5e4a48a26 100644 --- a/test/lisp/xdg-tests.el +++ b/test/lisp/xdg-tests.el @@ -65,4 +65,16 @@ (should (equal (xdg-desktop-strings " ") nil)) (should (equal (xdg-desktop-strings "a; ;") '("a" " ")))) +(ert-deftest xdg-mime-associations () + "Test reading MIME associations from files." + (let* ((apps (expand-file-name "mimeapps.list" xdg-tests-data-dir)) + (cache (expand-file-name "mimeinfo.cache" xdg-tests-data-dir)) + (fs (list apps cache))) + (should (equal (xdg-mime-collect-associations "x-test/foo" fs) + '("a.desktop" "b.desktop"))) + (should (equal (xdg-mime-collect-associations "x-test/bar" fs) + '("a.desktop" "c.desktop"))) + (should (equal (xdg-mime-collect-associations "x-test/baz" fs) + '("a.desktop" "b.desktop" "d.desktop"))))) + ;;; xdg-tests.el ends here |