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