584 lines
19 KiB
Perl
584 lines
19 KiB
Perl
#####################################################################
|
|
#
|
|
# The Perl::Tidy::Logger class writes the .LOG and .ERR files
|
|
#
|
|
#####################################################################
|
|
|
|
package Perl::Tidy::Logger;
|
|
use strict;
|
|
use warnings;
|
|
our $VERSION = '20210111';
|
|
|
|
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
|
|
}
|
|
|
|
sub new {
|
|
|
|
my ( $class, @args ) = @_;
|
|
|
|
my %defaults = (
|
|
rOpts => undef,
|
|
log_file => undef,
|
|
warning_file => undef,
|
|
fh_stderr => undef,
|
|
saw_extruce => undef,
|
|
display_name => undef,
|
|
is_encoded_data => undef,
|
|
);
|
|
|
|
my %args = ( %defaults, @args );
|
|
|
|
my $rOpts = $args{rOpts};
|
|
my $log_file = $args{log_file};
|
|
my $warning_file = $args{warning_file};
|
|
my $fh_stderr = $args{fh_stderr};
|
|
my $saw_extrude = $args{saw_extrude};
|
|
my $display_name = $args{display_name};
|
|
my $is_encoded_data = $args{is_encoded_data};
|
|
|
|
my $fh_warnings = $rOpts->{'standard-error-output'} ? $fh_stderr : undef;
|
|
|
|
# remove any old error output file if we might write a new one
|
|
unless ( $fh_warnings || ref($warning_file) ) {
|
|
if ( -e $warning_file ) {
|
|
unlink($warning_file)
|
|
or Perl::Tidy::Die(
|
|
"couldn't unlink warning file $warning_file: $!\n");
|
|
}
|
|
}
|
|
|
|
my $logfile_gap =
|
|
defined( $rOpts->{'logfile-gap'} )
|
|
? $rOpts->{'logfile-gap'}
|
|
: 50;
|
|
if ( $logfile_gap == 0 ) { $logfile_gap = 1 }
|
|
|
|
my $filename_stamp = $display_name ? $display_name . ':' : "??";
|
|
my $input_stream_name = $display_name ? $display_name : "??";
|
|
return bless {
|
|
_log_file => $log_file,
|
|
_logfile_gap => $logfile_gap,
|
|
_rOpts => $rOpts,
|
|
_fh_warnings => $fh_warnings,
|
|
_last_input_line_written => 0,
|
|
_at_end_of_file => 0,
|
|
_use_prefix => 1,
|
|
_block_log_output => 0,
|
|
_line_of_tokens => undef,
|
|
_output_line_number => undef,
|
|
_wrote_line_information_string => 0,
|
|
_wrote_column_headings => 0,
|
|
_warning_file => $warning_file,
|
|
_warning_count => 0,
|
|
_complaint_count => 0,
|
|
_is_encoded_data => $is_encoded_data,
|
|
_saw_code_bug => -1, # -1=no 0=maybe 1=for sure
|
|
_saw_brace_error => 0,
|
|
_saw_extrude => $saw_extrude,
|
|
_output_array => [],
|
|
_input_stream_name => $input_stream_name,
|
|
_filename_stamp => $filename_stamp,
|
|
}, $class;
|
|
}
|
|
|
|
sub get_input_stream_name {
|
|
my $self = shift;
|
|
return $self->{_input_stream_name};
|
|
}
|
|
|
|
sub get_warning_count {
|
|
my $self = shift;
|
|
return $self->{_warning_count};
|
|
}
|
|
|
|
sub get_use_prefix {
|
|
my $self = shift;
|
|
return $self->{_use_prefix};
|
|
}
|
|
|
|
sub block_log_output {
|
|
my $self = shift;
|
|
$self->{_block_log_output} = 1;
|
|
return;
|
|
}
|
|
|
|
sub unblock_log_output {
|
|
my $self = shift;
|
|
$self->{_block_log_output} = 0;
|
|
return;
|
|
}
|
|
|
|
sub interrupt_logfile {
|
|
my $self = shift;
|
|
$self->{_use_prefix} = 0;
|
|
$self->warning("\n");
|
|
$self->write_logfile_entry( '#' x 24 . " WARNING " . '#' x 25 . "\n" );
|
|
return;
|
|
}
|
|
|
|
sub resume_logfile {
|
|
my $self = shift;
|
|
$self->write_logfile_entry( '#' x 60 . "\n" );
|
|
$self->{_use_prefix} = 1;
|
|
return;
|
|
}
|
|
|
|
sub we_are_at_the_last_line {
|
|
my $self = shift;
|
|
unless ( $self->{_wrote_line_information_string} ) {
|
|
$self->write_logfile_entry("Last line\n\n");
|
|
}
|
|
$self->{_at_end_of_file} = 1;
|
|
return;
|
|
}
|
|
|
|
# record some stuff in case we go down in flames
|
|
sub black_box {
|
|
my ( $self, $line_of_tokens, $output_line_number ) = @_;
|
|
my $input_line = $line_of_tokens->{_line_text};
|
|
my $input_line_number = $line_of_tokens->{_line_number};
|
|
|
|
# save line information in case we have to write a logfile message
|
|
$self->{_line_of_tokens} = $line_of_tokens;
|
|
$self->{_output_line_number} = $output_line_number;
|
|
$self->{_wrote_line_information_string} = 0;
|
|
|
|
my $last_input_line_written = $self->{_last_input_line_written};
|
|
if (
|
|
(
|
|
( $input_line_number - $last_input_line_written ) >=
|
|
$self->{_logfile_gap}
|
|
)
|
|
|| ( $input_line =~ /^\s*(sub|package)\s+(\w+)/ )
|
|
)
|
|
{
|
|
my $structural_indentation_level = $line_of_tokens->{_level_0};
|
|
$structural_indentation_level = 0
|
|
if ( $structural_indentation_level < 0 );
|
|
$self->{_last_input_line_written} = $input_line_number;
|
|
( my $out_str = $input_line ) =~ s/^\s*//;
|
|
chomp $out_str;
|
|
|
|
$out_str = ( '.' x $structural_indentation_level ) . $out_str;
|
|
|
|
if ( length($out_str) > 35 ) {
|
|
$out_str = substr( $out_str, 0, 35 ) . " ....";
|
|
}
|
|
$self->logfile_output( "", "$out_str\n" );
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub write_logfile_entry {
|
|
|
|
my ( $self, @msg ) = @_;
|
|
|
|
# add leading >>> to avoid confusing error messages and code
|
|
$self->logfile_output( ">>>", "@msg" );
|
|
return;
|
|
}
|
|
|
|
sub write_column_headings {
|
|
my $self = shift;
|
|
|
|
$self->{_wrote_column_headings} = 1;
|
|
my $routput_array = $self->{_output_array};
|
|
push @{$routput_array}, <<EOM;
|
|
The nesting depths in the table below are at the start of the lines.
|
|
The indicated output line numbers are not always exact.
|
|
ci = levels of continuation indentation; bk = 1 if in BLOCK, 0 if not.
|
|
|
|
in:out indent c b nesting code + messages; (messages begin with >>>)
|
|
lines levels i k (code begins with one '.' per indent level)
|
|
------ ----- - - -------- -------------------------------------------
|
|
EOM
|
|
return;
|
|
}
|
|
|
|
sub make_line_information_string {
|
|
|
|
# make columns of information when a logfile message needs to go out
|
|
my $self = shift;
|
|
my $line_of_tokens = $self->{_line_of_tokens};
|
|
my $input_line_number = $line_of_tokens->{_line_number};
|
|
my $line_information_string = "";
|
|
if ($input_line_number) {
|
|
|
|
my $output_line_number = $self->{_output_line_number};
|
|
my $brace_depth = $line_of_tokens->{_curly_brace_depth};
|
|
my $paren_depth = $line_of_tokens->{_paren_depth};
|
|
my $square_bracket_depth = $line_of_tokens->{_square_bracket_depth};
|
|
my $guessed_indentation_level =
|
|
$line_of_tokens->{_guessed_indentation_level};
|
|
|
|
my $structural_indentation_level = $line_of_tokens->{_level_0};
|
|
|
|
$self->write_column_headings() unless $self->{_wrote_column_headings};
|
|
|
|
# keep logfile columns aligned for scripts up to 999 lines;
|
|
# for longer scripts it doesn't really matter
|
|
my $extra_space = "";
|
|
$extra_space .=
|
|
( $input_line_number < 10 ) ? " "
|
|
: ( $input_line_number < 100 ) ? " "
|
|
: "";
|
|
$extra_space .=
|
|
( $output_line_number < 10 ) ? " "
|
|
: ( $output_line_number < 100 ) ? " "
|
|
: "";
|
|
|
|
# there are 2 possible nesting strings:
|
|
# the original which looks like this: (0 [1 {2
|
|
# the new one, which looks like this: {{[
|
|
# the new one is easier to read, and shows the order, but
|
|
# could be arbitrarily long, so we use it unless it is too long
|
|
my $nesting_string =
|
|
"($paren_depth [$square_bracket_depth {$brace_depth";
|
|
my $nesting_string_new = $line_of_tokens->{_nesting_tokens_0};
|
|
my $ci_level = $line_of_tokens->{_ci_level_0};
|
|
if ( $ci_level > 9 ) { $ci_level = '*' }
|
|
my $bk = ( $line_of_tokens->{_nesting_blocks_0} =~ /1$/ ) ? '1' : '0';
|
|
|
|
if ( length($nesting_string_new) <= 8 ) {
|
|
$nesting_string =
|
|
$nesting_string_new . " " x ( 8 - length($nesting_string_new) );
|
|
}
|
|
$line_information_string =
|
|
"L$input_line_number:$output_line_number$extra_space i$guessed_indentation_level:$structural_indentation_level $ci_level $bk $nesting_string";
|
|
}
|
|
return $line_information_string;
|
|
}
|
|
|
|
sub logfile_output {
|
|
my ( $self, $prompt, $msg ) = @_;
|
|
return if ( $self->{_block_log_output} );
|
|
|
|
my $routput_array = $self->{_output_array};
|
|
if ( $self->{_at_end_of_file} || !$self->{_use_prefix} ) {
|
|
push @{$routput_array}, "$msg";
|
|
}
|
|
else {
|
|
my $line_information_string = $self->make_line_information_string();
|
|
$self->{_wrote_line_information_string} = 1;
|
|
|
|
if ($line_information_string) {
|
|
push @{$routput_array}, "$line_information_string $prompt$msg";
|
|
}
|
|
else {
|
|
push @{$routput_array}, "$msg";
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub get_saw_brace_error {
|
|
my $self = shift;
|
|
return $self->{_saw_brace_error};
|
|
}
|
|
|
|
sub increment_brace_error {
|
|
my $self = shift;
|
|
$self->{_saw_brace_error}++;
|
|
return;
|
|
}
|
|
|
|
sub brace_warning {
|
|
my ( $self, $msg ) = @_;
|
|
|
|
#use constant BRACE_WARNING_LIMIT => 10;
|
|
my $BRACE_WARNING_LIMIT = 10;
|
|
my $saw_brace_error = $self->{_saw_brace_error};
|
|
|
|
if ( $saw_brace_error < $BRACE_WARNING_LIMIT ) {
|
|
$self->warning($msg);
|
|
}
|
|
$saw_brace_error++;
|
|
$self->{_saw_brace_error} = $saw_brace_error;
|
|
|
|
if ( $saw_brace_error == $BRACE_WARNING_LIMIT ) {
|
|
$self->warning("No further warnings of this type will be given\n");
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub complain {
|
|
|
|
# handle non-critical warning messages based on input flag
|
|
my ( $self, $msg ) = @_;
|
|
my $rOpts = $self->{_rOpts};
|
|
|
|
# these appear in .ERR output only if -w flag is used
|
|
if ( $rOpts->{'warning-output'} ) {
|
|
$self->warning($msg);
|
|
}
|
|
|
|
# otherwise, they go to the .LOG file
|
|
else {
|
|
$self->{_complaint_count}++;
|
|
$self->write_logfile_entry($msg);
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub warning {
|
|
|
|
# report errors to .ERR file (or stdout)
|
|
my ( $self, $msg ) = @_;
|
|
|
|
#use constant WARNING_LIMIT => 50;
|
|
my $WARNING_LIMIT = 50;
|
|
|
|
# Always bump the warn count, even if no message goes out
|
|
Perl::Tidy::Warn_count_bump();
|
|
|
|
my $rOpts = $self->{_rOpts};
|
|
unless ( $rOpts->{'quiet'} ) {
|
|
|
|
my $warning_count = $self->{_warning_count};
|
|
my $fh_warnings = $self->{_fh_warnings};
|
|
my $is_encoded_data = $self->{_is_encoded_data};
|
|
if ( !$fh_warnings ) {
|
|
my $warning_file = $self->{_warning_file};
|
|
( $fh_warnings, my $filename ) =
|
|
Perl::Tidy::streamhandle( $warning_file, 'w', $is_encoded_data );
|
|
$fh_warnings or Perl::Tidy::Die("couldn't open $filename $!\n");
|
|
Perl::Tidy::Warn_msg("## Please see file $filename\n")
|
|
unless ref($warning_file);
|
|
$self->{_fh_warnings} = $fh_warnings;
|
|
$fh_warnings->print("Perltidy version is $Perl::Tidy::VERSION\n");
|
|
}
|
|
|
|
my $filename_stamp = $self->{_filename_stamp};
|
|
|
|
if ( $warning_count < $WARNING_LIMIT ) {
|
|
|
|
if ( !$warning_count ) {
|
|
|
|
# On first error always write a line with the filename. Note
|
|
# that the filename will be 'perltidy' if input is from stdin
|
|
# or from a data structure.
|
|
if ($filename_stamp) {
|
|
$fh_warnings->print(
|
|
"\n$filename_stamp Begin Error Output Stream\n");
|
|
}
|
|
|
|
# Turn off filename stamping unless error output is directed
|
|
# to the standard error output (with -se flag)
|
|
if ( !$rOpts->{'standard-error-output'} ) {
|
|
$filename_stamp = "";
|
|
$self->{_filename_stamp} = $filename_stamp;
|
|
}
|
|
}
|
|
|
|
if ( $self->get_use_prefix() > 0 ) {
|
|
$self->write_logfile_entry("WARNING: $msg");
|
|
|
|
# add prefix 'filename:line_no: ' to message lines
|
|
my $input_line_number =
|
|
Perl::Tidy::Tokenizer::get_input_line_number();
|
|
if ( !defined($input_line_number) ) { $input_line_number = -1 }
|
|
my $pre_string = $filename_stamp . $input_line_number . ': ';
|
|
chomp $msg;
|
|
$msg =~ s/\n/\n$pre_string/g;
|
|
$msg = $pre_string . $msg . "\n";
|
|
|
|
$fh_warnings->print($msg);
|
|
|
|
}
|
|
else {
|
|
$self->write_logfile_entry($msg);
|
|
|
|
# add prefix 'filename: ' to message lines
|
|
if ($filename_stamp) {
|
|
my $pre_string = $filename_stamp . " ";
|
|
chomp $msg;
|
|
$msg =~ s/\n/\n$pre_string/g;
|
|
$msg = $pre_string . $msg . "\n";
|
|
}
|
|
|
|
$fh_warnings->print($msg);
|
|
}
|
|
}
|
|
$warning_count++;
|
|
$self->{_warning_count} = $warning_count;
|
|
|
|
if ( $warning_count == $WARNING_LIMIT ) {
|
|
$fh_warnings->print(
|
|
$filename_stamp . "No further warnings will be given\n" );
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
# programming bug codes:
|
|
# -1 = no bug
|
|
# 0 = maybe, not sure.
|
|
# 1 = definitely
|
|
sub report_possible_bug {
|
|
my $self = shift;
|
|
my $saw_code_bug = $self->{_saw_code_bug};
|
|
$self->{_saw_code_bug} = ( $saw_code_bug < 0 ) ? 0 : $saw_code_bug;
|
|
return;
|
|
}
|
|
|
|
sub report_definite_bug {
|
|
my $self = shift;
|
|
$self->{_saw_code_bug} = 1;
|
|
return;
|
|
}
|
|
|
|
sub ask_user_for_bug_report {
|
|
|
|
my ( $self, $infile_syntax_ok, $formatter ) = @_;
|
|
my $saw_code_bug = $self->{_saw_code_bug};
|
|
if ( ( $saw_code_bug == 0 ) && ( $infile_syntax_ok == 1 ) ) {
|
|
$self->warning(<<EOM);
|
|
|
|
You may have encountered a code bug in perltidy. If you think so, and
|
|
the problem is not listed in the BUGS file at
|
|
http://perltidy.sourceforge.net, please report it so that it can be
|
|
corrected. Include the smallest possible script which has the problem,
|
|
along with the .LOG file. See the manual pages for contact information.
|
|
Thank you!
|
|
EOM
|
|
|
|
}
|
|
elsif ( $saw_code_bug == 1 ) {
|
|
if ( $self->{_saw_extrude} ) {
|
|
$self->warning(<<EOM);
|
|
|
|
You may have encountered a bug in perltidy. However, since you are using the
|
|
-extrude option, the problem may be with perl or one of its modules, which have
|
|
occasional problems with this type of file. If you believe that the
|
|
problem is with perltidy, and the problem is not listed in the BUGS file at
|
|
http://perltidy.sourceforge.net, please report it so that it can be corrected.
|
|
Include the smallest possible script which has the problem, along with the .LOG
|
|
file. See the manual pages for contact information.
|
|
Thank you!
|
|
EOM
|
|
}
|
|
else {
|
|
$self->warning(<<EOM);
|
|
|
|
Oops, you seem to have encountered a bug in perltidy. Please check the
|
|
BUGS file at http://perltidy.sourceforge.net. If the problem is not
|
|
listed there, please report it so that it can be corrected. Include the
|
|
smallest possible script which produces this message, along with the
|
|
.LOG file if appropriate. See the manual pages for contact information.
|
|
Your efforts are appreciated.
|
|
Thank you!
|
|
EOM
|
|
my $added_semicolon_count = 0;
|
|
eval {
|
|
$added_semicolon_count =
|
|
$formatter->get_added_semicolon_count();
|
|
};
|
|
if ( $added_semicolon_count > 0 ) {
|
|
$self->warning(<<EOM);
|
|
|
|
The log file shows that perltidy added $added_semicolon_count semicolons.
|
|
Please rerun with -nasc to see if that is the cause of the syntax error. Even
|
|
if that is the problem, please report it so that it can be fixed.
|
|
EOM
|
|
|
|
}
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub get_save_logfile {
|
|
|
|
# To be called after tokenizer has finished to make formatting more
|
|
# efficient. This is not precisely the same as the check used below
|
|
# because we don't yet have the syntax check result, but since syntax
|
|
# checking is off by default it will be the same except in debug runs with
|
|
# syntax checking activated. In that case it will tell the formatter to
|
|
# save the logfile even if it may actually be deleted based on the syntax
|
|
# check.
|
|
my $self = shift;
|
|
my $saw_code_bug = $self->{_saw_code_bug};
|
|
my $rOpts = $self->{_rOpts};
|
|
return
|
|
$saw_code_bug == 1
|
|
|| $rOpts->{'logfile'}
|
|
|| $rOpts->{'check-syntax'};
|
|
}
|
|
|
|
sub finish {
|
|
|
|
# called after all formatting to summarize errors
|
|
my ( $self, $infile_syntax_ok, $formatter ) = @_;
|
|
|
|
my $rOpts = $self->{_rOpts};
|
|
my $warning_count = $self->{_warning_count};
|
|
my $saw_code_bug = $self->{_saw_code_bug};
|
|
|
|
my $save_logfile =
|
|
( $saw_code_bug == 0 && $infile_syntax_ok == 1 )
|
|
|| $saw_code_bug == 1
|
|
|| $rOpts->{'logfile'};
|
|
my $log_file = $self->{_log_file};
|
|
if ($warning_count) {
|
|
if ($save_logfile) {
|
|
$self->block_log_output(); # avoid echoing this to the logfile
|
|
$self->warning(
|
|
"The logfile $log_file may contain useful information\n");
|
|
$self->unblock_log_output();
|
|
}
|
|
|
|
if ( $self->{_complaint_count} > 0 ) {
|
|
$self->warning(
|
|
"To see $self->{_complaint_count} non-critical warnings rerun with -w\n"
|
|
);
|
|
}
|
|
|
|
if ( $self->{_saw_brace_error}
|
|
&& ( $self->{_logfile_gap} > 1 || !$save_logfile ) )
|
|
{
|
|
$self->warning("To save a full .LOG file rerun with -g\n");
|
|
}
|
|
}
|
|
$self->ask_user_for_bug_report( $infile_syntax_ok, $formatter );
|
|
|
|
if ($save_logfile) {
|
|
my $log_file = $self->{_log_file};
|
|
my $is_encoded_data = $self->{_is_encoded_data};
|
|
my ( $fh, $filename ) =
|
|
Perl::Tidy::streamhandle( $log_file, 'w', $is_encoded_data );
|
|
if ($fh) {
|
|
my $routput_array = $self->{_output_array};
|
|
foreach ( @{$routput_array} ) { $fh->print($_) }
|
|
if ( $log_file ne '-' && !ref $log_file ) {
|
|
eval { $fh->close() };
|
|
}
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
1;
|
|
|