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