From: Steve Hancock <perltidy@users.sourceforge.net>
Date: Mon, 2 Jan 2023 23:41:56 +0000 (-0800)
Subject: add --use-feature=class, part 2
X-Git-Tag: 20221112.03~1
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=32962dee4c58716286ff5d21d8e804661f1d8ebf;p=perltidy.git

add --use-feature=class, part 2

Updates have been made to allow the default setting of --use-feature
to be --use-feature=class.  This can be turned off with --use-feature=' '.
---

diff --git a/CHANGES.md b/CHANGES.md
index 9bcdf999..1f0e0d75 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -2,6 +2,14 @@
 
 ## 2022 11 12.02
 
+    - Added option --use-feature=class, or -uf=class, for issue rt #145706.
+      This adds keywords 'class', 'method', 'field', and 'ADJUST' in support of
+      this feature which is being tested for future inclusion in Perl.
+      An effort has been made to avoid conflicts with past uses of these
+      words, especially 'method' and 'class'. The default setting
+      is --use-feature=class. If this causes a conflict, this option can
+      be turned off by entering -uf=' '.
+
     - Added option -bfvt=n, or --brace-follower-vertical-tightness=n,
       for part of issue git #110.  For n=2, this option looks for lines
       which would otherwise be, by default,
diff --git a/dev-bin/perltidy_random_setup.pl b/dev-bin/perltidy_random_setup.pl
index 9b46493a..3f1517b2 100755
--- a/dev-bin/perltidy_random_setup.pl
+++ b/dev-bin/perltidy_random_setup.pl
@@ -1163,6 +1163,8 @@ EOM
 
             'want-trailing-commas' => [ '0', '*', 'm', 'b', 'h', 'i', ' ' ],
 
+            'use-feature' => [ 'class', ' ', 'xyzzy' ],
+
             # Arbitrary limits to keep things readable
             'blank-lines-after-opening-block'  => [ 0, 4 ],
             'blank-lines-before-closing-block' => [ 0, 3 ],
diff --git a/lib/Perl/Tidy.pm b/lib/Perl/Tidy.pm
index 534e8a56..35e7d552 100644
--- a/lib/Perl/Tidy.pm
+++ b/lib/Perl/Tidy.pm
@@ -3577,6 +3577,7 @@ sub generate_options {
       noweld-nested-containers
       recombine
       nouse-unicode-gcstring
+      use-feature=class
       valign-code
       valign-block-comments
       valign-side-comments
@@ -4208,7 +4209,7 @@ sub cleanup_word_list {
 
     # Given:
     #   $rOpts - the global option hash
-    #   $option_name - hash key of this iption
+    #   $option_name - hash key of this option
     #   $rforced_words - ref to list of any words to be added
 
     # Returns:
diff --git a/lib/Perl/Tidy/Tokenizer.pm b/lib/Perl/Tidy/Tokenizer.pm
index f1c2fafc..820a3643 100644
--- a/lib/Perl/Tidy/Tokenizer.pm
+++ b/lib/Perl/Tidy/Tokenizer.pm
@@ -2195,6 +2195,137 @@ EOM
         return;
     } ## end sub scan_simple_identifier
 
+    sub method_ok_here {
+
+        # Return:
+        #   false if this is definitely an invalid method declaration
+        #   true otherwise (even if not sure)
+
+        # We are trying to avoid problems with old uses of 'method'
+        # when --use-feature=class is set (rt145706).
+        # For example, this should cause a return of 'false':
+
+        #  method paint => sub {
+        #    return;
+        #  };
+
+        # from do_scan_sub:
+        my $i_beg   = $i + 1;
+        my $pos_beg = $rtoken_map->[$i_beg];
+        pos($input_line) = $pos_beg;
+
+        # TEST 1: look a valid sub NAME
+        if (
+            $input_line =~ m/\G\s*
+        ((?:\w*(?:'|::))*)  # package - something that ends in :: or '
+        (\w+)               # NAME    - required
+        /gcx
+          )
+        {
+            my $subname = $2;
+            my $package = $1 ? $1 : EMPTY_STRING;
+        }
+        else {
+            return;
+        }
+
+        # TEST 2: look for invalid characters after name, such as here:
+        #    method paint => sub {
+        #     ...
+        #    }
+
+        if ( $input_line =~ m/\s*(\S)/gcx ) {
+            my $char = $1;
+
+            # Possibly valid next token types:
+            # '(' could start prototype or signature
+            # ':' could start ATTRIBUTE
+            # '{' cold start BLOCK
+            # ';' or '}' could end a statement
+            if ( $char =~ /^[\(\:\{\;\}]/ ) { return 1 }
+
+            # stop at a side comment - assume ok for now
+            if ( $char eq '#' ) { return 1 }
+
+            # nothing else is valid (in particular '#' and '"')
+            return;
+        }
+
+        # TBD: Still uncertain; may be at end of line
+        # We could continue will stop here and assume ok.
+        return 1;
+    }
+
+    sub class_ok_here {
+
+        # Return:
+        #   false if this is definitely an invalid class declaration
+        #   true otherwise (even if not sure)
+
+        # We are trying to avoid problems with old uses of 'class'
+        # when --use-feature=class is set (rt145706).
+
+        # Valid class declarations look like
+        #   class NAME ATTRS VERSION BLOCK
+        # where ATTRS VERSION and BLOCK are optional
+
+        # For example, this should cause a return of 'false':
+        #
+        #   class ExtendsBasicAttributes is BasicAttributes{
+
+        # TEST 1: class stmt can only go where a new statment can start
+        if ( !new_statement_ok() ) { return }
+
+        my $i_beg   = $i + 1;
+        my $pos_beg = $rtoken_map->[$i_beg];
+        pos($input_line) = $pos_beg;
+
+        # TEST 2: look for a valid NAME
+        if (
+            $input_line =~ m/\G\s*
+        ((?:\w*(?:'|::))*)  # package - something that ends in :: or '
+        (\w+)               # NAME    - required
+        /gcx
+          )
+        {
+            my $subname = $2;
+            my $package = $1 ? $1 : EMPTY_STRING;
+        }
+        else {
+            return;
+        }
+
+        # TEST 3: look for invalid characters after NAME
+        if ( $input_line =~ m/\s*(\S)/gcx ) {
+
+            my $char = $1;
+
+            # Must see one of: ATTRIBUTE, VERSION, BLOCK, or end stmt
+
+            # Possibly valid next token types:
+            # ':' could start ATTRIBUTE
+            # '\d' could start VERSION
+            # '{' cold start BLOCK
+            # ';' could end a statement
+            # '}' could end statement but would be strange
+            if ( $char =~ /^[\:\d\{\;\}]/ ) { return 1 }
+
+            # stop at a side comment - assume ok for now
+            if ( $char eq '#' ) { return 1 }
+
+            # Nothing else should be okay
+            return;
+
+            # non-dight letter - not ok
+            # ( this must be checked after \d )
+            ##OLD: if ( $tok =~ /^\w/) { return }
+        }
+
+        # TBD: Still uncertain; may be at end of line.
+        # We could continue will stop here and assume ok.
+        return 1;
+    }
+
     sub scan_id {
         ( $i, $tok, $type, $id_scan_state ) =
           scan_id_do( $input_line, $i, $tok, $rtokens, $rtoken_map,
@@ -2804,8 +2935,15 @@ EOM
             }
         }
 
-        $brace_type[ ++$brace_depth ]        = $block_type;
-        $brace_package[$brace_depth]         = $current_package;
+        $brace_type[ ++$brace_depth ] = $block_type;
+
+        # Patch for CLASS BLOCK definitions: do not update the package for the
+        # current depth if this is a BLOCK type definition.
+        # TODO: should make 'class' separate from 'package' and only do
+        # this for 'class'
+        $brace_package[$brace_depth] = $current_package
+          if ( substr( $block_type, 0, 8 ) ne 'package ' );
+
         $brace_structural_type[$brace_depth] = $type;
         $brace_context[$brace_depth]         = $context;
         ( $type_sequence, $indent_flag ) =
@@ -4090,11 +4228,15 @@ EOM
 
             if ( $tok_kw eq 'method' ) {
                 if (   $expecting == OPERATOR
-                    || $next_nonblank_token !~ /^(\w|\:)/ )
+                    || $next_nonblank_token !~ /^(\w|\:)/
+                    || !method_ok_here() )
                 {
                     do_UNKNOWN_BAREWORD($next_nonblank_token);
                 }
-                else { scan_id() }
+                else {
+                    initialize_subname();
+                    scan_id();
+                }
             }
             else {
                 error_if_expecting_OPERATOR()
@@ -4114,8 +4256,8 @@ EOM
             #   package($x) - error
             if ( $tok_kw eq 'class' ) {
                 if (   $expecting == OPERATOR
-                    || !new_statement_ok()
-                    || $next_nonblank_token !~ /^(\w|\:)/ )
+                    || $next_nonblank_token !~ /^(\w|\:)/
+                    || !class_ok_here() )
                 {
                     do_UNKNOWN_BAREWORD($next_nonblank_token);
                 }
@@ -8624,10 +8766,24 @@ EOM
                 }
             }
             elsif ($next_nonblank_token) {    # EOF technically ok
-                $subname = EMPTY_STRING unless defined($subname);
-                warning(
+
+                if ( $rinput_hash->{tok} eq 'method' && $call_type == SUB_CALL )
+                {
+                    # For a method call, silently ignore this error (rt145706)
+                    # to avoid needless warnings. Example which can produce it:
+                    #     test(method Pack (), "method");
+
+                    # TODO: scan for use feature 'class' and:
+                    # - if we saw 'use feature 'class' then issue the warning.
+                    # - if we did not see use feature 'class' then issue the
+                    #   warning and suggest turning off --use-feature=class
+                }
+                else {
+                    $subname = EMPTY_STRING unless defined($subname);
+                    warning(
 "expecting ':' or ';' or '{' after definition or declaration of sub '$subname' but saw '$next_nonblank_token'\n"
-                );
+                    );
+                }
             }
             check_prototype( $proto, $package, $subname );
         }
diff --git a/t/snippets/expect/rt145706.def b/t/snippets/expect/rt145706.def
new file mode 100644
index 00000000..64f81ef7
--- /dev/null
+++ b/t/snippets/expect/rt145706.def
@@ -0,0 +1,30 @@
+# some tests for default setting --use-feature=class, rt145706
+class Example::Subclass1 : isa(Example::Base) { ... }
+class Example::Subclass2 : isa(Example::Base 2.345) { ... }
+class Example::Subclass3 : isa(Example::Base) 1.345 { ... }
+field $y : param(the_y_value);
+class Pointer 2.0 {
+    field $x : param;
+    field $y : param;
+
+    method to_string() {
+        return "($x, $y)";
+    }
+}
+
+ADJUST {
+    $x = 0;
+}
+
+# these should not produce errors
+method paint => sub {
+    ...;
+};
+is( ( method Pack "a", "b", "c" ), "method,a,b,c" );
+class ExtendsBasicAttributes is BasicAttributes {
+    ...
+}
+class +Night with +Bad {
+    public nine { return 'crazy' }
+};
+my $x = field(50);
diff --git a/t/snippets/expect/sal.def b/t/snippets/expect/sal.def
index f7584da2..124fac14 100644
--- a/t/snippets/expect/sal.def
+++ b/t/snippets/expect/sal.def
@@ -2,7 +2,7 @@ sub get_val () {
 
 }
 
-method get_value() {
+method get_value () {
 
 }
 
diff --git a/t/snippets/packing_list.txt b/t/snippets/packing_list.txt
index 6307b9a1..c8caa644 100644
--- a/t/snippets/packing_list.txt
+++ b/t/snippets/packing_list.txt
@@ -376,6 +376,11 @@
 ../snippets27.t	wtc.wtc7
 ../snippets27.t	rt144979.def
 ../snippets27.t	rt144979.rt144979
+../snippets27.t	bfvt.bfvt0
+../snippets27.t	bfvt.bfvt2
+../snippets27.t	bfvt.def
+../snippets27.t	cpb.cpb
+../snippets27.t	cpb.def
 ../snippets3.t	ce_wn1.ce_wn
 ../snippets3.t	ce_wn1.def
 ../snippets3.t	colin.colin
@@ -516,8 +521,4 @@
 ../snippets9.t	rt98902.def
 ../snippets9.t	rt98902.rt98902
 ../snippets9.t	rt99961.def
-../snippets27.t	bfvt.bfvt0
-../snippets27.t	bfvt.bfvt2
-../snippets27.t	bfvt.def
-../snippets27.t	cpb.cpb
-../snippets27.t	cpb.def
+../snippets27.t	rt145706.def
diff --git a/t/snippets/rt145706.in b/t/snippets/rt145706.in
new file mode 100644
index 00000000..542280f6
--- /dev/null
+++ b/t/snippets/rt145706.in
@@ -0,0 +1,30 @@
+# some tests for default setting --use-feature=class, rt145706
+class Example::Subclass1 : isa(Example::Base) { ... }
+class Example::Subclass2 : isa(Example::Base 2.345) { ... }
+class Example::Subclass3 : isa(Example::Base) 1.345 { ... }
+field $y : param(the_y_value);
+class Pointer 2.0 {
+    field $x : param;
+    field $y : param;
+
+    method to_string() {
+        return "($x, $y)";
+    }
+}
+
+ADJUST {
+    $x = 0;
+}
+
+# these should not produce errors
+method paint => sub {
+    ...;
+};
+is( ( method Pack "a", "b", "c" ), "method,a,b,c" );
+class ExtendsBasicAttributes is BasicAttributes{
+ ...
+}
+class +Night with +Bad {
+    public nine { return 'crazy' }
+};
+my $x = field(50);
diff --git a/t/snippets15.t b/t/snippets15.t
index b51c0c5f..eac77b01 100644
--- a/t/snippets15.t
+++ b/t/snippets15.t
@@ -435,7 +435,7 @@ sub get_val () {
 
 }
 
-method get_value() {
+method get_value () {
 
 }
 
diff --git a/t/snippets27.t b/t/snippets27.t
index 01ed0e43..c266b5fd 100644
--- a/t/snippets27.t
+++ b/t/snippets27.t
@@ -17,6 +17,7 @@
 #14 bfvt.def
 #15 cpb.cpb
 #16 cpb.def
+#17 rt145706.def
 
 # To locate test #13 you can search for its name or the string '#13'
 
@@ -153,6 +154,39 @@ GetOptions(
             }
 }}}
 
+----------
+
+        'rt145706' => <<'----------',
+# some tests for default setting --use-feature=class, rt145706
+class Example::Subclass1 : isa(Example::Base) { ... }
+class Example::Subclass2 : isa(Example::Base 2.345) { ... }
+class Example::Subclass3 : isa(Example::Base) 1.345 { ... }
+field $y : param(the_y_value);
+class Pointer 2.0 {
+    field $x : param;
+    field $y : param;
+
+    method to_string() {
+        return "($x, $y)";
+    }
+}
+
+ADJUST {
+    $x = 0;
+}
+
+# these should not produce errors
+method paint => sub {
+    ...;
+};
+is( ( method Pack "a", "b", "c" ), "method,a,b,c" );
+class ExtendsBasicAttributes is BasicAttributes{
+ ...
+}
+class +Night with +Bad {
+    public nine { return 'crazy' }
+};
+my $x = field(50);
 ----------
 
         'wtc' => <<'----------',
@@ -852,6 +886,43 @@ foreach my $dir (
 
 #16...........
         },
+
+        'rt145706.def' => {
+            source => "rt145706",
+            params => "def",
+            expect => <<'#17...........',
+# some tests for default setting --use-feature=class, rt145706
+class Example::Subclass1 : isa(Example::Base) { ... }
+class Example::Subclass2 : isa(Example::Base 2.345) { ... }
+class Example::Subclass3 : isa(Example::Base) 1.345 { ... }
+field $y : param(the_y_value);
+class Pointer 2.0 {
+    field $x : param;
+    field $y : param;
+
+    method to_string() {
+        return "($x, $y)";
+    }
+}
+
+ADJUST {
+    $x = 0;
+}
+
+# these should not produce errors
+method paint => sub {
+    ...;
+};
+is( ( method Pack "a", "b", "c" ), "method,a,b,c" );
+class ExtendsBasicAttributes is BasicAttributes {
+    ...
+}
+class +Night with +Bad {
+    public nine { return 'crazy' }
+};
+my $x = field(50);
+#17...........
+        },
     };
 
     my $ntests = 0 + keys %{$rtests};