regress/regress.pl

   1 #!/usr/bin/env perl
   2 #
   3 # $Id: regress.pl,v 1.1 2017/02/08 03:02:13 schwarze Exp $
   4 #
   5 # Copyright (c) 2017 Ingo Schwarze <schwarze@openbsd.org>
   6 #
   7 # Permission to use, copy, modify, and distribute this software for any
   8 # purpose with or without fee is hereby granted, provided that the above
   9 # copyright notice and this permission notice appear in all copies.
  10 #
  11 # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  12 # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  13 # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  14 # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  15 # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  16 # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  17 # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  18
  19 use warnings;
  20 use strict;
  21
  22 # Used because open(3p) and open2(3p) provide no way for handling
  23 # STDERR of the child process, neither for appending it to STDOUT,
  24 # nor for piping it into the Perl program.
  25 use IPC::Open3 qw(open3);
  26
  27 # --- utility functions ------------------------------------------------
  28
  29 sub usage ($) {
  30         warn shift;
  31         print STDERR "usage: $0 [directory[:test] [modifier ...]]\n";
  32         exit 1;
  33 }
  34
  35 # Run a command and send STDOUT and STDERR to a file.
  36 # 1st argument: path to the output file
  37 # 2nd argument: command name
  38 # The remaining arguments are passed to the command.
  39 sub sysout ($@) {
  40         my $outfile = shift;
  41         local *OUT_FH;
  42         open OUT_FH, '>', $outfile or die "$outfile: $!";
  43         my $pid = open3 undef, ">&OUT_FH", undef, @_;
  44         close OUT_FH;
  45         waitpid $pid, 0;
  46         return $? >> 8;
  47 }
  48
  49 # Simlar, but filter the output as needed for the lint test.
  50 sub syslint ($@) {
  51         my $outfile = shift;
  52         open my $outfd, '>', $outfile or die "$outfile: $!";
  53         my $infd;
  54         my $pid = open3 undef, $infd, undef, @_;
  55         while (<$infd>) {
  56                 s/^mandoc: [^:]+\//mandoc: /;
  57                 print $outfd $_;
  58         }
  59         close $outfd;
  60         close $infd;
  61         waitpid $pid, 0;
  62         return 0;
  63 }
  64
  65 # Simlar, but filter the output as needed for the html test.
  66 sub syshtml ($@) {
  67         my $outfile = shift;
  68         open my $outfd, '>', $outfile or die "$outfile: $!";
  69         my $infd;
  70         my $pid = open3 undef, $infd, undef, @_;
  71         my $state;
  72         while (<$infd>) {
  73                 chomp;
  74                 if (!$state && s/.*<math class="eqn">//) {
  75                         $state = 1;
  76                         next unless length;
  77                 }
  78                 $state = 1 if /^BEGINTEST/;
  79                 if ($state && s/<\/math>.*//) {
  80                         s/^ *//;
  81                         print $outfd "$_\n" if length;
  82                         undef $state;
  83                         next;
  84                 }
  85                 s/^ *//;
  86                 print $outfd "$_\n" if $state;
  87                 undef $state if /^ENDTEST/;
  88         }
  89         close $outfd;
  90         close $infd;
  91         waitpid $pid, 0;
  92         return 0;
  93 }
  94
  95 my @failures;
  96 sub fail ($$$) {
  97         warn "FAILED: @_\n";
  98         push @failures, [@_];
  99 }
 100
 101
 102 # --- process command line arguments -----------------------------------
 103
 104 my ($subdir, $onlytest) = split ':', (shift // '.');
 105 my $displaylevel = 2;
 106 my %targets;
 107 for (@ARGV) {
 108         if (/^[0123]$/) {
 109                 $displaylevel = int;
 110                 next;
 111         }
 112         /^(all|ascii|utf8|man|html|lint|clean|verbose)$/
 113             or usage "$_: invalid modifier";
 114         $targets{$_} = 1;
 115 }
 116 $targets{all} = 1
 117     unless $targets{ascii} || $targets{utf8} || $targets{man} ||
 118       $targets{html} || $targets{lint} || $targets{clean};
 119 $targets{ascii} = $targets{utf8} = $targets{man} = $targets{html} =
 120     $targets{lint} = 1 if $targets{all};
 121 $displaylevel = 3 if $targets{verbose};
 122
 123
 124 # --- parse Makefiles --------------------------------------------------
 125
 126 my %vars = (MOPTS => '');
 127 sub parse_makefile ($) {
 128         my $filename = shift;
 129         open my $fh, '<', $filename or die "$filename: $!";
 130         while (<$fh>) {
 131                 chomp;
 132                 next unless /\S/;
 133                 last if /^# OpenBSD only/;
 134                 next if /^#/;
 135                 next if /^\.include/;
 136                 /^(\w+)\s*([?+]?)=\s*(.*)/
 137                     or die "$filename: parse error: $_";
 138                 my $var = $1;
 139                 my $opt = $2;
 140                 my $val = $3;
 141                 $val =~ s/\${(\w+)}/$vars{$1}/;
 142                 $val = "$vars{$var} $val" if $opt eq '+';
 143                 $vars{$var} = $val
 144                     unless $opt eq '?' && defined $vars{$var};
 145         }
 146         close $fh;
 147 }
 148
 149 if ($subdir eq '.') {
 150         $vars{SUBDIR} = 'roff char mdoc man tbl eqn';
 151 } else {
 152         parse_makefile "$subdir/Makefile";
 153         parse_makefile "$subdir/../Makefile.inc"
 154             if -e "$subdir/../Makefile.inc";
 155 }
 156
 157 my @mandoc = '../mandoc';
 158 my @subdir_names;
 159 my (@regress_testnames, @utf8_testnames, @html_testnames, @lint_testnames);
 160 my (%skip_ascii, %skip_man);
 161
 162 push @mandoc, split ' ', $vars{MOPTS} if $vars{MOPTS};
 163 delete $vars{MOPTS};
 164 delete $vars{SKIP_GROFF};
 165 delete $vars{SKIP_GROFF_ASCII};
 166 delete $vars{TBL};
 167 delete $vars{EQN};
 168 if (defined $vars{SUBDIR}) {
 169         @subdir_names = split ' ', $vars{SUBDIR};
 170         delete $vars{SUBDIR};
 171 }
 172 if (defined $vars{REGRESS_TARGETS}) {
 173         @regress_testnames = split ' ', $vars{REGRESS_TARGETS};
 174         delete $vars{REGRESS_TARGETS};
 175 }
 176 if (defined $vars{UTF8_TARGETS}) {
 177         @utf8_testnames = split ' ', $vars{UTF8_TARGETS};
 178         delete $vars{UTF8_TARGETS};
 179 }
 180 if (defined $vars{HTML_TARGETS}) {
 181         @html_testnames = split ' ', $vars{HTML_TARGETS};
 182         delete $vars{HTML_TARGETS};
 183 }
 184 if (defined $vars{LINT_TARGETS}) {
 185         @lint_testnames = split ' ', $vars{LINT_TARGETS};
 186         delete $vars{LINT_TARGETS};
 187 }
 188 if (defined $vars{SKIP_ASCII}) {
 189         for (split ' ', $vars{SKIP_ASCII}) {
 190                 $skip_ascii{$_} = 1;
 191                 $skip_man{$_} = 1;
 192         }
 193         delete $vars{SKIP_ASCII};
 194 }
 195 if (defined $vars{SKIP_TMAN}) {
 196         $skip_man{$_} = 1 for split ' ', $vars{SKIP_TMAN};
 197         delete $vars{SKIP_TMAN};
 198 }
 199 if (keys %vars) {
 200         my @vars = keys %vars;
 201         die "unknown var(s) @vars";
 202 }
 203 map { $skip_ascii{$_} = 1; } @regress_testnames if $skip_ascii{ALL};
 204 map { $skip_man{$_} = 1; } @regress_testnames if $skip_man{ALL};
 205
 206 # --- run targets ------------------------------------------------------
 207
 208 my $count_total = 0;
 209 for my $dirname (@subdir_names) {
 210         $count_total++;
 211         print "\n" if $targets{verbose};
 212         system './regress.pl', "$subdir/$dirname", keys %targets,
 213             ($displaylevel ? $displaylevel - 1 : 0),
 214             and fail $subdir, $dirname, 'subdir';
 215 }
 216
 217 my $count_ascii = 0;
 218 my $count_man = 0;
 219 for my $testname (@regress_testnames) {
 220         next if $onlytest && $testname ne $onlytest;
 221         my $i = "$subdir/$testname.in";
 222         my $o = "$subdir/$testname.mandoc_ascii";
 223         my $w = "$subdir/$testname.out_ascii";
 224         if ($targets{ascii} && !$skip_ascii{$testname}) {
 225                 $count_ascii++;
 226                 $count_total++;
 227                 print "@mandoc -T ascii $i\n" if $targets{verbose};
 228                 sysout $o, @mandoc, qw(-T ascii), $i
 229                     and fail $subdir, $testname, 'ascii:mandoc';
 230                 system qw(diff -au), $w, $o
 231                     and fail $subdir, $testname, 'ascii:diff';
 232         }
 233         my $m = "$subdir/$testname.in_man";
 234         my $mo = "$subdir/$testname.mandoc_man";
 235         if ($targets{man} && !$skip_man{$testname}) {
 236                 $count_man++;
 237                 $count_total++;
 238                 print "@mandoc -T man $i\n" if $targets{verbose};
 239                 sysout $m, @mandoc, qw(-T man), $i
 240                     and fail $subdir, $testname, 'man:man';
 241                 print "@mandoc -man -T ascii $m\n" if $targets{verbose};
 242                 sysout $mo, @mandoc, qw(-man -T ascii -O mdoc), $m
 243                     and fail $subdir, $testname, 'man:mandoc';
 244                 system qw(diff -au), $w, $mo
 245                     and fail $subdir, $testname, 'man:diff';
 246         }
 247         if ($targets{clean}) {
 248                 print "rm $o\n"
 249                     if $targets{verbose} && !$skip_ascii{$testname};
 250                 unlink $o;
 251                 print "rm $m $mo\n"
 252                     if $targets{verbose} && !$skip_man{$testname};
 253                 unlink $m, $mo;
 254         }
 255 }
 256
 257 my $count_utf8 = 0;
 258 for my $testname (@utf8_testnames) {
 259         next if $onlytest && $testname ne $onlytest;
 260         my $i = "$subdir/$testname.in";
 261         my $o = "$subdir/$testname.mandoc_utf8";
 262         my $w = "$subdir/$testname.out_utf8";
 263         if ($targets{utf8}) {
 264                 $count_utf8++;
 265                 $count_total++;
 266                 print "@mandoc -T utf8 $i\n" if $targets{verbose};
 267                 sysout $o, @mandoc, qw(-T utf8), $i
 268                     and fail $subdir, $testname, 'utf8:mandoc';
 269                 system qw(diff -au), $w, $o
 270                     and fail $subdir, $testname, 'utf8:diff';
 271         }
 272         if ($targets{clean}) {
 273                 print "rm $o\n" if $targets{verbose};
 274                 unlink $o;
 275         }
 276 }
 277
 278 my $count_html = 0;
 279 for my $testname (@html_testnames) {
 280         next if $onlytest && $testname ne $onlytest;
 281         my $i = "$subdir/$testname.in";
 282         my $o = "$subdir/$testname.mandoc_html";
 283         my $w = "$subdir/$testname.out_html";
 284         if ($targets{html}) {
 285                 $count_html++;
 286                 $count_total++;
 287                 print "@mandoc -T html $i\n" if $targets{verbose};
 288                 syshtml $o, @mandoc, qw(-T html), $i
 289                     and fail $subdir, $testname, 'html:mandoc';
 290                 system qw(diff -au), $w, $o
 291                     and fail $subdir, $testname, 'html:diff';
 292         }
 293         if ($targets{clean}) {
 294                 print "rm $o\n" if $targets{verbose};
 295                 unlink $o;
 296         }
 297 }
 298
 299 my $count_lint = 0;
 300 for my $testname (@lint_testnames) {
 301         next if $onlytest && $testname ne $onlytest;
 302         my $i = "$subdir/$testname.in";
 303         my $o = "$subdir/$testname.mandoc_lint";
 304         my $w = "$subdir/$testname.out_lint";
 305         if ($targets{lint}) {
 306                 $count_lint++;
 307                 $count_total++;
 308                 print "@mandoc -T lint $i\n" if $targets{verbose};
 309                 syslint $o, @mandoc, qw(-T lint), $i
 310                     and fail $subdir, $testname, 'lint:mandoc';
 311                 system qw(diff -au), $w, $o
 312                     and fail $subdir, $testname, 'lint:diff';
 313         }
 314         if ($targets{clean}) {
 315                 print "rm $o\n" if $targets{verbose};
 316                 unlink $o;
 317         }
 318 }
 319
 320 exit 0 unless $displaylevel or @failures;
 321
 322 print "\n" if $targets{verbose};
 323 if ($onlytest) {
 324         print "test $subdir:$onlytest finished";
 325 } else {
 326         print "testsuite $subdir finished";
 327 }
 328 print ' ', (scalar @subdir_names), ' subdirectories' if @subdir_names;
 329 print " $count_ascii ascii" if $count_ascii;
 330 print " $count_man man" if $count_man;
 331 print " $count_utf8 utf8" if $count_utf8;
 332 print " $count_html html" if $count_html;
 333 print " $count_lint lint" if $count_lint;
 334
 335 if (@failures) {
 336         print " (FAIL)\n\nSOME TESTS FAILED:\n\n";
 337         print "@$_\n" for @failures;
 338         print "\n";
 339         exit 1;
 340 } elsif ($count_total == 1) {
 341         print " (OK)\n";
 342 } elsif ($count_total) {
 343         print " (all $count_total tests OK)\n";
 344 } else {
 345         print " (no tests run)\n";
 346 }
 347 exit 0;