1 #####################################################################
3 # the Perl::Tidy::FileWriter class writes the output file
5 #####################################################################
7 package Perl::Tidy::FileWriter;
10 our $VERSION = '20230309';
12 use constant DEVEL_MODE => 0;
13 use constant EMPTY_STRING => q{};
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.
21 return if ( $AUTOLOAD =~ /\bDESTROY$/ );
22 my ( $pkg, $fname, $lno ) = caller();
23 my $my_package = __PACKAGE__;
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 ======================================================================
38 # required to avoid call to AUTOLOAD in some versions of perl
41 my $input_stream_name = EMPTY_STRING;
43 # Maximum number of little messages; probably need not be changed.
44 use constant MAX_NAG_MESSAGES => 6;
48 # Array index names for variables.
49 # Do not combine with other BEGIN blocks (c101).
52 _line_sink_object_ => $i++,
53 _logger_object_ => $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++,
78 Perl::Tidy::Die($msg);
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__;
95 ==============================================================================
96 While operating on input stream with name: '$input_stream_name'
97 A fault was detected at line $line0 of sub '$subroutine1'
99 which was called from line $line1 of sub '$subroutine2'
101 This is probably an error introduced by a recent programming change.
102 $pkg reports VERSION='$VERSION'.
103 ==============================================================================
106 # This return is to keep Perl-Critic from complaining.
111 my ( $self, $msg ) = @_;
112 my $logger_object = $self->[_logger_object_];
113 if ($logger_object) { $logger_object->warning($msg); }
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);
124 } ## end sub write_logfile_entry
127 my ( $class, $line_sink_object, $rOpts, $logger_object ) = @_;
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);
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();
162 sub setup_convergence_test {
163 my ( $self, $rlist ) = @_;
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;
172 $self->[_rK_checklist_] = \@list;
174 $self->[_K_arrival_order_matches_] = 1;
175 $self->[_K_sequence_error_msg_] = EMPTY_STRING;
176 $self->[_K_last_arrival_] = -1;
178 } ## end sub setup_convergence_test
180 sub get_convergence_check {
182 my $rlist = $self->[_rK_checklist_];
184 # converged if all K arrived and in correct order
185 return $self->[_K_arrival_order_matches_] && !@{$rlist};
186 } ## end sub get_convergence_check
188 sub get_output_line_number {
189 return $_[0]->[_output_line_number_];
192 sub decrement_output_line_number {
193 $_[0]->[_output_line_number_]--;
197 sub get_consecutive_nonblank_lines {
198 return $_[0]->[_consecutive_nonblank_lines_];
201 sub get_consecutive_blank_lines {
202 return $_[0]->[_consecutive_blank_lines_];
205 sub reset_consecutive_blank_lines {
206 $_[0]->[_consecutive_blank_lines_] = 0;
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;
218 sub want_blank_line {
220 unless ( $self->[_consecutive_blank_lines_] ) {
221 $self->write_blank_code_line();
224 } ## end sub want_blank_line
226 sub require_blank_code_lines {
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);
239 } ## end sub require_blank_code_lines
241 sub write_blank_code_line {
242 my ( $self, $forced ) = @_;
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
249 my $rOpts = $self->[_rOpts_];
252 && $self->[_consecutive_blank_lines_] >=
253 $rOpts->{'maximum-consecutive-blank-lines'} );
255 $self->[_consecutive_nonblank_lines_] = 0;
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_]--;
264 $self->[_line_sink_object_]->write_line("\n");
265 $self->[_output_line_number_]++;
267 $self->[_consecutive_blank_lines_]++;
268 $self->[_consecutive_new_blank_lines_]++ if ($forced);
271 } ## end sub write_blank_code_line
273 use constant MAX_PRINTED_CHARS => 80;
275 sub write_code_line {
276 my ( $self, $str, $K ) = @_;
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.
284 $self->[_consecutive_blank_lines_] = 0;
285 $self->[_consecutive_new_blank_lines_] = 0;
286 $self->[_consecutive_nonblank_lines_]++;
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) }
292 #----------------------------
293 # Convergence and error check
294 #----------------------------
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;
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
314 if ( !$self->[_K_sequence_error_msg_] ) {
315 my $K_prev = $self->[_K_last_arrival_];
316 if ( $K < $K_prev ) {
318 if ( length($str) > MAX_PRINTED_CHARS ) {
319 $str = substr( $str, 0, MAX_PRINTED_CHARS ) . "...";
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:
327 This is probably due to a recent programming change and needs to be fixed.
330 # Always die during development, this needs to be fixed
331 if (DEVEL_MODE) { Fault($msg) }
333 # Otherwise warn if string is not empty (added for b1378)
334 $self->warning($msg) if ( length($str) );
336 # Only issue this warning once
337 $self->[_K_sequence_error_msg_] = $msg;
341 $self->[_K_last_arrival_] = $K;
344 } ## end sub write_code_line
347 my ( $self, $str ) = @_;
349 # Write a line directly to the output, without any counting of blank or
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) }
357 } ## end sub write_line
359 sub check_line_lengths {
360 my ( $self, $str ) = @_;
362 # collect info on line lengths for logfile
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'};
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;
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;
389 if ( $self->[_last_line_length_error_] >
390 $self->[_max_line_length_error_] )
392 $self->[_max_line_length_error_] = $exceed;
393 $self->[_max_line_length_error_at_] = $output_line_number - 1;
396 if ( $self->[_line_length_error_count_] < MAX_NAG_MESSAGES ) {
397 $self->write_logfile_entry(
398 "Line length exceeded by $exceed characters\n");
400 $self->[_line_length_error_count_]++;
403 } ## end sub check_line_lengths
405 sub report_line_length_errors {
408 # Write summary info about line lengths to the log file
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"
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"
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"
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"
445 $self->write_logfile_entry(
446 " Last at line $last_line_length_error_at by $last_line_length_error characters\n"
451 } ## end sub report_line_length_errors