362 lines
12 KiB
Perl
362 lines
12 KiB
Perl
#####################################################################
|
|
#
|
|
# the Perl::Tidy::FileWriter class writes the output file
|
|
#
|
|
#####################################################################
|
|
|
|
package Perl::Tidy::FileWriter;
|
|
use strict;
|
|
use warnings;
|
|
our $VERSION = '20210111';
|
|
|
|
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 <<EOM;
|
|
======================================================================
|
|
Error detected in package '$my_package', version $VERSION
|
|
Received unexpected AUTOLOAD call for sub '$AUTOLOAD'
|
|
Called from package: '$pkg'
|
|
Called from File '$fname' at line '$lno'
|
|
This error is probably due to a recent programming change
|
|
======================================================================
|
|
EOM
|
|
exit 1;
|
|
}
|
|
|
|
sub DESTROY {
|
|
|
|
# required to avoid call to AUTOLOAD in some versions of perl
|
|
}
|
|
|
|
my $input_stream_name = "";
|
|
|
|
# Maximum number of little messages; probably need not be changed.
|
|
my $MAX_NAG_MESSAGES = 6;
|
|
|
|
BEGIN {
|
|
|
|
# Array index names for variables
|
|
my $i = 0;
|
|
use constant {
|
|
_line_sink_object_ => $i++,
|
|
_logger_object_ => $i++,
|
|
_rOpts_ => $i++,
|
|
_output_line_number_ => $i++,
|
|
_consecutive_blank_lines_ => $i++,
|
|
_consecutive_nonblank_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_];
|
|
if ($logger_object) {
|
|
$logger_object->write_logfile_entry($msg);
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub new {
|
|
my ( $class, $line_sink_object, $rOpts, $logger_object ) = @_;
|
|
|
|
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->[_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 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 {
|
|
return $_[0]->[_output_line_number_];
|
|
}
|
|
|
|
sub decrement_output_line_number {
|
|
$_[0]->[_output_line_number_]--;
|
|
return;
|
|
}
|
|
|
|
sub get_consecutive_nonblank_lines {
|
|
return $_[0]->[_consecutive_nonblank_lines_];
|
|
}
|
|
|
|
sub reset_consecutive_blank_lines {
|
|
$_[0]->[_consecutive_blank_lines_] = 0;
|
|
return;
|
|
}
|
|
|
|
sub want_blank_line {
|
|
my $self = shift;
|
|
unless ( $self->[_consecutive_blank_lines_] ) {
|
|
$self->write_blank_code_line();
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub require_blank_code_lines {
|
|
|
|
# write out the requested number of blanks regardless of the value of -mbl
|
|
# 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 $forced = $rOpts->{'maximum-consecutive-blank-lines'} > 0;
|
|
foreach my $i ( 0 .. $need - 1 ) {
|
|
$self->write_blank_code_line($forced);
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub write_blank_code_line {
|
|
my $self = shift;
|
|
my $forced = shift;
|
|
my $rOpts = $self->[_rOpts_];
|
|
return
|
|
if (!$forced
|
|
&& $self->[_consecutive_blank_lines_] >=
|
|
$rOpts->{'maximum-consecutive-blank-lines'} );
|
|
$self->[_consecutive_blank_lines_]++;
|
|
$self->[_consecutive_nonblank_lines_] = 0;
|
|
$self->write_line("\n");
|
|
return;
|
|
}
|
|
|
|
sub write_code_line {
|
|
my ( $self, $str, $K ) = @_;
|
|
|
|
$self->[_consecutive_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 = <<EOM;
|
|
While operating on input stream with name: '$input_stream_name'
|
|
Lines have arrived out of order in sub 'write_code_line'
|
|
as detected by token index K=$K arriving after index K=$K_prev in the following line:
|
|
$str
|
|
This is probably due to a recent programming change and needs to be fixed.
|
|
EOM
|
|
|
|
# FIXME: it would be best to set a 'severe_error' flag here and
|
|
# tell caller to output the original file
|
|
$self->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;
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub write_line {
|
|
my ( $self, $str ) = @_;
|
|
|
|
$self->[_line_sink_object_]->write_line($str);
|
|
|
|
if ( chomp $str ) { $self->[_output_line_number_]++; }
|
|
|
|
# This calculation of excess line length ignores any internal tabs
|
|
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 ( $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;
|
|
}
|
|
|
|
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;
|
|
}
|
|
|
|
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_]++;
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub report_line_length_errors {
|
|
my $self = shift;
|
|
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_];
|
|
$self->write_logfile_entry(
|
|
" Maximum output line length was $max_output_line_length at line $max_output_line_length_at\n"
|
|
);
|
|
|
|
}
|
|
else {
|
|
|
|
my $word = ( $line_length_error_count > 1 ) ? "s" : "";
|
|
$self->write_logfile_entry(
|
|
"$line_length_error_count output line$word exceeded $rOpts->{'maximum-line-length'} characters:\n"
|
|
);
|
|
|
|
$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_];
|
|
$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_];
|
|
$self->write_logfile_entry(
|
|
" Maximum at line $max_line_length_error_at by $max_line_length_error characters\n"
|
|
);
|
|
$self->write_logfile_entry(
|
|
" Last at line $last_line_length_error_at by $last_line_length_error characters\n"
|
|
);
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
1;
|