lib/Perl/Tidy/FileWriter.pm

   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;