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 = '20221112';
  11
  12 use constant DEVEL_MODE   => 0;
  13 use constant EMPTY_STRING => q{};
  14
  15 sub AUTOLOAD {
  16
  17     # Catch any undefined sub calls so that we are sure to get
  18     # some diagnostic information.  This sub should never be called
  19     # except for a programming error.
  20     our $AUTOLOAD;
  21     return if ( $AUTOLOAD =~ /\bDESTROY$/ );
  22     my ( $pkg, $fname, $lno ) = caller();
  23     my $my_package = __PACKAGE__;
  24     print STDERR <<EOM;
  25 ======================================================================
  26 Error detected in package '$my_package', version $VERSION
  27 Received unexpected AUTOLOAD call for sub '$AUTOLOAD'
  28 Called from package: '$pkg'
  29 Called from File '$fname'  at line '$lno'
  30 This error is probably due to a recent programming change
  31 ======================================================================
  32 EOM
  33     exit 1;
  34 }
  35
  36 sub DESTROY {
  37
  38     # required to avoid call to AUTOLOAD in some versions of perl
  39 }
  40
  41 my $input_stream_name = EMPTY_STRING;
  42
  43 # Maximum number of little messages; probably need not be changed.
  44 use constant MAX_NAG_MESSAGES => 6;
  45
  46 BEGIN {
  47
  48     # Array index names for variables.
  49     # Do not combine with other BEGIN blocks (c101).
  50     my $i = 0;
  51     use constant {
  52         _line_sink_object_            => $i++,
  53         _logger_object_               => $i++,
  54         _rOpts_                       => $i++,
  55         _output_line_number_          => $i++,
  56         _consecutive_blank_lines_     => $i++,
  57         _consecutive_nonblank_lines_  => $i++,
  58         _consecutive_new_blank_lines_ => $i++,
  59         _first_line_length_error_     => $i++,
  60         _max_line_length_error_       => $i++,
  61         _last_line_length_error_      => $i++,
  62         _first_line_length_error_at_  => $i++,
  63         _max_line_length_error_at_    => $i++,
  64         _last_line_length_error_at_   => $i++,
  65         _line_length_error_count_     => $i++,
  66         _max_output_line_length_      => $i++,
  67         _max_output_line_length_at_   => $i++,
  68         _rK_checklist_                => $i++,
  69         _K_arrival_order_matches_     => $i++,
  70         _K_sequence_error_msg_        => $i++,
  71         _K_last_arrival_              => $i++,
  72     };
  73 }
  74
  75 sub Die {
  76     my ($msg) = @_;
  77     Perl::Tidy::Die($msg);
  78     return;
  79 }
  80
  81 sub Fault {
  82     my ($msg) = @_;
  83
  84     # This routine is called for errors that really should not occur
  85     # except if there has been a bug introduced by a recent program change.
  86     # Please add comments at calls to Fault to explain why the call
  87     # should not occur, and where to look to fix it.
  88     my ( $package0, $filename0, $line0, $subroutine0 ) = caller(0);
  89     my ( $package1, $filename1, $line1, $subroutine1 ) = caller(1);
  90     my ( $package2, $filename2, $line2, $subroutine2 ) = caller(2);
  91
  92     Die(<<EOM);
  93 ==============================================================================
  94 While operating on input stream with name: '$input_stream_name'
  95 A fault was detected at line $line0 of sub '$subroutine1'
  96 in file '$filename1'
  97 which was called from line $line1 of sub '$subroutine2'
  98 Message: '$msg'
  99 This is probably an error introduced by a recent programming change.
 100 Perl::Tidy::FileWriter.pm reports VERSION='$VERSION'.
 101 ==============================================================================
 102 EOM
 103
 104     # This return is to keep Perl-Critic from complaining.
 105     return;
 106 }
 107
 108 sub warning {
 109     my ( $self, $msg ) = @_;
 110     my $logger_object = $self->[_logger_object_];
 111     if ($logger_object) { $logger_object->warning($msg); }
 112     return;
 113 }
 114
 115 sub write_logfile_entry {
 116     my ( $self, $msg ) = @_;
 117     my $logger_object = $self->[_logger_object_];
 118     if ($logger_object) {
 119         $logger_object->write_logfile_entry($msg);
 120     }
 121     return;
 122 }
 123
 124 sub new {
 125     my ( $class, $line_sink_object, $rOpts, $logger_object ) = @_;
 126
 127     my $self = [];
 128     $self->[_line_sink_object_]            = $line_sink_object;
 129     $self->[_logger_object_]               = $logger_object;
 130     $self->[_rOpts_]                       = $rOpts;
 131     $self->[_output_line_number_]          = 1;
 132     $self->[_consecutive_blank_lines_]     = 0;
 133     $self->[_consecutive_nonblank_lines_]  = 0;
 134     $self->[_consecutive_new_blank_lines_] = 0;
 135     $self->[_first_line_length_error_]     = 0;
 136     $self->[_max_line_length_error_]       = 0;
 137     $self->[_last_line_length_error_]      = 0;
 138     $self->[_first_line_length_error_at_]  = 0;
 139     $self->[_max_line_length_error_at_]    = 0;
 140     $self->[_last_line_length_error_at_]   = 0;
 141     $self->[_line_length_error_count_]     = 0;
 142     $self->[_max_output_line_length_]      = 0;
 143     $self->[_max_output_line_length_at_]   = 0;
 144     $self->[_rK_checklist_]                = [];
 145     $self->[_K_arrival_order_matches_]     = 0;
 146     $self->[_K_sequence_error_msg_]        = EMPTY_STRING;
 147     $self->[_K_last_arrival_]              = -1;
 148
 149     # save input stream name for local error messages
 150     $input_stream_name = EMPTY_STRING;
 151     if ($logger_object) {
 152         $input_stream_name = $logger_object->get_input_stream_name();
 153     }
 154
 155     bless $self, $class;
 156     return $self;
 157 }
 158
 159 sub setup_convergence_test {
 160     my ( $self, $rlist ) = @_;
 161     if ( @{$rlist} ) {
 162
 163         # We are going to destroy the list, so make a copy
 164         # and put in reverse order so we can pop values
 165         my @list = @{$rlist};
 166         if ( $list[0] < $list[-1] ) {
 167             @list = reverse @list;
 168         }
 169         $self->[_rK_checklist_] = \@list;
 170     }
 171     $self->[_K_arrival_order_matches_] = 1;
 172     $self->[_K_sequence_error_msg_]    = EMPTY_STRING;
 173     $self->[_K_last_arrival_]          = -1;
 174     return;
 175 }
 176
 177 sub get_convergence_check {
 178     my ($self) = @_;
 179     my $rlist = $self->[_rK_checklist_];
 180
 181     # converged if all K arrived and in correct order
 182     return $self->[_K_arrival_order_matches_] && !@{$rlist};
 183 }
 184
 185 sub get_output_line_number {
 186     return $_[0]->[_output_line_number_];
 187 }
 188
 189 sub decrement_output_line_number {
 190     $_[0]->[_output_line_number_]--;
 191     return;
 192 }
 193
 194 sub get_consecutive_nonblank_lines {
 195     return $_[0]->[_consecutive_nonblank_lines_];
 196 }
 197
 198 sub get_consecutive_blank_lines {
 199     return $_[0]->[_consecutive_blank_lines_];
 200 }
 201
 202 sub reset_consecutive_blank_lines {
 203     $_[0]->[_consecutive_blank_lines_] = 0;
 204     return;
 205 }
 206
 207 sub want_blank_line {
 208     my $self = shift;
 209     unless ( $self->[_consecutive_blank_lines_] ) {
 210         $self->write_blank_code_line();
 211     }
 212     return;
 213 }
 214
 215 sub require_blank_code_lines {
 216
 217     # write out the requested number of blanks regardless of the value of -mbl
 218     # unless -mbl=0.  This allows extra blank lines to be written for subs and
 219     # packages even with the default -mbl=1
 220     my ( $self, $count ) = @_;
 221     my $need   = $count - $self->[_consecutive_blank_lines_];
 222     my $rOpts  = $self->[_rOpts_];
 223     my $forced = $rOpts->{'maximum-consecutive-blank-lines'} > 0;
 224     foreach my $i ( 0 .. $need - 1 ) {
 225         $self->write_blank_code_line($forced);
 226     }
 227     return;
 228 }
 229
 230 sub write_blank_code_line {
 231     my $self   = shift;
 232     my $forced = shift;
 233     my $rOpts  = $self->[_rOpts_];
 234     return
 235       if (!$forced
 236         && $self->[_consecutive_blank_lines_] >=
 237         $rOpts->{'maximum-consecutive-blank-lines'} );
 238
 239     $self->[_consecutive_nonblank_lines_] = 0;
 240
 241     # Balance old blanks against new (forced) blanks instead of writing them.
 242     # This fixes case b1073.
 243     if ( !$forced && $self->[_consecutive_new_blank_lines_] > 0 ) {
 244         $self->[_consecutive_new_blank_lines_]--;
 245         return;
 246     }
 247
 248     $self->write_line("\n");
 249     $self->[_consecutive_blank_lines_]++;
 250     $self->[_consecutive_new_blank_lines_]++ if ($forced);
 251
 252     return;
 253 }
 254
 255 use constant MAX_PRINTED_CHARS => 80;
 256
 257 sub write_code_line {
 258     my ( $self, $str, $K ) = @_;
 259
 260     $self->[_consecutive_blank_lines_]     = 0;
 261     $self->[_consecutive_new_blank_lines_] = 0;
 262     $self->[_consecutive_nonblank_lines_]++;
 263     $self->write_line($str);
 264
 265     #----------------------------
 266     # Convergence and error check
 267     #----------------------------
 268     if ( defined($K) ) {
 269
 270         # Convergence check: we are checking if all defined K values arrive in
 271         # the order which was defined by the caller.  Quit checking if any
 272         # unexpected K value arrives.
 273         if ( $self->[_K_arrival_order_matches_] ) {
 274             my $Kt = pop @{ $self->[_rK_checklist_] };
 275             if ( !defined($Kt) || $Kt != $K ) {
 276                 $self->[_K_arrival_order_matches_] = 0;
 277             }
 278         }
 279
 280         # Check for out-of-order arrivals of index K. The K values are the
 281         # token indexes of the last token of code lines, and they should come
 282         # out in increasing order.  Otherwise something is seriously wrong.
 283         # Most likely a recent programming change to VerticalAligner.pm has
 284         # caused lines to go out in the wrong order.  This could happen if
 285         # either the cache or buffer that it uses are emptied in the wrong
 286         # order.
 287         if ( !$self->[_K_sequence_error_msg_] ) {
 288             my $K_prev = $self->[_K_last_arrival_];
 289             if ( $K < $K_prev ) {
 290                 chomp $str;
 291                 if ( length($str) > MAX_PRINTED_CHARS ) {
 292                     $str = substr( $str, 0, MAX_PRINTED_CHARS ) . "...";
 293                 }
 294
 295                 my $msg = <<EOM;
 296 While operating on input stream with name: '$input_stream_name'
 297 Lines have arrived out of order in sub 'write_code_line'
 298 as detected by token index K=$K arriving after index K=$K_prev in the following line:
 299 $str
 300 This is probably due to a recent programming change and needs to be fixed.
 301 EOM
 302
 303                 # Always die during development, this needs to be fixed
 304                 if (DEVEL_MODE) { Fault($msg) }
 305
 306                 # Otherwise warn if string is not empty (added for b1378)
 307                 $self->warning($msg) if ( length($str) );
 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" : EMPTY_STRING;
 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" : EMPTY_STRING;
 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;