"Fossies" - the Fresh Open Source Software Archive

Member "Perl-Tidy-20200110/lib/Perl/Tidy/Logger.pm" (7 Jan 2020, 16772 Bytes) of package /linux/misc/Perl-Tidy-20200110.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Logger.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 20191203_vs_20200110.

    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