regress/regress.pl

   1 #!/usr/bin/env perl
   2 #
   3 # $Id: regress.pl,v 1.15 2020/07/21 15:14:20 schwarze Exp $
   4 #
   5 # Copyright (c) 2017, 2018, 2019, 2020 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 system @diff, '/dev/null', '/dev/null' and @diff = qw(diff -u);
  31
  32 # --- utility functions ------------------------------------------------
  33
  34 sub usage ($) {
  35         warn shift;
  36         print STDERR "usage: $0 [directory[:test] [modifier ...]]\n";
  37         exit 1;
  38 }
  39
  40 # Modifier arguments provided on the command line,
  41 # inspected by the main program and by the utility functions.
  42 my %targets;
  43
  44 # Run a command and send STDOUT and STDERR to a file.
  45 # 1st argument: path to the output file
  46 # 2nd argument: command name
  47 # The remaining arguments are passed to the command.
  48 sub sysout ($@) {
  49         my $outfile = shift;
  50         print "@_\n" if $targets{verbose};
  51         local *OUT_FH;
  52         open OUT_FH, '>', $outfile or die "$outfile: $!";
  53         my $pid = open3 undef, ">&OUT_FH", undef, @_;
  54         close OUT_FH;
  55         waitpid $pid, 0;
  56         return $? >> 8;
  57 }
  58
  59 # Simlar, but filter the output as needed for the lint test.
  60 sub syslint ($@) {
  61         my $outfile = shift;
  62         print "@_\n" if $targets{verbose};
  63         open my $outfd, '>', $outfile or die "$outfile: $!";
  64         my $infd;
  65         my $pid = open3 undef, $infd, undef, @_;
  66         while (<$infd>) {
  67                 s/^mandoc: [^:]+\//mandoc: /;
  68                 print $outfd $_;
  69         }
  70         close $outfd;
  71         close $infd;
  72         waitpid $pid, 0;
  73         return 0;
  74 }
  75
  76 # Simlar, but filter the output as needed for the html test.
  77 sub syshtml ($@) {
  78         my $outfile = shift;
  79         print "@_\n" if $targets{verbose};
  80         open my $outfd, '>', $outfile or die "$outfile: $!";
  81         my $infd;
  82         my $pid = open3 undef, $infd, undef, @_;
  83         my $state = 0;
  84         while (<$infd>) {
  85                 chomp;
  86                 if (!$state && s/.*<math class="eqn">//) {
  87                         $state = 'math';
  88                         next unless length;
  89                 } elsif (/BEGINTEST/) {
  90                         $state = 'other';
  91                         next;
  92                 } elsif (/ENDTEST/) {
  93                         $state = 0;
  94                         next;
  95                 }
  96                 if ($state eq 'math') {
  97                         s/^ *//;
  98                         if (s/<\/math>.*//) {
  99                                 print $outfd "$_\n" if length;
 100                                 $state = 0;
 101                                 next;
 102                         }
 103                 }
 104                 print $outfd "$_\n" if $state;
 105         }
 106         close $outfd;
 107         close $infd;
 108         waitpid $pid, 0;
 109         return 0;
 110 }
 111
 112 my @failures;
 113 sub fail ($$) {
 114         warn "FAILED: @_\n";
 115         push @failures, [@_];
 116 }
 117
 118
 119 # --- process command line arguments -----------------------------------
 120
 121 my $onlytest = shift // '';
 122 for (@ARGV) {
 123         /^(all|ascii|tag|man|utf8|html|markdown|lint|clean|verbose)$/
 124             or usage "$_: invalid modifier";
 125         $targets{$_} = 1;
 126 }
 127 $targets{all} = 1
 128     unless $targets{ascii} || $targets{tag} || $targets{man} ||
 129       $targets{utf8} || $targets{html} || $targets{markdown} ||
 130       $targets{lint} || $targets{clean};
 131 $targets{ascii} = $targets{tag} = $targets{man} = $targets{utf8} =
 132     $targets{html} = $targets{markdown} = $targets{lint} = 1
 133     if $targets{all};
 134
 135
 136 # --- parse Makefiles --------------------------------------------------
 137
 138 sub parse_makefile ($%) {
 139         my ($filename, $vars) = @_;
 140         open my $fh, '<', $filename or die "$filename: $!";
 141         while (<$fh>) {
 142                 chomp;
 143                 next unless /\S/;
 144                 last if /^# OpenBSD only/;
 145                 next if /^#/;
 146                 next if /^\.include/;
 147                 /^(\w+)\s*([?+]?)=\s*(.*)/
 148                     or die "$filename: parse error: $_";
 149                 my $var = $1;
 150                 my $opt = $2;
 151                 my $val = $3;
 152                 $val =~ s/\$\{(\w+)\}/$vars->{$1}/;
 153                 $val = "$vars->{$var} $val" if $opt eq '+';
 154                 $vars->{$var} = $val
 155                     unless $opt eq '?' && defined $vars->{$var};
 156         }
 157         close $fh;
 158 }
 159
 160 my (@regress_tests, @utf8_tests, @lint_tests, @html_tests);
 161 my (%tag_tests, %skip_ascii, %skip_man, %skip_markdown);
 162 foreach my $module (qw(roff char mdoc man tbl eqn)) {
 163         my %modvars;
 164         parse_makefile "$module/Makefile", \%modvars;
 165         foreach my $subdir (split ' ', $modvars{SUBDIR}) {
 166                 my %subvars = (MOPTS => '');
 167                 parse_makefile "$module/$subdir/Makefile", \%subvars;
 168                 parse_makefile "$module/Makefile.inc", \%subvars;
 169                 delete $subvars{GOPTS};
 170                 delete $subvars{SKIP_GROFF};
 171                 delete $subvars{SKIP_GROFF_ASCII};
 172                 my @mopts = split ' ', $subvars{MOPTS};
 173                 delete $subvars{MOPTS};
 174                 my @regress_testnames;
 175                 if (defined $subvars{TAG_TARGETS}) {
 176                         $tag_tests{"$module/$subdir/$_"} = 1
 177                             for split ' ', $subvars{TAG_TARGETS};
 178                         delete $subvars{TAG_TARGETS};
 179                 }
 180                 if (defined $subvars{REGRESS_TARGETS}) {
 181                         push @regress_testnames,
 182                             split ' ', $subvars{REGRESS_TARGETS};
 183                         push @regress_tests, {
 184                             NAME => "$module/$subdir/$_",
 185                             MOPTS => \@mopts,
 186                         } foreach @regress_testnames;
 187                         delete $subvars{REGRESS_TARGETS};
 188                 }
 189                 if (defined $subvars{UTF8_TARGETS}) {
 190                         push @utf8_tests, {
 191                             NAME => "$module/$subdir/$_",
 192                             MOPTS => \@mopts,
 193                         } foreach split ' ', $subvars{UTF8_TARGETS};
 194                         delete $subvars{UTF8_TARGETS};
 195                 }
 196                 if (defined $subvars{HTML_TARGETS}) {
 197                         push @html_tests, {
 198                             NAME => "$module/$subdir/$_",
 199                             MOPTS => \@mopts,
 200                         } foreach split ' ', $subvars{HTML_TARGETS};
 201                         delete $subvars{HTML_TARGETS};
 202                 }
 203                 if (defined $subvars{LINT_TARGETS}) {
 204                         push @lint_tests, {
 205                             NAME => "$module/$subdir/$_",
 206                             MOPTS => \@mopts,
 207                         } foreach split ' ', $subvars{LINT_TARGETS};
 208                         delete $subvars{LINT_TARGETS};
 209                 }
 210                 if (defined $subvars{SKIP_ASCII}) {
 211                         for (split ' ', $subvars{SKIP_ASCII}) {
 212                                 $skip_ascii{"$module/$subdir/$_"} = 1;
 213                                 $skip_man{"$module/$subdir/$_"} = 1;
 214                         }
 215                         delete $subvars{SKIP_ASCII};
 216                 }
 217                 if (defined $subvars{SKIP_TMAN}) {
 218                         $skip_man{"$module/$subdir/$_"} = 1
 219                             for split ' ', $subvars{SKIP_TMAN};
 220                         delete $subvars{SKIP_TMAN};
 221                 }
 222                 if (defined $subvars{SKIP_MARKDOWN}) {
 223                         $skip_markdown{"$module/$subdir/$_"} = 1
 224                             for split ' ', $subvars{SKIP_MARKDOWN};
 225                         delete $subvars{SKIP_MARKDOWN};
 226                 }
 227                 if (keys %subvars) {
 228                         my @vars = keys %subvars;
 229                         die "unknown var(s) @vars in dir $module/$subdir";
 230                 }
 231                 map {
 232                         $skip_ascii{"$module/$subdir/$_"} = 1;
 233                 } @regress_testnames if $skip_ascii{"$module/$subdir/ALL"};
 234                 map {
 235                         $skip_man{"$module/$subdir/$_"} = 1;
 236                 } @regress_testnames if $skip_man{"$module/$subdir/ALL"};
 237                 map {
 238                         $skip_markdown{"$module/$subdir/$_"} = 1;
 239                 } @regress_testnames if $skip_markdown{"$module/$subdir/ALL"};
 240         }
 241         delete $modvars{SUBDIR};
 242         if (keys %modvars) {
 243                 my @vars = keys %modvars;
 244                 die "unknown var(s) @vars in module $module";
 245         }
 246 }
 247
 248 # --- run targets ------------------------------------------------------
 249
 250 my $count_total = 0;
 251 my $count_ascii = 0;
 252 my $count_tag = 0;
 253 my $count_man = 0;
 254 my $count_rm = 0;
 255 if ($targets{ascii} || $targets{tag} || $targets{man}) {
 256         print "Running ascii, tag, and man tests ";
 257         print "...\n" if $targets{verbose};
 258 }
 259 for my $test (@regress_tests) {
 260         my $i = "$test->{NAME}.in";
 261         my $o = "$test->{NAME}.mandoc_ascii";
 262         my $w = "$test->{NAME}.out_ascii";
 263         my $to = "$test->{NAME}.mandoc_tag";
 264         my $tw = "$test->{NAME}.out_tag";
 265         my $diff_ascii;
 266         if ($targets{tag} && $tag_tests{$test->{NAME}} &&
 267             $test->{NAME} =~ /^$onlytest/) {
 268                 $count_tag++;
 269                 $count_total++;
 270                 my @cmd = (qw(../man -l), @{$test->{MOPTS}},
 271                     qw(-I os=OpenBSD -T ascii -O),
 272                     "outfilename=$o,tagfilename=$to", "$i");
 273                 print "@cmd\n" if $targets{verbose};
 274                 system @cmd
 275                     and fail $test->{NAME}, 'tag:man';
 276                 system qw(sed -i), 's/ .*\// /', $to;
 277                 system @diff, $tw, $to
 278                     and fail $test->{NAME}, 'tag:diff';
 279                 print "." unless $targets{verbose};
 280                 $diff_ascii = $targets{ascii};
 281         } elsif ($targets{ascii} && !$skip_ascii{$test->{NAME}} &&
 282             $test->{NAME} =~ /^$onlytest/) {
 283                 sysout $o, '../mandoc', @{$test->{MOPTS}},
 284                     qw(-I os=OpenBSD -T ascii), $i
 285                     and fail $test->{NAME}, 'ascii:mandoc';
 286                 $diff_ascii = 1;
 287         }
 288         if ($diff_ascii) {
 289                 $count_ascii++;
 290                 $count_total++;
 291                 system @diff, $w, $o
 292                     and fail $test->{NAME}, 'ascii:diff';
 293                 print "." unless $targets{verbose};
 294         }
 295         my $m = "$test->{NAME}.in_man";
 296         my $mo = "$test->{NAME}.mandoc_man";
 297         if ($targets{man} && !$skip_man{$test->{NAME}} &&
 298             $test->{NAME} =~ /^$onlytest/) {
 299                 $count_man++;
 300                 $count_total++;
 301                 sysout $m, '../mandoc', @{$test->{MOPTS}},
 302                     qw(-I os=OpenBSD -T man), $i
 303                     and fail $test->{NAME}, 'man:man';
 304                 sysout $mo, '../mandoc', @{$test->{MOPTS}},
 305                     qw(-man -I os=OpenBSD -T ascii -O mdoc), $m
 306                     and fail $test->{NAME}, 'man:mandoc';
 307                 system @diff, $w, $mo
 308                     and fail $test->{NAME}, 'man:diff';
 309                 print "." unless $targets{verbose};
 310         }
 311         if ($targets{clean}) {
 312                 print "rm $o $to $m $mo\n" if $targets{verbose};
 313                 $count_rm += unlink $o, $to, $m, $mo;
 314         }
 315 }
 316 if ($targets{ascii} || $targets{tag} || $targets{man}) {
 317         print "Number of ascii, tag, and man tests:" if $targets{verbose};
 318         print " $count_ascii + $count_tag + $count_man tests run.\n";
 319 }
 320
 321 my $count_utf8 = 0;
 322 if ($targets{utf8}) {
 323         print "Running utf8 tests ";
 324         print "...\n" if $targets{verbose};
 325 }
 326 for my $test (@utf8_tests) {
 327         my $i = "$test->{NAME}.in";
 328         my $o = "$test->{NAME}.mandoc_utf8";
 329         my $w = "$test->{NAME}.out_utf8";
 330         if ($targets{utf8} && $test->{NAME} =~ /^$onlytest/o) {
 331                 $count_utf8++;
 332                 $count_total++;
 333                 sysout $o, '../mandoc', @{$test->{MOPTS}},
 334                     qw(-I os=OpenBSD -T utf8), $i
 335                     and fail $test->{NAME}, 'utf8:mandoc';
 336                 system @diff, $w, $o
 337                     and fail $test->{NAME}, 'utf8:diff';
 338                 print "." unless $targets{verbose};
 339         }
 340         if ($targets{clean}) {
 341                 print "rm $o\n" if $targets{verbose};
 342                 $count_rm += unlink $o;
 343         }
 344 }
 345 if ($targets{utf8}) {
 346         print "Number of utf8 tests:" if $targets{verbose};
 347         print " $count_utf8 tests run.\n";
 348 }
 349
 350 my $count_html = 0;
 351 if ($targets{html}) {
 352         print "Running html tests ";
 353         print "...\n" if $targets{verbose};
 354 }
 355 for my $test (@html_tests) {
 356         my $i = "$test->{NAME}.in";
 357         my $o = "$test->{NAME}.mandoc_html";
 358         my $w = "$test->{NAME}.out_html";
 359         if ($targets{html} && $test->{NAME} =~ /^$onlytest/) {
 360                 $count_html++;
 361                 $count_total++;
 362                 syshtml $o, '../mandoc', @{$test->{MOPTS}},
 363                     qw(-T html), $i
 364                     and fail $test->{NAME}, 'html:mandoc';
 365                 system @diff, $w, $o
 366                     and fail $test->{NAME}, 'html:diff';
 367                 print "." unless $targets{verbose};
 368         }
 369         if ($targets{clean}) {
 370                 print "rm $o\n" if $targets{verbose};
 371                 $count_rm += unlink $o;
 372         }
 373 }
 374 if ($targets{html}) {
 375         print "Number of html tests:" if $targets{verbose};
 376         print " $count_html tests run.\n";
 377 }
 378
 379 my $count_markdown = 0;
 380 if ($targets{markdown}) {
 381         print "Running markdown tests ";
 382         print "...\n" if $targets{verbose};
 383 }
 384 for my $test (@regress_tests) {
 385         my $i = "$test->{NAME}.in";
 386         my $o = "$test->{NAME}.mandoc_markdown";
 387         my $w = "$test->{NAME}.out_markdown";
 388         if ($targets{markdown} && !$skip_markdown{$test->{NAME}} &&
 389             $test->{NAME} =~ /^$onlytest/) {
 390                 $count_markdown++;
 391                 $count_total++;
 392                 sysout $o, '../mandoc', @{$test->{MOPTS}},
 393                     qw(-I os=OpenBSD -T markdown), $i
 394                     and fail $test->{NAME}, 'markdown:mandoc';
 395                 system @diff, $w, $o
 396                     and fail $test->{NAME}, 'markdown:diff';
 397                 print "." unless $targets{verbose};
 398         }
 399         if ($targets{clean}) {
 400                 print "rm $o\n" if $targets{verbose};
 401                 $count_rm += unlink $o;
 402         }
 403 }
 404 if ($targets{markdown}) {
 405         print "Number of markdown tests:" if $targets{verbose};
 406         print " $count_markdown tests run.\n";
 407 }
 408
 409 my $count_lint = 0;
 410 if ($targets{lint}) {
 411         print "Running lint tests ";
 412         print "...\n" if $targets{verbose};
 413 }
 414 for my $test (@lint_tests) {
 415         my $i = "$test->{NAME}.in";
 416         my $o = "$test->{NAME}.mandoc_lint";
 417         my $w = "$test->{NAME}.out_lint";
 418         if ($targets{lint} && $test->{NAME} =~ /^$onlytest/) {
 419                 $count_lint++;
 420                 $count_total++;
 421                 syslint $o, '../mandoc', @{$test->{MOPTS}},
 422                     qw(-I os=OpenBSD -T lint -W all), $i
 423                     and fail $test->{NAME}, 'lint:mandoc';
 424                 system @diff, $w, $o
 425                     and fail $test->{NAME}, 'lint:diff';
 426                 print "." unless $targets{verbose};
 427         }
 428         if ($targets{clean}) {
 429                 print "rm $o\n" if $targets{verbose};
 430                 $count_rm += unlink $o;
 431         }
 432 }
 433 if ($targets{lint}) {
 434         print "Number of lint tests:" if $targets{verbose};
 435         print " $count_lint tests run.\n";
 436 }
 437
 438 # --- final report -----------------------------------------------------
 439
 440 if (@failures) {
 441         print "\nNUMBER OF FAILED TESTS: ", scalar @failures,
 442             " (of $count_total tests run.)\n";
 443         print "@$_\n" for @failures;
 444         print "\n";
 445         exit 1;
 446 }
 447 print "\n" if $targets{verbose};
 448 if ($count_total == 1) {
 449         print "Test succeeded.\n";
 450 } elsif ($count_total) {
 451         print "All $count_total tests OK:";
 452         print " $count_ascii ascii" if $count_ascii;
 453         print " $count_tag tag" if $count_tag;
 454         print " $count_man man" if $count_man;
 455         print " $count_utf8 utf8" if $count_utf8;
 456         print " $count_html html" if $count_html;
 457         print " $count_markdown markdown" if $count_markdown;
 458         print " $count_lint lint" if $count_lint;
 459         print "\n";
 460 } else {
 461         print "No tests were run.\n";
 462 }
 463 if ($targets{clean}) {
 464         if ($count_rm) {
 465                 print "Deleted $count_rm test output files.\n";
 466                 print "The tree is now clean.\n";
 467         } else {
 468                 print "No test output files were found.\n";
 469                 print "The tree was already clean.\n";
 470         }
 471 }
 472 exit 0;