t/regress.t

   1 #!/usr/bin/env perl
   2 use 5.014;
   3 use warnings;
   4 use re '/ms';
   5 use Getopt::Long qw(2.32 :config gnu_getopt);
   6 use Test::More;
   7 use File::Basename;
   8
   9 chdir dirname($0) or exit 1;
  10
  11 GetOptions(\my %opt,
  12         'regenerate|G!',
  13 ) or do {
  14         say "Usage: $0 [-G] [<files>...]";
  15         exit 64;  # EX_USAGE
  16 };
  17
  18 local $ENV{COLUMNS} = 40;
  19
  20 my @params = @ARGV ? @ARGV : glob 't*.out';
  21 plan(tests => int @params);
  22
  23 for my $candidate (@params) {
  24         my $name = basename($candidate, '.out');
  25         $name =~ tr/_/ /;
  26         my $todo = $name =~ s/ #TODO$//;
  27         local $TODO = $todo ? ' ' : undef;
  28
  29         if (!-e $candidate) {
  30                 local $TODO = 'missing output';
  31                 fail($name);
  32                 next;
  33         }
  34
  35         open my $fh, '<', $candidate or die "missing $candidate: $!\n";
  36         !!(my $spec = readline $fh)
  37                 or die "input lacks a script on the first line\n";
  38
  39         my $script = $spec;
  40         chomp $script;
  41         my $wantexit = $script =~ s/\h+[?](\d+)\z// ? $1 : 0;
  42         my $wantwarn = $script !~ s/[?]\z//;
  43         my $shell = $script;
  44         if ($script =~ /\|/) {
  45                 # explicit shell wrapper to capture all warnings
  46                 $shell =~ s/'/'\\''/g;
  47                 $shell = "sh -c '$shell'";
  48         }
  49         $shell .= ' 2>' . ($wantwarn ? '&1' : '/dev/null');
  50
  51         open my $cmd, '-|', $shell or do {
  52                 fail($name);
  53                 diag("open failure: $!");
  54                 diag("command: $script");
  55                 next;
  56         };
  57         my @lines = readline $cmd;
  58         close $cmd;
  59         my $error = $? >> 8;
  60
  61         if ($opt{regenerate}) {
  62                 #TODO: error
  63                 open my $rewrite, '>', $candidate;
  64                 print {$rewrite} $_ for $spec, @lines;
  65         }
  66
  67         if ($error != $wantexit) {
  68                 fail($name);
  69                 diag("unexpected exit status $error");
  70                 diag("command: $script");
  71                 next;
  72         }
  73
  74         my @diff;
  75         my @wanted = readline $fh;
  76
  77         while (@lines or @wanted) {
  78                 my $was = shift @wanted;
  79                 my $is  = shift @lines;
  80                 next if defined $was and defined $is and $was eq $is;
  81                 push @diff, color(32) . "< " . color(0) . $_ for $was // ();
  82                 push @diff, color(31) . "> " . color(0) . $_ for $is  // ();
  83         }
  84
  85         ok(!@diff, $name) or do {
  86                 diag(@diff);
  87                 diag("command: $script");
  88         };
  89 }
  90
  91 done_testing();
  92
  93 sub color {
  94         return !$ENV{NOCOLOR} && "\e[@{_}m";
  95 }