From: Steve Hancock Date: Sat, 31 Dec 2022 17:24:04 +0000 (-0800) Subject: add --use-feature=class, part 1 X-Git-Tag: 20221112.03~2 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=4ba5a84e82bfe7d2a1890d7032e41afbf227ed4f;p=perltidy.git add --use-feature=class, part 1 This version adds option --use-feature='class' to format code using "use feature 'class'" (see rt145706). The main changes are: 'class' is treated as a generalization of 'package'. It is updated to accept attributes and an optional BLOCK. 'method' is handled using the existing --sub-alias-list option, i.e. --sub-alias-list=method 'field' is treated the same as 'my' 'ADJUST' is treated like 'BEGIN' In a future update, the new option --use-feature="class" will be set to be the default. That requires some additional updates to avoid conflicts with older uses of these keywords. --- diff --git a/lib/Perl/Tidy.pm b/lib/Perl/Tidy.pm index 15018738..534e8a56 100644 --- a/lib/Perl/Tidy.pm +++ b/lib/Perl/Tidy.pm @@ -3153,6 +3153,7 @@ sub generate_options { $add_option->( 'sub-alias-list', 'sal', '=s' ); $add_option->( 'grep-alias-list', 'gal', '=s' ); $add_option->( 'grep-alias-exclusion-list', 'gaxl', '=s' ); + $add_option->( 'use-feature', 'uf', '=s' ); ######################################## $category = 2; # Code indentation control @@ -4198,6 +4199,54 @@ sub make_grep_alias_string { return; } ## end sub make_grep_alias_string +sub cleanup_word_list { + my ( $rOpts, $option_name, $rforced_words ) = @_; + + # Clean up the list of words in a user option to simplify use by + # later routines (delete repeats, replace commas with single space, + # remove non-words) + + # Given: + # $rOpts - the global option hash + # $option_name - hash key of this iption + # $rforced_words - ref to list of any words to be added + + # Returns: + # \%seen - hash of the final list of words + + my %seen; + my @input_list; + + my $input_string = $rOpts->{$option_name}; + if ( defined($input_string) && length($input_string) ) { + $input_string =~ s/,/ /g; # allow commas + $input_string =~ s/^\s+//; + $input_string =~ s/\s+$//; + @input_list = split /\s+/, $input_string; + } + + if ($rforced_words) { + push @input_list, @{$rforced_words}; + } + + my @filtered_word_list; + foreach my $word (@input_list) { + if ($word) { + + # look for obviously bad words + if ( $word =~ /^\d/ || $word !~ /^\w[\w\d]*$/ ) { + Warn("unexpected '$option_name' word '$word' - ignoring\n"); + } + if ( !$seen{$word} ) { + $seen{$word}++; + push @filtered_word_list, $word; + } + } + } + $rOpts->{$option_name} = join SPACE, @filtered_word_list; + return \%seen; +} + sub check_options { my ( $rOpts, $is_Windows, $Windows_type, $rpending_complaint ) = @_; @@ -4347,30 +4396,30 @@ EOM $rOpts->{'default-tabsize'} = 8; } + # Check and clean up any use-feature list + my $saw_use_feature_class; + if ( $rOpts->{'use-feature'} ) { + my $rseen = cleanup_word_list( $rOpts, 'use-feature' ); + $saw_use_feature_class = $rseen->{'class'}; + } + # Check and clean up any sub-alias-list - if ( $rOpts->{'sub-alias-list'} ) { - my $sub_alias_string = $rOpts->{'sub-alias-list'}; - $sub_alias_string =~ s/,/ /g; # allow commas - $sub_alias_string =~ s/^\s+//; - $sub_alias_string =~ s/\s+$//; - my @sub_alias_list = split /\s+/, $sub_alias_string; - my @filtered_word_list = ('sub'); - my %seen; - - # include 'sub' for later convenience - $seen{sub}++; - foreach my $word (@sub_alias_list) { - if ($word) { - if ( $word !~ /^\w[\w\d]*$/ ) { - Warn("unexpected sub alias '$word' - ignoring\n"); - } - if ( !$seen{$word} ) { - $seen{$word}++; - push @filtered_word_list, $word; - } - } - } - $rOpts->{'sub-alias-list'} = join SPACE, @filtered_word_list; + if ( + defined( $rOpts->{'sub-alias-list'} ) + && length( $rOpts->{'sub-alias-list'} ) + + || $saw_use_feature_class + ) + { + my @forced_words; + + # include 'sub' for convenience if this option is used + push @forced_words, 'sub'; + + # use-feature=class requires method as a sub alias + push @forced_words, 'method' if ($saw_use_feature_class); + + cleanup_word_list( $rOpts, 'sub-alias-list', \@forced_words ); } make_grep_alias_string($rOpts); diff --git a/lib/Perl/Tidy/Formatter.pm b/lib/Perl/Tidy/Formatter.pm index f13bb5c6..7f103eab 100644 --- a/lib/Perl/Tidy/Formatter.pm +++ b/lib/Perl/Tidy/Formatter.pm @@ -6328,19 +6328,6 @@ EOM { $type = 'closure'; } - elsif ( $ris_sub_block->{$seqno} - && ( $dump_all_types || $dump_block_types{'sub'} ) ) - { - $type = 'sub'; - - # what we want: - # $block_type $name - # 'sub setidentifier($)' => 'setidentifier' - # 'method setidentifier($)' => 'setidentifier' - my @parts = split /\s+/, $block_type; - $name = $parts[1]; - $name =~ s/\W.*$//; - } # Both 'sub' and 'asub' select an anonymous sub. # This allows anonymous subs to be explicitely selected @@ -6373,6 +6360,28 @@ EOM } } } + elsif ( $ris_sub_block->{$seqno} + && ( $dump_all_types || $dump_block_types{'sub'} ) ) + { + $type = 'sub'; + + # what we want: + # $block_type $name + # 'sub setidentifier($)' => 'setidentifier' + # 'method setidentifier($)' => 'setidentifier' + my @parts = split /\s+/, $block_type; + $name = $parts[1]; + $name =~ s/\(.*$//; + } + elsif ( $block_type =~ /^package\s/ + && ( $dump_all_types || $dump_block_types{'package'} ) ) + { + $type = 'package'; + my @parts = split /\s+/, $block_type; + $name = $parts[1]; + $name =~ s/\(.*$//; + } + elsif ( $is_loop_type{$block_type} && ( $dump_all_types diff --git a/lib/Perl/Tidy/Tokenizer.pm b/lib/Perl/Tidy/Tokenizer.pm index 4146e934..f1c2fafc 100644 --- a/lib/Perl/Tidy/Tokenizer.pm +++ b/lib/Perl/Tidy/Tokenizer.pm @@ -101,6 +101,7 @@ use vars qw{ %is_tetragraph %is_valid_token_type %is_keyword + %is_my_our_state %is_code_block_token %is_sort_map_grep_eval_do %is_sort_map_grep @@ -338,6 +339,38 @@ sub check_options { } } + # Update hash values for any -use-feature options + if ( $rOpts->{'use-feature'} ) { + + # These are the main updates for this option. There are additional + # changes elsewhere, usually indicated with a comment 'rt145706' + + # Update hash values for use_feature=class, added for rt145706 + # see 'perlclass.pod' + if ( $rOpts->{'use-feature'} =~ /\bclass\b/ ) { + + # there are 4 new keywords: + + # 'class' - treated specially as generalization of 'package' + # Note: we must not set 'class' to be a keyword to avoid problems + # with older uses. + $is_package{'class'} = 1; + + # 'method' - treated like sub using the sub-alias-list option + # Note: we must not set 'method' to be a keyword to avoid problems + # with older uses. + + # 'field' - added as a keyword, and works like 'my' + $is_keyword{'field'} = 1; + $is_my_our_state{'field'} = 1; + + # 'ADJUST' - added as a keyword and works like 'BEGIN' + # TODO: if ADJUST gets a paren list, this will need to be updated + $is_keyword{'ADJUST'} = 1; + $is_code_block_token{'ADJUST'} = 1; + } + } + %is_grep_alias = (); if ( $rOpts->{'grep-alias-list'} ) { @@ -1859,14 +1892,13 @@ EOM @q = qw(for foreach); @is_for_foreach{@q} = (1) x scalar(@q); - my %is_my_our_state; - @q = qw(my our state); - @is_my_our_state{@q} = (1) x scalar(@q); - # These keywords may introduce blocks after parenthesized expressions, # in the form: # keyword ( .... ) { BLOCK } # patch for SWITCH/CASE: added 'switch' 'case' 'given' 'when' + # NOTE for --use-feature=class: if ADJUST blocks eventually take a + # parameter list, then ADJUST might need to be added to this list (see + # perlclass.pod) my %is_blocktype_with_paren; @q = qw(if elsif unless while until for foreach switch case given when catch); @@ -2660,7 +2692,8 @@ EOM # ATTRS: for a '{' following an attribute list, reset # things to look like we just saw the sub name - if ( $statement_type =~ /^sub\b/ ) { + # Added 'package' (can be 'class') for --use-feature=class (rt145706) + if ( $statement_type =~ /^(sub|package)\b/ ) { $last_nonblank_token = $statement_type; $last_nonblank_type = 'i'; $statement_type = EMPTY_STRING; @@ -2973,7 +3006,8 @@ EOM # ATTRS: check for a ':' which introduces an attribute list # either after a 'sub' keyword or within a paren list - elsif ( $statement_type =~ /^sub\b/ ) { + # Added 'package' (can be 'class') for --use-feature=class (rt145706) + elsif ( $statement_type =~ /^(sub|package)\b/ ) { $type = 'A'; $in_attribute_list = 1; } @@ -4043,19 +4077,55 @@ EOM $i = $i_next; } - # 'sub' or alias + # 'sub' or other sub alias elsif ( $is_sub{$tok_kw} ) { - error_if_expecting_OPERATOR() - if ( $expecting == OPERATOR ); - initialize_subname(); - scan_id(); + + # Update for --use-feature=class (rt145706): + # We have to be extra careful to avoid misparsing other uses of + # 'method' in older scripts. + + # TODO: This is just a preliminary version. A future version + # should add an option to silently parse as a sub and then + # on error backtrack and parse as a bareword. + + if ( $tok_kw eq 'method' ) { + if ( $expecting == OPERATOR + || $next_nonblank_token !~ /^(\w|\:)/ ) + { + do_UNKNOWN_BAREWORD($next_nonblank_token); + } + else { scan_id() } + } + else { + error_if_expecting_OPERATOR() + if ( $expecting == OPERATOR ); + initialize_subname(); + scan_id(); + } } - # 'package' + # 'package' elsif ( $is_package{$tok_kw} ) { - error_if_expecting_OPERATOR() - if ( $expecting == OPERATOR ); - scan_id(); + + # Update for --use-feature=class (rt145706): + # We have to be extra careful because 'class' may be used for other + # purposes on older code; i.e. + # class($x) - valid sub call + # package($x) - error + if ( $tok_kw eq 'class' ) { + if ( $expecting == OPERATOR + || !new_statement_ok() + || $next_nonblank_token !~ /^(\w|\:)/ ) + { + do_UNKNOWN_BAREWORD($next_nonblank_token); + } + else { scan_id() } + } + else { + error_if_expecting_OPERATOR() + if ( $expecting == OPERATOR ); + scan_id(); + } } # Fix for c035: split 'format' from 'is_format_END_DATA' to be @@ -5787,6 +5857,13 @@ sub operator_expected { if ( $last_nonblank_token eq 'prototype' ) { $op_expected = TERM; } + + # update for --use-feature=class (rt145706): + # Look for class VERSION after possible attribute, as in + # class Example::Subclass : isa(Example::Base) 1.345 { ... } + elsif ( $statement_type =~ /^package\b/ ) { + $op_expected = TERM; + } } # file handle or similar @@ -7343,7 +7420,8 @@ sub do_scan_package { # Examples of valid primitive tokens that might follow are: # 1235 . ; { } v3 v # FIX: added a '#' since a side comment may also follow - if ( $next_nonblank_token =~ /^([v\.\d;\{\}\#])|v\d|\d+$/ ) { + # Added ':' for class attributes (for --use-feature=class, rt145706) + if ( $next_nonblank_token =~ /^([v\.\d;\{\}\#\:])|v\d|\d+$/ ) { $statement_type = $tok; } else { @@ -9807,10 +9885,15 @@ BEGIN { @q = qw( print printf sort exec system say); @is_indirect_object_taker{@q} = (1) x scalar(@q); + # Note: 'field' will be added by sub check_options if --use-feature=class + @q = qw(my our state); + @is_my_our_state{@q} = (1) x scalar(@q); + # These tokens may precede a code block # patched for SWITCH/CASE/CATCH. Actually these could be removed # now and we could let the extended-syntax coding handle them. # Added 'default' for Switch::Plain. + # Note: 'ADJUST' will be added by sub check_options if --use-feature=class @q = qw( BEGIN END CHECK INIT AUTOLOAD DESTROY UNITCHECK continue if elsif else unless do while until eval for foreach map grep sort @@ -10060,8 +10143,12 @@ BEGIN { isa catch + ); + # Note: 'ADJUST', 'field' are added by sub check_options + # if --use-feature=class + # patched above for SWITCH/CASE given/when err say # 'err' is a fairly safe addition. # Added 'default' for Switch::Plain. Note that we could also have @@ -10161,6 +10248,7 @@ BEGIN { @q = qw(q qq qw qx qr s y tr m); @is_q_qq_qw_qx_qr_s_y_tr_m{@q} = (1) x scalar(@q); + # Note: 'class' will be added by sub check_options if -use-feature=class @q = qw(package); @is_package{@q} = (1) x scalar(@q);