| 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 `?!LINT: ...?!` annotation at the location of |
| 13 | # each detected problem, where "..." is an explanation of the problem. Returns |
| 14 | # 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 | use File::Basename; |
| 27 | do(dirname($0) . "/lib-shell-parser.pl") |
| 28 | or die "$0: failed to load lib-shell-parser.pl: $@$!\n"; |
| 29 | |
| 30 | # TestParser is a subclass of ShellParser which, beyond parsing shell script |
| 31 | # code, is also imbued with semantic knowledge of test construction, and checks |
| 32 | # tests for common problems (such as broken &&-chains) which might hide bugs in |
| 33 | # the tests themselves or in behaviors being exercised by the tests. As such, |
| 34 | # TestParser is only called upon to parse test bodies, not the top-level |
| 35 | # scripts in which the tests are defined. |
| 36 | |
| 37 | package TestParser; |
| 38 | |
| 39 | our @ISA = ('ShellParser'); |
| 40 | |
| 41 | sub new { |
| 42 | my $class = shift @_; |
| 43 | my $self = $class->SUPER::new(@_); |
| 44 | $self->{problems} = []; |
| 45 | return $self; |
| 46 | } |
| 47 | |
| 48 | sub find_non_nl { |
| 49 | my $tokens = shift @_; |
| 50 | my $n = shift @_; |
| 51 | $n = $#$tokens if !defined($n); |
| 52 | $n-- while $n >= 0 && $$tokens[$n]->[0] eq "\n"; |
| 53 | return $n; |
| 54 | } |
| 55 | |
| 56 | sub ends_with { |
| 57 | my ($tokens, $needles) = @_; |
| 58 | my $n = find_non_nl($tokens); |
| 59 | for my $needle (reverse(@$needles)) { |
| 60 | return undef if $n < 0; |
| 61 | $n = find_non_nl($tokens, $n), next if $needle eq "\n"; |
| 62 | return undef if $$tokens[$n]->[0] !~ $needle; |
| 63 | $n--; |
| 64 | } |
| 65 | return 1; |
| 66 | } |
| 67 | |
| 68 | sub match_ending { |
| 69 | my ($tokens, $endings) = @_; |
| 70 | for my $needles (@$endings) { |
| 71 | next if @$tokens < scalar(grep {$_ ne "\n"} @$needles); |
| 72 | return 1 if ends_with($tokens, $needles); |
| 73 | } |
| 74 | return undef; |
| 75 | } |
| 76 | |
| 77 | sub parse_loop_body { |
| 78 | my $self = shift @_; |
| 79 | my @tokens = $self->SUPER::parse_loop_body(@_); |
| 80 | # did loop signal failure via "|| return" or "|| exit"? |
| 81 | return @tokens if !@tokens || grep {$_->[0] =~ /^(?:return|exit|\$\?)$/} @tokens; |
| 82 | # did loop upstream of a pipe signal failure via "|| echo 'impossible |
| 83 | # text'" as the final command in the loop body? |
| 84 | return @tokens if ends_with(\@tokens, [qr/^\|\|$/, "\n", qr/^echo$/, qr/^.+$/]); |
| 85 | # flag missing "return/exit" handling explicit failure in loop body |
| 86 | my $n = find_non_nl(\@tokens); |
| 87 | push(@{$self->{problems}}, [$self->{insubshell} ? 'LOOPEXIT' : 'LOOPRETURN', $tokens[$n]]); |
| 88 | return @tokens; |
| 89 | } |
| 90 | |
| 91 | my @safe_endings = ( |
| 92 | [qr/^(?:&&|\|\||\||&)$/], |
| 93 | [qr/^(?:exit|return)$/, qr/^(?:\d+|\$\?)$/], |
| 94 | [qr/^(?:exit|return)$/, qr/^(?:\d+|\$\?)$/, qr/^;$/], |
| 95 | [qr/^(?:exit|return|continue)$/], |
| 96 | [qr/^(?:exit|return|continue)$/, qr/^;$/]); |
| 97 | |
| 98 | sub accumulate { |
| 99 | my ($self, $tokens, $cmd) = @_; |
| 100 | my $problems = $self->{problems}; |
| 101 | |
| 102 | # no previous command to check for missing "&&" |
| 103 | goto DONE unless @$tokens; |
| 104 | |
| 105 | # new command is empty line; can't yet check if previous is missing "&&" |
| 106 | goto DONE if @$cmd == 1 && $$cmd[0]->[0] eq "\n"; |
| 107 | |
| 108 | # did previous command end with "&&", "|", "|| return" or similar? |
| 109 | goto DONE if match_ending($tokens, \@safe_endings); |
| 110 | |
| 111 | # if this command handles "$?" specially, then okay for previous |
| 112 | # command to be missing "&&" |
| 113 | for my $token (@$cmd) { |
| 114 | goto DONE if $token->[0] =~ /\$\?/; |
| 115 | } |
| 116 | |
| 117 | # if this command is "false", "return 1", or "exit 1" (which signal |
| 118 | # failure explicitly), then okay for all preceding commands to be |
| 119 | # missing "&&" |
| 120 | if ($$cmd[0]->[0] =~ /^(?:false|return|exit)$/) { |
| 121 | @$problems = grep {$_->[0] ne 'AMP'} @$problems; |
| 122 | goto DONE; |
| 123 | } |
| 124 | |
| 125 | # flag missing "&&" at end of previous command |
| 126 | my $n = find_non_nl($tokens); |
| 127 | push(@$problems, ['AMP', $tokens->[$n]]) unless $n < 0; |
| 128 | |
| 129 | DONE: |
| 130 | $self->SUPER::accumulate($tokens, $cmd); |
| 131 | } |
| 132 | |
| 133 | # ChainlintParser extends ScriptParser with &&-chain checking |
| 134 | package ChainlintParser; |
| 135 | |
| 136 | our @ISA = ('ScriptParser'); |
| 137 | |
| 138 | sub format_problem { |
| 139 | local $_ = shift; |
| 140 | /^AMP$/ && return "missing '&&'"; |
| 141 | /^LOOPRETURN$/ && return "missing '|| return 1'"; |
| 142 | /^LOOPEXIT$/ && return "missing '|| exit 1'"; |
| 143 | /^HEREDOC$/ && return 'unclosed heredoc'; |
| 144 | die("unrecognized problem type '$_'\n"); |
| 145 | } |
| 146 | |
| 147 | sub check_test { |
| 148 | my $self = shift @_; |
| 149 | my $title = ScriptParser::unwrap(shift @_); |
| 150 | my $body = shift @_; |
| 151 | my $lineno = $body->[3]; |
| 152 | $body = ScriptParser::unwrap($body); |
| 153 | if ($body eq '-') { |
| 154 | my $herebody = shift @_; |
| 155 | $body = $herebody->{content}; |
| 156 | $lineno = $herebody->{start_line}; |
| 157 | } |
| 158 | $self->{ntests}++; |
| 159 | my $parser = TestParser->new(\$body); |
| 160 | my @tokens = $parser->parse(); |
| 161 | my $problems = $parser->{problems}; |
| 162 | $self->{nerrs} += @$problems; |
| 163 | return unless $emit_all || @$problems; |
| 164 | my $c = main::fd_colors(1); |
| 165 | my ($erropen, $errclose) = -t 1 ? ("$c->{rev}$c->{red}", $c->{reset}) : ('?!', '?!'); |
| 166 | my $start = 0; |
| 167 | my $checked = ''; |
| 168 | for (sort {$a->[1]->[2] <=> $b->[1]->[2]} @$problems) { |
| 169 | my ($label, $token) = @$_; |
| 170 | my $pos = $token->[2]; |
| 171 | my $err = format_problem($label); |
| 172 | $checked .= substr($body, $start, $pos - $start); |
| 173 | $checked .= ' ' unless $checked =~ /\s$/; |
| 174 | $checked .= "${erropen}LINT: $err$errclose"; |
| 175 | $checked .= ' ' unless $pos >= length($body) || |
| 176 | substr($body, $pos, 1) =~ /^\s/; |
| 177 | $start = $pos; |
| 178 | } |
| 179 | $checked .= substr($body, $start); |
| 180 | $checked =~ s/^/$lineno++ . ' '/mge; |
| 181 | $checked =~ s/^\d+ \n//; |
| 182 | $checked =~ s/^\d+/$c->{dim}$&$c->{reset}/mg; |
| 183 | $checked .= "\n" unless $checked =~ /\n$/; |
| 184 | push(@{$self->{output}}, "$c->{blue}# chainlint: $title$c->{reset}\n$checked"); |
| 185 | } |
| 186 | |
| 187 | # main contains high-level functionality for processing command-line switches, |
| 188 | # feeding input test scripts to ChainlintParser, and reporting results. |
| 189 | package main; |
| 190 | |
| 191 | my $getnow = sub { return time(); }; |
| 192 | my $interval = sub { return time() - shift; }; |
| 193 | if (eval {require Time::HiRes; Time::HiRes->import(); 1;}) { |
| 194 | $getnow = sub { return [Time::HiRes::gettimeofday()]; }; |
| 195 | $interval = sub { return Time::HiRes::tv_interval(shift); }; |
| 196 | } |
| 197 | |
| 198 | # Restore TERM if test framework set it to "dumb" so 'tput' will work; do this |
| 199 | # outside of get_colors() since under 'ithreads' all threads use %ENV of main |
| 200 | # thread and ignore %ENV changes in subthreads. |
| 201 | $ENV{TERM} = $ENV{USER_TERM} if $ENV{USER_TERM}; |
| 202 | |
| 203 | my @NOCOLORS = (bold => '', rev => '', dim => '', reset => '', blue => '', green => '', red => ''); |
| 204 | my %COLORS = (); |
| 205 | sub get_colors { |
| 206 | return \%COLORS if %COLORS; |
| 207 | if (exists($ENV{NO_COLOR})) { |
| 208 | %COLORS = @NOCOLORS; |
| 209 | return \%COLORS; |
| 210 | } |
| 211 | if ($ENV{TERM} =~ /xterm|xterm-\d+color|xterm-new|xterm-direct|nsterm|nsterm-\d+color|nsterm-direct/) { |
| 212 | %COLORS = (bold => "\e[1m", |
| 213 | rev => "\e[7m", |
| 214 | dim => "\e[2m", |
| 215 | reset => "\e[0m", |
| 216 | blue => "\e[34m", |
| 217 | green => "\e[32m", |
| 218 | red => "\e[31m"); |
| 219 | return \%COLORS; |
| 220 | } |
| 221 | if (system("tput sgr0 >/dev/null 2>&1") == 0 && |
| 222 | system("tput bold >/dev/null 2>&1") == 0 && |
| 223 | system("tput rev >/dev/null 2>&1") == 0 && |
| 224 | system("tput dim >/dev/null 2>&1") == 0 && |
| 225 | system("tput setaf 1 >/dev/null 2>&1") == 0) { |
| 226 | %COLORS = (bold => `tput bold`, |
| 227 | rev => `tput rev`, |
| 228 | dim => `tput dim`, |
| 229 | reset => `tput sgr0`, |
| 230 | blue => `tput setaf 4`, |
| 231 | green => `tput setaf 2`, |
| 232 | red => `tput setaf 1`); |
| 233 | return \%COLORS; |
| 234 | } |
| 235 | %COLORS = @NOCOLORS; |
| 236 | return \%COLORS; |
| 237 | } |
| 238 | |
| 239 | my %FD_COLORS = (); |
| 240 | sub fd_colors { |
| 241 | my $fd = shift; |
| 242 | return $FD_COLORS{$fd} if exists($FD_COLORS{$fd}); |
| 243 | $FD_COLORS{$fd} = -t $fd ? get_colors() : {@NOCOLORS}; |
| 244 | return $FD_COLORS{$fd}; |
| 245 | } |
| 246 | |
| 247 | sub ncores { |
| 248 | # Windows |
| 249 | if (exists($ENV{NUMBER_OF_PROCESSORS})) { |
| 250 | my $ncpu = $ENV{NUMBER_OF_PROCESSORS}; |
| 251 | return $ncpu > 0 ? $ncpu : 1; |
| 252 | } |
| 253 | # Linux / MSYS2 / Cygwin / WSL |
| 254 | if (open my $fh, '<', '/proc/cpuinfo') { |
| 255 | my $cpuinfo = do { local $/; <$fh> }; |
| 256 | close($fh); |
| 257 | if ($cpuinfo =~ /^n?cpus active\s*:\s*(\d+)/m) { |
| 258 | return $1 if $1 > 0; |
| 259 | } |
| 260 | my @matches = ($cpuinfo =~ /^(processor|CPU)[\s\d]*:/mg); |
| 261 | return @matches ? scalar(@matches) : 1; |
| 262 | } |
| 263 | # macOS & BSD |
| 264 | if ($^O =~ /(?:^darwin$|bsd)/) { |
| 265 | my $ncpu = qx/sysctl -n hw.ncpu/; |
| 266 | return $ncpu > 0 ? $ncpu : 1; |
| 267 | } |
| 268 | return 1; |
| 269 | } |
| 270 | |
| 271 | sub show_stats { |
| 272 | my ($start_time, $stats) = @_; |
| 273 | my $walltime = $interval->($start_time); |
| 274 | my ($usertime) = times(); |
| 275 | my ($total_workers, $total_scripts, $total_tests, $total_errs) = (0, 0, 0, 0); |
| 276 | my $c = fd_colors(2); |
| 277 | print(STDERR $c->{green}); |
| 278 | for (@$stats) { |
| 279 | my ($worker, $nscripts, $ntests, $nerrs) = @$_; |
| 280 | print(STDERR "worker $worker: $nscripts scripts, $ntests tests, $nerrs errors\n"); |
| 281 | $total_workers++; |
| 282 | $total_scripts += $nscripts; |
| 283 | $total_tests += $ntests; |
| 284 | $total_errs += $nerrs; |
| 285 | } |
| 286 | 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); |
| 287 | } |
| 288 | |
| 289 | sub check_script { |
| 290 | my ($id, $next_script, $emit) = @_; |
| 291 | my ($nscripts, $ntests, $nerrs) = (0, 0, 0); |
| 292 | while (my $path = $next_script->()) { |
| 293 | $nscripts++; |
| 294 | my $fh; |
| 295 | unless (open($fh, "<:unix:crlf", $path)) { |
| 296 | $emit->("?!ERR?! $path: $!\n"); |
| 297 | next; |
| 298 | } |
| 299 | my $s = do { local $/; <$fh> }; |
| 300 | close($fh); |
| 301 | my $parser = ChainlintParser->new(\$s); |
| 302 | 1 while $parser->parse_cmd(); |
| 303 | if (@{$parser->{output}}) { |
| 304 | my $c = fd_colors(1); |
| 305 | my $s = join('', @{$parser->{output}}); |
| 306 | $emit->("$c->{bold}$c->{blue}# chainlint: $path$c->{reset}\n" . $s); |
| 307 | } |
| 308 | $ntests += $parser->{ntests}; |
| 309 | $nerrs += $parser->{nerrs}; |
| 310 | } |
| 311 | return [$id, $nscripts, $ntests, $nerrs]; |
| 312 | } |
| 313 | |
| 314 | sub exit_code { |
| 315 | my $stats = shift @_; |
| 316 | for (@$stats) { |
| 317 | my ($worker, $nscripts, $ntests, $nerrs) = @$_; |
| 318 | return 1 if $nerrs; |
| 319 | } |
| 320 | return 0; |
| 321 | } |
| 322 | |
| 323 | Getopt::Long::Configure(qw{bundling}); |
| 324 | GetOptions( |
| 325 | "emit-all!" => \$emit_all, |
| 326 | "jobs|j=i" => \$jobs, |
| 327 | "stats|show-stats!" => \$show_stats) or die("option error\n"); |
| 328 | $jobs = ncores() if $jobs < 1; |
| 329 | |
| 330 | my $start_time = $getnow->(); |
| 331 | my @stats; |
| 332 | |
| 333 | my @scripts; |
| 334 | push(@scripts, File::Glob::bsd_glob($_)) for (@ARGV); |
| 335 | unless (@scripts) { |
| 336 | show_stats($start_time, \@stats) if $show_stats; |
| 337 | exit; |
| 338 | } |
| 339 | $jobs = @scripts if @scripts < $jobs; |
| 340 | |
| 341 | unless ($jobs > 1 && |
| 342 | $Config{useithreads} && eval { |
| 343 | require threads; threads->import(); |
| 344 | require Thread::Queue; Thread::Queue->import(); |
| 345 | 1; |
| 346 | }) { |
| 347 | push(@stats, check_script(1, sub { shift(@scripts); }, sub { print(@_); })); |
| 348 | show_stats($start_time, \@stats) if $show_stats; |
| 349 | exit(exit_code(\@stats)); |
| 350 | } |
| 351 | |
| 352 | my $script_queue = Thread::Queue->new(); |
| 353 | my $output_queue = Thread::Queue->new(); |
| 354 | |
| 355 | sub next_script { return $script_queue->dequeue(); } |
| 356 | sub emit { $output_queue->enqueue(@_); } |
| 357 | |
| 358 | sub monitor { |
| 359 | while (my $s = $output_queue->dequeue()) { |
| 360 | print($s); |
| 361 | } |
| 362 | } |
| 363 | |
| 364 | my $mon = threads->create({'context' => 'void'}, \&monitor); |
| 365 | threads->create({'context' => 'list'}, \&check_script, $_, \&next_script, \&emit) for 1..$jobs; |
| 366 | |
| 367 | $script_queue->enqueue(@scripts); |
| 368 | $script_queue->end(); |
| 369 | |
| 370 | for (threads->list()) { |
| 371 | push(@stats, $_->join()) unless $_ == $mon; |
| 372 | } |
| 373 | |
| 374 | $output_queue->end(); |
| 375 | $mon->join(); |
| 376 | |
| 377 | show_stats($start_time, \@stats) if $show_stats; |
| 378 | exit(exit_code(\@stats)); |