"Fossies" - the Fresh Open Source Software Archive

Member "Perl-Tidy-20210717/lib/Perl/Tidy/FileWriter.pm" (14 Jul 2021, 12671 Bytes) of package /linux/misc/Perl-Tidy-20210717.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.

    1 #####################################################################
    2 #
    3 # the Perl::Tidy::FileWriter class writes the output file
    4 #
    5 #####################################################################
    6 
    7 package Perl::Tidy::FileWriter;
    8 use strict;
    9 use warnings;
   10 our $VERSION = '20210717';
   11 
   12 use constant DEVEL_MODE => 0;
   13 
   14 sub AUTOLOAD {
   15 
   16     # Catch any undefined sub calls so that we are sure to get
   17     # some diagnostic information.  This sub should never be called
   18     # except for a programming error.
   19     our $AUTOLOAD;
   20     return if ( $AUTOLOAD =~ /\bDESTROY$/ );
   21     my ( $pkg, $fname, $lno ) = caller();
   22     my $my_package = __PACKAGE__;
   23     print STDERR <<EOM;
   24 ======================================================================
   25 Error detected in package '$my_package', version $VERSION
   26 Received unexpected AUTOLOAD call for sub '$AUTOLOAD'
   27 Called from package: '$pkg'  
   28 Called from File '$fname'  at line '$lno'
   29 This error is probably due to a recent programming change
   30 ======================================================================
   31 EOM
   32     exit 1;
   33 }
   34 
   35 sub DESTROY {
   36 
   37     # required to avoid call to AUTOLOAD in some versions of perl
   38 }
   39 
   40 my $input_stream_name = "";
   41 
   42 # Maximum number of little messages; probably need not be changed.
   43 my $MAX_NAG_MESSAGES = 6;
   44 
   45 BEGIN {
   46 
   47     # Array index names for variables
   48     my $i = 0;
   49     use constant {
   50         _line_sink_object_            => $i++,
   51         _logger_object_               => $i++,
   52         _rOpts_                       => $i++,
   53         _output_line_number_          => $i++,
   54         _consecutive_blank_lines_     => $i++,
   55         _consecutive_nonblank_lines_  => $i++,
   56         _consecutive_new_blank_lines_ => $i++,
   57         _first_line_length_error_     => $i++,
   58         _max_line_length_error_       => $i++,
   59         _last_line_length_error_      => $i++,
   60         _first_line_length_error_at_  => $i++,
   61         _max_line_length_error_at_    => $i++,
   62         _last_line_length_error_at_   => $i++,
   63         _line_length_error_count_     => $i++,
   64         _max_output_line_length_      => $i++,
   65         _max_output_line_length_at_   => $i++,
   66         _rK_checklist_                => $i++,
   67         _K_arrival_order_matches_     => $i++,
   68         _K_sequence_error_msg_        => $i++,
   69         _K_last_arrival_              => $i++,
   70     };
   71 }
   72 
   73 sub warning {
   74     my ( $self, $msg ) = @_;
   75     my $logger_object = $self->[_logger_object_];
   76     if ($logger_object) { $logger_object->warning($msg); }
   77     return;
   78 }
   79 
   80 sub write_logfile_entry {
   81     my ( $self, $msg ) = @_;
   82     my $logger_object = $self->[_logger_object_];
   83     if ($logger_object) {
   84         $logger_object->write_logfile_entry($msg);
   85     }
   86     return;
   87 }
   88 
   89 sub new {
   90     my ( $class, $line_sink_object, $rOpts, $logger_object ) = @_;
   91 
   92     my $self = [];
   93     $self->[_line_sink_object_]            = $line_sink_object;
   94     $self->[_logger_object_]               = $logger_object;
   95     $self->[_rOpts_]                       = $rOpts;
   96     $self->[_output_line_number_]          = 1;
   97     $self->[_consecutive_blank_lines_]     = 0;
   98     $self->[_consecutive_nonblank_lines_]  = 0;
   99     $self->[_consecutive_new_blank_lines_] = 0;
  100     $self->[_first_line_length_error_]     = 0;
  101     $self->[_max_line_length_error_]       = 0;
  102     $self->[_last_line_length_error_]      = 0;
  103     $self->[_first_line_length_error_at_]  = 0;
  104     $self->[_max_line_length_error_at_]    = 0;
  105     $self->[_last_line_length_error_at_]   = 0;
  106     $self->[_line_length_error_count_]     = 0;
  107     $self->[_max_output_line_length_]      = 0;
  108     $self->[_max_output_line_length_at_]   = 0;
  109     $self->[_rK_checklist_]                = [];
  110     $self->[_K_arrival_order_matches_]     = 0;
  111     $self->[_K_sequence_error_msg_]        = "";
  112     $self->[_K_last_arrival_]              = -1;
  113 
  114     # save input stream name for local error messages
  115     $input_stream_name = "";
  116     if ($logger_object) {
  117         $input_stream_name = $logger_object->get_input_stream_name();
  118     }
  119 
  120     bless $self, $class;
  121     return $self;
  122 }
  123 
  124 sub setup_convergence_test {
  125     my ( $self, $rlist ) = @_;
  126     if ( @{$rlist} ) {
  127 
  128         # We are going to destroy the list, so make a copy
  129         # and put in reverse order so we can pop values
  130         my @list = @{$rlist};
  131         if ( $list[0] < $list[-1] ) {
  132             @list = reverse @list;
  133         }
  134         $self->[_rK_checklist_] = \@list;
  135     }
  136     $self->[_K_arrival_order_matches_] = 1;
  137     $self->[_K_sequence_error_msg_]    = "";
  138     $self->[_K_last_arrival_]          = -1;
  139     return;
  140 }
  141 
  142 sub get_convergence_check {
  143     my ($self) = @_;
  144     my $rlist = $self->[_rK_checklist_];
  145 
  146     # converged if all K arrived and in correct order
  147     return $self->[_K_arrival_order_matches_] && !@{$rlist};
  148 }
  149 
  150 sub get_K_sequence_error_msg {
  151     my ($self) = @_;
  152     return $self->[_K_sequence_error_msg_];
  153 }
  154 
  155 sub get_output_line_number {
  156     return $_[0]->[_output_line_number_];
  157 }
  158 
  159 sub decrement_output_line_number {
  160     $_[0]->[_output_line_number_]--;
  161     return;
  162 }
  163 
  164 sub get_consecutive_nonblank_lines {
  165     return $_[0]->[_consecutive_nonblank_lines_];
  166 }
  167 
  168 sub get_consecutive_blank_lines {
  169     return $_[0]->[_consecutive_blank_lines_];
  170 }
  171 
  172 sub reset_consecutive_blank_lines {
  173     $_[0]->[_consecutive_blank_lines_] = 0;
  174     return;
  175 }
  176 
  177 sub want_blank_line {
  178     my $self = shift;
  179     unless ( $self->[_consecutive_blank_lines_] ) {
  180         $self->write_blank_code_line();
  181     }
  182     return;
  183 }
  184 
  185 sub require_blank_code_lines {
  186 
  187     # write out the requested number of blanks regardless of the value of -mbl
  188     # unless -mbl=0.  This allows extra blank lines to be written for subs and
  189     # packages even with the default -mbl=1
  190     my ( $self, $count ) = @_;
  191     my $need   = $count - $self->[_consecutive_blank_lines_];
  192     my $rOpts  = $self->[_rOpts_];
  193     my $forced = $rOpts->{'maximum-consecutive-blank-lines'} > 0;
  194     foreach my $i ( 0 .. $need - 1 ) {
  195         $self->write_blank_code_line($forced);
  196     }
  197     return;
  198 }
  199 
  200 sub write_blank_code_line {
  201     my $self   = shift;
  202     my $forced = shift;
  203     my $rOpts  = $self->[_rOpts_];
  204     return
  205       if (!$forced
  206         && $self->[_consecutive_blank_lines_] >=
  207         $rOpts->{'maximum-consecutive-blank-lines'} );
  208 
  209     $self->[_consecutive_nonblank_lines_] = 0;
  210 
  211     # Balance old blanks against new (forced) blanks instead of writing them.
  212     # This fixes case b1073.
  213     if ( !$forced && $self->[_consecutive_new_blank_lines_] > 0 ) {
  214         $self->[_consecutive_new_blank_lines_]--;
  215         return;
  216     }
  217 
  218     $self->write_line("\n");
  219     $self->[_consecutive_blank_lines_]++;
  220     $self->[_consecutive_new_blank_lines_]++ if ($forced);
  221 
  222     return;
  223 }
  224 
  225 sub write_code_line {
  226     my ( $self, $str, $K ) = @_;
  227 
  228     $self->[_consecutive_blank_lines_]     = 0;
  229     $self->[_consecutive_new_blank_lines_] = 0;
  230     $self->[_consecutive_nonblank_lines_]++;
  231     $self->write_line($str);
  232 
  233     #----------------------------
  234     # Convergence and error check
  235     #----------------------------
  236     if ( defined($K) ) {
  237 
  238         # Convergence check: we are checking if all defined K values arrive in
  239         # the order which was defined by the caller.  Quit checking if any
  240         # unexpected K value arrives.
  241         if ( $self->[_K_arrival_order_matches_] ) {
  242             my $Kt = pop @{ $self->[_rK_checklist_] };
  243             if ( !defined($Kt) || $Kt != $K ) {
  244                 $self->[_K_arrival_order_matches_] = 0;
  245             }
  246         }
  247 
  248         # Check for out-of-order arrivals of index K. The K values are the
  249         # token indexes of the last token of code lines, and they should come
  250         # out in increasing order.  Otherwise something is seriously wrong.
  251         # Most likely a recent programming change to VerticalAligner.pm has
  252         # caused lines to go out in the wrong order.  This could happen if
  253         # either the cache or buffer that it uses are emptied in the wrong
  254         # order.
  255         if ( !$self->[_K_sequence_error_msg_] ) {
  256             my $K_prev = $self->[_K_last_arrival_];
  257             if ( $K < $K_prev ) {
  258                 chomp $str;
  259                 if ( length($str) > 80 ) {
  260                     $str = substr( $str, 0, 80 ) . "...";
  261                 }
  262 
  263                 my $msg = <<EOM;
  264 While operating on input stream with name: '$input_stream_name'
  265 Lines have arrived out of order in sub 'write_code_line'
  266 as detected by token index K=$K arriving after index K=$K_prev in the following line:
  267 $str
  268 This is probably due to a recent programming change and needs to be fixed.
  269 EOM
  270 
  271                 # FIXME: it would be best to set a 'severe_error' flag here and
  272                 # tell caller to output the original file
  273                 $self->warning($msg);
  274 
  275                 # Only issue this warning once
  276                 $self->[_K_sequence_error_msg_] = $msg;
  277 
  278                 # stop here in DEVEL mode so this issue doesn't get missed
  279                 DEVEL_MODE && Perl::Tidy::Die($msg);
  280             }
  281         }
  282         $self->[_K_last_arrival_] = $K;
  283     }
  284     return;
  285 }
  286 
  287 sub write_line {
  288     my ( $self, $str ) = @_;
  289 
  290     $self->[_line_sink_object_]->write_line($str);
  291 
  292     if ( chomp $str ) { $self->[_output_line_number_]++; }
  293 
  294     # This calculation of excess line length ignores any internal tabs
  295     my $rOpts   = $self->[_rOpts_];
  296     my $len_str = length($str);
  297     my $exceed  = $len_str - $rOpts->{'maximum-line-length'};
  298     if ( $str && substr( $str, 0, 1 ) eq "\t" && $str =~ /^\t+/g ) {
  299         $exceed += pos($str) * $rOpts->{'indent-columns'};
  300     }
  301 
  302     # Note that we just incremented output line number to future value
  303     # so we must subtract 1 for current line number
  304     if ( $len_str > $self->[_max_output_line_length_] ) {
  305         $self->[_max_output_line_length_] = $len_str;
  306         $self->[_max_output_line_length_at_] =
  307           $self->[_output_line_number_] - 1;
  308     }
  309 
  310     if ( $exceed > 0 ) {
  311         my $output_line_number = $self->[_output_line_number_];
  312         $self->[_last_line_length_error_]    = $exceed;
  313         $self->[_last_line_length_error_at_] = $output_line_number - 1;
  314         if ( $self->[_line_length_error_count_] == 0 ) {
  315             $self->[_first_line_length_error_]    = $exceed;
  316             $self->[_first_line_length_error_at_] = $output_line_number - 1;
  317         }
  318 
  319         if ( $self->[_last_line_length_error_] >
  320             $self->[_max_line_length_error_] )
  321         {
  322             $self->[_max_line_length_error_]    = $exceed;
  323             $self->[_max_line_length_error_at_] = $output_line_number - 1;
  324         }
  325 
  326         if ( $self->[_line_length_error_count_] < $MAX_NAG_MESSAGES ) {
  327             $self->write_logfile_entry(
  328                 "Line length exceeded by $exceed characters\n");
  329         }
  330         $self->[_line_length_error_count_]++;
  331     }
  332     return;
  333 }
  334 
  335 sub report_line_length_errors {
  336     my $self                    = shift;
  337     my $rOpts                   = $self->[_rOpts_];
  338     my $line_length_error_count = $self->[_line_length_error_count_];
  339     if ( $line_length_error_count == 0 ) {
  340         $self->write_logfile_entry(
  341             "No lines exceeded $rOpts->{'maximum-line-length'} characters\n");
  342         my $max_output_line_length    = $self->[_max_output_line_length_];
  343         my $max_output_line_length_at = $self->[_max_output_line_length_at_];
  344         $self->write_logfile_entry(
  345 "  Maximum output line length was $max_output_line_length at line $max_output_line_length_at\n"
  346         );
  347 
  348     }
  349     else {
  350 
  351         my $word = ( $line_length_error_count > 1 ) ? "s" : "";
  352         $self->write_logfile_entry(
  353 "$line_length_error_count output line$word exceeded $rOpts->{'maximum-line-length'} characters:\n"
  354         );
  355 
  356         $word = ( $line_length_error_count > 1 ) ? "First" : "";
  357         my $first_line_length_error    = $self->[_first_line_length_error_];
  358         my $first_line_length_error_at = $self->[_first_line_length_error_at_];
  359         $self->write_logfile_entry(
  360 " $word at line $first_line_length_error_at by $first_line_length_error characters\n"
  361         );
  362 
  363         if ( $line_length_error_count > 1 ) {
  364             my $max_line_length_error    = $self->[_max_line_length_error_];
  365             my $max_line_length_error_at = $self->[_max_line_length_error_at_];
  366             my $last_line_length_error   = $self->[_last_line_length_error_];
  367             my $last_line_length_error_at =
  368               $self->[_last_line_length_error_at_];
  369             $self->write_logfile_entry(
  370 " Maximum at line $max_line_length_error_at by $max_line_length_error characters\n"
  371             );
  372             $self->write_logfile_entry(
  373 " Last at line $last_line_length_error_at by $last_line_length_error characters\n"
  374             );
  375         }
  376     }
  377     return;
  378 }
  379 1;