From 0e2726d4f9a241716076425e8e8f300303445e75 Mon Sep 17 00:00:00 2001 From: Steve Hancock Date: Tue, 26 Nov 2024 17:12:42 -0800 Subject: [PATCH] optional sub args can be indicated with extra parens this allows more accurate checking for mismatched sub call args --- bin/perltidy | 29 ++++++- lib/Perl/Tidy.pm | 6 +- lib/Perl/Tidy/FileWriter.pm | 2 +- lib/Perl/Tidy/Formatter.pm | 135 ++++++++++++++++++++++++++----- lib/Perl/Tidy/Logger.pm | 2 +- lib/Perl/Tidy/Tokenizer.pm | 7 +- lib/Perl/Tidy/VerticalAligner.pm | 2 +- perltidyrc | 2 +- 8 files changed, 154 insertions(+), 31 deletions(-) diff --git a/bin/perltidy b/bin/perltidy index 9c6c712d..3bd39c35 100755 --- a/bin/perltidy +++ b/bin/perltidy @@ -6592,7 +6592,29 @@ For example In this case, the sub is expecting a total of three args (C<$self>, C<$v1>, and C<$v2>) but only receives two (C<$self> and C<42>), so an undercount is reported. This is not necessarily an error because the sub may allow for this -possibility, but it is worth checking. The simple static processing done by perltidy cannot determine which sub args are optional. +possibility, but it is worth checking. + +Although it is not possible to automatically determine which sub args are +optional, if optional sub args are enclosed in an extra set of parentheses, +perltidy will take this a signal that they are optional and not issue a +warning. So if the above example is written as + + sub gnab_gib { + my $self = shift; + my ( $v1, ($v2) ) = @_; # <-- extra parens on $v2 indicate optional + ...; + } + +then perltidy will consider that the second arg is optional and not issue +a warning for: + + $self->gnab_gib(42); + +For multiple default call args, place one set of parens around them all. Some +examples: + + my ( $v1, ( $v2, $v3 ) ) = @_; # <-- $v2 and $v3 are optional + my ( ($v1) ) = @_; # <-- $v1 is optional =item B B a specific number of expected args for a sub could not be determined, but it is called with a specific number. This issue is reported for the B<--dump-> option but not the B<--warn-> option. @@ -6665,6 +6687,11 @@ error for a program can be determined by running with B<-wma -wmauc=0>. If there are undercount errors, a note at the bottom of the error output indicates the value of B required to avoid reporting them. +As noted above for the parameter B<--dump-mismatched-args>, if optional call +args are enclosed in separate parentheses, then perltidy will recognize them as +optional args and avoid needless warnings. If this method is used, +then B<-wmauc=0> should be used for maximal checking. + =item * B<--warn-mismatched-arg-overcount-cutoff=n>, or B<-wmaoc=n>, can be used to avoid B warnings when the expected number of args is less than B. diff --git a/lib/Perl/Tidy.pm b/lib/Perl/Tidy.pm index 0aaec7a7..6eb0f2a2 100644 --- a/lib/Perl/Tidy.pm +++ b/lib/Perl/Tidy.pm @@ -167,7 +167,7 @@ EOM sub streamhandle { - my ( $filename, $mode, $is_encoded_data ) = @_; + my ( $filename, $mode, ($is_encoded_data) ) = @_; # Given: # $filename @@ -316,7 +316,7 @@ EOM sub stream_slurp { - my ( $filename, $timeout_in_seconds ) = @_; + my ( $filename, ($timeout_in_seconds) ) = @_; # Given: # $filename @@ -1204,7 +1204,7 @@ sub make_file_extension { # Make a file extension, adding any leading '.' if necessary. # (the '.' may actually be an '_' under VMS). - my ( $self, $extension, $default ) = @_; + my ( $self, $extension, ($default) ) = @_; # Given: # $extension = the first choice (usually a user entry) diff --git a/lib/Perl/Tidy/FileWriter.pm b/lib/Perl/Tidy/FileWriter.pm index a65ae2c2..b5a017bc 100644 --- a/lib/Perl/Tidy/FileWriter.pm +++ b/lib/Perl/Tidy/FileWriter.pm @@ -293,7 +293,7 @@ sub require_blank_code_lines { } ## end sub require_blank_code_lines sub write_blank_code_line { - my ( $self, $forced ) = @_; + my ( $self, ($forced) ) = @_; # Write a blank line of code, given: # $forced = optional flag which, if set, forces the blank line diff --git a/lib/Perl/Tidy/Formatter.pm b/lib/Perl/Tidy/Formatter.pm index 114a8fcd..8c3f3a82 100644 --- a/lib/Perl/Tidy/Formatter.pm +++ b/lib/Perl/Tidy/Formatter.pm @@ -1424,7 +1424,7 @@ EOM # interface to Perl::Tidy::Logger routines sub warning { - my ( $msg, $msg_line_number ) = @_; + my ( $msg, ($msg_line_number) ) = @_; # Issue a warning message # Given: @@ -1437,7 +1437,7 @@ EOM } ## end sub warning sub complain { - my ( $msg, $msg_line_number ) = @_; + my ( $msg, ($msg_line_number) ) = @_; # Issue a complaint message # Given: @@ -1558,7 +1558,7 @@ sub split_words { } ## end sub split_words sub K_next_code { - my ( $self, $KK, $rLL ) = @_; + my ( $self, $KK, ($rLL) ) = @_; # Given: # $KK = index of a token in $rLL @@ -1586,7 +1586,7 @@ sub K_next_code { } ## end sub K_next_code sub K_next_nonblank { - my ( $self, $KK, $rLL ) = @_; + my ( $self, $KK, ($rLL) ) = @_; # Given: # $KK = index of a token in $rLL @@ -1615,7 +1615,7 @@ sub K_next_nonblank { sub K_previous_code { - my ( $self, $KK, $rLL ) = @_; + my ( $self, $KK, ($rLL) ) = @_; # Given: # $KK = index of a token in $rLL @@ -1654,7 +1654,7 @@ EOM sub K_previous_nonblank { - my ( $self, $KK, $rLL ) = @_; + my ( $self, $KK, ($rLL) ) = @_; # Given: # $KK = index of a token in $rLL @@ -1695,7 +1695,8 @@ EOM } ## end sub K_previous_nonblank sub K_first_code { - my ( $self, $rLL ) = @_; + + my ( $self, ($rLL) ) = @_; # Given: # $rLL = optional token array to override default @@ -1713,7 +1714,8 @@ sub K_first_code { } ## end sub K_first_code sub K_last_code { - my ( $self, $rLL ) = @_; + + my ( $self, ($rLL) ) = @_; # Given: # $rLL = optional token array to override default @@ -1758,7 +1760,7 @@ EOM } ## end sub get_parent_containers sub mark_parent_containers { - my ( $self, $seqno, $rhash, $value ) = @_; + my ( $self, $seqno, $rhash, ($value) ) = @_; # Task: # set $rhash->{$seqno}=$value for all parent containers @@ -10303,7 +10305,7 @@ sub expand_EXPORT_list { sub scan_variable_usage { - my ( $self, $roption ) = @_; + my ( $self, ($roption) ) = @_; # Scan for unused and reused lexical variables in a single sweep. @@ -13972,7 +13974,7 @@ EOM sub store_token { - my ( $self, $item ) = @_; + my ( $self, ($item) ) = @_; # Store one token during respace operations @@ -14462,6 +14464,7 @@ sub add_phantom_semicolon { } ## end sub add_phantom_semicolon sub delay_trailing_comma_op { + my ( $self, $if_add, $stable_flag ) = @_; # Given: @@ -14778,7 +14781,7 @@ sub delete_interbracket_arrow { sub unstore_last_nonblank_token { - my ( $self, $type, $want_space ) = @_; + my ( $self, $type, ($want_space) ) = @_; # remove the most recent nonblank token from the new token list # Input parameter: @@ -16476,6 +16479,75 @@ EOM return $K_sub; } ## end sub find_sub_token +sub count_default_sub_args { + my ( $self, $item, $seqno ) = @_; + + # Given: + # $item = hash ref with sub arg info + # $seqno => sequence number of a sub block of a paren + # containing possible default args + # Task: + # count default args and update minimum arg count in $item + + my $rLL = $self->[_rLL_]; + return unless ($seqno); + + # The token before the opening must be a ',' or '(' + my $K_o = $self->[_K_opening_container_]->{$seqno}; + my $K_test = $self->K_previous_code($K_o); + return unless defined($K_test); + my $token_test = $rLL->[$K_test]->[_TOKEN_]; + return if ( $token_test ne ',' && $token_test ne '(' ); + + # Check that an opening token has the previous sequence number + if ( $token_test eq '(' ) { + my $seqno_o = $rLL->[$K_test]->[_TYPE_SEQUENCE_]; + if ( !$seqno_o || $seqno_o != $seqno - 1 ) { + + # shouldn't happen: may be bad call value since the token + # with '$seqno' was just before a closing paren + DEVEL_MODE && Fault("seqno_o=$seqno_o != $seqno-1\n"); + return; + } + } + + my $rtype_count = $self->[_rtype_count_by_seqno_]->{$seqno}; + my $default_arg_count; + if ($rtype_count) { + + # One or more commas, like: ( ... $v1, $v2, ($d1, $d2) )=@_ + # Note that the comma_count does not include any trailing comma + # so we always add 1 + $default_arg_count = $rtype_count->{','} + 1; + } + + if ( !defined($default_arg_count) ) { + + # Check for empty parens, like: ( ... $v1, $v2, () )=@_ + my $K_n = $self->K_next_code($K_o); + my $K_c = $self->[_K_closing_container_]->{$seqno}; + return if ( $K_n == $K_c ); + + # No commas but not empty, so 1 arg in parens + # Something like: ( ... $v1, $v2, ($d1) )=@_ + $default_arg_count = 1; + } + return unless ($default_arg_count); + + # Update the minimum count to exclude the defaults + if ( $item->{shift_count_min} >= $default_arg_count ) { + $item->{shift_count_min} -= $default_arg_count; + } + else { + DEVEL_MODE + && Fault( +"default count is $default_arg_count but total is $item->{shift_count_min}" + ); + } + + return; +} ## end sub count_default_sub_args + sub count_sub_input_args { my ( $self, $item ) = @_; @@ -16706,6 +16778,29 @@ sub count_sub_input_args { $item->{shift_count_max} = $shift_count; $self->count_list_elements($item); + # Count default args placed in separate parens, such as: + # .. $v1 ,($def1, $def2)) = @_ + # .. $v1 ,($def1, $def2),) = @_ + + # look at the token before the last ')' + my $K_mm_p = $self->K_previous_code($K_mm); + my $token_mm_p = + $K_mm_p ? $rLL->[$K_mm_p]->[_TOKEN_] : SPACE; + + # skip past a trailing comma + if ( $token_mm_p eq ',' ) { + $K_mm_p = $self->K_previous_code($K_mm_p); + $token_mm_p = + $K_mm_p ? $rLL->[$K_mm_p]->[_TOKEN_] : SPACE; + } + + # if we find a closing paren, count the items and + # update shift_count_min + if ( $token_mm_p eq ')' ) { + my $seqno_mm_p = $rLL->[$K_mm_p]->[_TYPE_SEQUENCE_]; + $self->count_default_sub_args( $item, $seqno_mm_p ); + } + # NOTE: this could disagree with $_[n] usage; we # ignore this for now. return; @@ -18097,7 +18192,6 @@ sub cross_check_sub_calls { if ( !defined($min) || $arg_count < $min ) { $common_hash{$key}->{min_arg_count} = $arg_count; } - if ( $excess < 0 ) { push @{ $common_hash{$key}->{under_count} }, $rcall_item; } @@ -18448,6 +18542,7 @@ EOM my $wmauc_min = $max_shift_count_with_undercount + 1; $call_arg_hint = <[_rblock_type_of_seqno_]; # kill any current block - we can only go 1 deep - create_one_line_block(); + create_one_line_block(undef); my $i_start = 0; @@ -34143,7 +34238,7 @@ sub total_line_length { sub excess_line_length { - my ( $self, $ibeg, $iend, $ignore_right_weld ) = @_; + my ( $self, $ibeg, $iend, ($ignore_right_weld) ) = @_; # Return number of characters by which a line of tokens ($ibeg..$iend) # exceeds the allowable line length. @@ -36018,7 +36113,7 @@ EOM sub check_batch_summed_lengths { - my ( $self, $msg ) = @_; + my ( $self, ($msg) ) = @_; # Debug routine for summed lengths # $msg = optional debug message @@ -40888,7 +40983,7 @@ sub wrapup { # This is the last routine called when a file is formatted. # Flush buffer and write any informative messages - my ( $self, $severe_error ) = @_; + my ( $self, ($severe_error) ) = @_; # Optional parameter: # $severe_error = true if program is ending on an error diff --git a/lib/Perl/Tidy/Logger.pm b/lib/Perl/Tidy/Logger.pm index fed920df..adc3bae8 100644 --- a/lib/Perl/Tidy/Logger.pm +++ b/lib/Perl/Tidy/Logger.pm @@ -371,7 +371,7 @@ sub complain { sub warning { - my ( $self, $msg, $msg_line_number ) = @_; + my ( $self, $msg, ($msg_line_number) ) = @_; # Report errors to .ERR file (or stdout) # Given: diff --git a/lib/Perl/Tidy/Tokenizer.pm b/lib/Perl/Tidy/Tokenizer.pm index f9f9765e..50f81d7c 100644 --- a/lib/Perl/Tidy/Tokenizer.pm +++ b/lib/Perl/Tidy/Tokenizer.pm @@ -2290,7 +2290,7 @@ EOM } sub peeked_ahead { - my $flag = shift; + ( ( my $flag ) ) = @_; # get or set the closure flag '$peeked_ahead': # - set $peeked_ahead to $flag if given, then @@ -2985,7 +2985,8 @@ EOM # a sub to warn if token found where operator expected sub error_if_expecting_OPERATOR { - my ( $self, $thing ) = @_; + + my ( $self, ($thing) ) = @_; # Issue warning on error if expecting operator # Given: @@ -10911,7 +10912,7 @@ sub write_on_underline { sub pre_tokenize { - my ( $str, $max_tokens_wanted ) = @_; + my ( $str, ($max_tokens_wanted) ) = @_; # Input parameters: # $str = string to be parsed diff --git a/lib/Perl/Tidy/VerticalAligner.pm b/lib/Perl/Tidy/VerticalAligner.pm index f0971602..b102727c 100644 --- a/lib/Perl/Tidy/VerticalAligner.pm +++ b/lib/Perl/Tidy/VerticalAligner.pm @@ -1756,7 +1756,7 @@ sub _flush_group_lines { # This is the vertical aligner internal flush, which leaves the cache # intact - my ( $self, $level_jump ) = @_; + my ( $self, ($level_jump) ) = @_; # $level_jump = $next_level-$group_level, if known # = undef if not known diff --git a/perltidyrc b/perltidyrc index eee56256..58e4b175 100644 --- a/perltidyrc +++ b/perltidyrc @@ -20,7 +20,7 @@ # warn if call arg counts differ from sub definitions # (requires version > 20240202.04) --warn-mismatched-args ---warn-mismatched-arg-undercount-cutoff=5 +--warn-mismatched-arg-undercount-cutoff=0 # warn if return count wanted differs from sub return statements --warn-mismatched-returns -- 2.39.5