1 #####################################################################
3 # the Perl::Tidy::FileWriter class writes the output file
5 #####################################################################
7 package Perl::Tidy::FileWriter;
10 our $VERSION = '20221112';
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++,
77 Perl::Tidy::Die($msg);
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);
93 ==============================================================================
94 While operating on input stream with name: '$input_stream_name'
95 A fault was detected at line $line0 of sub '$subroutine1'
97 which was called from line $line1 of sub '$subroutine2'
99 This is probably an error introduced by a recent programming change.
100 Perl::Tidy::FileWriter.pm reports VERSION='$VERSION'.
101 ==============================================================================
104 # This return is to keep Perl-Critic from complaining.
109 my ( $self, $msg ) = @_;
110 my $logger_object = $self->[_logger_object_];
111 if ($logger_object) { $logger_object->warning($msg); }
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);
125 my ( $class, $line_sink_object, $rOpts, $logger_object ) = @_;
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;
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();
159 sub setup_convergence_test {
160 my ( $self, $rlist ) = @_;
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;
169 $self->[_rK_checklist_] = \@list;
171 $self->[_K_arrival_order_matches_] = 1;
172 $self->[_K_sequence_error_msg_] = EMPTY_STRING;
173 $self->[_K_last_arrival_] = -1;
177 sub get_convergence_check {
179 my $rlist = $self->[_rK_checklist_];
181 # converged if all K arrived and in correct order
182 return $self->[_K_arrival_order_matches_] && !@{$rlist};
185 sub get_output_line_number {
186 return $_[0]->[_output_line_number_];
189 sub decrement_output_line_number {
190 $_[0]->[_output_line_number_]--;
194 sub get_consecutive_nonblank_lines {
195 return $_[0]->[_consecutive_nonblank_lines_];
198 sub get_consecutive_blank_lines {
199 return $_[0]->[_consecutive_blank_lines_];
202 sub reset_consecutive_blank_lines {
203 $_[0]->[_consecutive_blank_lines_] = 0;
207 sub want_blank_line {
209 unless ( $self->[_consecutive_blank_lines_] ) {
210 $self->write_blank_code_line();
215 sub require_blank_code_lines {
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);
230 sub write_blank_code_line {
233 my $rOpts = $self->[_rOpts_];
236 && $self->[_consecutive_blank_lines_] >=
237 $rOpts->{'maximum-consecutive-blank-lines'} );
239 $self->[_consecutive_nonblank_lines_] = 0;
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_]--;
248 $self->write_line("\n");
249 $self->[_consecutive_blank_lines_]++;
250 $self->[_consecutive_new_blank_lines_]++ if ($forced);
255 use constant MAX_PRINTED_CHARS => 80;
257 sub write_code_line {
258 my ( $self, $str, $K ) = @_;
260 $self->[_consecutive_blank_lines_] = 0;
261 $self->[_consecutive_new_blank_lines_] = 0;
262 $self->[_consecutive_nonblank_lines_]++;
263 $self->write_line($str);
265 #----------------------------
266 # Convergence and error check
267 #----------------------------
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;
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
287 if ( !$self->[_K_sequence_error_msg_] ) {
288 my $K_prev = $self->[_K_last_arrival_];
289 if ( $K < $K_prev ) {
291 if ( length($str) > MAX_PRINTED_CHARS ) {
292 $str = substr( $str, 0, MAX_PRINTED_CHARS ) . "...";
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:
300 This is probably due to a recent programming change and needs to be fixed.
303 # Always die during development, this needs to be fixed
304 if (DEVEL_MODE) { Fault($msg) }
306 # Otherwise warn if string is not empty (added for b1378)
307 $self->warning($msg) if ( length($str) );
309 # Only issue this warning once
310 $self->[_K_sequence_error_msg_] = $msg;
314 $self->[_K_last_arrival_] = $K;
320 my ( $self, $str ) = @_;
322 $self->[_line_sink_object_]->write_line($str);
324 if ( chomp $str ) { $self->[_output_line_number_]++; }
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'};
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;
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;
351 if ( $self->[_last_line_length_error_] >
352 $self->[_max_line_length_error_] )
354 $self->[_max_line_length_error_] = $exceed;
355 $self->[_max_line_length_error_at_] = $output_line_number - 1;
358 if ( $self->[_line_length_error_count_] < MAX_NAG_MESSAGES ) {
359 $self->write_logfile_entry(
360 "Line length exceeded by $exceed characters\n");
362 $self->[_line_length_error_count_]++;
367 sub report_line_length_errors {
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"
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"
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"
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"
404 $self->write_logfile_entry(
405 " Last at line $last_line_length_error_at by $last_line_length_error characters\n"