line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
##################################################################### |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# the Perl::Tidy::FileWriter class writes the output file |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
##################################################################### |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
package Perl::Tidy::FileWriter; |
8
|
38
|
|
|
38
|
|
264
|
use strict; |
|
38
|
|
|
|
|
91
|
|
|
38
|
|
|
|
|
1118
|
|
9
|
38
|
|
|
38
|
|
206
|
use warnings; |
|
38
|
|
|
|
|
66
|
|
|
38
|
|
|
|
|
1535
|
|
10
|
|
|
|
|
|
|
our $VERSION = '20230701'; |
11
|
|
|
|
|
|
|
|
12
|
38
|
|
|
38
|
|
203
|
use constant DEVEL_MODE => 0; |
|
38
|
|
|
|
|
78
|
|
|
38
|
|
|
|
|
2645
|
|
13
|
38
|
|
|
38
|
|
245
|
use constant EMPTY_STRING => q{}; |
|
38
|
|
|
|
|
81
|
|
|
38
|
|
|
|
|
8179
|
|
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
|
0
|
|
|
0
|
|
0
|
our $AUTOLOAD; |
21
|
0
|
0
|
|
|
|
0
|
return if ( $AUTOLOAD =~ /\bDESTROY$/ ); |
22
|
0
|
|
|
|
|
0
|
my ( $pkg, $fname, $lno ) = caller(); |
23
|
0
|
|
|
|
|
0
|
my $my_package = __PACKAGE__; |
24
|
0
|
|
|
|
|
0
|
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
|
0
|
|
|
|
|
0
|
exit 1; |
34
|
|
|
|
|
|
|
} ## end sub AUTOLOAD |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
0
|
|
|
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
|
38
|
|
|
38
|
|
295
|
use constant MAX_NAG_MESSAGES => 6; |
|
38
|
|
|
|
|
69
|
|
|
38
|
|
|
|
|
5253
|
|
45
|
|
|
|
|
|
|
|
46
|
0
|
|
|
|
|
0
|
BEGIN { |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
# Array index names for variables. |
49
|
|
|
|
|
|
|
# Do not combine with other BEGIN blocks (c101). |
50
|
38
|
|
|
38
|
|
46264
|
my $i = 0; |
51
|
|
|
|
|
|
|
use constant { |
52
|
38
|
|
|
|
|
9275
|
_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
|
38
|
|
|
38
|
|
280
|
}; |
|
38
|
|
|
|
|
83
|
|
74
|
|
|
|
|
|
|
} ## end BEGIN |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub Die { |
77
|
0
|
|
|
0
|
0
|
0
|
my ($msg) = @_; |
78
|
0
|
|
|
|
|
0
|
Perl::Tidy::Die($msg); |
79
|
0
|
|
|
|
|
0
|
return; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
sub Fault { |
83
|
0
|
|
|
0
|
0
|
0
|
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
|
0
|
|
|
|
|
0
|
my ( $package0, $filename0, $line0, $subroutine0 ) = caller(0); |
90
|
0
|
|
|
|
|
0
|
my ( $package1, $filename1, $line1, $subroutine1 ) = caller(1); |
91
|
0
|
|
|
|
|
0
|
my ( $package2, $filename2, $line2, $subroutine2 ) = caller(2); |
92
|
0
|
|
|
|
|
0
|
my $pkg = __PACKAGE__; |
93
|
|
|
|
|
|
|
|
94
|
0
|
|
|
|
|
0
|
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
|
0
|
|
|
|
|
0
|
return; |
108
|
|
|
|
|
|
|
} ## end sub Fault |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
sub warning { |
111
|
0
|
|
|
0
|
0
|
0
|
my ( $self, $msg ) = @_; |
112
|
0
|
|
|
|
|
0
|
my $logger_object = $self->[_logger_object_]; |
113
|
0
|
0
|
|
|
|
0
|
if ($logger_object) { $logger_object->warning($msg); } |
|
0
|
|
|
|
|
0
|
|
114
|
0
|
|
|
|
|
0
|
return; |
115
|
|
|
|
|
|
|
} ## end sub warning |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
sub write_logfile_entry { |
118
|
1110
|
|
|
1110
|
0
|
2768
|
my ( $self, $msg ) = @_; |
119
|
1110
|
|
|
|
|
2242
|
my $logger_object = $self->[_logger_object_]; |
120
|
1110
|
100
|
|
|
|
2817
|
if ($logger_object) { |
121
|
1106
|
|
|
|
|
2742
|
$logger_object->write_logfile_entry($msg); |
122
|
|
|
|
|
|
|
} |
123
|
1110
|
|
|
|
|
2684
|
return; |
124
|
|
|
|
|
|
|
} ## end sub write_logfile_entry |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
sub new { |
127
|
555
|
|
|
555
|
0
|
2179
|
my ( $class, $line_sink_object, $rOpts, $logger_object ) = @_; |
128
|
|
|
|
|
|
|
|
129
|
555
|
|
|
|
|
1510
|
my $self = []; |
130
|
555
|
|
|
|
|
1750
|
$self->[_line_sink_object_] = $line_sink_object; |
131
|
555
|
|
|
|
|
1594
|
$self->[_logger_object_] = $logger_object; |
132
|
555
|
|
|
|
|
1292
|
$self->[_rOpts_] = $rOpts; |
133
|
555
|
|
|
|
|
1409
|
$self->[_output_line_number_] = 1; |
134
|
555
|
|
|
|
|
1479
|
$self->[_consecutive_blank_lines_] = 0; |
135
|
555
|
|
|
|
|
1478
|
$self->[_consecutive_nonblank_lines_] = 0; |
136
|
555
|
|
|
|
|
1510
|
$self->[_consecutive_new_blank_lines_] = 0; |
137
|
555
|
|
|
|
|
1522
|
$self->[_first_line_length_error_] = 0; |
138
|
555
|
|
|
|
|
1370
|
$self->[_max_line_length_error_] = 0; |
139
|
555
|
|
|
|
|
1339
|
$self->[_last_line_length_error_] = 0; |
140
|
555
|
|
|
|
|
1403
|
$self->[_first_line_length_error_at_] = 0; |
141
|
555
|
|
|
|
|
1449
|
$self->[_max_line_length_error_at_] = 0; |
142
|
555
|
|
|
|
|
1390
|
$self->[_last_line_length_error_at_] = 0; |
143
|
555
|
|
|
|
|
1362
|
$self->[_line_length_error_count_] = 0; |
144
|
555
|
|
|
|
|
1306
|
$self->[_max_output_line_length_] = 0; |
145
|
555
|
|
|
|
|
1405
|
$self->[_max_output_line_length_at_] = 0; |
146
|
555
|
|
|
|
|
1501
|
$self->[_rK_checklist_] = []; |
147
|
555
|
|
|
|
|
1347
|
$self->[_K_arrival_order_matches_] = 0; |
148
|
555
|
|
|
|
|
1779
|
$self->[_K_sequence_error_msg_] = EMPTY_STRING; |
149
|
555
|
|
|
|
|
1344
|
$self->[_K_last_arrival_] = -1; |
150
|
555
|
|
|
|
|
1590
|
$self->[_save_logfile_] = defined($logger_object); |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
# save input stream name for local error messages |
153
|
555
|
|
|
|
|
1527
|
$input_stream_name = EMPTY_STRING; |
154
|
555
|
100
|
|
|
|
2106
|
if ($logger_object) { |
155
|
553
|
|
|
|
|
2678
|
$input_stream_name = $logger_object->get_input_stream_name(); |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
|
158
|
555
|
|
|
|
|
1572
|
bless $self, $class; |
159
|
555
|
|
|
|
|
1794
|
return $self; |
160
|
|
|
|
|
|
|
} ## end sub new |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub setup_convergence_test { |
163
|
552
|
|
|
552
|
0
|
2101
|
my ( $self, $rlist ) = @_; |
164
|
552
|
100
|
|
|
|
1084
|
if ( @{$rlist} ) { |
|
552
|
|
|
|
|
2004
|
|
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
|
542
|
|
|
|
|
1171
|
my @list = @{$rlist}; |
|
542
|
|
|
|
|
2173
|
|
169
|
542
|
100
|
|
|
|
2162
|
if ( $list[0] < $list[-1] ) { |
170
|
467
|
|
|
|
|
1277
|
@list = reverse @list; |
171
|
|
|
|
|
|
|
} |
172
|
542
|
|
|
|
|
1738
|
$self->[_rK_checklist_] = \@list; |
173
|
|
|
|
|
|
|
} |
174
|
552
|
|
|
|
|
1479
|
$self->[_K_arrival_order_matches_] = 1; |
175
|
552
|
|
|
|
|
1338
|
$self->[_K_sequence_error_msg_] = EMPTY_STRING; |
176
|
552
|
|
|
|
|
1264
|
$self->[_K_last_arrival_] = -1; |
177
|
552
|
|
|
|
|
1566
|
return; |
178
|
|
|
|
|
|
|
} ## end sub setup_convergence_test |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub get_convergence_check { |
181
|
555
|
|
|
555
|
0
|
1531
|
my ($self) = @_; |
182
|
555
|
|
|
|
|
1435
|
my $rlist = $self->[_rK_checklist_]; |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
# converged if all K arrived and in correct order |
185
|
555
|
|
66
|
|
|
4453
|
return $self->[_K_arrival_order_matches_] && !@{$rlist}; |
186
|
|
|
|
|
|
|
} ## end sub get_convergence_check |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
sub get_output_line_number { |
189
|
493
|
|
|
493
|
0
|
1442
|
return $_[0]->[_output_line_number_]; |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
sub decrement_output_line_number { |
193
|
555
|
|
|
555
|
0
|
1374
|
$_[0]->[_output_line_number_]--; |
194
|
555
|
|
|
|
|
1223
|
return; |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
sub get_consecutive_nonblank_lines { |
198
|
1
|
|
|
1
|
0
|
6
|
return $_[0]->[_consecutive_nonblank_lines_]; |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
sub get_consecutive_blank_lines { |
202
|
0
|
|
|
0
|
0
|
0
|
return $_[0]->[_consecutive_blank_lines_]; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
sub reset_consecutive_blank_lines { |
206
|
120
|
|
|
120
|
0
|
251
|
$_[0]->[_consecutive_blank_lines_] = 0; |
207
|
120
|
|
|
|
|
214
|
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
|
553
|
|
|
553
|
0
|
2107
|
my ( $self, $save_logfile ) = @_; |
214
|
553
|
|
|
|
|
1584
|
$self->[_save_logfile_] = $save_logfile; |
215
|
553
|
|
|
|
|
1474
|
return; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
sub want_blank_line { |
219
|
20
|
|
|
20
|
0
|
53
|
my $self = shift; |
220
|
20
|
100
|
|
|
|
85
|
unless ( $self->[_consecutive_blank_lines_] ) { |
221
|
12
|
|
|
|
|
43
|
$self->write_blank_code_line(); |
222
|
|
|
|
|
|
|
} |
223
|
20
|
|
|
|
|
57
|
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
|
45
|
|
|
45
|
0
|
134
|
my ( $self, $count ) = @_; |
232
|
45
|
|
|
|
|
105
|
my $need = $count - $self->[_consecutive_blank_lines_]; |
233
|
45
|
|
|
|
|
82
|
my $rOpts = $self->[_rOpts_]; |
234
|
45
|
|
|
|
|
108
|
my $forced = $rOpts->{'maximum-consecutive-blank-lines'} > 0; |
235
|
45
|
|
|
|
|
143
|
foreach ( 0 .. $need - 1 ) { |
236
|
31
|
|
|
|
|
94
|
$self->write_blank_code_line($forced); |
237
|
|
|
|
|
|
|
} |
238
|
45
|
|
|
|
|
119
|
return; |
239
|
|
|
|
|
|
|
} ## end sub require_blank_code_lines |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
sub write_blank_code_line { |
242
|
872
|
|
|
872
|
0
|
2029
|
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
|
872
|
|
|
|
|
1717
|
my $rOpts = $self->[_rOpts_]; |
250
|
|
|
|
|
|
|
return |
251
|
|
|
|
|
|
|
if (!$forced |
252
|
|
|
|
|
|
|
&& $self->[_consecutive_blank_lines_] >= |
253
|
872
|
100
|
100
|
|
|
4217
|
$rOpts->{'maximum-consecutive-blank-lines'} ); |
254
|
|
|
|
|
|
|
|
255
|
770
|
|
|
|
|
1528
|
$self->[_consecutive_nonblank_lines_] = 0; |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
# Balance old blanks against new (forced) blanks instead of writing them. |
258
|
|
|
|
|
|
|
# This fixes case b1073. |
259
|
770
|
50
|
66
|
|
|
3242
|
if ( !$forced && $self->[_consecutive_new_blank_lines_] > 0 ) { |
260
|
0
|
|
|
|
|
0
|
$self->[_consecutive_new_blank_lines_]--; |
261
|
0
|
|
|
|
|
0
|
return; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
770
|
|
|
|
|
3044
|
$self->[_line_sink_object_]->write_line("\n"); |
265
|
770
|
|
|
|
|
1677
|
$self->[_output_line_number_]++; |
266
|
|
|
|
|
|
|
|
267
|
770
|
|
|
|
|
1748
|
$self->[_consecutive_blank_lines_]++; |
268
|
770
|
100
|
|
|
|
2237
|
$self->[_consecutive_new_blank_lines_]++ if ($forced); |
269
|
|
|
|
|
|
|
|
270
|
770
|
|
|
|
|
1575
|
return; |
271
|
|
|
|
|
|
|
} ## end sub write_blank_code_line |
272
|
|
|
|
|
|
|
|
273
|
38
|
|
|
38
|
|
325
|
use constant MAX_PRINTED_CHARS => 80; |
|
38
|
|
|
|
|
96
|
|
|
38
|
|
|
|
|
37429
|
|
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
sub write_code_line { |
276
|
7363
|
|
|
7363
|
0
|
15898
|
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
|
7363
|
|
|
|
|
12717
|
$self->[_consecutive_blank_lines_] = 0; |
285
|
7363
|
|
|
|
|
11041
|
$self->[_consecutive_new_blank_lines_] = 0; |
286
|
7363
|
|
|
|
|
10720
|
$self->[_consecutive_nonblank_lines_]++; |
287
|
|
|
|
|
|
|
|
288
|
7363
|
|
|
|
|
27304
|
$self->[_line_sink_object_]->write_line($str); |
289
|
7363
|
50
|
|
|
|
16732
|
if ( chomp $str ) { $self->[_output_line_number_]++; } |
|
7363
|
|
|
|
|
12089
|
|
290
|
7363
|
100
|
|
|
|
15290
|
if ( $self->[_save_logfile_] ) { $self->check_line_lengths($str) } |
|
5
|
|
|
|
|
17
|
|
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
#---------------------------- |
293
|
|
|
|
|
|
|
# Convergence and error check |
294
|
|
|
|
|
|
|
#---------------------------- |
295
|
7363
|
100
|
|
|
|
14873
|
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
|
6563
|
100
|
|
|
|
14252
|
if ( $self->[_K_arrival_order_matches_] ) { |
301
|
3198
|
|
|
|
|
4812
|
my $Kt = pop @{ $self->[_rK_checklist_] }; |
|
3198
|
|
|
|
|
6900
|
|
302
|
3198
|
100
|
66
|
|
|
13666
|
if ( !defined($Kt) || $Kt != $K ) { |
303
|
264
|
|
|
|
|
905
|
$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
|
6563
|
50
|
|
|
|
14156
|
if ( !$self->[_K_sequence_error_msg_] ) { |
315
|
6563
|
|
|
|
|
10668
|
my $K_prev = $self->[_K_last_arrival_]; |
316
|
6563
|
50
|
|
|
|
14010
|
if ( $K < $K_prev ) { |
317
|
0
|
|
|
|
|
0
|
chomp $str; |
318
|
0
|
0
|
|
|
|
0
|
if ( length($str) > MAX_PRINTED_CHARS ) { |
319
|
0
|
|
|
|
|
0
|
$str = substr( $str, 0, MAX_PRINTED_CHARS ) . "..."; |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
|
322
|
0
|
|
|
|
|
0
|
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
|
0
|
|
|
|
|
0
|
if (DEVEL_MODE) { Fault($msg) } |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
# Otherwise warn if string is not empty (added for b1378) |
334
|
0
|
0
|
|
|
|
0
|
$self->warning($msg) if ( length($str) ); |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
# Only issue this warning once |
337
|
0
|
|
|
|
|
0
|
$self->[_K_sequence_error_msg_] = $msg; |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
} |
341
|
6563
|
|
|
|
|
10303
|
$self->[_K_last_arrival_] = $K; |
342
|
|
|
|
|
|
|
} |
343
|
7363
|
|
|
|
|
14806
|
return; |
344
|
|
|
|
|
|
|
} ## end sub write_code_line |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
sub write_line { |
347
|
255
|
|
|
255
|
0
|
521
|
my ( $self, $str ) = @_; |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
# Write a line directly to the output, without any counting of blank or |
350
|
|
|
|
|
|
|
# non-blank lines. |
351
|
|
|
|
|
|
|
|
352
|
255
|
|
|
|
|
941
|
$self->[_line_sink_object_]->write_line($str); |
353
|
255
|
100
|
|
|
|
733
|
if ( chomp $str ) { $self->[_output_line_number_]++; } |
|
249
|
|
|
|
|
443
|
|
354
|
255
|
50
|
|
|
|
557
|
if ( $self->[_save_logfile_] ) { $self->check_line_lengths($str) } |
|
0
|
|
|
|
|
0
|
|
355
|
|
|
|
|
|
|
|
356
|
255
|
|
|
|
|
479
|
return; |
357
|
|
|
|
|
|
|
} ## end sub write_line |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
sub check_line_lengths { |
360
|
5
|
|
|
5
|
0
|
12
|
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
|
5
|
|
|
|
|
10
|
my $rOpts = $self->[_rOpts_]; |
366
|
5
|
|
|
|
|
8
|
my $len_str = length($str); |
367
|
5
|
|
|
|
|
11
|
my $exceed = $len_str - $rOpts->{'maximum-line-length'}; |
368
|
5
|
50
|
33
|
|
|
26
|
if ( $str && substr( $str, 0, 1 ) eq "\t" && $str =~ /^\t+/g ) { |
|
|
|
33
|
|
|
|
|
369
|
0
|
|
|
|
|
0
|
$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
|
5
|
100
|
|
|
|
21
|
if ( $len_str > $self->[_max_output_line_length_] ) { |
375
|
3
|
|
|
|
|
6
|
$self->[_max_output_line_length_] = $len_str; |
376
|
3
|
|
|
|
|
9
|
$self->[_max_output_line_length_at_] = |
377
|
|
|
|
|
|
|
$self->[_output_line_number_] - 1; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
|
380
|
5
|
50
|
|
|
|
10
|
if ( $exceed > 0 ) { |
381
|
0
|
|
|
|
|
0
|
my $output_line_number = $self->[_output_line_number_]; |
382
|
0
|
|
|
|
|
0
|
$self->[_last_line_length_error_] = $exceed; |
383
|
0
|
|
|
|
|
0
|
$self->[_last_line_length_error_at_] = $output_line_number - 1; |
384
|
0
|
0
|
|
|
|
0
|
if ( $self->[_line_length_error_count_] == 0 ) { |
385
|
0
|
|
|
|
|
0
|
$self->[_first_line_length_error_] = $exceed; |
386
|
0
|
|
|
|
|
0
|
$self->[_first_line_length_error_at_] = $output_line_number - 1; |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
|
389
|
0
|
0
|
|
|
|
0
|
if ( $self->[_last_line_length_error_] > |
390
|
|
|
|
|
|
|
$self->[_max_line_length_error_] ) |
391
|
|
|
|
|
|
|
{ |
392
|
0
|
|
|
|
|
0
|
$self->[_max_line_length_error_] = $exceed; |
393
|
0
|
|
|
|
|
0
|
$self->[_max_line_length_error_at_] = $output_line_number - 1; |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
0
|
0
|
|
|
|
0
|
if ( $self->[_line_length_error_count_] < MAX_NAG_MESSAGES ) { |
397
|
0
|
|
|
|
|
0
|
$self->write_logfile_entry( |
398
|
|
|
|
|
|
|
"Line length exceeded by $exceed characters\n"); |
399
|
|
|
|
|
|
|
} |
400
|
0
|
|
|
|
|
0
|
$self->[_line_length_error_count_]++; |
401
|
|
|
|
|
|
|
} |
402
|
5
|
|
|
|
|
11
|
return; |
403
|
|
|
|
|
|
|
} ## end sub check_line_lengths |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
sub report_line_length_errors { |
406
|
555
|
|
|
555
|
0
|
1358
|
my $self = shift; |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
# Write summary info about line lengths to the log file |
409
|
|
|
|
|
|
|
|
410
|
555
|
|
|
|
|
1386
|
my $rOpts = $self->[_rOpts_]; |
411
|
555
|
|
|
|
|
1242
|
my $line_length_error_count = $self->[_line_length_error_count_]; |
412
|
555
|
50
|
|
|
|
2802
|
if ( $line_length_error_count == 0 ) { |
413
|
555
|
|
|
|
|
4002
|
$self->write_logfile_entry( |
414
|
|
|
|
|
|
|
"No lines exceeded $rOpts->{'maximum-line-length'} characters\n"); |
415
|
555
|
|
|
|
|
2289
|
my $max_output_line_length = $self->[_max_output_line_length_]; |
416
|
555
|
|
|
|
|
1857
|
my $max_output_line_length_at = $self->[_max_output_line_length_at_]; |
417
|
555
|
|
|
|
|
3257
|
$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
|
0
|
0
|
|
|
|
0
|
my $word = ( $line_length_error_count > 1 ) ? "s" : EMPTY_STRING; |
425
|
0
|
|
|
|
|
0
|
$self->write_logfile_entry( |
426
|
|
|
|
|
|
|
"$line_length_error_count output line$word exceeded $rOpts->{'maximum-line-length'} characters:\n" |
427
|
|
|
|
|
|
|
); |
428
|
|
|
|
|
|
|
|
429
|
0
|
0
|
|
|
|
0
|
$word = ( $line_length_error_count > 1 ) ? "First" : EMPTY_STRING; |
430
|
0
|
|
|
|
|
0
|
my $first_line_length_error = $self->[_first_line_length_error_]; |
431
|
0
|
|
|
|
|
0
|
my $first_line_length_error_at = $self->[_first_line_length_error_at_]; |
432
|
0
|
|
|
|
|
0
|
$self->write_logfile_entry( |
433
|
|
|
|
|
|
|
" $word at line $first_line_length_error_at by $first_line_length_error characters\n" |
434
|
|
|
|
|
|
|
); |
435
|
|
|
|
|
|
|
|
436
|
0
|
0
|
|
|
|
0
|
if ( $line_length_error_count > 1 ) { |
437
|
0
|
|
|
|
|
0
|
my $max_line_length_error = $self->[_max_line_length_error_]; |
438
|
0
|
|
|
|
|
0
|
my $max_line_length_error_at = $self->[_max_line_length_error_at_]; |
439
|
0
|
|
|
|
|
0
|
my $last_line_length_error = $self->[_last_line_length_error_]; |
440
|
0
|
|
|
|
|
0
|
my $last_line_length_error_at = |
441
|
|
|
|
|
|
|
$self->[_last_line_length_error_at_]; |
442
|
0
|
|
|
|
|
0
|
$self->write_logfile_entry( |
443
|
|
|
|
|
|
|
" Maximum at line $max_line_length_error_at by $max_line_length_error characters\n" |
444
|
|
|
|
|
|
|
); |
445
|
0
|
|
|
|
|
0
|
$self->write_logfile_entry( |
446
|
|
|
|
|
|
|
" Last at line $last_line_length_error_at by $last_line_length_error characters\n" |
447
|
|
|
|
|
|
|
); |
448
|
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
} |
450
|
555
|
|
|
|
|
2303
|
return; |
451
|
|
|
|
|
|
|
} ## end sub report_line_length_errors |
452
|
|
|
|
|
|
|
1; |