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 = '20220217';
  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     # Do not combine with other BEGIN blocks (c101).
  49     my $i = 0;
  50     use constant {
  51         _line_sink_object_            => $i++,
  52         _logger_object_               => $i++,
  53         _rOpts_                       => $i++,
  54         _output_line_number_          => $i++,
  55         _consecutive_blank_lines_     => $i++,
  56         _consecutive_nonblank_lines_  => $i++,
  57         _consecutive_new_blank_lines_ => $i++,
  58         _first_line_length_error_     => $i++,
  59         _max_line_length_error_       => $i++,
  60         _last_line_length_error_      => $i++,
  61         _first_line_length_error_at_  => $i++,
  62         _max_line_length_error_at_    => $i++,
  63         _last_line_length_error_at_   => $i++,
  64         _line_length_error_count_     => $i++,
  65         _max_output_line_length_      => $i++,
  66         _max_output_line_length_at_   => $i++,
  67         _rK_checklist_                => $i++,
  68         _K_arrival_order_matches_     => $i++,
  69         _K_sequence_error_msg_        => $i++,
  70         _K_last_arrival_              => $i++,
  71     };
  72 }
  73
  74 sub Die {
  75     my ($msg) = @_;
  76     Perl::Tidy::Die($msg);
  77     return;
  78 }
  79
  80 sub Fault {
  81     my ($msg) = @_;
  82
  83     # This routine is called for errors that really should not occur
  84     # except if there has been a bug introduced by a recent program change.
  85     # Please add comments at calls to Fault to explain why the call
  86     # should not occur, and where to look to fix it.
  87     my ( $package0, $filename0, $line0, $subroutine0 ) = caller(0);
  88     my ( $package1, $filename1, $line1, $subroutine1 ) = caller(1);
  89     my ( $package2, $filename2, $line2, $subroutine2 ) = caller(2);
  90
  91     Die(<<EOM);
  92 ==============================================================================
  93 While operating on input stream with name: '$input_stream_name'
  94 A fault was detected at line $line0 of sub '$subroutine1'
  95 in file '$filename1'
  96 which was called from line $line1 of sub '$subroutine2'
  97 Message: '$msg'
  98 This is probably an error introduced by a recent programming change.
  99 Perl::Tidy::FileWriter.pm reports VERSION='$VERSION'.
 100 ==============================================================================
 101 EOM
 102
 103     # This return is to keep Perl-Critic from complaining.
 104     return;
 105 }
 106
 107 sub warning {
 108     my ( $self, $msg ) = @_;
 109     my $logger_object = $self->[_logger_object_];
 110     if ($logger_object) { $logger_object->warning($msg); }
 111     return;
 112 }
 113
 114 sub write_logfile_entry {
 115     my ( $self, $msg ) = @_;
 116     my $logger_object = $self->[_logger_object_];
 117     if ($logger_object) {
 118         $logger_object->write_logfile_entry($msg);
 119     }
 120     return;
 121 }
 122
 123 sub new {
 124     my ( $class, $line_sink_object, $rOpts, $logger_object ) = @_;
 125
 126     my $self = [];
 127     $self->[_line_sink_object_]            = $line_sink_object;
 128     $self->[_logger_object_]               = $logger_object;
 129     $self->[_rOpts_]                       = $rOpts;
 130     $self->[_output_line_number_]          = 1;
 131     $self->[_consecutive_blank_lines_]     = 0;
 132     $self->[_consecutive_nonblank_lines_]  = 0;
 133     $self->[_consecutive_new_blank_lines_] = 0;
 134     $self->[_first_line_length_error_]     = 0;
 135     $self->[_max_line_length_error_]       = 0;
 136     $self->[_last_line_length_error_]      = 0;
 137     $self->[_first_line_length_error_at_]  = 0;
 138     $self->[_max_line_length_error_at_]    = 0;
 139     $self->[_last_line_length_error_at_]   = 0;
 140     $self->[_line_length_error_count_]     = 0;
 141     $self->[_max_output_line_length_]      = 0;
 142     $self->[_max_output_line_length_at_]   = 0;
 143     $self->[_rK_checklist_]                = [];
 144     $self->[_K_arrival_order_matches_]     = 0;
 145     $self->[_K_sequence_error_msg_]        = "";
 146     $self->[_K_last_arrival_]              = -1;
 147
 148     # save input stream name for local error messages
 149     $input_stream_name = "";
 150     if ($logger_object) {
 151         $input_stream_name = $logger_object->get_input_stream_name();
 152     }
 153
 154     bless $self, $class;
 155     return $self;
 156 }
 157
 158 sub setup_convergence_test {
 159     my ( $self, $rlist ) = @_;
 160     if ( @{$rlist} ) {
 161
 162         # We are going to destroy the list, so make a copy
 163         # and put in reverse order so we can pop values
 164         my @list = @{$rlist};
 165         if ( $list[0] < $list[-1] ) {
 166             @list = reverse @list;
 167         }
 168         $self->[_rK_checklist_] = \@list;
 169     }
 170     $self->[_K_arrival_order_matches_] = 1;
 171     $self->[_K_sequence_error_msg_]    = "";
 172     $self->[_K_last_arrival_]          = -1;
 173     return;
 174 }
 175
 176 sub get_convergence_check {
 177     my ($self) = @_;
 178     my $rlist = $self->[_rK_checklist_];
 179
 180     # converged if all K arrived and in correct order
 181     return $self->[_K_arrival_order_matches_] && !@{$rlist};
 182 }
 183
 184 sub get_K_sequence_error_msg {
 185     my ($self) = @_;
 186     return $self->[_K_sequence_error_msg_];
 187 }
 188
 189 sub get_output_line_number {
 190     return $_[0]->[_output_line_number_];
 191 }
 192
 193 sub decrement_output_line_number {
 194     $_[0]->[_output_line_number_]--;
 195     return;
 196 }
 197
 198 sub get_consecutive_nonblank_lines {
 199     return $_[0]->[_consecutive_nonblank_lines_];
 200 }
 201
 202 sub get_consecutive_blank_lines {
 203     return $_[0]->[_consecutive_blank_lines_];
 204 }
 205
 206 sub reset_consecutive_blank_lines {
 207     $_[0]->[_consecutive_blank_lines_] = 0;
 208     return;
 209 }
 210
 211 sub want_blank_line {
 212     my $self = shift;
 213     unless ( $self->[_consecutive_blank_lines_] ) {
 214         $self->write_blank_code_line();
 215     }
 216     return;
 217 }
 218
 219 sub require_blank_code_lines {
 220
 221     # write out the requested number of blanks regardless of the value of -mbl
 222     # unless -mbl=0.  This allows extra blank lines to be written for subs and
 223     # packages even with the default -mbl=1
 224     my ( $self, $count ) = @_;
 225     my $need   = $count - $self->[_consecutive_blank_lines_];
 226     my $rOpts  = $self->[_rOpts_];
 227     my $forced = $rOpts->{'maximum-consecutive-blank-lines'} > 0;
 228     foreach my $i ( 0 .. $need - 1 ) {
 229         $self->write_blank_code_line($forced);
 230     }
 231     return;
 232 }
 233
 234 sub write_blank_code_line {
 235     my $self   = shift;
 236     my $forced = shift;
 237     my $rOpts  = $self->[_rOpts_];
 238     return
 239       if (!$forced
 240         && $self->[_consecutive_blank_lines_] >=
 241         $rOpts->{'maximum-consecutive-blank-lines'} );
 242
 243     $self->[_consecutive_nonblank_lines_] = 0;
 244
 245     # Balance old blanks against new (forced) blanks instead of writing them.
 246     # This fixes case b1073.
 247     if ( !$forced && $self->[_consecutive_new_blank_lines_] > 0 ) {
 248         $self->[_consecutive_new_blank_lines_]--;
 249         return;
 250     }
 251
 252     $self->write_line("\n");
 253     $self->[_consecutive_blank_lines_]++;
 254     $self->[_consecutive_new_blank_lines_]++ if ($forced);
 255
 256     return;
 257 }
 258
 259 sub write_code_line {
 260     my ( $self, $str, $K ) = @_;
 261
 262     $self->[_consecutive_blank_lines_]     = 0;
 263     $self->[_consecutive_new_blank_lines_] = 0;
 264     $self->[_consecutive_nonblank_lines_]++;
 265     $self->write_line($str);
 266
 267     #----------------------------
 268     # Convergence and error check
 269     #----------------------------
 270     if ( defined($K) ) {
 271
 272         # Convergence check: we are checking if all defined K values arrive in
 273         # the order which was defined by the caller.  Quit checking if any
 274         # unexpected K value arrives.
 275         if ( $self->[_K_arrival_order_matches_] ) {
 276             my $Kt = pop @{ $self->[_rK_checklist_] };
 277             if ( !defined($Kt) || $Kt != $K ) {
 278                 $self->[_K_arrival_order_matches_] = 0;
 279             }
 280         }
 281
 282         # Check for out-of-order arrivals of index K. The K values are the
 283         # token indexes of the last token of code lines, and they should come
 284         # out in increasing order.  Otherwise something is seriously wrong.
 285         # Most likely a recent programming change to VerticalAligner.pm has
 286         # caused lines to go out in the wrong order.  This could happen if
 287         # either the cache or buffer that it uses are emptied in the wrong
 288         # order.
 289         if ( !$self->[_K_sequence_error_msg_] ) {
 290             my $K_prev = $self->[_K_last_arrival_];
 291             if ( $K < $K_prev ) {
 292                 chomp $str;
 293                 if ( length($str) > 80 ) {
 294                     $str = substr( $str, 0, 80 ) . "...";
 295                 }
 296
 297                 my $msg = <<EOM;
 298 While operating on input stream with name: '$input_stream_name'
 299 Lines have arrived out of order in sub 'write_code_line'
 300 as detected by token index K=$K arriving after index K=$K_prev in the following line:
 301 $str
 302 This is probably due to a recent programming change and needs to be fixed.
 303 EOM
 304
 305                 if (DEVEL_MODE) { Fault($msg) }
 306
 307                 $self->warning($msg);
 308
 309                 # Only issue this warning once
 310                 $self->[_K_sequence_error_msg_] = $msg;
 311
 312             }
 313         }
 314         $self->[_K_last_arrival_] = $K;
 315     }
 316     return;
 317 }
 318
 319 sub write_line {
 320     my ( $self, $str ) = @_;
 321
 322     $self->[_line_sink_object_]->write_line($str);
 323
 324     if ( chomp $str ) { $self->[_output_line_number_]++; }
 325
 326     # This calculation of excess line length ignores any internal tabs
 327     my $rOpts   = $self->[_rOpts_];
 328     my $len_str = length($str);
 329     my $exceed  = $len_str - $rOpts->{'maximum-line-length'};
 330     if ( $str && substr( $str, 0, 1 ) eq "\t" && $str =~ /^\t+/g ) {
 331         $exceed += pos($str) * $rOpts->{'indent-columns'};
 332     }
 333
 334     # Note that we just incremented output line number to future value
 335     # so we must subtract 1 for current line number
 336     if ( $len_str > $self->[_max_output_line_length_] ) {
 337         $self->[_max_output_line_length_] = $len_str;
 338         $self->[_max_output_line_length_at_] =
 339           $self->[_output_line_number_] - 1;
 340     }
 341
 342     if ( $exceed > 0 ) {
 343         my $output_line_number = $self->[_output_line_number_];
 344         $self->[_last_line_length_error_]    = $exceed;
 345         $self->[_last_line_length_error_at_] = $output_line_number - 1;
 346         if ( $self->[_line_length_error_count_] == 0 ) {
 347             $self->[_first_line_length_error_]    = $exceed;
 348             $self->[_first_line_length_error_at_] = $output_line_number - 1;
 349         }
 350
 351         if ( $self->[_last_line_length_error_] >
 352             $self->[_max_line_length_error_] )
 353         {
 354             $self->[_max_line_length_error_]    = $exceed;
 355             $self->[_max_line_length_error_at_] = $output_line_number - 1;
 356         }
 357
 358         if ( $self->[_line_length_error_count_] < $MAX_NAG_MESSAGES ) {
 359             $self->write_logfile_entry(
 360                 "Line length exceeded by $exceed characters\n");
 361         }
 362         $self->[_line_length_error_count_]++;
 363     }
 364     return;
 365 }
 366
 367 sub report_line_length_errors {
 368     my $self                    = shift;
 369     my $rOpts                   = $self->[_rOpts_];
 370     my $line_length_error_count = $self->[_line_length_error_count_];
 371     if ( $line_length_error_count == 0 ) {
 372         $self->write_logfile_entry(
 373             "No lines exceeded $rOpts->{'maximum-line-length'} characters\n");
 374         my $max_output_line_length    = $self->[_max_output_line_length_];
 375         my $max_output_line_length_at = $self->[_max_output_line_length_at_];
 376         $self->write_logfile_entry(
 377 "  Maximum output line length was $max_output_line_length at line $max_output_line_length_at\n"
 378         );
 379
 380     }
 381     else {
 382
 383         my $word = ( $line_length_error_count > 1 ) ? "s" : "";
 384         $self->write_logfile_entry(
 385 "$line_length_error_count output line$word exceeded $rOpts->{'maximum-line-length'} characters:\n"
 386         );
 387
 388         $word = ( $line_length_error_count > 1 ) ? "First" : "";
 389         my $first_line_length_error    = $self->[_first_line_length_error_];
 390         my $first_line_length_error_at = $self->[_first_line_length_error_at_];
 391         $self->write_logfile_entry(
 392 " $word at line $first_line_length_error_at by $first_line_length_error characters\n"
 393         );
 394
 395         if ( $line_length_error_count > 1 ) {
 396             my $max_line_length_error    = $self->[_max_line_length_error_];
 397             my $max_line_length_error_at = $self->[_max_line_length_error_at_];
 398             my $last_line_length_error   = $self->[_last_line_length_error_];
 399             my $last_line_length_error_at =
 400               $self->[_last_line_length_error_at_];
 401             $self->write_logfile_entry(
 402 " Maximum at line $max_line_length_error_at by $max_line_length_error characters\n"
 403             );
 404             $self->write_logfile_entry(
 405 " Last at line $last_line_length_error_at by $last_line_length_error characters\n"
 406             );
 407         }
 408     }
 409     return;
 410 }
 411 1;