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