regress/regress.pl

   1 #!/usr/bin/env perl
   2 #
   3 # $Id: regress.pl,v 1.4 2017/03/05 19:57:39 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 # Define this at one place such that it can easily be changed
  28 # if diff(1) does not support the -a option.
  29 my @diff = qw(diff -au);
  30
  31 # --- utility functions ------------------------------------------------
  32
  33 sub usage ($) {
  34         warn shift;
  35         print STDERR "usage: $0 [directory[:test] [modifier ...]]\n";
  36         exit 1;
  37 }
  38
  39 # Run a command and send STDOUT and STDERR to a file.
  40 # 1st argument: path to the output file
  41 # 2nd argument: command name
  42 # The remaining arguments are passed to the command.
  43 sub sysout ($@) {
  44         my $outfile = shift;
  45         local *OUT_FH;
  46         open OUT_FH, '>', $outfile or die "$outfile: $!";
  47         my $pid = open3 undef, ">&OUT_FH", undef, @_;
  48         close OUT_FH;
  49         waitpid $pid, 0;
  50         return $? >> 8;
  51 }
  52
  53 # Simlar, but filter the output as needed for the lint test.
  54 sub syslint ($@) {
  55         my $outfile = shift;
  56         open my $outfd, '>', $outfile or die "$outfile: $!";
  57         my $infd;
  58         my $pid = open3 undef, $infd, undef, @_;
  59         while (<$infd>) {
  60                 s/^mandoc: [^:]+\//mandoc: /;
  61                 print $outfd $_;
  62         }
  63         close $outfd;
  64         close $infd;
  65         waitpid $pid, 0;
  66         return 0;
  67 }
  68
  69 # Simlar, but filter the output as needed for the html test.
  70 sub syshtml ($@) {
  71         my $outfile = shift;
  72         open my $outfd, '>', $outfile or die "$outfile: $!";
  73         my $infd;
  74         my $pid = open3 undef, $infd, undef, @_;
  75         my $state;
  76         while (<$infd>) {
  77                 chomp;
  78                 if (!$state && s/.*<math class="eqn">//) {
  79                         $state = 1;
  80                         next unless length;
  81                 }
  82                 $state = 1 if /^BEGINTEST/;
  83                 if ($state && s/<\/math>.*//) {
  84                         s/^ *//;
  85                         print $outfd "$_\n" if length;
  86                         undef $state;
  87                         next;
  88                 }
  89                 s/^ *//;
  90                 print $outfd "$_\n" if $state;
  91                 undef $state if /^ENDTEST/;
  92         }
  93         close $outfd;
  94         close $infd;
  95         waitpid $pid, 0;
  96         return 0;
  97 }
  98
  99 my @failures;
 100 sub fail ($$$) {
 101         warn "FAILED: @_\n";
 102         push @failures, [@_];
 103 }
 104
 105
 106 # --- process command line arguments -----------------------------------
 107
 108 my ($subdir, $onlytest) = split ':', (shift // '.');
 109 my $displaylevel = 2;
 110 my %targets;
 111 for (@ARGV) {
 112         if (/^[0123]$/) {
 113                 $displaylevel = int;
 114                 next;
 115         }
 116         /^(all|ascii|utf8|man|html|markdown|lint|clean|verbose)$/
 117             or usage "$_: invalid modifier";
 118         $targets{$_} = 1;
 119 }
 120 $targets{all} = 1
 121     unless $targets{ascii} || $targets{utf8} || $targets{man} ||
 122       $targets{html} || $targets{markdown} ||
 123       $targets{lint} || $targets{clean};
 124 $targets{ascii} = $targets{utf8} = $targets{man} = $targets{html} =
 125     $targets{markdown} = $targets{lint} = 1 if $targets{all};
 126 $displaylevel = 3 if $targets{verbose};
 127
 128
 129 # --- parse Makefiles --------------------------------------------------
 130
 131 my %vars = (MOPTS => '');
 132 sub parse_makefile ($) {
 133         my $filename = shift;
 134         open my $fh, '<', $filename or die "$filename: $!";
 135         while (<$fh>) {
 136                 chomp;
 137                 next unless /\S/;
 138                 last if /^# OpenBSD only/;
 139                 next if /^#/;
 140                 next if /^\.include/;
 141                 /^(\w+)\s*([?+]?)=\s*(.*)/
 142                     or die "$filename: parse error: $_";
 143                 my $var = $1;
 144                 my $opt = $2;
 145                 my $val = $3;
 146                 $val =~ s/\$\{(\w+)\}/$vars{$1}/;
 147                 $val = "$vars{$var} $val" if $opt eq '+';
 148                 $vars{$var} = $val
 149                     unless $opt eq '?' && defined $vars{$var};
 150         }
 151         close $fh;
 152 }
 153
 154 if ($subdir eq '.') {
 155         $vars{SUBDIR} = 'roff char mdoc man tbl eqn';
 156 } else {
 157         parse_makefile "$subdir/Makefile";
 158         parse_makefile "$subdir/../Makefile.inc"
 159             if -e "$subdir/../Makefile.inc";
 160 }
 161
 162 my @mandoc = '../mandoc';
 163 my @subdir_names;
 164 my (@regress_testnames, @utf8_testnames, @lint_testnames);
 165 my (@html_testnames, @markdown_testnames);
 166 my (%skip_ascii, %skip_man);
 167
 168 push @mandoc, split ' ', $vars{MOPTS} if $vars{MOPTS};
 169 delete $vars{MOPTS};
 170 delete $vars{SKIP_GROFF};
 171 delete $vars{SKIP_GROFF_ASCII};
 172 delete $vars{TBL};
 173 delete $vars{EQN};
 174 if (defined $vars{SUBDIR}) {
 175         @subdir_names = split ' ', $vars{SUBDIR};
 176         delete $vars{SUBDIR};
 177 }
 178 if (defined $vars{REGRESS_TARGETS}) {
 179         @regress_testnames = split ' ', $vars{REGRESS_TARGETS};
 180         delete $vars{REGRESS_TARGETS};
 181 }
 182 if (defined $vars{UTF8_TARGETS}) {
 183         @utf8_testnames = split ' ', $vars{UTF8_TARGETS};
 184         delete $vars{UTF8_TARGETS};
 185 }
 186 if (defined $vars{HTML_TARGETS}) {
 187         @html_testnames = split ' ', $vars{HTML_TARGETS};
 188         delete $vars{HTML_TARGETS};
 189 }
 190 if (defined $vars{MARKDOWN_TARGETS}) {
 191         @markdown_testnames = split ' ', $vars{MARKDOWN_TARGETS};
 192         delete $vars{MARKDOWN_TARGETS};
 193 }
 194 if (defined $vars{LINT_TARGETS}) {
 195         @lint_testnames = split ' ', $vars{LINT_TARGETS};
 196         delete $vars{LINT_TARGETS};
 197 }
 198 if (defined $vars{SKIP_ASCII}) {
 199         for (split ' ', $vars{SKIP_ASCII}) {
 200                 $skip_ascii{$_} = 1;
 201                 $skip_man{$_} = 1;
 202         }
 203         delete $vars{SKIP_ASCII};
 204 }
 205 if (defined $vars{SKIP_TMAN}) {
 206         $skip_man{$_} = 1 for split ' ', $vars{SKIP_TMAN};
 207         delete $vars{SKIP_TMAN};
 208 }
 209 if (keys %vars) {
 210         my @vars = keys %vars;
 211         die "unknown var(s) @vars";
 212 }
 213 map { $skip_ascii{$_} = 1; } @regress_testnames if $skip_ascii{ALL};
 214 map { $skip_man{$_} = 1; } @regress_testnames if $skip_man{ALL};
 215
 216 # --- run targets ------------------------------------------------------
 217
 218 my $count_total = 0;
 219 for my $dirname (@subdir_names) {
 220         $count_total++;
 221         print "\n" if $targets{verbose};
 222         system './regress.pl', "$subdir/$dirname", keys %targets,
 223             ($displaylevel ? $displaylevel - 1 : 0),
 224             and fail $subdir, $dirname, 'subdir';
 225 }
 226
 227 my $count_ascii = 0;
 228 my $count_man = 0;
 229 for my $testname (@regress_testnames) {
 230         next if $onlytest && $testname ne $onlytest;
 231         my $i = "$subdir/$testname.in";
 232         my $o = "$subdir/$testname.mandoc_ascii";
 233         my $w = "$subdir/$testname.out_ascii";
 234         if ($targets{ascii} && !$skip_ascii{$testname}) {
 235                 $count_ascii++;
 236                 $count_total++;
 237                 print "@mandoc -T ascii $i\n" if $targets{verbose};
 238                 sysout $o, @mandoc, qw(-T ascii), $i
 239                     and fail $subdir, $testname, 'ascii:mandoc';
 240                 system @diff, $w, $o
 241                     and fail $subdir, $testname, 'ascii:diff';
 242         }
 243         my $m = "$subdir/$testname.in_man";
 244         my $mo = "$subdir/$testname.mandoc_man";
 245         if ($targets{man} && !$skip_man{$testname}) {
 246                 $count_man++;
 247                 $count_total++;
 248                 print "@mandoc -T man $i\n" if $targets{verbose};
 249                 sysout $m, @mandoc, qw(-T man), $i
 250                     and fail $subdir, $testname, 'man:man';
 251                 print "@mandoc -man -T ascii $m\n" if $targets{verbose};
 252                 sysout $mo, @mandoc, qw(-man -T ascii -O mdoc), $m
 253                     and fail $subdir, $testname, 'man:mandoc';
 254                 system @diff, $w, $mo
 255                     and fail $subdir, $testname, 'man:diff';
 256         }
 257         if ($targets{clean}) {
 258                 print "rm $o\n"
 259                     if $targets{verbose} && !$skip_ascii{$testname};
 260                 unlink $o;
 261                 print "rm $m $mo\n"
 262                     if $targets{verbose} && !$skip_man{$testname};
 263                 unlink $m, $mo;
 264         }
 265 }
 266
 267 my $count_utf8 = 0;
 268 for my $testname (@utf8_testnames) {
 269         next if $onlytest && $testname ne $onlytest;
 270         my $i = "$subdir/$testname.in";
 271         my $o = "$subdir/$testname.mandoc_utf8";
 272         my $w = "$subdir/$testname.out_utf8";
 273         if ($targets{utf8}) {
 274                 $count_utf8++;
 275                 $count_total++;
 276                 print "@mandoc -T utf8 $i\n" if $targets{verbose};
 277                 sysout $o, @mandoc, qw(-T utf8), $i
 278                     and fail $subdir, $testname, 'utf8:mandoc';
 279                 system @diff, $w, $o
 280                     and fail $subdir, $testname, 'utf8:diff';
 281         }
 282         if ($targets{clean}) {
 283                 print "rm $o\n" if $targets{verbose};
 284                 unlink $o;
 285         }
 286 }
 287
 288 my $count_html = 0;
 289 for my $testname (@html_testnames) {
 290         next if $onlytest && $testname ne $onlytest;
 291         my $i = "$subdir/$testname.in";
 292         my $o = "$subdir/$testname.mandoc_html";
 293         my $w = "$subdir/$testname.out_html";
 294         if ($targets{html}) {
 295                 $count_html++;
 296                 $count_total++;
 297                 print "@mandoc -T html $i\n" if $targets{verbose};
 298                 syshtml $o, @mandoc, qw(-T html), $i
 299                     and fail $subdir, $testname, 'html:mandoc';
 300                 system @diff, $w, $o
 301                     and fail $subdir, $testname, 'html:diff';
 302         }
 303         if ($targets{clean}) {
 304                 print "rm $o\n" if $targets{verbose};
 305                 unlink $o;
 306         }
 307 }
 308
 309 my $count_markdown = 0;
 310 for my $testname (@markdown_testnames) {
 311         next if $onlytest && $testname ne $onlytest;
 312         my $i = "$subdir/$testname.in";
 313         my $o = "$subdir/$testname.mandoc_markdown";
 314         my $w = "$subdir/$testname.out_markdown";
 315         if ($targets{markdown}) {
 316                 $count_markdown++;
 317                 $count_total++;
 318                 print "@mandoc -T markdown $i\n" if $targets{verbose};
 319                 sysout $o, @mandoc, qw(-T markdown), $i
 320                     and fail $subdir, $testname, 'markdown:mandoc';
 321                 system @diff, $w, $o
 322                     and fail $subdir, $testname, 'markdown:diff';
 323         }
 324         if ($targets{clean}) {
 325                 print "rm $o\n" if $targets{verbose};
 326                 unlink $o;
 327         }
 328 }
 329
 330 my $count_lint = 0;
 331 for my $testname (@lint_testnames) {
 332         next if $onlytest && $testname ne $onlytest;
 333         my $i = "$subdir/$testname.in";
 334         my $o = "$subdir/$testname.mandoc_lint";
 335         my $w = "$subdir/$testname.out_lint";
 336         if ($targets{lint}) {
 337                 $count_lint++;
 338                 $count_total++;
 339                 print "@mandoc -T lint $i\n" if $targets{verbose};
 340                 syslint $o, @mandoc, qw(-T lint), $i
 341                     and fail $subdir, $testname, 'lint:mandoc';
 342                 system @diff, $w, $o
 343                     and fail $subdir, $testname, 'lint:diff';
 344         }
 345         if ($targets{clean}) {
 346                 print "rm $o\n" if $targets{verbose};
 347                 unlink $o;
 348         }
 349 }
 350
 351 exit 0 unless $displaylevel or @failures;
 352
 353 print "\n" if $targets{verbose};
 354 if ($onlytest) {
 355         print "test $subdir:$onlytest finished";
 356 } else {
 357         print "testsuite $subdir finished";
 358 }
 359 print ' ', (scalar @subdir_names), ' subdirectories' if @subdir_names;
 360 print " $count_ascii ascii" if $count_ascii;
 361 print " $count_man man" if $count_man;
 362 print " $count_utf8 utf8" if $count_utf8;
 363 print " $count_html html" if $count_html;
 364 print " $count_markdown markdown" if $count_markdown;
 365 print " $count_lint lint" if $count_lint;
 366
 367 if (@failures) {
 368         print " (FAIL)\n\nSOME TESTS FAILED:\n\n";
 369         print "@$_\n" for @failures;
 370         print "\n";
 371         exit 1;
 372 } elsif ($count_total == 1) {
 373         print " (OK)\n";
 374 } elsif ($count_total) {
 375         print " (all $count_total tests OK)\n";
 376 } else {
 377         print " (no tests run)\n";
 378 }
 379 exit 0;