Initial Commit
This commit is contained in:
Riley Schneider
361
database/perl/vendor/lib/Perl/Tidy/FileWriter.pm
vendored
Normal file
361
database/perl/vendor/lib/Perl/Tidy/FileWriter.pm
vendored
Normal file
@@ -0,0 +1,361 @@
|
||||
#####################################################################
|
||||
#
|
||||
# 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;
|
||||
Reference in New Issue
Block a user