lib/Perl/Tidy/Logger.pm

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