git

1
#!/usr/bin/env perl
2
#
3
# Copyright (c) 2021-2022 Eric Sunshine <sunshine@sunshineco.com>
4
#
5
# This tool scans shell scripts for test definitions and checks those tests for
6
# problems, such as broken &&-chains, which might hide bugs in the tests
7
# themselves or in behaviors being exercised by the tests.
8
#
9
# Input arguments are pathnames of shell scripts containing test definitions,
10
# or globs referencing a collection of scripts. For each problem discovered,
11
# the pathname of the script containing the test is printed along with the test
12
# name and the test body with a `?!FOO?!` annotation at the location of each
13
# detected problem, where "FOO" is a tag such as "AMP" which indicates a broken
14
# &&-chain. Returns zero if no problems are discovered, otherwise non-zero.
15

16
use warnings;
17
use strict;
18
use Config;
19
use File::Glob;
20
use Getopt::Long;
21

22
my $jobs = -1;
23
my $show_stats;
24
my $emit_all;
25

26
# Lexer tokenizes POSIX shell scripts. It is roughly modeled after section 2.3
27
# "Token Recognition" of POSIX chapter 2 "Shell Command Language". Although
28
# similar to lexical analyzers for other languages, this one differs in a few
29
# substantial ways due to quirks of the shell command language.
30
#
31
# For instance, in many languages, newline is just whitespace like space or
32
# TAB, but in shell a newline is a command separator, thus a distinct lexical
33
# token. A newline is significant and returned as a distinct token even at the
34
# end of a shell comment.
35
#
36
# In other languages, `1+2` would typically be scanned as three tokens
37
# (`1`, `+`, and `2`), but in shell it is a single token. However, the similar
38
# `1 + 2`, which embeds whitepace, is scanned as three token in shell, as well.
39
# In shell, several characters with special meaning lose that meaning when not
40
# surrounded by whitespace. For instance, the negation operator `!` is special
41
# when standing alone surrounded by whitespace; whereas in `foo!uucp` it is
42
# just a plain character in the longer token "foo!uucp". In many other
43
# languages, `"string"/foo:'string'` might be scanned as five tokens ("string",
44
# `/`, `foo`, `:`, and 'string'), but in shell, it is just a single token.
45
#
46
# The lexical analyzer for the shell command language is also somewhat unusual
47
# in that it recursively invokes the parser to handle the body of `$(...)`
48
# expressions which can contain arbitrary shell code. Such expressions may be
49
# encountered both inside and outside of double-quoted strings.
50
#
51
# The lexical analyzer is responsible for consuming shell here-doc bodies which
52
# extend from the line following a `<<TAG` operator until a line consisting
53
# solely of `TAG`. Here-doc consumption begins when a newline is encountered.
54
# It is legal for multiple here-doc `<<TAG` operators to be present on a single
55
# line, in which case their bodies must be present one following the next, and
56
# are consumed in the (left-to-right) order the `<<TAG` operators appear on the
57
# line. A special complication is that the bodies of all here-docs must be
58
# consumed when the newline is encountered even if the parse context depth has
59
# changed. For instance, in `cat <<A && x=$(cat <<B &&\n`, bodies of here-docs
60
# "A" and "B" must be consumed even though "A" was introduced outside the
61
# recursive parse context in which "B" was introduced and in which the newline
62
# is encountered.
63
package Lexer;
64

65
sub new {
66
	my ($class, $parser, $s) = @_;
67
	bless {
68
		parser => $parser,
69
		buff => $s,
70
		lineno => 1,
71
		heretags => []
72
	} => $class;
73
}
74

75
sub scan_heredoc_tag {
76
	my $self = shift @_;
77
	${$self->{buff}} =~ /\G(-?)/gc;
78
	my $indented = $1;
79
	my $token = $self->scan_token();
80
	return "<<$indented" unless $token;
81
	my $tag = $token->[0];
82
	$tag =~ s/['"\\]//g;
83
	$$token[0] = $indented ? "\t$tag" : "$tag";
84
	push(@{$self->{heretags}}, $token);
85
	return "<<$indented$tag";
86
}
87

88
sub scan_op {
89
	my ($self, $c) = @_;
90
	my $b = $self->{buff};
91
	return $c unless $$b =~ /\G(.)/sgc;
92
	my $cc = $c . $1;
93
	return scan_heredoc_tag($self) if $cc eq '<<';
94
	return $cc if $cc =~ /^(?:&&|\|\||>>|;;|<&|>&|<>|>\|)$/;
95
	pos($$b)--;
96
	return $c;
97
}
98

99
sub scan_sqstring {
100
	my $self = shift @_;
101
	${$self->{buff}} =~ /\G([^']*'|.*\z)/sgc;
102
	my $s = $1;
103
	$self->{lineno} += () = $s =~ /\n/sg;
104
	return "'" . $s;
105
}
106

107
sub scan_dqstring {
108
	my $self = shift @_;
109
	my $b = $self->{buff};
110
	my $s = '"';
111
	while (1) {
112
		# slurp up non-special characters
113
		$s .= $1 if $$b =~ /\G([^"\$\\]+)/gc;
114
		# handle special characters
115
		last unless $$b =~ /\G(.)/sgc;
116
		my $c = $1;
117
		$s .= '"', last if $c eq '"';
118
		$s .= '$' . $self->scan_dollar(), next if $c eq '$';
119
		if ($c eq '\\') {
120
			$s .= '\\', last unless $$b =~ /\G(.)/sgc;
121
			$c = $1;
122
			$self->{lineno}++, next if $c eq "\n"; # line splice
123
			# backslash escapes only $, `, ", \ in dq-string
124
			$s .= '\\' unless $c =~ /^[\$`"\\]$/;
125
			$s .= $c;
126
			next;
127
		}
128
		die("internal error scanning dq-string '$c'\n");
129
	}
130
	$self->{lineno} += () = $s =~ /\n/sg;
131
	return $s;
132
}
133

134
sub scan_balanced {
135
	my ($self, $c1, $c2) = @_;
136
	my $b = $self->{buff};
137
	my $depth = 1;
138
	my $s = $c1;
139
	while ($$b =~ /\G([^\Q$c1$c2\E]*(?:[\Q$c1$c2\E]|\z))/gc) {
140
		$s .= $1;
141
		$depth++, next if $s =~ /\Q$c1\E$/;
142
		$depth--;
143
		last if $depth == 0;
144
	}
145
	$self->{lineno} += () = $s =~ /\n/sg;
146
	return $s;
147
}
148

149
sub scan_subst {
150
	my $self = shift @_;
151
	my @tokens = $self->{parser}->parse(qr/^\)$/);
152
	$self->{parser}->next_token(); # closing ")"
153
	return @tokens;
154
}
155

156
sub scan_dollar {
157
	my $self = shift @_;
158
	my $b = $self->{buff};
159
	return $self->scan_balanced('(', ')') if $$b =~ /\G\((?=\()/gc; # $((...))
160
	return '(' . join(' ', map {$_->[0]} $self->scan_subst()) . ')' if $$b =~ /\G\(/gc; # $(...)
161
	return $self->scan_balanced('{', '}') if $$b =~ /\G\{/gc; # ${...}
162
	return $1 if $$b =~ /\G(\w+)/gc; # $var
163
	return $1 if $$b =~ /\G([@*#?$!0-9-])/gc; # $*, $1, $$, etc.
164
	return '';
165
}
166

167
sub swallow_heredocs {
168
	my $self = shift @_;
169
	my $b = $self->{buff};
170
	my $tags = $self->{heretags};
171
	while (my $tag = shift @$tags) {
172
		my $start = pos($$b);
173
		my $indent = $$tag[0] =~ s/^\t// ? '\\s*' : '';
174
		$$b =~ /(?:\G|\n)$indent\Q$$tag[0]\E(?:\n|\z)/gc;
175
		if (pos($$b) > $start) {
176
			my $body = substr($$b, $start, pos($$b) - $start);
177
			$self->{parser}->{heredocs}->{$$tag[0]} = {
178
				content => substr($body, 0, length($body) - length($&)),
179
				start_line => $self->{lineno},
180
		        };
181
			$self->{lineno} += () = $body =~ /\n/sg;
182
			next;
183
		}
184
		push(@{$self->{parser}->{problems}}, ['UNCLOSED-HEREDOC', $tag]);
185
		$$b =~ /(?:\G|\n).*\z/gc; # consume rest of input
186
		my $body = substr($$b, $start, pos($$b) - $start);
187
		$self->{lineno} += () = $body =~ /\n/sg;
188
		last;
189
	}
190
}
191

192
sub scan_token {
193
	my $self = shift @_;
194
	my $b = $self->{buff};
195
	my $token = '';
196
	my ($start, $startln);
197
RESTART:
198
	$startln = $self->{lineno};
199
	$$b =~ /\G[ \t]+/gc; # skip whitespace (but not newline)
200
	$start = pos($$b) || 0;
201
	$self->{lineno}++, return ["\n", $start, pos($$b), $startln, $startln] if $$b =~ /\G#[^\n]*(?:\n|\z)/gc; # comment
202
	while (1) {
203
		# slurp up non-special characters
204
		$token .= $1 if $$b =~ /\G([^\\;&|<>(){}'"\$\s]+)/gc;
205
		# handle special characters
206
		last unless $$b =~ /\G(.)/sgc;
207
		my $c = $1;
208
		pos($$b)--, last if $c =~ /^[ \t]$/; # whitespace ends token
209
		pos($$b)--, last if length($token) && $c =~ /^[;&|<>(){}\n]$/;
210
		$token .= $self->scan_sqstring(), next if $c eq "'";
211
		$token .= $self->scan_dqstring(), next if $c eq '"';
212
		$token .= $c . $self->scan_dollar(), next if $c eq '$';
213
		$self->{lineno}++, $self->swallow_heredocs(), $token = $c, last if $c eq "\n";
214
		$token = $self->scan_op($c), last if $c =~ /^[;&|<>]$/;
215
		$token = $c, last if $c =~ /^[(){}]$/;
216
		if ($c eq '\\') {
217
			$token .= '\\', last unless $$b =~ /\G(.)/sgc;
218
			$c = $1;
219
			$self->{lineno}++, next if $c eq "\n" && length($token); # line splice
220
			$self->{lineno}++, goto RESTART if $c eq "\n"; # line splice
221
			$token .= '\\' . $c;
222
			next;
223
		}
224
		die("internal error scanning character '$c'\n");
225
	}
226
	return length($token) ? [$token, $start, pos($$b), $startln, $self->{lineno}] : undef;
227
}
228

229
# ShellParser parses POSIX shell scripts (with minor extensions for Bash). It
230
# is a recursive descent parser very roughly modeled after section 2.10 "Shell
231
# Grammar" of POSIX chapter 2 "Shell Command Language".
232
package ShellParser;
233

234
sub new {
235
	my ($class, $s) = @_;
236
	my $self = bless {
237
		buff => [],
238
		stop => [],
239
		output => [],
240
		heredocs => {},
241
	} => $class;
242
	$self->{lexer} = Lexer->new($self, $s);
243
	return $self;
244
}
245

246
sub next_token {
247
	my $self = shift @_;
248
	return pop(@{$self->{buff}}) if @{$self->{buff}};
249
	return $self->{lexer}->scan_token();
250
}
251

252
sub untoken {
253
	my $self = shift @_;
254
	push(@{$self->{buff}}, @_);
255
}
256

257
sub peek {
258
	my $self = shift @_;
259
	my $token = $self->next_token();
260
	return undef unless defined($token);
261
	$self->untoken($token);
262
	return $token;
263
}
264

265
sub stop_at {
266
	my ($self, $token) = @_;
267
	return 1 unless defined($token);
268
	my $stop = ${$self->{stop}}[-1] if @{$self->{stop}};
269
	return defined($stop) && $token->[0] =~ $stop;
270
}
271

272
sub expect {
273
	my ($self, $expect) = @_;
274
	my $token = $self->next_token();
275
	return $token if defined($token) && $token->[0] eq $expect;
276
	push(@{$self->{output}}, "?!ERR?! expected '$expect' but found '" . (defined($token) ? $token->[0] : "<end-of-input>") . "'\n");
277
	$self->untoken($token) if defined($token);
278
	return ();
279
}
280

281
sub optional_newlines {
282
	my $self = shift @_;
283
	my @tokens;
284
	while (my $token = $self->peek()) {
285
		last unless $token->[0] eq "\n";
286
		push(@tokens, $self->next_token());
287
	}
288
	return @tokens;
289
}
290

291
sub parse_group {
292
	my $self = shift @_;
293
	return ($self->parse(qr/^}$/),
294
		$self->expect('}'));
295
}
296

297
sub parse_subshell {
298
	my $self = shift @_;
299
	return ($self->parse(qr/^\)$/),
300
		$self->expect(')'));
301
}
302

303
sub parse_case_pattern {
304
	my $self = shift @_;
305
	my @tokens;
306
	while (defined(my $token = $self->next_token())) {
307
		push(@tokens, $token);
308
		last if $token->[0] eq ')';
309
	}
310
	return @tokens;
311
}
312

313
sub parse_case {
314
	my $self = shift @_;
315
	my @tokens;
316
	push(@tokens,
317
	     $self->next_token(), # subject
318
	     $self->optional_newlines(),
319
	     $self->expect('in'),
320
	     $self->optional_newlines());
321
	while (1) {
322
		my $token = $self->peek();
323
		last unless defined($token) && $token->[0] ne 'esac';
324
		push(@tokens,
325
		     $self->parse_case_pattern(),
326
		     $self->optional_newlines(),
327
		     $self->parse(qr/^(?:;;|esac)$/)); # item body
328
		$token = $self->peek();
329
		last unless defined($token) && $token->[0] ne 'esac';
330
		push(@tokens,
331
		     $self->expect(';;'),
332
		     $self->optional_newlines());
333
	}
334
	push(@tokens, $self->expect('esac'));
335
	return @tokens;
336
}
337

338
sub parse_for {
339
	my $self = shift @_;
340
	my @tokens;
341
	push(@tokens,
342
	     $self->next_token(), # variable
343
	     $self->optional_newlines());
344
	my $token = $self->peek();
345
	if (defined($token) && $token->[0] eq 'in') {
346
		push(@tokens,
347
		     $self->expect('in'),
348
		     $self->optional_newlines());
349
	}
350
	push(@tokens,
351
	     $self->parse(qr/^do$/), # items
352
	     $self->expect('do'),
353
	     $self->optional_newlines(),
354
	     $self->parse_loop_body(),
355
	     $self->expect('done'));
356
	return @tokens;
357
}
358

359
sub parse_if {
360
	my $self = shift @_;
361
	my @tokens;
362
	while (1) {
363
		push(@tokens,
364
		     $self->parse(qr/^then$/), # if/elif condition
365
		     $self->expect('then'),
366
		     $self->optional_newlines(),
367
		     $self->parse(qr/^(?:elif|else|fi)$/)); # if/elif body
368
		my $token = $self->peek();
369
		last unless defined($token) && $token->[0] eq 'elif';
370
		push(@tokens, $self->expect('elif'));
371
	}
372
	my $token = $self->peek();
373
	if (defined($token) && $token->[0] eq 'else') {
374
		push(@tokens,
375
		     $self->expect('else'),
376
		     $self->optional_newlines(),
377
		     $self->parse(qr/^fi$/)); # else body
378
	}
379
	push(@tokens, $self->expect('fi'));
380
	return @tokens;
381
}
382

383
sub parse_loop_body {
384
	my $self = shift @_;
385
	return $self->parse(qr/^done$/);
386
}
387

388
sub parse_loop {
389
	my $self = shift @_;
390
	return ($self->parse(qr/^do$/), # condition
391
		$self->expect('do'),
392
		$self->optional_newlines(),
393
		$self->parse_loop_body(),
394
		$self->expect('done'));
395
}
396

397
sub parse_func {
398
	my $self = shift @_;
399
	return ($self->expect('('),
400
		$self->expect(')'),
401
		$self->optional_newlines(),
402
		$self->parse_cmd()); # body
403
}
404

405
sub parse_bash_array_assignment {
406
	my $self = shift @_;
407
	my @tokens = $self->expect('(');
408
	while (defined(my $token = $self->next_token())) {
409
		push(@tokens, $token);
410
		last if $token->[0] eq ')';
411
	}
412
	return @tokens;
413
}
414

415
my %compound = (
416
	'{' => \&parse_group,
417
	'(' => \&parse_subshell,
418
	'case' => \&parse_case,
419
	'for' => \&parse_for,
420
	'if' => \&parse_if,
421
	'until' => \&parse_loop,
422
	'while' => \&parse_loop);
423

424
sub parse_cmd {
425
	my $self = shift @_;
426
	my $cmd = $self->next_token();
427
	return () unless defined($cmd);
428
	return $cmd if $cmd->[0] eq "\n";
429

430
	my $token;
431
	my @tokens = $cmd;
432
	if ($cmd->[0] eq '!') {
433
		push(@tokens, $self->parse_cmd());
434
		return @tokens;
435
	} elsif (my $f = $compound{$cmd->[0]}) {
436
		push(@tokens, $self->$f());
437
	} elsif (defined($token = $self->peek()) && $token->[0] eq '(') {
438
		if ($cmd->[0] !~ /\w=$/) {
439
			push(@tokens, $self->parse_func());
440
			return @tokens;
441
		}
442
		my @array = $self->parse_bash_array_assignment();
443
		$tokens[-1]->[0] .= join(' ', map {$_->[0]} @array);
444
		$tokens[-1]->[2] = $array[$#array][2] if @array;
445
	}
446

447
	while (defined(my $token = $self->next_token())) {
448
		$self->untoken($token), last if $self->stop_at($token);
449
		push(@tokens, $token);
450
		last if $token->[0] =~ /^(?:[;&\n|]|&&|\|\|)$/;
451
	}
452
	push(@tokens, $self->next_token()) if $tokens[-1]->[0] ne "\n" && defined($token = $self->peek()) && $token->[0] eq "\n";
453
	return @tokens;
454
}
455

456
sub accumulate {
457
	my ($self, $tokens, $cmd) = @_;
458
	push(@$tokens, @$cmd);
459
}
460

461
sub parse {
462
	my ($self, $stop) = @_;
463
	push(@{$self->{stop}}, $stop);
464
	goto DONE if $self->stop_at($self->peek());
465
	my @tokens;
466
	while (my @cmd = $self->parse_cmd()) {
467
		$self->accumulate(\@tokens, \@cmd);
468
		last if $self->stop_at($self->peek());
469
	}
470
DONE:
471
	pop(@{$self->{stop}});
472
	return @tokens;
473
}
474

475
# TestParser is a subclass of ShellParser which, beyond parsing shell script
476
# code, is also imbued with semantic knowledge of test construction, and checks
477
# tests for common problems (such as broken &&-chains) which might hide bugs in
478
# the tests themselves or in behaviors being exercised by the tests. As such,
479
# TestParser is only called upon to parse test bodies, not the top-level
480
# scripts in which the tests are defined.
481
package TestParser;
482

483
use base 'ShellParser';
484

485
sub new {
486
	my $class = shift @_;
487
	my $self = $class->SUPER::new(@_);
488
	$self->{problems} = [];
489
	return $self;
490
}
491

492
sub find_non_nl {
493
	my $tokens = shift @_;
494
	my $n = shift @_;
495
	$n = $#$tokens if !defined($n);
496
	$n-- while $n >= 0 && $$tokens[$n]->[0] eq "\n";
497
	return $n;
498
}
499

500
sub ends_with {
501
	my ($tokens, $needles) = @_;
502
	my $n = find_non_nl($tokens);
503
	for my $needle (reverse(@$needles)) {
504
		return undef if $n < 0;
505
		$n = find_non_nl($tokens, $n), next if $needle eq "\n";
506
		return undef if $$tokens[$n]->[0] !~ $needle;
507
		$n--;
508
	}
509
	return 1;
510
}
511

512
sub match_ending {
513
	my ($tokens, $endings) = @_;
514
	for my $needles (@$endings) {
515
		next if @$tokens < scalar(grep {$_ ne "\n"} @$needles);
516
		return 1 if ends_with($tokens, $needles);
517
	}
518
	return undef;
519
}
520

521
sub parse_loop_body {
522
	my $self = shift @_;
523
	my @tokens = $self->SUPER::parse_loop_body(@_);
524
	# did loop signal failure via "|| return" or "|| exit"?
525
	return @tokens if !@tokens || grep {$_->[0] =~ /^(?:return|exit|\$\?)$/} @tokens;
526
	# did loop upstream of a pipe signal failure via "|| echo 'impossible
527
	# text'" as the final command in the loop body?
528
	return @tokens if ends_with(\@tokens, [qr/^\|\|$/, "\n", qr/^echo$/, qr/^.+$/]);
529
	# flag missing "return/exit" handling explicit failure in loop body
530
	my $n = find_non_nl(\@tokens);
531
	push(@{$self->{problems}}, ['LOOP', $tokens[$n]]);
532
	return @tokens;
533
}
534

535
my @safe_endings = (
536
	[qr/^(?:&&|\|\||\||&)$/],
537
	[qr/^(?:exit|return)$/, qr/^(?:\d+|\$\?)$/],
538
	[qr/^(?:exit|return)$/, qr/^(?:\d+|\$\?)$/, qr/^;$/],
539
	[qr/^(?:exit|return|continue)$/],
540
	[qr/^(?:exit|return|continue)$/, qr/^;$/]);
541

542
sub accumulate {
543
	my ($self, $tokens, $cmd) = @_;
544
	my $problems = $self->{problems};
545

546
	# no previous command to check for missing "&&"
547
	goto DONE unless @$tokens;
548

549
	# new command is empty line; can't yet check if previous is missing "&&"
550
	goto DONE if @$cmd == 1 && $$cmd[0]->[0] eq "\n";
551

552
	# did previous command end with "&&", "|", "|| return" or similar?
553
	goto DONE if match_ending($tokens, \@safe_endings);
554

555
	# if this command handles "$?" specially, then okay for previous
556
	# command to be missing "&&"
557
	for my $token (@$cmd) {
558
		goto DONE if $token->[0] =~ /\$\?/;
559
	}
560

561
	# if this command is "false", "return 1", or "exit 1" (which signal
562
	# failure explicitly), then okay for all preceding commands to be
563
	# missing "&&"
564
	if ($$cmd[0]->[0] =~ /^(?:false|return|exit)$/) {
565
		@$problems = grep {$_->[0] ne 'AMP'} @$problems;
566
		goto DONE;
567
	}
568

569
	# flag missing "&&" at end of previous command
570
	my $n = find_non_nl($tokens);
571
	push(@$problems, ['AMP', $tokens->[$n]]) unless $n < 0;
572

573
DONE:
574
	$self->SUPER::accumulate($tokens, $cmd);
575
}
576

577
# ScriptParser is a subclass of ShellParser which identifies individual test
578
# definitions within test scripts, and passes each test body through TestParser
579
# to identify possible problems. ShellParser detects test definitions not only
580
# at the top-level of test scripts but also within compound commands such as
581
# loops and function definitions.
582
package ScriptParser;
583

584
use base 'ShellParser';
585

586
sub new {
587
	my $class = shift @_;
588
	my $self = $class->SUPER::new(@_);
589
	$self->{ntests} = 0;
590
	return $self;
591
}
592

593
# extract the raw content of a token, which may be a single string or a
594
# composition of multiple strings and non-string character runs; for instance,
595
# `"test body"` unwraps to `test body`; `word"a b"42'c d'` to `worda b42c d`
596
sub unwrap {
597
	my $token = (@_ ? shift @_ : $_)->[0];
598
	# simple case: 'sqstring' or "dqstring"
599
	return $token if $token =~ s/^'([^']*)'$/$1/;
600
	return $token if $token =~ s/^"([^"]*)"$/$1/;
601

602
	# composite case
603
	my ($s, $q, $escaped);
604
	while (1) {
605
		# slurp up non-special characters
606
		$s .= $1 if $token =~ /\G([^\\'"]*)/gc;
607
		# handle special characters
608
		last unless $token =~ /\G(.)/sgc;
609
		my $c = $1;
610
		$q = undef, next if defined($q) && $c eq $q;
611
		$q = $c, next if !defined($q) && $c =~ /^['"]$/;
612
		if ($c eq '\\') {
613
			last unless $token =~ /\G(.)/sgc;
614
			$c = $1;
615
			$s .= '\\' if $c eq "\n"; # preserve line splice
616
		}
617
		$s .= $c;
618
	}
619
	return $s
620
}
621

622
sub check_test {
623
	my $self = shift @_;
624
	my $title = unwrap(shift @_);
625
	my $body = shift @_;
626
	my $lineno = $body->[3];
627
	$body = unwrap($body);
628
	if ($body eq '-') {
629
		my $herebody = shift @_;
630
		$body = $herebody->{content};
631
		$lineno = $herebody->{start_line};
632
	}
633
	$self->{ntests}++;
634
	my $parser = TestParser->new(\$body);
635
	my @tokens = $parser->parse();
636
	my $problems = $parser->{problems};
637
	return unless $emit_all || @$problems;
638
	my $c = main::fd_colors(1);
639
	my $start = 0;
640
	my $checked = '';
641
	for (sort {$a->[1]->[2] <=> $b->[1]->[2]} @$problems) {
642
		my ($label, $token) = @$_;
643
		my $pos = $token->[2];
644
		$checked .= substr($body, $start, $pos - $start) . " ?!$label?! ";
645
		$start = $pos;
646
	}
647
	$checked .= substr($body, $start);
648
	$checked =~ s/^/$lineno++ . ' '/mge;
649
	$checked =~ s/^\d+ \n//;
650
	$checked =~ s/(\s) \?!/$1?!/mg;
651
	$checked =~ s/\?! (\s)/?!$1/mg;
652
	$checked =~ s/(\?![^?]+\?!)/$c->{rev}$c->{red}$1$c->{reset}/mg;
653
	$checked =~ s/^\d+/$c->{dim}$&$c->{reset}/mg;
654
	$checked .= "\n" unless $checked =~ /\n$/;
655
	push(@{$self->{output}}, "$c->{blue}# chainlint: $title$c->{reset}\n$checked");
656
}
657

658
sub parse_cmd {
659
	my $self = shift @_;
660
	my @tokens = $self->SUPER::parse_cmd();
661
	return @tokens unless @tokens && $tokens[0]->[0] =~ /^test_expect_(?:success|failure)$/;
662
	my $n = $#tokens;
663
	$n-- while $n >= 0 && $tokens[$n]->[0] =~ /^(?:[;&\n|]|&&|\|\|)$/;
664
	my $herebody;
665
	if ($n >= 2 && $tokens[$n-1]->[0] eq '-' && $tokens[$n]->[0] =~ /^<<-?(.+)$/) {
666
		$herebody = $self->{heredocs}->{$1};
667
		$n--;
668
	}
669
	$self->check_test($tokens[1], $tokens[2], $herebody) if $n == 2; # title body
670
	$self->check_test($tokens[2], $tokens[3], $herebody) if $n > 2;  # prereq title body
671
	return @tokens;
672
}
673

674
# main contains high-level functionality for processing command-line switches,
675
# feeding input test scripts to ScriptParser, and reporting results.
676
package main;
677

678
my $getnow = sub { return time(); };
679
my $interval = sub { return time() - shift; };
680
if (eval {require Time::HiRes; Time::HiRes->import(); 1;}) {
681
	$getnow = sub { return [Time::HiRes::gettimeofday()]; };
682
	$interval = sub { return Time::HiRes::tv_interval(shift); };
683
}
684

685
# Restore TERM if test framework set it to "dumb" so 'tput' will work; do this
686
# outside of get_colors() since under 'ithreads' all threads use %ENV of main
687
# thread and ignore %ENV changes in subthreads.
688
$ENV{TERM} = $ENV{USER_TERM} if $ENV{USER_TERM};
689

690
my @NOCOLORS = (bold => '', rev => '', dim => '', reset => '', blue => '', green => '', red => '');
691
my %COLORS = ();
692
sub get_colors {
693
	return \%COLORS if %COLORS;
694
	if (exists($ENV{NO_COLOR})) {
695
		%COLORS = @NOCOLORS;
696
		return \%COLORS;
697
	}
698
	if ($ENV{TERM} =~ /xterm|xterm-\d+color|xterm-new|xterm-direct|nsterm|nsterm-\d+color|nsterm-direct/) {
699
		%COLORS = (bold  => "\e[1m",
700
			   rev   => "\e[7m",
701
			   dim   => "\e[2m",
702
			   reset => "\e[0m",
703
			   blue  => "\e[34m",
704
			   green => "\e[32m",
705
			   red   => "\e[31m");
706
		return \%COLORS;
707
	}
708
	if (system("tput sgr0 >/dev/null 2>&1") == 0 &&
709
	    system("tput bold >/dev/null 2>&1") == 0 &&
710
	    system("tput rev  >/dev/null 2>&1") == 0 &&
711
	    system("tput dim  >/dev/null 2>&1") == 0 &&
712
	    system("tput setaf 1 >/dev/null 2>&1") == 0) {
713
		%COLORS = (bold  => `tput bold`,
714
			   rev   => `tput rev`,
715
			   dim   => `tput dim`,
716
			   reset => `tput sgr0`,
717
			   blue  => `tput setaf 4`,
718
			   green => `tput setaf 2`,
719
			   red   => `tput setaf 1`);
720
		return \%COLORS;
721
	}
722
	%COLORS = @NOCOLORS;
723
	return \%COLORS;
724
}
725

726
my %FD_COLORS = ();
727
sub fd_colors {
728
	my $fd = shift;
729
	return $FD_COLORS{$fd} if exists($FD_COLORS{$fd});
730
	$FD_COLORS{$fd} = -t $fd ? get_colors() : {@NOCOLORS};
731
	return $FD_COLORS{$fd};
732
}
733

734
sub ncores {
735
	# Windows
736
	if (exists($ENV{NUMBER_OF_PROCESSORS})) {
737
		my $ncpu = $ENV{NUMBER_OF_PROCESSORS};
738
		return $ncpu > 0 ? $ncpu : 1;
739
	}
740
	# Linux / MSYS2 / Cygwin / WSL
741
	if (open my $fh, '<', '/proc/cpuinfo') {
742
		my $cpuinfo = do { local $/; <$fh> };
743
		close($fh);
744
		if ($cpuinfo =~ /^n?cpus active\s*:\s*(\d+)/m) {
745
			return $1 if $1 > 0;
746
		}
747
		my @matches = ($cpuinfo =~ /^(processor|CPU)[\s\d]*:/mg);
748
		return @matches ? scalar(@matches) : 1;
749
	}
750
	# macOS & BSD
751
	if ($^O =~ /(?:^darwin$|bsd)/) {
752
		my $ncpu = qx/sysctl -n hw.ncpu/;
753
		return $ncpu > 0 ? $ncpu : 1;
754
	}
755
	return 1;
756
}
757

758
sub show_stats {
759
	my ($start_time, $stats) = @_;
760
	my $walltime = $interval->($start_time);
761
	my ($usertime) = times();
762
	my ($total_workers, $total_scripts, $total_tests, $total_errs) = (0, 0, 0, 0);
763
	my $c = fd_colors(2);
764
	print(STDERR $c->{green});
765
	for (@$stats) {
766
		my ($worker, $nscripts, $ntests, $nerrs) = @$_;
767
		print(STDERR "worker $worker: $nscripts scripts, $ntests tests, $nerrs errors\n");
768
		$total_workers++;
769
		$total_scripts += $nscripts;
770
		$total_tests += $ntests;
771
		$total_errs += $nerrs;
772
	}
773
	printf(STDERR "total: %d workers, %d scripts, %d tests, %d errors, %.2fs/%.2fs (wall/user)$c->{reset}\n", $total_workers, $total_scripts, $total_tests, $total_errs, $walltime, $usertime);
774
}
775

776
sub check_script {
777
	my ($id, $next_script, $emit) = @_;
778
	my ($nscripts, $ntests, $nerrs) = (0, 0, 0);
779
	while (my $path = $next_script->()) {
780
		$nscripts++;
781
		my $fh;
782
		unless (open($fh, "<:unix:crlf", $path)) {
783
			$emit->("?!ERR?! $path: $!\n");
784
			next;
785
		}
786
		my $s = do { local $/; <$fh> };
787
		close($fh);
788
		my $parser = ScriptParser->new(\$s);
789
		1 while $parser->parse_cmd();
790
		if (@{$parser->{output}}) {
791
			my $c = fd_colors(1);
792
			my $s = join('', @{$parser->{output}});
793
			$emit->("$c->{bold}$c->{blue}# chainlint: $path$c->{reset}\n" . $s);
794
			$nerrs += () = $s =~ /\?![^?]+\?!/g;
795
		}
796
		$ntests += $parser->{ntests};
797
	}
798
	return [$id, $nscripts, $ntests, $nerrs];
799
}
800

801
sub exit_code {
802
	my $stats = shift @_;
803
	for (@$stats) {
804
		my ($worker, $nscripts, $ntests, $nerrs) = @$_;
805
		return 1 if $nerrs;
806
	}
807
	return 0;
808
}
809

810
Getopt::Long::Configure(qw{bundling});
811
GetOptions(
812
	"emit-all!" => \$emit_all,
813
	"jobs|j=i" => \$jobs,
814
	"stats|show-stats!" => \$show_stats) or die("option error\n");
815
$jobs = ncores() if $jobs < 1;
816

817
my $start_time = $getnow->();
818
my @stats;
819

820
my @scripts;
821
push(@scripts, File::Glob::bsd_glob($_)) for (@ARGV);
822
unless (@scripts) {
823
	show_stats($start_time, \@stats) if $show_stats;
824
	exit;
825
}
826
$jobs = @scripts if @scripts < $jobs;
827

828
unless ($jobs > 1 &&
829
	$Config{useithreads} && eval {
830
	require threads; threads->import();
831
	require Thread::Queue; Thread::Queue->import();
832
	1;
833
	}) {
834
	push(@stats, check_script(1, sub { shift(@scripts); }, sub { print(@_); }));
835
	show_stats($start_time, \@stats) if $show_stats;
836
	exit(exit_code(\@stats));
837
}
838

839
my $script_queue = Thread::Queue->new();
840
my $output_queue = Thread::Queue->new();
841

842
sub next_script { return $script_queue->dequeue(); }
843
sub emit { $output_queue->enqueue(@_); }
844

845
sub monitor {
846
	while (my $s = $output_queue->dequeue()) {
847
		print($s);
848
	}
849
}
850

851
my $mon = threads->create({'context' => 'void'}, \&monitor);
852
threads->create({'context' => 'list'}, \&check_script, $_, \&next_script, \&emit) for 1..$jobs;
853

854
$script_queue->enqueue(@scripts);
855
$script_queue->end();
856

857
for (threads->list()) {
858
	push(@stats, $_->join()) unless $_ == $mon;
859
}
860

861
$output_queue->end();
862
$mon->join();
863

864
show_stats($start_time, \@stats) if $show_stats;
865
exit(exit_code(\@stats));
866