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