diff options
Diffstat (limited to 'test')
20 files changed, 707 insertions, 40 deletions
diff --git a/test/data/xdg/mimeapps.list b/test/data/xdg/mimeapps.list new file mode 100644 index 00000000000..27fbd94b16b --- /dev/null +++ b/test/data/xdg/mimeapps.list @@ -0,0 +1,9 @@ +[Default Applications] +x-test/foo=a.desktop + +[Added Associations] +x-test/foo=b.desktop +x-test/baz=a.desktop + +[Removed Associations] +x-test/foo=c.desktop;d.desktop diff --git a/test/data/xdg/mimeinfo.cache b/test/data/xdg/mimeinfo.cache new file mode 100644 index 00000000000..6e54f604fa0 --- /dev/null +++ b/test/data/xdg/mimeinfo.cache @@ -0,0 +1,4 @@ +[MIME Cache] +x-test/foo=c.desktop;d.desktop +x-test/bar=a.desktop;c.desktop +x-test/baz=b.desktop;d.desktop diff --git a/test/lisp/auth-source-pass-tests.el b/test/lisp/auth-source-pass-tests.el index 9b6b5687cab..84423b7d06d 100644 --- a/test/lisp/auth-source-pass-tests.el +++ b/test/lisp/auth-source-pass-tests.el @@ -128,6 +128,11 @@ This function is intended to be set to `auth-source-debug`." (should (equal (auth-source-pass--find-match "foo.bar.com" 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) + "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") diff --git a/test/lisp/char-fold-tests.el b/test/lisp/char-fold-tests.el index 83d6fa79b1e..a16f2879809 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/dired-aux-tests.el b/test/lisp/dired-aux-tests.el index d41feb1592f..9316217dd2a 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,59 @@ (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))))) + + (provide 'dired-aux-tests) ;; dired-aux-tests.el ends here diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index fc69919fbe1..7df2449b9eb 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -617,6 +617,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 +644,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 +665,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 +686,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 +707,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 +728,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-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) + ;; 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/faceup-resources/faceup-test-mode.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el new file mode 100644 index 00000000000..ec2cf272368 --- /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-2017 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..e9d8b7074c2 --- /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-2017 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..6009bfa836d --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el @@ -0,0 +1,287 @@ +;;; faceup-test-basics.el --- Tests for the `faceup' package. + +;; Copyright (C) 2014-2017 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: + +(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 () + "Test basic `faceup' features." + ;; ---------- + ;; Basics + (should (equal (faceup-markup-string "") "")) + (should (equal (faceup-markup-string "test") "test")) + ;; ---------- + ;; 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«»")) + ;; ---------- + ;; Plain property. + ;; + ;; UU + ;; ABCDEF + (let ((s "ABCDEF")) + (set-text-properties 2 4 '(face underline) s) + (should (equal (faceup-markup-string s) "AB«U:CD»EF"))) + ;; ---------- + ;; Plain property, full text + ;; + ;; UUUUUU + ;; ABCDEF + (let ((s "ABCDEF")) + (set-text-properties 0 6 '(face underline) s) + (should (equal (faceup-markup-string s) "«U:ABCDEF»"))) + ;; ---------- + ;; Anonymous face. + ;; + ;; AA + ;; ABCDEF + (let ((s "ABCDEF")) + (set-text-properties 2 4 '(face (:underline t)) s) + (should (equal (faceup-markup-string s) "AB«:(:underline t):CD»EF"))) + ;; ---------- + ;; Anonymous face -- plist with two keys. + ;; + ;; AA + ;; ABCDEF + (let ((s "ABCDEF")) + (set-text-properties 2 4 '(face (:foo t :bar nil)) s) + (should (equal (faceup-markup-string s) + "AB«:(:foo t):«:(:bar nil):CD»»EF"))) + ;; Ditto, with plist in list. + (let ((s "ABCDEF")) + (set-text-properties 2 4 '(face ((:foo t :bar nil))) s) + (should (equal (faceup-markup-string s) + "AB«:(:foo t):«:(:bar nil):CD»»EF"))) + ;; ---------- + ;; Anonymous face -- Two plists. + ;; + ;; AA + ;; ABCDEF + (let ((s "ABCDEF")) + (set-text-properties 2 4 '(face ((:foo t) (:bar nil))) s) + (should (equal (faceup-markup-string s) + "AB«:(:bar nil):«:(:foo t):CD»»EF"))) + ;; ---------- + ;; Anonymous face -- Nested. + ;; + ;; AA + ;; IIII + ;; ABCDEF + (let ((s "ABCDEF")) + (set-text-properties 1 2 '(face ((:foo t))) s) + (set-text-properties 2 4 '(face ((:bar t) (:foo t))) s) + (set-text-properties 4 5 '(face ((:foo t))) s) + (should (equal (faceup-markup-string s) + "A«:(:foo t):B«:(:bar t):CD»E»F"))) + ;; ---------- + ;; Nested properties. + ;; + ;; UU + ;; IIII + ;; ABCDEF + (let ((s "ABCDEF")) + (set-text-properties 1 2 '(face italic) s) + (set-text-properties 2 4 '(face (underline italic)) s) + (set-text-properties 4 5 '(face italic) s) + (should (equal (faceup-markup-string s) "A«I:B«U:CD»E»F"))) + ;; ---------- + ;; Overlapping, but not nesting, properties. + ;; + ;; UUU + ;; III + ;; ABCDEF + (let ((s "ABCDEF")) + (set-text-properties 1 2 '(face italic) s) + (set-text-properties 2 4 '(face (underline italic)) s) + (set-text-properties 4 5 '(face underline) s) + (should (equal (faceup-markup-string s) "A«I:B«U:CD»»«U:E»F"))) + ;; ---------- + ;; Overlapping, but not nesting, properties. + ;; + ;; III + ;; UUU + ;; ABCDEF + (let ((s "ABCDEF")) + (set-text-properties 1 2 '(face italic) s) + (set-text-properties 2 4 '(face (italic underline)) s) + (set-text-properties 4 5 '(face underline) s) + (should (equal (faceup-markup-string s) "A«I:B»«U:«I:CD»E»F"))) + ;; ---------- + ;; More than one face at the same location. + ;; + ;; The property to the front takes precedence, it is rendered as the + ;; innermost parenthesis pair. + (let ((s "ABCDEF")) + (set-text-properties 2 4 '(face (underline italic)) s) + (should (equal (faceup-markup-string s) "AB«I:«U:CD»»EF"))) + (let ((s "ABCDEF")) + (set-text-properties 2 4 '(face (italic underline)) s) + (should (equal (faceup-markup-string s) "AB«U:«I:CD»»EF"))) + ;; ---------- + ;; Equal ranges, full text. + (let ((s "ABCDEF")) + (set-text-properties 0 6 '(face (underline italic)) s) + (should (equal (faceup-markup-string s) "«I:«U:ABCDEF»»"))) + ;; Ditto, with stray markup characters. + (let ((s "AB«CD»EF")) + (set-text-properties 0 8 '(face (underline italic)) s) + (should (equal (faceup-markup-string s) "«I:«U:AB««CD«»EF»»"))) + + ;; ---------- + ;; Multiple properties + (let ((faceup-properties '(alpha beta gamma))) + ;; One property. + (let ((s "ABCDEF")) + (set-text-properties 2 4 '(alpha (a l p h a)) s) + (should (equal (faceup-markup-string s) "AB«(alpha):(a l p h a):CD»EF"))) + + ;; Two properties, inner enclosed. + (let ((s "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) + (should (equal (faceup-markup-string s) + "AB«(alpha):(a l p h a):CD«(beta):(b e t a):EF»GH»IJ"))) + + ;; Two properties, same end + (let ((s "ABCDEFGH")) + (set-text-properties 2 6 '(alpha (a)) s) + (add-text-properties 4 6 '(beta (b)) s) + (should + (equal + (faceup-markup-string s) + "AB«(alpha):(a):CD«(beta):(b):EF»»GH"))) + + ;; Two properties, overlap. + (let ((s "ABCDEFGHIJ")) + (set-text-properties 2 6 '(alpha (a)) s) + (add-text-properties 4 8 '(beta (b)) s) + (should + (equal + (faceup-markup-string 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..0f136862094 --- /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-2017 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/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el index edb539f4c27..6a9612db05a 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%%%)%%%) @@ -230,7 +227,6 @@ ;; ==== quotes-within-backquotes-bug-25316 ==== "Forms to instrument are found within quotes within backquotes." -:expected-result :failed ;; ==== (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)) @@ -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 instruments 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 ;; ==== (defun testcover-testcase-vec (a b c) `[,a%%% ,(list b%%% c%%%)%%%]%%%) @@ -415,7 +413,6 @@ ;; ==== vector-in-macro-spec-bug-25316 ==== "Testcover reinstruments within vectors." -:expected-result :failed ;; ==== (defmacro testcover-testcase-nth-case (arg vec) (declare (indent 1) @@ -435,7 +432,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 +446,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 +458,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)%%%) @@ -494,10 +490,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 0f0ee9a5095..2e03488b306 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/help-fns-tests.el b/test/lisp/help-fns-tests.el index 98e6b335b90..6dc5299ef3c 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/xdg-tests.el b/test/lisp/xdg-tests.el index b80f5e85524..eaf03ab9a03 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 diff --git a/test/manual/cedet/semantic-ia-utest.el b/test/manual/cedet/semantic-ia-utest.el index 7861fd73949..53cff05adc4 100644 --- a/test/manual/cedet/semantic-ia-utest.el +++ b/test/manual/cedet/semantic-ia-utest.el @@ -434,7 +434,7 @@ tag that contains point, and return that." (when (interactive-p) (message "Found %d occurrences of %s in %.2f seconds" Lcount (semantic-tag-name target) - (semantic-elapsed-time start (current-time)))) + (semantic-elapsed-time start nil))) Lcount))) (defun semantic-src-utest-buffer-refs () diff --git a/test/manual/cedet/semantic-tests.el b/test/manual/cedet/semantic-tests.el index 3a19328ac79..0495170058a 100644 --- a/test/manual/cedet/semantic-tests.el +++ b/test/manual/cedet/semantic-tests.el @@ -178,9 +178,8 @@ Optional argument ARG specifies not to use color." "Test `semantic-idle-scheduler-work-parse-neighboring-files' and time it." (interactive) (let ((start (current-time)) - (junk (semantic-idle-scheduler-work-parse-neighboring-files)) - (end (current-time))) - (message "Work took %.2f seconds." (semantic-elapsed-time start end)))) + (junk (semantic-idle-scheduler-work-parse-neighboring-files))) + (message "Work took %.2f seconds." (semantic-elapsed-time start nil)))) ;;; From semantic-lex: @@ -195,10 +194,9 @@ If universal argument ARG, then try the whole buffer." (result (semantic-lex (if arg (point-min) (point)) (point-max) - 100)) - (end (current-time))) + 100))) (message "Elapsed Time: %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (pop-to-buffer "*Lexer Output*") (require 'pp) (erase-buffer) @@ -278,7 +276,7 @@ tag that contains point, and return that." (when (interactive-p) (message "Found %d occurrences of %s in %.2f seconds" Lcount (semantic-tag-name target) - (semantic-elapsed-time start (current-time)))) + (semantic-elapsed-time start nil))) Lcount))) ;;; From bovine-gcc: diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 8de8c145d40..374d1689b9e 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -107,6 +107,21 @@ (should (isnan (min 1.0 0.0e+NaN))) (should (isnan (min 1.0 0.0e+NaN 1.1)))) +(defun data-tests-popcnt (byte) + "Calculate the Hamming weight of BYTE." + (if (< byte 0) + (setq byte (lognot byte))) + (setq byte (- byte (logand (lsh byte -1) #x55555555))) + (setq byte (+ (logand byte #x33333333) (logand (lsh byte -2) #x33333333))) + (lsh (* (logand (+ byte (lsh byte -4)) #x0f0f0f0f) #x01010101) -24)) + +(ert-deftest data-tests-logcount () + (should (cl-loop for n in (number-sequence -255 255) + always (= (logcount n) (data-tests-popcnt n)))) + ;; https://oeis.org/A000120 + (should (= 11 (logcount 9727))) + (should (= 8 (logcount 9999)))) + ;; Bool vector tests. Compactly represent bool vectors as hex ;; strings. diff --git a/test/src/keyboard-tests.el b/test/src/keyboard-tests.el new file mode 100644 index 00000000000..301cef0092c --- /dev/null +++ b/test/src/keyboard-tests.el @@ -0,0 +1,36 @@ +;;; keyboard-tests.el --- Tests for keyboard.c -*- lexical-binding: t -*- + +;; Copyright (C) 2017 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) + +(ert-deftest keyboard-unread-command-events () + "Test `unread-command-events'." + (should (equal (progn (push ?\C-a unread-command-events) + (read-event nil nil 1)) + ?\C-a)) + (should (equal (progn (run-with-timer + 1 nil + (lambda () (push '(t . ?\C-b) unread-command-events))) + (read-event nil nil 2)) + ?\C-b))) + +(provide 'keyboard-tests) +;;; keyboard-tests.el ends here |