lib/Perl/Tidy/Logger.pm

   1 #####################################################################
   2 #
   3 # The Perl::Tidy::Logger class writes the .LOG and .ERR files
   4 #
   5 #####################################################################
   6
   7 package Perl::Tidy::Logger;
   8 use strict;
   9 use warnings;
  10 our $VERSION = '20220613';
  11 use English qw( -no_match_vars );
  12
  13 use constant EMPTY_STRING => q{};
  14 use constant SPACE        => q{ };
  15
  16 sub AUTOLOAD {
  17
  18     # Catch any undefined sub calls so that we are sure to get
  19     # some diagnostic information.  This sub should never be called
  20     # except for a programming error.
  21     our $AUTOLOAD;
  22     return if ( $AUTOLOAD =~ /\bDESTROY$/ );
  23     my ( $pkg, $fname, $lno ) = caller();
  24     my $my_package = __PACKAGE__;
  25     print STDERR <<EOM;
  26 ======================================================================
  27 Error detected in package '$my_package', version $VERSION
  28 Received unexpected AUTOLOAD call for sub '$AUTOLOAD'
  29 Called from package: '$pkg'
  30 Called from File '$fname'  at line '$lno'
  31 This error is probably due to a recent programming change
  32 ======================================================================
  33 EOM
  34     exit 1;
  35 }
  36
  37 sub DESTROY {
  38
  39     # required to avoid call to AUTOLOAD in some versions of perl
  40 }
  41
  42 use constant DEFAULT_LOGFILE_GAP => 50;
  43
  44 sub new {
  45
  46     my ( $class, @args ) = @_;
  47
  48     my %defaults = (
  49         rOpts           => undef,
  50         log_file        => undef,
  51         warning_file    => undef,
  52         fh_stderr       => undef,
  53         display_name    => undef,
  54         is_encoded_data => undef,
  55     );
  56
  57     my %args = ( %defaults, @args );
  58
  59     my $rOpts           = $args{rOpts};
  60     my $log_file        = $args{log_file};
  61     my $warning_file    = $args{warning_file};
  62     my $fh_stderr       = $args{fh_stderr};
  63     my $display_name    = $args{display_name};
  64     my $is_encoded_data = $args{is_encoded_data};
  65
  66     my $fh_warnings = $rOpts->{'standard-error-output'} ? $fh_stderr : undef;
  67
  68     # remove any old error output file if we might write a new one
  69     unless ( $fh_warnings || ref($warning_file) ) {
  70         if ( -e $warning_file ) {
  71             unlink($warning_file)
  72               or Perl::Tidy::Die(
  73                 "couldn't unlink warning file $warning_file: $ERRNO\n");
  74         }
  75     }
  76
  77     my $logfile_gap =
  78       defined( $rOpts->{'logfile-gap'} )
  79       ? $rOpts->{'logfile-gap'}
  80       : DEFAULT_LOGFILE_GAP;
  81     if ( $logfile_gap == 0 ) { $logfile_gap = 1 }
  82
  83     my $filename_stamp    = $display_name ? $display_name . ':' : "??";
  84     my $input_stream_name = $display_name ? $display_name       : "??";
  85     return bless {
  86         _log_file                      => $log_file,
  87         _logfile_gap                   => $logfile_gap,
  88         _rOpts                         => $rOpts,
  89         _fh_warnings                   => $fh_warnings,
  90         _last_input_line_written       => 0,
  91         _at_end_of_file                => 0,
  92         _use_prefix                    => 1,
  93         _block_log_output              => 0,
  94         _line_of_tokens                => undef,
  95         _output_line_number            => undef,
  96         _wrote_line_information_string => 0,
  97         _wrote_column_headings         => 0,
  98         _warning_file                  => $warning_file,
  99         _warning_count                 => 0,
 100         _complaint_count               => 0,
 101         _is_encoded_data               => $is_encoded_data,
 102         _saw_code_bug      => -1,                   # -1=no 0=maybe 1=for sure
 103         _saw_brace_error   => 0,
 104         _output_array      => [],
 105         _input_stream_name => $input_stream_name,
 106         _filename_stamp    => $filename_stamp,
 107     }, $class;
 108 }
 109
 110 sub get_input_stream_name {
 111     my $self = shift;
 112     return $self->{_input_stream_name};
 113 }
 114
 115 sub get_warning_count {
 116     my $self = shift;
 117     return $self->{_warning_count};
 118 }
 119
 120 sub get_use_prefix {
 121     my $self = shift;
 122     return $self->{_use_prefix};
 123 }
 124
 125 sub block_log_output {
 126     my $self = shift;
 127     $self->{_block_log_output} = 1;
 128     return;
 129 }
 130
 131 sub unblock_log_output {
 132     my $self = shift;
 133     $self->{_block_log_output} = 0;
 134     return;
 135 }
 136
 137 sub interrupt_logfile {
 138     my $self = shift;
 139     $self->{_use_prefix} = 0;
 140     $self->warning("\n");
 141     $self->write_logfile_entry( '#' x 24 . "  WARNING  " . '#' x 25 . "\n" );
 142     return;
 143 }
 144
 145 sub resume_logfile {
 146     my $self = shift;
 147     $self->write_logfile_entry( '#' x 60 . "\n" );
 148     $self->{_use_prefix} = 1;
 149     return;
 150 }
 151
 152 sub we_are_at_the_last_line {
 153     my $self = shift;
 154     unless ( $self->{_wrote_line_information_string} ) {
 155         $self->write_logfile_entry("Last line\n\n");
 156     }
 157     $self->{_at_end_of_file} = 1;
 158     return;
 159 }
 160
 161 # record some stuff in case we go down in flames
 162 use constant MAX_PRINTED_CHARS => 35;
 163
 164 sub black_box {
 165     my ( $self, $line_of_tokens, $output_line_number ) = @_;
 166     my $input_line        = $line_of_tokens->{_line_text};
 167     my $input_line_number = $line_of_tokens->{_line_number};
 168
 169     # save line information in case we have to write a logfile message
 170     $self->{_line_of_tokens}                = $line_of_tokens;
 171     $self->{_output_line_number}            = $output_line_number;
 172     $self->{_wrote_line_information_string} = 0;
 173
 174     my $last_input_line_written = $self->{_last_input_line_written};
 175     if (
 176         (
 177             ( $input_line_number - $last_input_line_written ) >=
 178             $self->{_logfile_gap}
 179         )
 180         || ( $input_line =~ /^\s*(sub|package)\s+(\w+)/ )
 181       )
 182     {
 183         my $structural_indentation_level = $line_of_tokens->{_level_0};
 184         $structural_indentation_level = 0
 185           if ( $structural_indentation_level < 0 );
 186         $self->{_last_input_line_written} = $input_line_number;
 187         ( my $out_str = $input_line ) =~ s/^\s*//;
 188         chomp $out_str;
 189
 190         $out_str = ( '.' x $structural_indentation_level ) . $out_str;
 191
 192         if ( length($out_str) > MAX_PRINTED_CHARS ) {
 193             $out_str = substr( $out_str, 0, MAX_PRINTED_CHARS ) . " ....";
 194         }
 195         $self->logfile_output( EMPTY_STRING, "$out_str\n" );
 196     }
 197     return;
 198 }
 199
 200 sub write_logfile_entry {
 201
 202     my ( $self, @msg ) = @_;
 203
 204     # add leading >>> to avoid confusing error messages and code
 205     $self->logfile_output( ">>>", "@msg" );
 206     return;
 207 }
 208
 209 sub write_column_headings {
 210     my $self = shift;
 211
 212     $self->{_wrote_column_headings} = 1;
 213     my $routput_array = $self->{_output_array};
 214     push @{$routput_array}, <<EOM;
 215
 216 Starting formatting pass...
 217 The nesting depths in the table below are at the start of the lines.
 218 The indicated output line numbers are not always exact.
 219 ci = levels of continuation indentation; bk = 1 if in BLOCK, 0 if not.
 220
 221 in:out indent c b  nesting   code + messages; (messages begin with >>>)
 222 lines  levels i k            (code begins with one '.' per indent level)
 223 ------  ----- - - --------   -------------------------------------------
 224 EOM
 225     return;
 226 }
 227
 228 sub make_line_information_string {
 229
 230     # make columns of information when a logfile message needs to go out
 231     my $self                    = shift;
 232     my $line_of_tokens          = $self->{_line_of_tokens};
 233     my $input_line_number       = $line_of_tokens->{_line_number};
 234     my $line_information_string = EMPTY_STRING;
 235     if ($input_line_number) {
 236
 237         my $output_line_number   = $self->{_output_line_number};
 238         my $brace_depth          = $line_of_tokens->{_curly_brace_depth};
 239         my $paren_depth          = $line_of_tokens->{_paren_depth};
 240         my $square_bracket_depth = $line_of_tokens->{_square_bracket_depth};
 241         my $guessed_indentation_level =
 242           $line_of_tokens->{_guessed_indentation_level};
 243
 244         my $structural_indentation_level = $line_of_tokens->{_level_0};
 245
 246         $self->write_column_headings() unless $self->{_wrote_column_headings};
 247
 248         # keep logfile columns aligned for scripts up to 999 lines;
 249         # for longer scripts it doesn't really matter
 250         my $extra_space = EMPTY_STRING;
 251         $extra_space .=
 252             ( $input_line_number < 10 )  ? SPACE x 2
 253           : ( $input_line_number < 100 ) ? SPACE
 254           :                                EMPTY_STRING;
 255         $extra_space .=
 256             ( $output_line_number < 10 )  ? SPACE x 2
 257           : ( $output_line_number < 100 ) ? SPACE
 258           :                                 EMPTY_STRING;
 259
 260         # there are 2 possible nesting strings:
 261         # the original which looks like this:  (0 [1 {2
 262         # the new one, which looks like this:  {{[
 263         # the new one is easier to read, and shows the order, but
 264         # could be arbitrarily long, so we use it unless it is too long
 265         my $nesting_string =
 266           "($paren_depth [$square_bracket_depth {$brace_depth";
 267         my $nesting_string_new = $line_of_tokens->{_nesting_tokens_0};
 268         my $ci_level           = $line_of_tokens->{_ci_level_0};
 269         if ( $ci_level > 9 ) { $ci_level = '*' }
 270         my $bk = ( $line_of_tokens->{_nesting_blocks_0} =~ /1$/ ) ? '1' : '0';
 271
 272         if ( length($nesting_string_new) <= 8 ) {
 273             $nesting_string =
 274               $nesting_string_new . SPACE x ( 8 - length($nesting_string_new) );
 275         }
 276         $line_information_string =
 277 "L$input_line_number:$output_line_number$extra_space i$guessed_indentation_level:$structural_indentation_level $ci_level $bk $nesting_string";
 278     }
 279     return $line_information_string;
 280 }
 281
 282 sub logfile_output {
 283     my ( $self, $prompt, $msg ) = @_;
 284     return if ( $self->{_block_log_output} );
 285
 286     my $routput_array = $self->{_output_array};
 287     if ( $self->{_at_end_of_file} || !$self->{_use_prefix} ) {
 288         push @{$routput_array}, "$msg";
 289     }
 290     else {
 291         my $line_information_string = $self->make_line_information_string();
 292         $self->{_wrote_line_information_string} = 1;
 293
 294         if ($line_information_string) {
 295             push @{$routput_array}, "$line_information_string   $prompt$msg";
 296         }
 297         else {
 298             push @{$routput_array}, "$msg";
 299         }
 300     }
 301     return;
 302 }
 303
 304 sub get_saw_brace_error {
 305     my $self = shift;
 306     return $self->{_saw_brace_error};
 307 }
 308
 309 sub increment_brace_error {
 310     my $self = shift;
 311     $self->{_saw_brace_error}++;
 312     return;
 313 }
 314
 315 sub brace_warning {
 316     my ( $self, $msg ) = @_;
 317
 318     use constant BRACE_WARNING_LIMIT => 10;
 319     my $saw_brace_error = $self->{_saw_brace_error};
 320
 321     if ( $saw_brace_error < BRACE_WARNING_LIMIT ) {
 322         $self->warning($msg);
 323     }
 324     $saw_brace_error++;
 325     $self->{_saw_brace_error} = $saw_brace_error;
 326
 327     if ( $saw_brace_error == BRACE_WARNING_LIMIT ) {
 328         $self->warning("No further warnings of this type will be given\n");
 329     }
 330     return;
 331 }
 332
 333 sub complain {
 334
 335     # handle non-critical warning messages based on input flag
 336     my ( $self, $msg ) = @_;
 337     my $rOpts = $self->{_rOpts};
 338
 339     # these appear in .ERR output only if -w flag is used
 340     if ( $rOpts->{'warning-output'} ) {
 341         $self->warning($msg);
 342     }
 343
 344     # otherwise, they go to the .LOG file
 345     else {
 346         $self->{_complaint_count}++;
 347         $self->write_logfile_entry($msg);
 348     }
 349     return;
 350 }
 351
 352 sub warning {
 353
 354     # report errors to .ERR file (or stdout)
 355     my ( $self, $msg ) = @_;
 356
 357     use constant WARNING_LIMIT => 50;
 358
 359     # Always bump the warn count, even if no message goes out
 360     Perl::Tidy::Warn_count_bump();
 361
 362     my $rOpts = $self->{_rOpts};
 363     unless ( $rOpts->{'quiet'} ) {
 364
 365         my $warning_count   = $self->{_warning_count};
 366         my $fh_warnings     = $self->{_fh_warnings};
 367         my $is_encoded_data = $self->{_is_encoded_data};
 368         if ( !$fh_warnings ) {
 369             my $warning_file = $self->{_warning_file};
 370             ( $fh_warnings, my $filename ) =
 371               Perl::Tidy::streamhandle( $warning_file, 'w', $is_encoded_data );
 372             $fh_warnings
 373               or Perl::Tidy::Die("couldn't open $filename: $ERRNO\n");
 374             Perl::Tidy::Warn_msg("## Please see file $filename\n")
 375               unless ref($warning_file);
 376             $self->{_fh_warnings} = $fh_warnings;
 377             $fh_warnings->print("Perltidy version is $Perl::Tidy::VERSION\n");
 378         }
 379
 380         my $filename_stamp = $self->{_filename_stamp};
 381
 382         if ( $warning_count < WARNING_LIMIT ) {
 383
 384             if ( !$warning_count ) {
 385
 386                 # On first error always write a line with the filename.  Note
 387                 # that the filename will be 'perltidy' if input is from stdin
 388                 # or from a data structure.
 389                 if ($filename_stamp) {
 390                     $fh_warnings->print(
 391                         "\n$filename_stamp Begin Error Output Stream\n");
 392                 }
 393
 394                 # Turn off filename stamping unless error output is directed
 395                 # to the standard error output (with -se flag)
 396                 if ( !$rOpts->{'standard-error-output'} ) {
 397                     $filename_stamp = EMPTY_STRING;
 398                     $self->{_filename_stamp} = $filename_stamp;
 399                 }
 400             }
 401
 402             if ( $self->get_use_prefix() > 0 ) {
 403                 $self->write_logfile_entry("WARNING: $msg");
 404
 405                 # add prefix 'filename:line_no: ' to message lines
 406                 my $input_line_number =
 407                   Perl::Tidy::Tokenizer::get_input_line_number();
 408                 if ( !defined($input_line_number) ) { $input_line_number = -1 }
 409                 my $pre_string = $filename_stamp . $input_line_number . ': ';
 410                 chomp $msg;
 411                 $msg =~ s/\n/\n$pre_string/g;
 412                 $msg = $pre_string . $msg . "\n";
 413
 414                 $fh_warnings->print($msg);
 415
 416             }
 417             else {
 418                 $self->write_logfile_entry($msg);
 419
 420                 # add prefix 'filename: ' to message lines
 421                 if ($filename_stamp) {
 422                     my $pre_string = $filename_stamp . SPACE;
 423                     chomp $msg;
 424                     $msg =~ s/\n/\n$pre_string/g;
 425                     $msg = $pre_string . $msg . "\n";
 426                 }
 427
 428                 $fh_warnings->print($msg);
 429             }
 430         }
 431         $warning_count++;
 432         $self->{_warning_count} = $warning_count;
 433
 434         if ( $warning_count == WARNING_LIMIT ) {
 435             $fh_warnings->print(
 436                 $filename_stamp . "No further warnings will be given\n" );
 437         }
 438     }
 439     return;
 440 }
 441
 442 sub report_definite_bug {
 443     my $self = shift;
 444     $self->{_saw_code_bug} = 1;
 445     return;
 446 }
 447
 448 sub get_save_logfile {
 449
 450     # To be called after tokenizer has finished to make formatting more
 451     # efficient.
 452     my $self         = shift;
 453     my $saw_code_bug = $self->{_saw_code_bug};
 454     my $rOpts        = $self->{_rOpts};
 455     return $saw_code_bug == 1 || $rOpts->{'logfile'};
 456 }
 457
 458 sub finish {
 459
 460     # called after all formatting to summarize errors
 461     my ( $self, $formatter ) = @_;
 462
 463     my $rOpts         = $self->{_rOpts};
 464     my $warning_count = $self->{_warning_count};
 465     my $saw_code_bug  = $self->{_saw_code_bug};
 466
 467     my $save_logfile = $saw_code_bug == 1
 468       || $rOpts->{'logfile'};
 469     my $log_file = $self->{_log_file};
 470     if ($warning_count) {
 471         if ($save_logfile) {
 472             $self->block_log_output();    # avoid echoing this to the logfile
 473             $self->warning(
 474                 "The logfile $log_file may contain useful information\n");
 475             $self->unblock_log_output();
 476         }
 477
 478         if ( $self->{_complaint_count} > 0 ) {
 479             $self->warning(
 480 "To see $self->{_complaint_count} non-critical warnings rerun with -w\n"
 481             );
 482         }
 483
 484         if ( $self->{_saw_brace_error}
 485             && ( $self->{_logfile_gap} > 1 || !$save_logfile ) )
 486         {
 487             $self->warning("To save a full .LOG file rerun with -g\n");
 488         }
 489     }
 490
 491     if ($save_logfile) {
 492         my $is_encoded_data = $self->{_is_encoded_data};
 493         my ( $fh, $filename ) =
 494           Perl::Tidy::streamhandle( $log_file, 'w', $is_encoded_data );
 495         if ($fh) {
 496             my $routput_array = $self->{_output_array};
 497             foreach my $line ( @{$routput_array} ) { $fh->print($line) }
 498             if ( $log_file ne '-' && !ref $log_file ) {
 499                 eval { $fh->close() };
 500             }
 501         }
 502     }
 503     return;
 504 }
 505 1;
 506