From 766784f186a5f28720c33180f7525ddc227f8c44 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Harald=20J=C3=B6rg?= Date: Mon, 3 Jul 2023 22:55:19 +0200 Subject: [PATCH] cperl-mode.el: Add support for new Perl syntax in Perl 5.36 and 5.38 Perl 5.38 was released on 2023-07-03. This patch supports the new features for 5.36 and 5.38 for font-lock, indentation, and imenu index creation. * lisp/progmodes/cperl-mode.el (cperl-praise): Mention classes. (defconst): Fix typo in docstring of cperl--single-attribute-rx. Add "class" to cperl--package-rx, and adjust its docstring. New rx sequence cperl--class-for-imenu-rx to capture classes, use this in cperl--imenu-entries-rx. Add "method" to cperl--sub-name-for-imenu-rx. Add "class" to cperl--block-declaration-rx. (cperl-sub-keywords): Add "method". (cperl-mode): Add "ADJUST" to defun-prompt-regexp. (cperl-after-block-p): Add new keywords for Perl 5.36 and 5.38. (cperl-indent-exp): Add "field" to expression starters. (cperl-imenu--create-perl-index): Rename variables refering to "package", because they also contain classes. (cperl-init-faces): Add new keywords for Perl 5.36 and 5.38. (cperl-find-tags): Add support for "class". (cperl-short-docs): Add new keywords for Perl 5.36 and 5.38. (cperl-indent-exp): Add new keywords for Perl 5.36 and 5.38. * test/lisp/progmodes/cperl-mode-tests.el (cperl-test-fontify-class): New test for fontification of class elements. (cperl-test-imenu-index): Add tests for (nested) class definitions. * test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts: Add test cases for try/catch/finally, defer, class, method * test/lisp/progmodes/cperl-mode-resources/perl-class.pl: New resource for fontification tests of class elements. * test/lisp/progmodes/cperl-mode-resources/grammar.pl: Add some classes to the test resource. --- lisp/progmodes/cperl-mode.el | 171 ++++++++++++------ .../cperl-mode-resources/cperl-indents.erts | 55 ++++++ .../progmodes/cperl-mode-resources/grammar.pl | 25 +++ .../cperl-mode-resources/perl-class.pl | 19 ++ test/lisp/progmodes/cperl-mode-tests.el | 37 +++- 5 files changed, 246 insertions(+), 61 deletions(-) create mode 100644 test/lisp/progmodes/cperl-mode-resources/perl-class.pl diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 0b3cee7d2d0..54547c4668a 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -705,7 +705,7 @@ voice); d) Has support for imenu, including: 1) Separate unordered list of \"interesting places\"; 2) Separate TOC of POD sections; - 3) Separate list of packages; + 3) Separate list of packages/classes; 4) Hierarchical view of methods in (sub)packages; 5) and functions (by the full name - with package); e) Has an interface to INFO docs for Perl; The interface is @@ -1311,7 +1311,7 @@ or \"${ foo }\" will not.") ")"))) "A regular expression for a single attribute, without leading colon. It may have parameters in parens, but parens within the -parameter's value are not supported.. This regexp does not have +parameter's value are not supported. This regexp does not have capture groups.") (defconst cperl--attribute-list-rx @@ -1368,14 +1368,14 @@ not be covered by regular expressions. This sequence captures enough to distinguish a signature from a prototype.") (defconst cperl--package-rx - `(sequence (group "package") + `(sequence (group (or "package" "class")) ,cperl--ws+-rx (group ,cperl--normal-identifier-rx) (optional (sequence ,cperl--ws+-rx (group (regexp ,cperl--version-regexp))))) - "A regular expression for package NAME VERSION in Perl. -Contains three groups for the keyword \"package\", for the -package name and for the version.") + "A regular expression for package|class NAME VERSION in Perl. +Contains three groups for the initial keyword \"package\" or +\"class\", for the package name and for the version.") (defconst cperl--package-for-imenu-rx `(sequence symbol-start @@ -1392,27 +1392,59 @@ NAME BLOCK\" and \"package NAME VERSION BLOCK.\" Contains three groups: One for the keyword \"package\", one for the package name, and one for the discovery of a following BLOCK.") + ;; This gets a regexp of its own because classes allow attributes + ;; (e.g. ":isa(Parent)") while packages don't. We skip over it, but + ;; like for "package" we capture the following ";" or "{". + (defconst cperl--class-for-imenu-rx + `(sequence symbol-start + (group-n 1 "class") + ,cperl--ws*-rx + (group-n 2 ,cperl--normal-identifier-rx) + (optional (sequence ,cperl--ws+-rx + (regexp ,cperl--version-regexp))) + (optional (sequence ,cperl--ws*-rx + ,cperl--attribute-list-rx)) + ,cperl--ws*-rx + (group-n 3 (or ";" "{"))) + "A regular expression to collect package names for `imenu'. +Catches \"class NAME;\", \"class NAME VERSION;\", \"class NAME +BLOCK\" and \"class NAME VERSION BLOCK\" and allows for +attributes like \":isa(Parent)\". Contains three groups: One for +the keyword \"package\", one for the package name, and one for +the discovery of a following BLOCK.") + (defconst cperl--sub-name-for-imenu-rx `(sequence symbol-start (optional (sequence (group-n 3 (or "my" "state" "our")) ,cperl--ws+-rx)) - (group-n 1 "sub") + (group-n 1 (or "method" "sub")) ,cperl--ws+-rx (group-n 2 ,cperl--normal-identifier-rx)) - "A regular expression to detect a subroutine start. -Contains three groups: One to distinguish lexical from -\"normal\" subroutines, for the keyword \"sub\", and one for the -subroutine name.") + "A regular expression to detect a subroutine or method start. +Contains three groups: One to distinguish lexical from \"normal\" +subroutines, for the keyword \"sub\" or \"method\", and one for +the subroutine name.") (defconst cperl--block-declaration-rx `(sequence - (or "package" "sub") ; "class" and "method" coming soon + (or "class" "method" "package" "sub") (1+ ,cperl--ws-or-comment-rx) ,cperl--normal-identifier-rx) "A regular expression to find a declaration for a named block. Used for indentation. These declarations introduce a block which does not need a semicolon to terminate the statement.") +;;; Initializer blocks are not (yet) part of the Perl core. +;; (defconst cperl--field-declaration-rx +;; `(sequence +;; "field" +;; (1+ ,cperl--ws-or-comment-rx) +;; ,cperl--basic-variable-rx) +;; "A regular expression to find a declaration for a field. +;; Used for indentation. These declarations allow an initializer +;; block which does not need a semicolon to terminate the +;; statement.") + (defconst cperl--pod-heading-rx `(sequence line-start (group-n 1 "=head") @@ -1425,10 +1457,11 @@ heading text.") (defconst cperl--imenu-entries-rx `(or ,cperl--package-for-imenu-rx + ,cperl--class-for-imenu-rx ,cperl--sub-name-for-imenu-rx ,cperl--pod-heading-rx) "A regular expression to collect stuff that goes into the `imenu' index. -Covers packages, subroutines, and POD headings.") +Covers packages and classes, subroutines and methods, and POD headings.") ;; end of eval-and-compiled stuff ) @@ -1534,7 +1567,7 @@ the last)." ;; Tired of editing this in 8 places every time I remember that there ;; is another method-defining keyword (defvar cperl-sub-keywords - '("sub")) + '("sub" "method")) (defvar cperl-sub-regexp (regexp-opt cperl-sub-keywords)) @@ -1832,7 +1865,8 @@ or as help on variables `cperl-tips', `cperl-problems', (rx (eval cperl--ws*-rx)) (rx (optional (eval cperl--signature-rx))) "\\|" ; per toke.c - "\\(BEGIN\\|UNITCHECK\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)" + (rx (or "ADJUST" "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" + "END" "INIT" "UNITCHECK")) "\\)" cperl-maybe-white-and-comment-rex)) (setq-local comment-indent-function #'cperl-comment-indent) @@ -4853,7 +4887,7 @@ recursive calls in starting lines of here-documents." (setq tmpend tb)))) ((match-beginning 14) ; sub with prototype or attribute ;; 1+6+2+1+1=11 extra () before this (sub with proto/attr): - ;; match-string 12: Keyword "sub" + ;; match-string 12: Keyword "sub" or "method" ;; match-string 13: Name of the subroutine (optional) ;; match-string 14: Indicator for proto/attr/signature ;; match-string 15: Prototype @@ -4862,7 +4896,7 @@ recursive calls in starting lines of here-documents." (setq b1 (match-beginning 13) e1 (match-end 13)) (if (memq (char-after (1- b)) '(?\$ ?\@ ?\% ?\& ?\*)) - nil ;; we found $sub or @sub etc + nil ;; we found $sub or @method etc (goto-char b) (if (match-beginning 15) ; a complete prototype (progn @@ -5006,7 +5040,11 @@ statement would start; thus the block in ${func()} does not count." (save-excursion (forward-sexp -1) ;; else {} but not else::func {} - (or (and (looking-at "\\(else\\|catch\\|try\\|continue\\|grep\\|map\\|BEGIN\\|END\\|UNITCHECK\\|CHECK\\|INIT\\)\\>") + (or (and (looking-at (rx (or "else" "catch" "try" + "finally" "defer" + "continue" "grep" "map" + "ADJUST" "BEGIN" "CHECK" "END" + "INIT" "UNITCHECK"))) (not (looking-at "\\(\\sw\\|_\\)+::"))) ;; sub f {} (progn @@ -5168,18 +5206,16 @@ conditional/loop constructs." (if (eq (following-char) ?$ ) ; for my $var (list) (progn (forward-sexp -1) - (if (looking-at "\\(state\\|my\\|local\\|our\\)\\>") + (if (looking-at "\\(state\\|my\\|local\\|our\\|field\\)\\>") (forward-sexp -1)))) (if (looking-at (concat "\\(elsif\\|if\\|unless\\|while\\|until" + "\\|try\\|catch\\|finally\\|defer" "\\|for\\(each\\)?\\>\\(\\(" cperl-maybe-white-and-comment-rex - "\\(state\\|my\\|local\\|our\\)\\)?" + "\\(state\\|my\\|local\\|our\\|field\\)\\)?" cperl-maybe-white-and-comment-rex - (rx - (sequence - "$" - (eval cperl--basic-identifier-rx))) + (rx (eval cperl--basic-variable-rx)) "\\)?\\)\\>")) (progn (goto-char top) @@ -5296,6 +5332,7 @@ Returns some position at the last line." (opt (sequence "}" (0+ blank) )) symbol-start (or "else" "elsif" "continue" "if" "unless" "while" "until" + "try" "catch" "finally" "defer" (sequence (or "for" "foreach") (opt (opt (sequence (1+ blank) @@ -5625,6 +5662,8 @@ indentation and initial hashes. Behaves usually outside of comment." ;; Previous space could have gone: (or (memq (preceding-char) '(?\s ?\t)) (insert " ")))))) +;; The following lists are used for categorizing the entries found by +;; `cperl-imenu--create-perl-index'. (defvar cperl-imenu-package-keywords '("package" "class" "role")) (defvar cperl-imenu-sub-keywords '("sub" "method" "function" "fun")) (defvar cperl-imenu-pod-keywords '("=head")) @@ -5643,16 +5682,16 @@ comment, or POD." (index-pod-alist '()) (index-sub-alist '()) (index-unsorted-alist '()) - (package-stack '()) ; for package NAME BLOCK - (current-package "(main)") - (current-package-end (point-max))) ; end of package scope + (namespace-stack '()) ; for package NAME BLOCK + (current-namespace "(main)") + (current-namespace-end (point-max))) ; end of package scope ;; collect index entries (while (re-search-forward (rx (eval cperl--imenu-entries-rx)) nil t) ;; First, check whether we have left the scope of previously ;; recorded packages, and if so, eliminate them from the stack. - (while (< current-package-end (point)) - (setq current-package (pop package-stack)) - (setq current-package-end (pop package-stack))) + (while (< current-namespace-end (point)) + (setq current-namespace (pop namespace-stack)) + (setq current-namespace-end (pop namespace-stack))) (let ((state (syntax-ppss)) (entry-type (match-string 1)) name marker) ; for the "current" entry @@ -5663,15 +5702,15 @@ comment, or POD." (setq name (match-string-no-properties 2) marker (copy-marker (match-end 2))) (if (string= (match-string 3) ";") - (setq current-package name) ; package NAME; + (setq current-namespace name) ; package NAME; ;; No semicolon, therefore we have: package NAME BLOCK. ;; Stash the current package, because we need to restore ;; it after the end of BLOCK. - (push current-package-end package-stack) - (push current-package package-stack) + (push current-namespace-end namespace-stack) + (push current-namespace namespace-stack) ;; record the current name and its scope - (setq current-package name) - (setq current-package-end (save-excursion + (setq current-namespace name) + (setq current-namespace-end (save-excursion (goto-char (match-beginning 3)) (forward-sexp) (point)))) @@ -5682,14 +5721,14 @@ comment, or POD." (unless (nth 4 state) ; skip if in a comment (setq name (match-string-no-properties 2) marker (copy-marker (match-end 2))) - ;; Qualify the sub name with the package if it doesn't + ;; Qualify the sub name with the namespace if it doesn't ;; already have one, and if it isn't lexically scoped. ;; "my" and "state" subs are lexically scoped, but "our" ;; are just lexical aliases to package subs. (if (and (null (string-match "::" name)) (or (null (match-string 3)) (string-equal (match-string 3) "our"))) - (setq name (concat current-package "::" name))) + (setq name (concat current-namespace "::" name))) (let ((index (cons name marker))) (push index index-alist) (push index index-sub-alist) @@ -5753,7 +5792,7 @@ comment, or POD." hier-list) index-alist))) (and index-package-alist - (push (cons "+Packages+..." + (push (cons "+Classes,Packages+..." (nreverse index-package-alist)) index-alist)) (and (or index-package-alist index-pod-alist @@ -5846,13 +5885,17 @@ default function." '("if" "until" "while" "elsif" "else" "given" "when" "default" "break" "unless" "for" - "try" "catch" "finally" + "try" "catch" "defer" "finally" "foreach" "continue" "exit" "die" "last" "goto" "next" "redo" "return" "local" "exec" "do" "dump" "use" "our" "require" "package" "eval" "evalbytes" "my" "state" - "BEGIN" "END" "CHECK" "INIT" "UNITCHECK"))) ; Flow control + "class" "field" "method" + "ADJUST" "BEGIN" "CHECK" + "END" "INIT" "UNITCHECK" + ;; not in core, but per popular request + "async" "await"))) ; Flow control "\\)\\>") 2) ; was "\\)[ \n\t;():,|&]" ; In what follows we use `type' style ; for overwritable builtins @@ -5969,23 +6012,28 @@ default function." ;; -------- anchored: Signature `(,(rx (sequence (in "(,") (eval cperl--ws*-rx) - (group (or (eval cperl--basic-scalar-rx) - (eval cperl--basic-array-rx) - (eval cperl--basic-hash-rx))))) + (group (eval cperl--basic-variable-rx)))) (progn (goto-char (match-beginning 2)) ; pre-match: Back to sig (match-end 2)) nil (1 font-lock-variable-name-face))) ;; -------- various stuff calling for a package name - ;; (matcher subexp facespec) - `(,(rx (sequence symbol-start - (or "package" "require" "use" "import" - "no" "bootstrap") - (eval cperl--ws+-rx) - (group-n 1 (eval cperl--normal-identifier-rx)) - (any " \t\n;"))) ; require A if B; - 1 font-lock-function-name-face) + ;; (matcher (subexp facespec) (subexp facespec)) + `(,(rx (sequence + (or (sequence symbol-start + (or "package" "require" "use" "import" + "no" "bootstrap" "class") + (eval cperl--ws+-rx)) + (sequence (group-n 2 (sequence ":" + (eval cperl--ws*-rx) + "isa")) + "(" + (eval cperl--ws*-rx))) + (group-n 1 (eval cperl--normal-identifier-rx)) + (any " \t\n;)"))) ; require A if B; + (1 font-lock-function-name-face) + (2 font-lock-constant-face t t)) ;; -------- formats ;; (matcher subexp facespec) '("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$" @@ -6047,7 +6095,7 @@ default function." ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var ;; -------- variable declarations ;; (matcher (subexp facespec) ... - `(,(rx (sequence (or "state" "my" "local" "our")) + `(,(rx (sequence (or "state" "my" "local" "our" "field")) (eval cperl--ws*-rx) (opt (group (sequence "(" (eval cperl--ws*-rx)))) (group @@ -6959,7 +7007,9 @@ Does not move point." 127 (if (string-match "^package " (car elt)) (substring (car elt) 8) - (car elt) ) + (if (string-match "^class " (car elt)) + (substring (car elt) 6) + (car elt))) 1 (number-to-string (elt elt 2)) ; Line "," @@ -7712,6 +7762,7 @@ __FILE__ Current (source) filename. __LINE__ Current line in current source. __PACKAGE__ Current package. __SUB__ Current sub. +ADJUST {...} Callback for object creation ARGV Default multi-file input filehandle. is a synonym for <>. ARGVOUT Output filehandle with -i flag. BEGIN { ... } Immediately executed (during compilation) piece of code. @@ -7722,7 +7773,9 @@ INIT { ... } Pseudo-subroutine executed before the script starts running. DATA Input filehandle for what follows after __END__ or __DATA__. accept(NEWSOCKET,GENERICSOCKET) alarm(SECONDS) +async(SUB NAME {}|SUB {}) Mark function as potentially asynchronous atan2(X,Y) +await(ASYNCEXPR) Yield result of Future bind(SOCKET,NAME) binmode(FILEHANDLE) break Break out of a given/when statement @@ -7732,6 +7785,7 @@ chmod(LIST) chop[(LIST|VAR)] chown(LIST) chroot(FILENAME) +class NAME Introduce a class. close(FILEHANDLE) closedir(DIRHANDLE) ... cmp ... String compare. @@ -7742,6 +7796,7 @@ crypt(PLAINTEXT,SALT) dbmclose(%HASH) dbmopen(%HASH,DBNAME,MODE) default { ... } default case for given/when block +defer { ... } run this block after the containing block. defined(EXPR) delete($HASH{KEY}) die(LIST) @@ -7763,6 +7818,7 @@ exec([TRUENAME] ARGV0, ARGVs) or exec(SHELL_COMMAND_LINE) exit(EXPR) exp(EXPR) fcntl(FILEHANDLE,FUNCTION,SCALAR) +field VAR [:param[(NAME)]] [=EXPR] declare an object attribute fileno(FILEHANDLE) flock(FILEHANDLE,OPERATION) for (EXPR;EXPR;EXPR) { ... } @@ -7803,7 +7859,7 @@ hex(EXPR) if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR index(STR,SUBSTR[,OFFSET]) int(EXPR) -ioctl(FILEHANDLE,FUNCTION,SCALAR) +ioctl(FILEHANDLE,FUNCTION,SCALA)R join(EXPR,LIST) keys(%HASH) kill(LIST) @@ -7818,6 +7874,7 @@ log(EXPR) lstat(EXPR|FILEHANDLE|VAR) ... lt ... String less than. m/PATTERN/iogsmx +method [NAME [(signature)]] { BODY } method NAME; mkdir(FILENAME,MODE) msgctl(ID,CMD,ARG) msgget(KEY,FLAGS) @@ -7956,7 +8013,7 @@ lc [ EXPR ] Returns lowercased EXPR. lcfirst [ EXPR ] Returns EXPR with lower-cased first letter. grep EXPR,LIST or grep {BLOCK} LIST Filters LIST via EXPR/BLOCK. map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST. -no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method. +no MODULE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method. not ... Low-precedence synonym for ! - negation. ... or ... Low-precedence synonym for ||. pos STRING Set/Get end-position of the last match over this string, see \\G. @@ -7967,12 +8024,12 @@ readline FH Synonym of . readpipe CMD Synonym of \\=`CMD\\=`. ref [ EXPR ] Type of EXPR when dereferenced. sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.) -tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable. +tie VAR, CLASS, LIST Hide an object behind a simple Perl variable. tied Returns internal object for a tied data. uc [ EXPR ] Returns upcased EXPR. ucfirst [ EXPR ] Returns EXPR with upcased first letter. untie VAR Unlink an object from a simple Perl variable. -use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'. +use MODULE [SYMBOL1, ...] Compile-time `require' with consequent `import'. ... xor ... Low-precedence synonym for exclusive or. prototype \\&SUB Returns prototype of the function given a reference. =head1 Top-level heading. diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts b/test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts index 6b874ffaa1f..ba35b1d0690 100644 --- a/test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts @@ -24,3 +24,58 @@ Name: cperl-indents1 ""; } =-=-= + +Name: cperl-try-catch-finally + +=-= +{ + try { + call_a_function(); + } + catch ($e) { + warn "Unable to call; $e"; + } + finally { + print "Finished\n"; + } +} +=-=-= + +Name: cperl-defer + +=-= +use feature 'defer'; + +{ + say "This happens first"; + defer { + say "This happens last"; + } + + say "And this happens inbetween"; +} +=-=-= + +Name: cperl-feature-class + +=-= +use 5.038; +use feature "class"; +no warnings "experimental"; + +class A { +} + +class C + : isa(A) +{ + method with_sig_and_attr + : lvalue + ($top,$down) + { + return $top-$down; + } +} + +say "done!"; +=-=-= diff --git a/test/lisp/progmodes/cperl-mode-resources/grammar.pl b/test/lisp/progmodes/cperl-mode-resources/grammar.pl index 96a86993082..9420c0d1fa8 100644 --- a/test/lisp/progmodes/cperl-mode-resources/grammar.pl +++ b/test/lisp/progmodes/cperl-mode-resources/grammar.pl @@ -169,4 +169,29 @@ sub erdős_number { } } +=head1 And now, for something completely different + +Perl 5.38 supports classes with the same scope weirdness as packages. +As long as this is experimental, CPAN tools don't play well with this, +so some weird constructs are recommended to authors of CPAN modules. + +=cut + +package Class::Class; + +our $VERSION = 0.01; + +class Class::Class 0.01 { + method init ($with,$signature) { + ...; + } + + class Class::Inner :isa(Class::Class); + # This class comes without a block, so takes over until the rest + # of the containing block. + method init_again (@with_parameters) { + ...; + } +} + 1; diff --git a/test/lisp/progmodes/cperl-mode-resources/perl-class.pl b/test/lisp/progmodes/cperl-mode-resources/perl-class.pl new file mode 100644 index 00000000000..032690d20a5 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/perl-class.pl @@ -0,0 +1,19 @@ +use 5.038; +use feature 'class'; +no warnings 'experimental'; + +class A { +} + +class C + : isa(A) +{ + method with_sig_and_attr + : lvalue + ($top,$down) + { + return $top-$down; + } +} + +say "done!"; diff --git a/test/lisp/progmodes/cperl-mode-tests.el b/test/lisp/progmodes/cperl-mode-tests.el index 8162953cefb..0ca985ae86e 100644 --- a/test/lisp/progmodes/cperl-mode-tests.el +++ b/test/lisp/progmodes/cperl-mode-tests.el @@ -213,6 +213,33 @@ attributes, prototypes and signatures." '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." @@ -408,7 +435,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 @@ -416,13 +443,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))) @@ -784,7 +811,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))))))) -- 2.39.2