"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. For more information about "FileWriter.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 20210402_vs_20210717.

    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;