diff options
Diffstat (limited to 'test/lisp/progmodes/cperl-mode-tests.el')
| -rw-r--r-- | test/lisp/progmodes/cperl-mode-tests.el | 321 |
1 files changed, 313 insertions, 8 deletions
diff --git a/test/lisp/progmodes/cperl-mode-tests.el b/test/lisp/progmodes/cperl-mode-tests.el index 9611de0a918..9d9718f719c 100644 --- a/test/lisp/progmodes/cperl-mode-tests.el +++ b/test/lisp/progmodes/cperl-mode-tests.el @@ -25,6 +25,10 @@ ;;; Commentary: ;; This is a collection of tests for CPerl-mode. +;; The maintainer would like to use this test file with cperl-mode.el +;; also in older Emacs versions (currently: Emacs 26.1): Please don't +;; use Emacs features which are not available in that version (unless +;; they're already used in existing tests). ;;; Code: @@ -107,9 +111,8 @@ end of the statement." (skip-unless (eq cperl-test-mode #'cperl-mode)) (cperl--run-test-cases (ert-resource-file "cperl-indent-styles.pl") - (cperl-set-style "PBP") - (indent-region (point-min) (point-max)) ; here we go! - (cperl-set-style-back))) + (cperl-file-style "PBP") + (indent-region (point-min) (point-max)))) ; here we go! ;;; Fontification tests @@ -177,14 +180,19 @@ attributes, prototypes and signatures." (should (equal (get-text-property (1+ (match-beginning 0)) 'face) 'font-lock-string-face))) (goto-char start-of-sub) + ;; Attributes with their optional parameters (when (search-forward-regexp "\\(:[a-z]+\\)\\((.*?)\\)?" end-of-sub t) (should (equal (get-text-property (match-beginning 1) 'face) 'font-lock-constant-face)) (when (match-beginning 2) (should (equal (get-text-property (match-beginning 2) 'face) 'font-lock-string-face)))) + ;; Subroutine signatures + (goto-char start-of-sub) + (when (search-forward "$bar" end-of-sub t) + (should (equal (get-text-property (match-beginning 0) 'face) + 'font-lock-variable-name-face))) (goto-char end-of-sub))) - ;; Anonymous subroutines (while (search-forward-regexp "= sub" nil t) (let ((start-of-sub (match-beginning 0)) @@ -201,8 +209,40 @@ attributes, prototypes and signatures." (when (match-beginning 2) (should (equal (get-text-property (match-beginning 2) 'face) 'font-lock-string-face)))) + ;; Subroutine signatures + (goto-char start-of-sub) + (when (search-forward "$bar" end-of-sub t) + (should (equal (get-text-property (match-beginning 0) 'face) + 'font-lock-variable-name-face))) (goto-char end-of-sub)))))) +(ert-deftest cperl-test-fontify-class () + "Test fontification of the various elements in a Perl class." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((file (ert-resource-file "perl-class.pl"))) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (funcall cperl-test-mode) + (font-lock-ensure) + + ;; The class name + (while (search-forward-regexp "class " nil t) + (should (equal (get-text-property (point) 'face) + 'font-lock-function-name-face))) + ;; The attributes (class and method) + (while (search-forward-regexp " : " nil t) + (should (equal (get-text-property (point) 'face) + 'font-lock-constant-face))) + ;; The signature + (goto-char (point-min)) + (search-forward-regexp "\\(\\$top\\),\\(\\$down\\)") + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-variable-name-face)) + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-variable-name-face)) +))) + (ert-deftest cperl-test-fontify-special-variables () "Test fontification of variables like $^T or ${^ENCODING}. These can occur as \"local\" aliases." @@ -219,6 +259,39 @@ These can occur as \"local\" aliases." (should (equal (get-text-property (point) 'face) 'font-lock-variable-name-face)))) +(ert-deftest cperl-test-fontify-sub-names () + "Test fontification of subroutines named like builtins. +On declaration, they should look like other used defined +functions. When called, they should not be fontified. In +comments and POD they should be fontified as POD." + (let ((file (ert-resource-file "sub-names.pl"))) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (funcall cperl-test-mode) + (font-lock-ensure) + ;; The declaration + (search-forward-regexp "sub \\(m\\)") + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-function-name-face)) + ;; calling as a method + (search-forward-regexp "C->new->\\(m\\)") + (should (equal (get-text-property (match-beginning 1) 'face) + (if (equal cperl-test-mode 'perl-mode) nil + 'cperl-method-call))) + ;; POD + (search-forward-regexp "\\(method\\) \\(name\\)") + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-comment-face)) + (should (equal (get-text-property (match-beginning 2) 'face) + 'font-lock-comment-face)) + ;; comment + (search-forward-regexp "\\(method\\) \\(name\\)") + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-comment-face)) + (should (equal (get-text-property (match-beginning 2) 'face) + 'font-lock-comment-face))))) + (ert-deftest cperl-test-identify-heredoc () "Test whether a construct containing \"<<\" followed by a bareword is properly identified for a here-document if @@ -306,6 +379,7 @@ issued by CPerl mode." (defvar perl-continued-statement-offset) (defvar perl-indent-level) +(defvar perl-indent-parens-as-block) (defconst cperl--tests-heredoc-face (if (equal cperl-test-mode 'perl-mode) 'perl-heredoc @@ -397,7 +471,7 @@ the whole string." valid invalid))) (ert-deftest cperl-test-package-regexp () - "Tests the regular expression of Perl package names with versions. + "Tests the regular expression of Perl package and class names with versions. Also includes valid cases with whitespace in strange places." (skip-unless (eq cperl-test-mode #'cperl-mode)) (let ((valid @@ -405,13 +479,13 @@ Also includes valid cases with whitespace in strange places." "package Foo::Bar" "package Foo::Bar v1.2.3" "package Foo::Bar::Baz 1.1" + "class O3D::Sphere" ; since Perl 5.38 "package \nFoo::Bar\n 1.00")) (invalid '("package Foo;" ; semicolon must not be included "package Foo 1.1 {" ; nor the opening brace "packageFoo" ; not a package declaration - "package Foo1.1" ; invalid package name - "class O3D::Sphere"))) ; class not yet supported + "package Foo1.1"))) ; invalid package name (cperl-test--validate-regexp (rx (eval cperl--package-rx)) valid invalid))) @@ -428,6 +502,66 @@ Also includes valid cases with whitespace in strange places." (cperl-test--validate-regexp (rx (eval cperl--basic-identifier-rx)) valid invalid))) +(ert-deftest cperl-test-attribute-rx () + "Test attributes and attribute lists" + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((valid + '("foo" "bar()" "baz(quux)")) + (invalid + '("+foo" ; not an identifier + "foo::bar" ; no package qualifiers allowed + "(no-identifier)" ; no attribute name + "baz (quux)"))) ; no space allowed before "(" + (cperl-test--validate-regexp (rx (eval cperl--single-attribute-rx)) + valid invalid))) + +(ert-deftest cperl-test-attribute-list-rx () + "Test attributes and attribute lists" + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((valid + '(":" ":foo" ": bar()" ":baz(quux):" + ":_" ":_foo" + ":isa(Foo) does(Bar)" ":isa(Foo):does(Bar)" + ":isa(Foo):does(Bar):" + ": isa(Foo::Bar) : does(Bar)")) + (invalid + '(":foo + bar" ; not an identifier + "::foo" ; not an attribute list + ": foo(bar : : baz" ; too many colons + ": foo(bar)baz" ; need a separator + ": baz (quux)"))) ; no space allowed before "(" + (cperl-test--validate-regexp (rx (eval cperl--attribute-list-rx)) + valid invalid))) + +(ert-deftest cperl-test-prototype-rx () + "Test subroutine prototypes" + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((valid + ;; Examples from perldoc perlsub + '("($$)" "($$$)" "($$;$)" "($$$;$)" "(@)" "($@)" "(\\@)" "(\\@$$@)" + "(\\[%@])" "(*;$)" "(**)" "(&@)" "(;$)" "()")) + (invalid + '("$" ; missing paren + "($self)" ; a variable, -> subroutine signature + "(!$)" ; not all punctuation is permitted + "{$$}"))) ; wrong type of paren + (cperl-test--validate-regexp (rx (eval cperl--prototype-rx)) + valid invalid))) + +(ert-deftest cperl-test-signature-rx () + "Test subroutine signatures." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((valid + '("()" "( )" "($self, %params)" "(@params)")) + (invalid + '("$self" ; missing paren + "($)" ; a subroutine signature + "($!)" ; globals not permitted in a signature + "(@par,%options)" ; two slurpy parameters + "{$self}"))) ; wrong type of paren + (cperl-test--validate-regexp (rx (eval cperl--signature-rx)) + valid invalid))) + ;;; Test unicode identifier in various places (defun cperl--test-unicode-setup (code string) @@ -717,7 +851,9 @@ created by CPerl mode, so skip it for Perl mode." "lexical" "Versioned::Block::signatured" "Package::in_package_again" - "Erdős::Number::erdős_number"))) + "Erdős::Number::erdős_number" + "Class::Class::init" + "Class::Inner::init_again"))) (dolist (sub expected) (should (assoc-string sub index))))))) @@ -788,6 +924,17 @@ under timeout control." (should (string-match "poop ('foo', \n 'bar')" (buffer-string)))))) +(ert-deftest cperl-test-bug-11733 () + "Verify indentation of braces after newline and non-labels." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (cperl--run-test-cases + (ert-resource-file "cperl-bug-11733.pl") + (goto-char (point-min)) + (while (null (eobp)) + (cperl-indent-command) + (forward-line 1)))) + + (ert-deftest cperl-test-bug-11996 () "Verify that we give the right syntax property to a backslash operator." (with-temp-buffer @@ -995,6 +1142,19 @@ Perl is not Lisp: An open paren in column 0 does not start a function." (cperl-indent-command) (forward-line 1)))) +(ert-deftest cperl-test-bug-35925 () + "Check that indentation is correct after a terminating format declaration." + (cperl--run-test-cases + (ert-resource-file "cperl-bug-35925.pl") + (cperl-file-style "PBP") ; Make cperl-mode use the same settings as perl-mode. + (let ((tab-function + (if (equal cperl-test-mode 'perl-mode) + #'indent-for-tab-command + #'cperl-indent-command))) + (goto-char (point-max)) + (forward-line -2) + (funcall tab-function)))) + (ert-deftest cperl-test-bug-37127 () "Verify that closing a paren in a regex goes without a message. Also check that the message is issued if the regex terminator is @@ -1145,6 +1305,151 @@ as a regex." (funcall cperl-test-mode) (should-not (nth 3 (syntax-ppss 3))))) +(ert-deftest cperl-test-bug-64190 () + "Verify correct fontification of multiline declarations" + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((file (ert-resource-file "cperl-bug-64190.pl"))) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (cperl-mode) + (font-lock-ensure) + ;; Example 1 + (while (search-forward "var" nil t) + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face))) + ;; Example 2 + (search-forward "package F") + (should (equal (get-text-property (point) 'face) + 'font-lock-function-name-face)) + + ;; Example 3 and 4 can't be directly tested because jit-lock and + ;; batch tests don't play together well. But we can approximate + ;; the behavior by calling the the fontification for the same + ;; region which would be used by jit-lock. + ;; Example 3 + (search-forward "sub do_stuff") + (let ((start-change (point))) + (insert "\n{") + (cperl-font-lock-fontify-region-function start-change + (point-max) + nil) ; silent + (font-lock-ensure start-change (point-max)) + (goto-char (1- start-change)) ; between the "ff" in "stuff" + (should (equal (get-text-property (point) 'face) + 'font-lock-function-name-face)) + (search-forward "{") + (insert "}")) ; make it legal again + + ;; Example 4 + (search-forward "$param2") + (beginning-of-line) + (let ((start-change (point))) + (insert " ") + (cperl-font-lock-fontify-region-function start-change + (point-max) + nil) ; silent + (font-lock-ensure start-change (point-max)) + (goto-char (1+ start-change)) + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face)) + (re-search-forward (rx (group "sub") " " (group "oops"))) + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-keyword-face)) + (should (equal (get-text-property (match-beginning 2) 'face) + 'font-lock-function-name-face)))))) + +(ert-deftest cperl-test-bug-64364 () + "Check that multi-line subroutine declarations indent correctly." + (cperl--run-test-cases + (ert-resource-file "cperl-bug-64364.pl") + (cperl-file-style "PBP") ; make cperl-mode use the same settings as perl-mode + (indent-region (point-min) (point-max))) + (cperl--run-test-cases + (ert-resource-file "cperl-bug-64364.pl") + (cperl-file-style "PBP") ; make cperl-mode use the same settings as perl-mode + (let ((tab-function + (if (equal cperl-test-mode 'perl-mode) + #'indent-for-tab-command + #'cperl-indent-command))) + (goto-char (point-min)) + (while (null (eobp)) + (funcall tab-function) + (forward-line 1))))) + +(ert-deftest cperl-test-bug-65834 () + "Verify that CPerl mode identifies a left-shift operator. +Left-shift and here-documents both use the \"<<\" operator. +In the code provided by this bug report, it needs to be +detected as left-shift operator." + (with-temp-buffer + (insert-file-contents (ert-resource-file "cperl-bug-65834.pl")) + (funcall cperl-test-mode) + (font-lock-ensure) + (search-forward "retur") ; leaves point before the "n" + (should (equal (get-text-property (point) 'face) + font-lock-keyword-face)) + (search-forward "# comm") ; leaves point before "ent" + (should (equal (get-text-property (point) 'face) + font-lock-comment-face)))) + +(ert-deftest cperl-test-bug-66145 () + "Verify that hashes and arrays are only fontified in code. +In strings, comments and POD the syntaxified faces should +prevail. The tests exercise all combinations of sigils $@% and +parenthesess [{ for comments, POD, strings and HERE-documents. +Fontification in code for `cperl-mode' is done in the tests +beginning with `cperl-test-unicode`." + (let ((types '("array" "hash" "key")) + (faces `(("string" . font-lock-string-face) + ("comment" . font-lock-comment-face) + ("here" . ,(if (equal cperl-test-mode 'perl-mode) + 'perl-heredoc + font-lock-string-face))))) + (with-temp-buffer + (insert-file-contents (ert-resource-file "cperl-bug-66145.pl")) + (funcall cperl-test-mode) + (font-lock-ensure) + (dolist (type types) + (goto-char (point-min)) + (while (re-search-forward (concat type "_\\([a-z]+\\)") nil t) + (should (equal (get-text-property (match-beginning 1) 'face) + (cdr (assoc (match-string-no-properties 1) + faces))))))))) + +(ert-deftest cperl-test-bug-66161 () + "Verify that text after \"__END__\" is fontified as comment. +For `cperl-mode', this needs the custom variable +`cperl-fontify-trailer' to be set to `comment'. Per default, +cperl-mode fontifies text after the delimiter as Perl code." + (with-temp-buffer + (insert-file-contents (ert-resource-file "cperl-bug-66161.pl")) + (setq cperl-fontify-trailer 'comment) + (funcall cperl-test-mode) + (font-lock-ensure) + (search-forward "TODO") ; leaves point before the colon + (should (equal (get-text-property (point) 'face) + font-lock-comment-face)))) + +(ert-deftest cperl-test-bug-69604 () + "Verify that $\" in a double-quoted string does not end the string. +Both `perl-mode' and `cperl-mode' treat ?$ as a quoting/escaping char to +avoid issues with punctuation variables. In a string, however, this is +not appropriate." + (let ((strings + '("\"$\\\" in string ---\"; # \"" ; $ must not quote \ + "$\" . \" in string ---\"; # \"" ; $ must quote \ + "\"\\$\" . \" in string ---\"; # \""))) ; \$ must not quote + (dolist (string strings) + (with-temp-buffer + (insert string) + (funcall cperl-test-mode) + (font-lock-ensure) + (goto-char (point-min)) + (search-forward "in string") + (should (equal (get-text-property (point) 'face) + font-lock-string-face)))))) + (ert-deftest test-indentation () (ert-test-erts-file (ert-resource-file "cperl-indents.erts"))) |