X-Git-Url: https://git.donarmstrong.com/?p=perltidy.git;a=blobdiff_plain;f=lib%2FPerl%2FTidy%2FFileWriter.pm;fp=lib%2FPerl%2FTidy%2FFileWriter.pm;h=9a9d62f20a7517f8333c3eed95872323c1923f41;hp=c598e1e8431f8390993342d285459cbbe0cdcb13;hb=57d829ae0e2c75828f8ecc9c7139579350927dbc;hpb=7f27e55dce5925b2bbe8fcfca64f385e917a52be diff --git a/lib/Perl/Tidy/FileWriter.pm b/lib/Perl/Tidy/FileWriter.pm index c598e1e..9a9d62f 100644 --- a/lib/Perl/Tidy/FileWriter.pm +++ b/lib/Perl/Tidy/FileWriter.pm @@ -7,14 +7,79 @@ package Perl::Tidy::FileWriter; use strict; use warnings; -our $VERSION = '20200110'; +our $VERSION = '20210717'; + +use constant DEVEL_MODE => 0; + +sub AUTOLOAD { + + # Catch any undefined sub calls so that we are sure to get + # some diagnostic information. This sub should never be called + # except for a programming error. + our $AUTOLOAD; + return if ( $AUTOLOAD =~ /\bDESTROY$/ ); + my ( $pkg, $fname, $lno ) = caller(); + my $my_package = __PACKAGE__; + print STDERR < $i++, + _logger_object_ => $i++, + _rOpts_ => $i++, + _output_line_number_ => $i++, + _consecutive_blank_lines_ => $i++, + _consecutive_nonblank_lines_ => $i++, + _consecutive_new_blank_lines_ => $i++, + _first_line_length_error_ => $i++, + _max_line_length_error_ => $i++, + _last_line_length_error_ => $i++, + _first_line_length_error_at_ => $i++, + _max_line_length_error_at_ => $i++, + _last_line_length_error_at_ => $i++, + _line_length_error_count_ => $i++, + _max_output_line_length_ => $i++, + _max_output_line_length_at_ => $i++, + _rK_checklist_ => $i++, + _K_arrival_order_matches_ => $i++, + _K_sequence_error_msg_ => $i++, + _K_last_arrival_ => $i++, + }; +} + +sub warning { + my ( $self, $msg ) = @_; + my $logger_object = $self->[_logger_object_]; + if ($logger_object) { $logger_object->warning($msg); } + return; +} + sub write_logfile_entry { my ( $self, $msg ) = @_; - my $logger_object = $self->{_logger_object}; + my $logger_object = $self->[_logger_object_]; if ($logger_object) { $logger_object->write_logfile_entry($msg); } @@ -24,62 +89,94 @@ sub write_logfile_entry { sub new { my ( $class, $line_sink_object, $rOpts, $logger_object ) = @_; - return bless { - _line_sink_object => $line_sink_object, - _logger_object => $logger_object, - _rOpts => $rOpts, - _output_line_number => 1, - _consecutive_blank_lines => 0, - _consecutive_nonblank_lines => 0, - _first_line_length_error => 0, - _max_line_length_error => 0, - _last_line_length_error => 0, - _first_line_length_error_at => 0, - _max_line_length_error_at => 0, - _last_line_length_error_at => 0, - _line_length_error_count => 0, - _max_output_line_length => 0, - _max_output_line_length_at => 0, - }, $class; -} - -sub tee_on { - my $self = shift; - $self->{_line_sink_object}->tee_on(); - return; + my $self = []; + $self->[_line_sink_object_] = $line_sink_object; + $self->[_logger_object_] = $logger_object; + $self->[_rOpts_] = $rOpts; + $self->[_output_line_number_] = 1; + $self->[_consecutive_blank_lines_] = 0; + $self->[_consecutive_nonblank_lines_] = 0; + $self->[_consecutive_new_blank_lines_] = 0; + $self->[_first_line_length_error_] = 0; + $self->[_max_line_length_error_] = 0; + $self->[_last_line_length_error_] = 0; + $self->[_first_line_length_error_at_] = 0; + $self->[_max_line_length_error_at_] = 0; + $self->[_last_line_length_error_at_] = 0; + $self->[_line_length_error_count_] = 0; + $self->[_max_output_line_length_] = 0; + $self->[_max_output_line_length_at_] = 0; + $self->[_rK_checklist_] = []; + $self->[_K_arrival_order_matches_] = 0; + $self->[_K_sequence_error_msg_] = ""; + $self->[_K_last_arrival_] = -1; + + # save input stream name for local error messages + $input_stream_name = ""; + if ($logger_object) { + $input_stream_name = $logger_object->get_input_stream_name(); + } + + bless $self, $class; + return $self; } -sub tee_off { - my $self = shift; - $self->{_line_sink_object}->tee_off(); +sub setup_convergence_test { + my ( $self, $rlist ) = @_; + if ( @{$rlist} ) { + + # We are going to destroy the list, so make a copy + # and put in reverse order so we can pop values + my @list = @{$rlist}; + if ( $list[0] < $list[-1] ) { + @list = reverse @list; + } + $self->[_rK_checklist_] = \@list; + } + $self->[_K_arrival_order_matches_] = 1; + $self->[_K_sequence_error_msg_] = ""; + $self->[_K_last_arrival_] = -1; return; } +sub get_convergence_check { + my ($self) = @_; + my $rlist = $self->[_rK_checklist_]; + + # converged if all K arrived and in correct order + return $self->[_K_arrival_order_matches_] && !@{$rlist}; +} + +sub get_K_sequence_error_msg { + my ($self) = @_; + return $self->[_K_sequence_error_msg_]; +} + sub get_output_line_number { - my $self = shift; - return $self->{_output_line_number}; + return $_[0]->[_output_line_number_]; } sub decrement_output_line_number { - my $self = shift; - $self->{_output_line_number}--; + $_[0]->[_output_line_number_]--; return; } sub get_consecutive_nonblank_lines { - my $self = shift; - return $self->{_consecutive_nonblank_lines}; + return $_[0]->[_consecutive_nonblank_lines_]; +} + +sub get_consecutive_blank_lines { + return $_[0]->[_consecutive_blank_lines_]; } sub reset_consecutive_blank_lines { - my $self = shift; - $self->{_consecutive_blank_lines} = 0; + $_[0]->[_consecutive_blank_lines_] = 0; return; } sub want_blank_line { my $self = shift; - unless ( $self->{_consecutive_blank_lines} ) { + unless ( $self->[_consecutive_blank_lines_] ) { $self->write_blank_code_line(); } return; @@ -91,8 +188,8 @@ sub require_blank_code_lines { # unless -mbl=0. This allows extra blank lines to be written for subs and # packages even with the default -mbl=1 my ( $self, $count ) = @_; - my $need = $count - $self->{_consecutive_blank_lines}; - my $rOpts = $self->{_rOpts}; + my $need = $count - $self->[_consecutive_blank_lines_]; + my $rOpts = $self->[_rOpts_]; my $forced = $rOpts->{'maximum-consecutive-blank-lines'} > 0; foreach my $i ( 0 .. $need - 1 ) { $self->write_blank_code_line($forced); @@ -103,93 +200,147 @@ sub require_blank_code_lines { sub write_blank_code_line { my $self = shift; my $forced = shift; - my $rOpts = $self->{_rOpts}; + my $rOpts = $self->[_rOpts_]; return if (!$forced - && $self->{_consecutive_blank_lines} >= + && $self->[_consecutive_blank_lines_] >= $rOpts->{'maximum-consecutive-blank-lines'} ); - $self->{_consecutive_blank_lines}++; - $self->{_consecutive_nonblank_lines} = 0; + + $self->[_consecutive_nonblank_lines_] = 0; + + # Balance old blanks against new (forced) blanks instead of writing them. + # This fixes case b1073. + if ( !$forced && $self->[_consecutive_new_blank_lines_] > 0 ) { + $self->[_consecutive_new_blank_lines_]--; + return; + } + $self->write_line("\n"); + $self->[_consecutive_blank_lines_]++; + $self->[_consecutive_new_blank_lines_]++ if ($forced); + return; } sub write_code_line { - my $self = shift; - my $a = shift; - - if ( $a =~ /^\s*$/ ) { - my $rOpts = $self->{_rOpts}; - return - if ( $self->{_consecutive_blank_lines} >= - $rOpts->{'maximum-consecutive-blank-lines'} ); - $self->{_consecutive_blank_lines}++; - $self->{_consecutive_nonblank_lines} = 0; - } - else { - $self->{_consecutive_blank_lines} = 0; - $self->{_consecutive_nonblank_lines}++; + my ( $self, $str, $K ) = @_; + + $self->[_consecutive_blank_lines_] = 0; + $self->[_consecutive_new_blank_lines_] = 0; + $self->[_consecutive_nonblank_lines_]++; + $self->write_line($str); + + #---------------------------- + # Convergence and error check + #---------------------------- + if ( defined($K) ) { + + # Convergence check: we are checking if all defined K values arrive in + # the order which was defined by the caller. Quit checking if any + # unexpected K value arrives. + if ( $self->[_K_arrival_order_matches_] ) { + my $Kt = pop @{ $self->[_rK_checklist_] }; + if ( !defined($Kt) || $Kt != $K ) { + $self->[_K_arrival_order_matches_] = 0; + } + } + + # Check for out-of-order arrivals of index K. The K values are the + # token indexes of the last token of code lines, and they should come + # out in increasing order. Otherwise something is seriously wrong. + # Most likely a recent programming change to VerticalAligner.pm has + # caused lines to go out in the wrong order. This could happen if + # either the cache or buffer that it uses are emptied in the wrong + # order. + if ( !$self->[_K_sequence_error_msg_] ) { + my $K_prev = $self->[_K_last_arrival_]; + if ( $K < $K_prev ) { + chomp $str; + if ( length($str) > 80 ) { + $str = substr( $str, 0, 80 ) . "..."; + } + + my $msg = <warning($msg); + + # Only issue this warning once + $self->[_K_sequence_error_msg_] = $msg; + + # stop here in DEVEL mode so this issue doesn't get missed + DEVEL_MODE && Perl::Tidy::Die($msg); + } + } + $self->[_K_last_arrival_] = $K; } - $self->write_line($a); return; } sub write_line { - my ( $self, $a ) = @_; + my ( $self, $str ) = @_; - # TODO: go through and see if the test is necessary here - if ( $a =~ /\n$/ ) { $self->{_output_line_number}++; } + $self->[_line_sink_object_]->write_line($str); - $self->{_line_sink_object}->write_line($a); + if ( chomp $str ) { $self->[_output_line_number_]++; } # This calculation of excess line length ignores any internal tabs - my $rOpts = $self->{_rOpts}; - my $exceed = length($a) - $rOpts->{'maximum-line-length'} - 1; - if ( $a =~ /^\t+/g ) { - $exceed += pos($a) * ( $rOpts->{'indent-columns'} - 1 ); + my $rOpts = $self->[_rOpts_]; + my $len_str = length($str); + my $exceed = $len_str - $rOpts->{'maximum-line-length'}; + if ( $str && substr( $str, 0, 1 ) eq "\t" && $str =~ /^\t+/g ) { + $exceed += pos($str) * $rOpts->{'indent-columns'}; } # Note that we just incremented output line number to future value # so we must subtract 1 for current line number - if ( length($a) > 1 + $self->{_max_output_line_length} ) { - $self->{_max_output_line_length} = length($a) - 1; - $self->{_max_output_line_length_at} = $self->{_output_line_number} - 1; + if ( $len_str > $self->[_max_output_line_length_] ) { + $self->[_max_output_line_length_] = $len_str; + $self->[_max_output_line_length_at_] = + $self->[_output_line_number_] - 1; } if ( $exceed > 0 ) { - my $output_line_number = $self->{_output_line_number}; - $self->{_last_line_length_error} = $exceed; - $self->{_last_line_length_error_at} = $output_line_number - 1; - if ( $self->{_line_length_error_count} == 0 ) { - $self->{_first_line_length_error} = $exceed; - $self->{_first_line_length_error_at} = $output_line_number - 1; + my $output_line_number = $self->[_output_line_number_]; + $self->[_last_line_length_error_] = $exceed; + $self->[_last_line_length_error_at_] = $output_line_number - 1; + if ( $self->[_line_length_error_count_] == 0 ) { + $self->[_first_line_length_error_] = $exceed; + $self->[_first_line_length_error_at_] = $output_line_number - 1; } - if ( - $self->{_last_line_length_error} > $self->{_max_line_length_error} ) + if ( $self->[_last_line_length_error_] > + $self->[_max_line_length_error_] ) { - $self->{_max_line_length_error} = $exceed; - $self->{_max_line_length_error_at} = $output_line_number - 1; + $self->[_max_line_length_error_] = $exceed; + $self->[_max_line_length_error_at_] = $output_line_number - 1; } - if ( $self->{_line_length_error_count} < $MAX_NAG_MESSAGES ) { + if ( $self->[_line_length_error_count_] < $MAX_NAG_MESSAGES ) { $self->write_logfile_entry( "Line length exceeded by $exceed characters\n"); } - $self->{_line_length_error_count}++; + $self->[_line_length_error_count_]++; } return; } sub report_line_length_errors { my $self = shift; - my $rOpts = $self->{_rOpts}; - my $line_length_error_count = $self->{_line_length_error_count}; + my $rOpts = $self->[_rOpts_]; + my $line_length_error_count = $self->[_line_length_error_count_]; if ( $line_length_error_count == 0 ) { $self->write_logfile_entry( "No lines exceeded $rOpts->{'maximum-line-length'} characters\n"); - my $max_output_line_length = $self->{_max_output_line_length}; - my $max_output_line_length_at = $self->{_max_output_line_length_at}; + my $max_output_line_length = $self->[_max_output_line_length_]; + my $max_output_line_length_at = $self->[_max_output_line_length_at_]; $self->write_logfile_entry( " Maximum output line length was $max_output_line_length at line $max_output_line_length_at\n" ); @@ -203,17 +354,18 @@ sub report_line_length_errors { ); $word = ( $line_length_error_count > 1 ) ? "First" : ""; - my $first_line_length_error = $self->{_first_line_length_error}; - my $first_line_length_error_at = $self->{_first_line_length_error_at}; + my $first_line_length_error = $self->[_first_line_length_error_]; + my $first_line_length_error_at = $self->[_first_line_length_error_at_]; $self->write_logfile_entry( " $word at line $first_line_length_error_at by $first_line_length_error characters\n" ); if ( $line_length_error_count > 1 ) { - my $max_line_length_error = $self->{_max_line_length_error}; - my $max_line_length_error_at = $self->{_max_line_length_error_at}; - my $last_line_length_error = $self->{_last_line_length_error}; - my $last_line_length_error_at = $self->{_last_line_length_error_at}; + my $max_line_length_error = $self->[_max_line_length_error_]; + my $max_line_length_error_at = $self->[_max_line_length_error_at_]; + my $last_line_length_error = $self->[_last_line_length_error_]; + my $last_line_length_error_at = + $self->[_last_line_length_error_at_]; $self->write_logfile_entry( " Maximum at line $max_line_length_error_at by $max_line_length_error characters\n" ); @@ -225,4 +377,3 @@ sub report_line_length_errors { return; } 1; -