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 = '20210717';
  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 # programming bug codes:
 439 #   -1 = no bug
 440 #    0 = maybe, not sure.
 441 #    1 = definitely
 442 sub report_possible_bug {
 443     my $self         = shift;
 444     my $saw_code_bug = $self->{_saw_code_bug};
 445     $self->{_saw_code_bug} = ( $saw_code_bug < 0 ) ? 0 : $saw_code_bug;
 446     return;
 447 }
 448
 449 sub report_definite_bug {
 450     my $self = shift;
 451     $self->{_saw_code_bug} = 1;
 452     return;
 453 }
 454
 455 sub ask_user_for_bug_report {
 456
 457     my ( $self, $infile_syntax_ok, $formatter ) = @_;
 458     my $saw_code_bug = $self->{_saw_code_bug};
 459     if ( ( $saw_code_bug == 0 ) && ( $infile_syntax_ok == 1 ) ) {
 460         $self->warning(<<EOM);
 461
 462 You may have encountered a code bug in perltidy.  If you think so, and
 463 the problem is not listed in the BUGS file at
 464 http://perltidy.sourceforge.net, please report it so that it can be
 465 corrected.  Include the smallest possible script which has the problem,
 466 along with the .LOG file. See the manual pages for contact information.
 467 Thank you!
 468 EOM
 469
 470     }
 471     elsif ( $saw_code_bug == 1 ) {
 472         if ( $self->{_saw_extrude} ) {
 473             $self->warning(<<EOM);
 474
 475 You may have encountered a bug in perltidy.  However, since you are using the
 476 -extrude option, the problem may be with perl or one of its modules, which have
 477 occasional problems with this type of file.  If you believe that the
 478 problem is with perltidy, and the problem is not listed in the BUGS file at
 479 http://perltidy.sourceforge.net, please report it so that it can be corrected.
 480 Include the smallest possible script which has the problem, along with the .LOG
 481 file. See the manual pages for contact information.
 482 Thank you!
 483 EOM
 484         }
 485         else {
 486             $self->warning(<<EOM);
 487
 488 Oops, you seem to have encountered a bug in perltidy.  Please check the
 489 BUGS file at http://perltidy.sourceforge.net.  If the problem is not
 490 listed there, please report it so that it can be corrected.  Include the
 491 smallest possible script which produces this message, along with the
 492 .LOG file if appropriate.  See the manual pages for contact information.
 493 Your efforts are appreciated.
 494 Thank you!
 495 EOM
 496             my $added_semicolon_count = 0;
 497             eval {
 498                 $added_semicolon_count =
 499                   $formatter->get_added_semicolon_count();
 500             };
 501             if ( $added_semicolon_count > 0 ) {
 502                 $self->warning(<<EOM);
 503
 504 The log file shows that perltidy added $added_semicolon_count semicolons.
 505 Please rerun with -nasc to see if that is the cause of the syntax error.  Even
 506 if that is the problem, please report it so that it can be fixed.
 507 EOM
 508
 509             }
 510         }
 511     }
 512     return;
 513 }
 514
 515 sub get_save_logfile {
 516
 517     # To be called after tokenizer has finished to make formatting more
 518     # efficient.  This is not precisely the same as the check used below
 519     # because we don't yet have the syntax check result, but since syntax
 520     # checking is off by default it will be the same except in debug runs with
 521     # syntax checking activated.  In that case it will tell the formatter to
 522     # save the logfile even if it may actually be deleted based on the syntax
 523     # check.
 524     my $self         = shift;
 525     my $saw_code_bug = $self->{_saw_code_bug};
 526     my $rOpts        = $self->{_rOpts};
 527     return
 528          $saw_code_bug == 1
 529       || $rOpts->{'logfile'}
 530       || $rOpts->{'check-syntax'};
 531 }
 532
 533 sub finish {
 534
 535     # called after all formatting to summarize errors
 536     my ( $self, $infile_syntax_ok, $formatter ) = @_;
 537
 538     my $rOpts         = $self->{_rOpts};
 539     my $warning_count = $self->{_warning_count};
 540     my $saw_code_bug  = $self->{_saw_code_bug};
 541
 542     my $save_logfile =
 543          ( $saw_code_bug == 0 && $infile_syntax_ok == 1 )
 544       || $saw_code_bug == 1
 545       || $rOpts->{'logfile'};
 546     my $log_file = $self->{_log_file};
 547     if ($warning_count) {
 548         if ($save_logfile) {
 549             $self->block_log_output();    # avoid echoing this to the logfile
 550             $self->warning(
 551                 "The logfile $log_file may contain useful information\n");
 552             $self->unblock_log_output();
 553         }
 554
 555         if ( $self->{_complaint_count} > 0 ) {
 556             $self->warning(
 557 "To see $self->{_complaint_count} non-critical warnings rerun with -w\n"
 558             );
 559         }
 560
 561         if ( $self->{_saw_brace_error}
 562             && ( $self->{_logfile_gap} > 1 || !$save_logfile ) )
 563         {
 564             $self->warning("To save a full .LOG file rerun with -g\n");
 565         }
 566     }
 567     $self->ask_user_for_bug_report( $infile_syntax_ok, $formatter );
 568
 569     if ($save_logfile) {
 570         my $log_file        = $self->{_log_file};
 571         my $is_encoded_data = $self->{_is_encoded_data};
 572         my ( $fh, $filename ) =
 573           Perl::Tidy::streamhandle( $log_file, 'w', $is_encoded_data );
 574         if ($fh) {
 575             my $routput_array = $self->{_output_array};
 576             foreach ( @{$routput_array} ) { $fh->print($_) }
 577             if ( $log_file ne '-' && !ref $log_file ) {
 578                 eval { $fh->close() };
 579             }
 580         }
 581     }
 582     return;
 583 }
 584 1;
 585