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 = '20220613';
  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_K_sequence_error_msg {
 186     my ($self) = @_;
 187     return $self->[_K_sequence_error_msg_];
 188 }
 189
 190 sub get_output_line_number {
 191     return $_[0]->[_output_line_number_];
 192 }
 193
 194 sub decrement_output_line_number {
 195     $_[0]->[_output_line_number_]--;
 196     return;
 197 }
 198
 199 sub get_consecutive_nonblank_lines {
 200     return $_[0]->[_consecutive_nonblank_lines_];
 201 }
 202
 203 sub get_consecutive_blank_lines {
 204     return $_[0]->[_consecutive_blank_lines_];
 205 }
 206
 207 sub reset_consecutive_blank_lines {
 208     $_[0]->[_consecutive_blank_lines_] = 0;
 209     return;
 210 }
 211
 212 sub want_blank_line {
 213     my $self = shift;
 214     unless ( $self->[_consecutive_blank_lines_] ) {
 215         $self->write_blank_code_line();
 216     }
 217     return;
 218 }
 219
 220 sub require_blank_code_lines {
 221
 222     # write out the requested number of blanks regardless of the value of -mbl
 223     # unless -mbl=0.  This allows extra blank lines to be written for subs and
 224     # packages even with the default -mbl=1
 225     my ( $self, $count ) = @_;
 226     my $need   = $count - $self->[_consecutive_blank_lines_];
 227     my $rOpts  = $self->[_rOpts_];
 228     my $forced = $rOpts->{'maximum-consecutive-blank-lines'} > 0;
 229     foreach my $i ( 0 .. $need - 1 ) {
 230         $self->write_blank_code_line($forced);
 231     }
 232     return;
 233 }
 234
 235 sub write_blank_code_line {
 236     my $self   = shift;
 237     my $forced = shift;
 238     my $rOpts  = $self->[_rOpts_];
 239     return
 240       if (!$forced
 241         && $self->[_consecutive_blank_lines_] >=
 242         $rOpts->{'maximum-consecutive-blank-lines'} );
 243
 244     $self->[_consecutive_nonblank_lines_] = 0;
 245
 246     # Balance old blanks against new (forced) blanks instead of writing them.
 247     # This fixes case b1073.
 248     if ( !$forced && $self->[_consecutive_new_blank_lines_] > 0 ) {
 249         $self->[_consecutive_new_blank_lines_]--;
 250         return;
 251     }
 252
 253     $self->write_line("\n");
 254     $self->[_consecutive_blank_lines_]++;
 255     $self->[_consecutive_new_blank_lines_]++ if ($forced);
 256
 257     return;
 258 }
 259
 260 use constant MAX_PRINTED_CHARS => 80;
 261
 262 sub write_code_line {
 263     my ( $self, $str, $K ) = @_;
 264
 265     $self->[_consecutive_blank_lines_]     = 0;
 266     $self->[_consecutive_new_blank_lines_] = 0;
 267     $self->[_consecutive_nonblank_lines_]++;
 268     $self->write_line($str);
 269
 270     #----------------------------
 271     # Convergence and error check
 272     #----------------------------
 273     if ( defined($K) ) {
 274
 275         # Convergence check: we are checking if all defined K values arrive in
 276         # the order which was defined by the caller.  Quit checking if any
 277         # unexpected K value arrives.
 278         if ( $self->[_K_arrival_order_matches_] ) {
 279             my $Kt = pop @{ $self->[_rK_checklist_] };
 280             if ( !defined($Kt) || $Kt != $K ) {
 281                 $self->[_K_arrival_order_matches_] = 0;
 282             }
 283         }
 284
 285         # Check for out-of-order arrivals of index K. The K values are the
 286         # token indexes of the last token of code lines, and they should come
 287         # out in increasing order.  Otherwise something is seriously wrong.
 288         # Most likely a recent programming change to VerticalAligner.pm has
 289         # caused lines to go out in the wrong order.  This could happen if
 290         # either the cache or buffer that it uses are emptied in the wrong
 291         # order.
 292         if ( !$self->[_K_sequence_error_msg_] ) {
 293             my $K_prev = $self->[_K_last_arrival_];
 294             if ( $K < $K_prev ) {
 295                 chomp $str;
 296                 if ( length($str) > MAX_PRINTED_CHARS ) {
 297                     $str = substr( $str, 0, MAX_PRINTED_CHARS ) . "...";
 298                 }
 299
 300                 my $msg = <<EOM;
 301 While operating on input stream with name: '$input_stream_name'
 302 Lines have arrived out of order in sub 'write_code_line'
 303 as detected by token index K=$K arriving after index K=$K_prev in the following line:
 304 $str
 305 This is probably due to a recent programming change and needs to be fixed.
 306 EOM
 307
 308                 if (DEVEL_MODE) { Fault($msg) }
 309
 310                 $self->warning($msg);
 311
 312                 # Only issue this warning once
 313                 $self->[_K_sequence_error_msg_] = $msg;
 314
 315             }
 316         }
 317         $self->[_K_last_arrival_] = $K;
 318     }
 319     return;
 320 }
 321
 322 sub write_line {
 323     my ( $self, $str ) = @_;
 324
 325     $self->[_line_sink_object_]->write_line($str);
 326
 327     if ( chomp $str ) { $self->[_output_line_number_]++; }
 328
 329     # This calculation of excess line length ignores any internal tabs
 330     my $rOpts   = $self->[_rOpts_];
 331     my $len_str = length($str);
 332     my $exceed  = $len_str - $rOpts->{'maximum-line-length'};
 333     if ( $str && substr( $str, 0, 1 ) eq "\t" && $str =~ /^\t+/g ) {
 334         $exceed += pos($str) * $rOpts->{'indent-columns'};
 335     }
 336
 337     # Note that we just incremented output line number to future value
 338     # so we must subtract 1 for current line number
 339     if ( $len_str > $self->[_max_output_line_length_] ) {
 340         $self->[_max_output_line_length_] = $len_str;
 341         $self->[_max_output_line_length_at_] =
 342           $self->[_output_line_number_] - 1;
 343     }
 344
 345     if ( $exceed > 0 ) {
 346         my $output_line_number = $self->[_output_line_number_];
 347         $self->[_last_line_length_error_]    = $exceed;
 348         $self->[_last_line_length_error_at_] = $output_line_number - 1;
 349         if ( $self->[_line_length_error_count_] == 0 ) {
 350             $self->[_first_line_length_error_]    = $exceed;
 351             $self->[_first_line_length_error_at_] = $output_line_number - 1;
 352         }
 353
 354         if ( $self->[_last_line_length_error_] >
 355             $self->[_max_line_length_error_] )
 356         {
 357             $self->[_max_line_length_error_]    = $exceed;
 358             $self->[_max_line_length_error_at_] = $output_line_number - 1;
 359         }
 360
 361         if ( $self->[_line_length_error_count_] < MAX_NAG_MESSAGES ) {
 362             $self->write_logfile_entry(
 363                 "Line length exceeded by $exceed characters\n");
 364         }
 365         $self->[_line_length_error_count_]++;
 366     }
 367     return;
 368 }
 369
 370 sub report_line_length_errors {
 371     my $self                    = shift;
 372     my $rOpts                   = $self->[_rOpts_];
 373     my $line_length_error_count = $self->[_line_length_error_count_];
 374     if ( $line_length_error_count == 0 ) {
 375         $self->write_logfile_entry(
 376             "No lines exceeded $rOpts->{'maximum-line-length'} characters\n");
 377         my $max_output_line_length    = $self->[_max_output_line_length_];
 378         my $max_output_line_length_at = $self->[_max_output_line_length_at_];
 379         $self->write_logfile_entry(
 380 "  Maximum output line length was $max_output_line_length at line $max_output_line_length_at\n"
 381         );
 382
 383     }
 384     else {
 385
 386         my $word = ( $line_length_error_count > 1 ) ? "s" : EMPTY_STRING;
 387         $self->write_logfile_entry(
 388 "$line_length_error_count output line$word exceeded $rOpts->{'maximum-line-length'} characters:\n"
 389         );
 390
 391         $word = ( $line_length_error_count > 1 ) ? "First" : EMPTY_STRING;
 392         my $first_line_length_error    = $self->[_first_line_length_error_];
 393         my $first_line_length_error_at = $self->[_first_line_length_error_at_];
 394         $self->write_logfile_entry(
 395 " $word at line $first_line_length_error_at by $first_line_length_error characters\n"
 396         );
 397
 398         if ( $line_length_error_count > 1 ) {
 399             my $max_line_length_error    = $self->[_max_line_length_error_];
 400             my $max_line_length_error_at = $self->[_max_line_length_error_at_];
 401             my $last_line_length_error   = $self->[_last_line_length_error_];
 402             my $last_line_length_error_at =
 403               $self->[_last_line_length_error_at_];
 404             $self->write_logfile_entry(
 405 " Maximum at line $max_line_length_error_at by $max_line_length_error characters\n"
 406             );
 407             $self->write_logfile_entry(
 408 " Last at line $last_line_length_error_at by $last_line_length_error characters\n"
 409             );
 410         }
 411     }
 412     return;
 413 }
 414 1;