|
| 1 | +#!/usr/bin/env perl |
| 2 | +# |
| 3 | +# Copyright (c) 2021-2022 Eric Sunshine <[email protected]> |
| 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 File::Glob; |
| 19 | +use Getopt::Long; |
| 20 | + |
| 21 | +my $show_stats; |
| 22 | +my $emit_all; |
| 23 | + |
| 24 | +package ScriptParser; |
| 25 | + |
| 26 | +sub new { |
| 27 | + my $class = shift @_; |
| 28 | + my $self = bless {} => $class; |
| 29 | + $self->{output} = []; |
| 30 | + $self->{ntests} = 0; |
| 31 | + return $self; |
| 32 | +} |
| 33 | + |
| 34 | +sub parse_cmd { |
| 35 | + return undef; |
| 36 | +} |
| 37 | + |
| 38 | +# main contains high-level functionality for processing command-line switches, |
| 39 | +# feeding input test scripts to ScriptParser, and reporting results. |
| 40 | +package main; |
| 41 | + |
| 42 | +my $getnow = sub { return time(); }; |
| 43 | +my $interval = sub { return time() - shift; }; |
| 44 | +if (eval {require Time::HiRes; Time::HiRes->import(); 1;}) { |
| 45 | + $getnow = sub { return [Time::HiRes::gettimeofday()]; }; |
| 46 | + $interval = sub { return Time::HiRes::tv_interval(shift); }; |
| 47 | +} |
| 48 | + |
| 49 | +sub show_stats { |
| 50 | + my ($start_time, $stats) = @_; |
| 51 | + my $walltime = $interval->($start_time); |
| 52 | + my ($usertime) = times(); |
| 53 | + my ($total_workers, $total_scripts, $total_tests, $total_errs) = (0, 0, 0, 0); |
| 54 | + for (@$stats) { |
| 55 | + my ($worker, $nscripts, $ntests, $nerrs) = @$_; |
| 56 | + print(STDERR "worker $worker: $nscripts scripts, $ntests tests, $nerrs errors\n"); |
| 57 | + $total_workers++; |
| 58 | + $total_scripts += $nscripts; |
| 59 | + $total_tests += $ntests; |
| 60 | + $total_errs += $nerrs; |
| 61 | + } |
| 62 | + printf(STDERR "total: %d workers, %d scripts, %d tests, %d errors, %.2fs/%.2fs (wall/user)\n", $total_workers, $total_scripts, $total_tests, $total_errs, $walltime, $usertime); |
| 63 | +} |
| 64 | + |
| 65 | +sub check_script { |
| 66 | + my ($id, $next_script, $emit) = @_; |
| 67 | + my ($nscripts, $ntests, $nerrs) = (0, 0, 0); |
| 68 | + while (my $path = $next_script->()) { |
| 69 | + $nscripts++; |
| 70 | + my $fh; |
| 71 | + unless (open($fh, "<", $path)) { |
| 72 | + $emit->("?!ERR?! $path: $!\n"); |
| 73 | + next; |
| 74 | + } |
| 75 | + my $s = do { local $/; <$fh> }; |
| 76 | + close($fh); |
| 77 | + my $parser = ScriptParser->new(\$s); |
| 78 | + 1 while $parser->parse_cmd(); |
| 79 | + if (@{$parser->{output}}) { |
| 80 | + my $s = join('', @{$parser->{output}}); |
| 81 | + $emit->("# chainlint: $path\n" . $s); |
| 82 | + $nerrs += () = $s =~ /\?![^?]+\?!/g; |
| 83 | + } |
| 84 | + $ntests += $parser->{ntests}; |
| 85 | + } |
| 86 | + return [$id, $nscripts, $ntests, $nerrs]; |
| 87 | +} |
| 88 | + |
| 89 | +sub exit_code { |
| 90 | + my $stats = shift @_; |
| 91 | + for (@$stats) { |
| 92 | + my ($worker, $nscripts, $ntests, $nerrs) = @$_; |
| 93 | + return 1 if $nerrs; |
| 94 | + } |
| 95 | + return 0; |
| 96 | +} |
| 97 | + |
| 98 | +Getopt::Long::Configure(qw{bundling}); |
| 99 | +GetOptions( |
| 100 | + "emit-all!" => \$emit_all, |
| 101 | + "stats|show-stats!" => \$show_stats) or die("option error\n"); |
| 102 | + |
| 103 | +my $start_time = $getnow->(); |
| 104 | +my @stats; |
| 105 | + |
| 106 | +my @scripts; |
| 107 | +push(@scripts, File::Glob::bsd_glob($_)) for (@ARGV); |
| 108 | +unless (@scripts) { |
| 109 | + show_stats($start_time, \@stats) if $show_stats; |
| 110 | + exit; |
| 111 | +} |
| 112 | + |
| 113 | +push(@stats, check_script(1, sub { shift(@scripts); }, sub { print(@_); })); |
| 114 | +show_stats($start_time, \@stats) if $show_stats; |
| 115 | +exit(exit_code(\@stats)); |
0 commit comments