t/regress.t

   1 #!/usr/bin/env perl
   2 use 5.014;
   3 use warnings;
   4 use re '/msx';
   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         local $TODO;
  27
  28         if (!-e $candidate) {
  29                 local $TODO = 'missing output';
  30                 fail($name);
  31                 next;
  32         }
  33
  34         open my $fh, '<', $candidate or die "missing $candidate: $!\n";
  35         !!(my $spec = readline $fh)
  36                 or die "input lacks a script on the first line\n";
  37
  38         my $script = $spec;
  39         chomp $script;
  40         $script =~ s/\h* [#]\h* todo \h* (.*?) \z//i
  41                 and $TODO = $+ || ' ';
  42         my $wantexit = $script =~ s/\h+[?](\d+)\z// ? $1 : 0;
  43         my $wantwarn = $script !~ s/[?]\z//;
  44
  45         my $shell = $script;
  46         if ($script =~ /\|/) {
  47                 # explicit shell wrapper to capture all warnings
  48                 $shell =~ s/'/'\\''/g;
  49                 $shell = "sh -c '$shell'";
  50         }
  51         $shell .= ' 2>' . ($wantwarn ? '&1' : '/dev/null');
  52
  53         open my $cmd, '-|', $shell or do {
  54                 fail($name);
  55                 diag("open failure: $!");
  56                 diag("command: $script");
  57                 next;
  58         };
  59         my @lines = readline $cmd;
  60         close $cmd;
  61         my $error = $? >> 8;
  62
  63         if ($opt{regenerate}) {
  64                 #TODO: error
  65                 open my $rewrite, '>', $candidate;
  66                 print {$rewrite} $_ for $spec, @lines;
  67         }
  68
  69         if ($error != $wantexit) {
  70                 fail($name);
  71                 diag("unexpected exit status $error");
  72                 diag(color(31), '> ', color(0), $_) for @lines;
  73                 diag("command: $script");
  74                 next;
  75         }
  76
  77         my @diff;
  78         my @wanted = readline $fh;
  79
  80         while (@lines or @wanted) {
  81                 my $was = shift @wanted;
  82                 my $is  = shift @lines;
  83                 next if defined $was and defined $is and $was eq $is;
  84                 push @diff, color(32) . "< " . color(0) . $_ for $was // ();
  85                 push @diff, color(31) . "> " . color(0) . $_ for $is  // ();
  86         }
  87
  88         ok(!@diff, $name) or do {
  89                 diag(@diff);
  90                 diag("command: $script");
  91         };
  92 }
  93
  94 done_testing();
  95
  96 sub color {
  97         return !$ENV{NOCOLOR} && "\e[@{_}m";
  98 }