1 #####################################################################
3 # the Perl::Tidy::FileWriter class writes the output file
5 #####################################################################
7 package Perl::Tidy::FileWriter;
10 our $VERSION = '20210717';
12 use constant DEVEL_MODE => 0;
16 # Catch any undefined sub calls so that we are sure to get
17 # some diagnostic information. This sub should never be called
18 # except for a programming error.
20 return if ( $AUTOLOAD =~ /\bDESTROY$/ );
21 my ( $pkg, $fname, $lno ) = caller();
22 my $my_package = __PACKAGE__;
24 ======================================================================
25 Error detected in package '$my_package', version $VERSION
26 Received unexpected AUTOLOAD call for sub '$AUTOLOAD'
27 Called from package: '$pkg'
28 Called from File '$fname' at line '$lno'
29 This error is probably due to a recent programming change
30 ======================================================================
37 # required to avoid call to AUTOLOAD in some versions of perl
40 my $input_stream_name = "";
42 # Maximum number of little messages; probably need not be changed.
43 my $MAX_NAG_MESSAGES = 6;
47 # Array index names for variables
50 _line_sink_object_ => $i++,
51 _logger_object_ => $i++,
53 _output_line_number_ => $i++,
54 _consecutive_blank_lines_ => $i++,
55 _consecutive_nonblank_lines_ => $i++,
56 _consecutive_new_blank_lines_ => $i++,
57 _first_line_length_error_ => $i++,
58 _max_line_length_error_ => $i++,
59 _last_line_length_error_ => $i++,
60 _first_line_length_error_at_ => $i++,
61 _max_line_length_error_at_ => $i++,
62 _last_line_length_error_at_ => $i++,
63 _line_length_error_count_ => $i++,
64 _max_output_line_length_ => $i++,
65 _max_output_line_length_at_ => $i++,
66 _rK_checklist_ => $i++,
67 _K_arrival_order_matches_ => $i++,
68 _K_sequence_error_msg_ => $i++,
69 _K_last_arrival_ => $i++,
74 my ( $self, $msg ) = @_;
75 my $logger_object = $self->[_logger_object_];
76 if ($logger_object) { $logger_object->warning($msg); }
80 sub write_logfile_entry {
81 my ( $self, $msg ) = @_;
82 my $logger_object = $self->[_logger_object_];
84 $logger_object->write_logfile_entry($msg);
90 my ( $class, $line_sink_object, $rOpts, $logger_object ) = @_;
93 $self->[_line_sink_object_] = $line_sink_object;
94 $self->[_logger_object_] = $logger_object;
95 $self->[_rOpts_] = $rOpts;
96 $self->[_output_line_number_] = 1;
97 $self->[_consecutive_blank_lines_] = 0;
98 $self->[_consecutive_nonblank_lines_] = 0;
99 $self->[_consecutive_new_blank_lines_] = 0;
100 $self->[_first_line_length_error_] = 0;
101 $self->[_max_line_length_error_] = 0;
102 $self->[_last_line_length_error_] = 0;
103 $self->[_first_line_length_error_at_] = 0;
104 $self->[_max_line_length_error_at_] = 0;
105 $self->[_last_line_length_error_at_] = 0;
106 $self->[_line_length_error_count_] = 0;
107 $self->[_max_output_line_length_] = 0;
108 $self->[_max_output_line_length_at_] = 0;
109 $self->[_rK_checklist_] = [];
110 $self->[_K_arrival_order_matches_] = 0;
111 $self->[_K_sequence_error_msg_] = "";
112 $self->[_K_last_arrival_] = -1;
114 # save input stream name for local error messages
115 $input_stream_name = "";
116 if ($logger_object) {
117 $input_stream_name = $logger_object->get_input_stream_name();
124 sub setup_convergence_test {
125 my ( $self, $rlist ) = @_;
128 # We are going to destroy the list, so make a copy
129 # and put in reverse order so we can pop values
130 my @list = @{$rlist};
131 if ( $list[0] < $list[-1] ) {
132 @list = reverse @list;
134 $self->[_rK_checklist_] = \@list;
136 $self->[_K_arrival_order_matches_] = 1;
137 $self->[_K_sequence_error_msg_] = "";
138 $self->[_K_last_arrival_] = -1;
142 sub get_convergence_check {
144 my $rlist = $self->[_rK_checklist_];
146 # converged if all K arrived and in correct order
147 return $self->[_K_arrival_order_matches_] && !@{$rlist};
150 sub get_K_sequence_error_msg {
152 return $self->[_K_sequence_error_msg_];
155 sub get_output_line_number {
156 return $_[0]->[_output_line_number_];
159 sub decrement_output_line_number {
160 $_[0]->[_output_line_number_]--;
164 sub get_consecutive_nonblank_lines {
165 return $_[0]->[_consecutive_nonblank_lines_];
168 sub get_consecutive_blank_lines {
169 return $_[0]->[_consecutive_blank_lines_];
172 sub reset_consecutive_blank_lines {
173 $_[0]->[_consecutive_blank_lines_] = 0;
177 sub want_blank_line {
179 unless ( $self->[_consecutive_blank_lines_] ) {
180 $self->write_blank_code_line();
185 sub require_blank_code_lines {
187 # write out the requested number of blanks regardless of the value of -mbl
188 # unless -mbl=0. This allows extra blank lines to be written for subs and
189 # packages even with the default -mbl=1
190 my ( $self, $count ) = @_;
191 my $need = $count - $self->[_consecutive_blank_lines_];
192 my $rOpts = $self->[_rOpts_];
193 my $forced = $rOpts->{'maximum-consecutive-blank-lines'} > 0;
194 foreach my $i ( 0 .. $need - 1 ) {
195 $self->write_blank_code_line($forced);
200 sub write_blank_code_line {
203 my $rOpts = $self->[_rOpts_];
206 && $self->[_consecutive_blank_lines_] >=
207 $rOpts->{'maximum-consecutive-blank-lines'} );
209 $self->[_consecutive_nonblank_lines_] = 0;
211 # Balance old blanks against new (forced) blanks instead of writing them.
212 # This fixes case b1073.
213 if ( !$forced && $self->[_consecutive_new_blank_lines_] > 0 ) {
214 $self->[_consecutive_new_blank_lines_]--;
218 $self->write_line("\n");
219 $self->[_consecutive_blank_lines_]++;
220 $self->[_consecutive_new_blank_lines_]++ if ($forced);
225 sub write_code_line {
226 my ( $self, $str, $K ) = @_;
228 $self->[_consecutive_blank_lines_] = 0;
229 $self->[_consecutive_new_blank_lines_] = 0;
230 $self->[_consecutive_nonblank_lines_]++;
231 $self->write_line($str);
233 #----------------------------
234 # Convergence and error check
235 #----------------------------
238 # Convergence check: we are checking if all defined K values arrive in
239 # the order which was defined by the caller. Quit checking if any
240 # unexpected K value arrives.
241 if ( $self->[_K_arrival_order_matches_] ) {
242 my $Kt = pop @{ $self->[_rK_checklist_] };
243 if ( !defined($Kt) || $Kt != $K ) {
244 $self->[_K_arrival_order_matches_] = 0;
248 # Check for out-of-order arrivals of index K. The K values are the
249 # token indexes of the last token of code lines, and they should come
250 # out in increasing order. Otherwise something is seriously wrong.
251 # Most likely a recent programming change to VerticalAligner.pm has
252 # caused lines to go out in the wrong order. This could happen if
253 # either the cache or buffer that it uses are emptied in the wrong
255 if ( !$self->[_K_sequence_error_msg_] ) {
256 my $K_prev = $self->[_K_last_arrival_];
257 if ( $K < $K_prev ) {
259 if ( length($str) > 80 ) {
260 $str = substr( $str, 0, 80 ) . "...";
264 While operating on input stream with name: '$input_stream_name'
265 Lines have arrived out of order in sub 'write_code_line'
266 as detected by token index K=$K arriving after index K=$K_prev in the following line:
268 This is probably due to a recent programming change and needs to be fixed.
271 # FIXME: it would be best to set a 'severe_error' flag here and
272 # tell caller to output the original file
273 $self->warning($msg);
275 # Only issue this warning once
276 $self->[_K_sequence_error_msg_] = $msg;
278 # stop here in DEVEL mode so this issue doesn't get missed
279 DEVEL_MODE && Perl::Tidy::Die($msg);
282 $self->[_K_last_arrival_] = $K;
288 my ( $self, $str ) = @_;
290 $self->[_line_sink_object_]->write_line($str);
292 if ( chomp $str ) { $self->[_output_line_number_]++; }
294 # This calculation of excess line length ignores any internal tabs
295 my $rOpts = $self->[_rOpts_];
296 my $len_str = length($str);
297 my $exceed = $len_str - $rOpts->{'maximum-line-length'};
298 if ( $str && substr( $str, 0, 1 ) eq "\t" && $str =~ /^\t+/g ) {
299 $exceed += pos($str) * $rOpts->{'indent-columns'};
302 # Note that we just incremented output line number to future value
303 # so we must subtract 1 for current line number
304 if ( $len_str > $self->[_max_output_line_length_] ) {
305 $self->[_max_output_line_length_] = $len_str;
306 $self->[_max_output_line_length_at_] =
307 $self->[_output_line_number_] - 1;
311 my $output_line_number = $self->[_output_line_number_];
312 $self->[_last_line_length_error_] = $exceed;
313 $self->[_last_line_length_error_at_] = $output_line_number - 1;
314 if ( $self->[_line_length_error_count_] == 0 ) {
315 $self->[_first_line_length_error_] = $exceed;
316 $self->[_first_line_length_error_at_] = $output_line_number - 1;
319 if ( $self->[_last_line_length_error_] >
320 $self->[_max_line_length_error_] )
322 $self->[_max_line_length_error_] = $exceed;
323 $self->[_max_line_length_error_at_] = $output_line_number - 1;
326 if ( $self->[_line_length_error_count_] < $MAX_NAG_MESSAGES ) {
327 $self->write_logfile_entry(
328 "Line length exceeded by $exceed characters\n");
330 $self->[_line_length_error_count_]++;
335 sub report_line_length_errors {
337 my $rOpts = $self->[_rOpts_];
338 my $line_length_error_count = $self->[_line_length_error_count_];
339 if ( $line_length_error_count == 0 ) {
340 $self->write_logfile_entry(
341 "No lines exceeded $rOpts->{'maximum-line-length'} characters\n");
342 my $max_output_line_length = $self->[_max_output_line_length_];
343 my $max_output_line_length_at = $self->[_max_output_line_length_at_];
344 $self->write_logfile_entry(
345 " Maximum output line length was $max_output_line_length at line $max_output_line_length_at\n"
351 my $word = ( $line_length_error_count > 1 ) ? "s" : "";
352 $self->write_logfile_entry(
353 "$line_length_error_count output line$word exceeded $rOpts->{'maximum-line-length'} characters:\n"
356 $word = ( $line_length_error_count > 1 ) ? "First" : "";
357 my $first_line_length_error = $self->[_first_line_length_error_];
358 my $first_line_length_error_at = $self->[_first_line_length_error_at_];
359 $self->write_logfile_entry(
360 " $word at line $first_line_length_error_at by $first_line_length_error characters\n"
363 if ( $line_length_error_count > 1 ) {
364 my $max_line_length_error = $self->[_max_line_length_error_];
365 my $max_line_length_error_at = $self->[_max_line_length_error_at_];
366 my $last_line_length_error = $self->[_last_line_length_error_];
367 my $last_line_length_error_at =
368 $self->[_last_line_length_error_at_];
369 $self->write_logfile_entry(
370 " Maximum at line $max_line_length_error_at by $max_line_length_error characters\n"
372 $self->write_logfile_entry(
373 " Last at line $last_line_length_error_at by $last_line_length_error characters\n"