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