regress/regress.pl

   1 #!/usr/bin/env perl
   2 #
   3 # $Id: regress.pl,v 1.16 2021/09/19 12:15:34 schwarze Exp $
   4 #
   5 # Copyright (c) 2017,2018,2019,2020,2021 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 $tos = "$test->{NAME}.mandoc_tag_s";
 265         my $tw = "$test->{NAME}.out_tag";
 266         my $diff_ascii;
 267         if ($targets{tag} && $tag_tests{$test->{NAME}} &&
 268             $test->{NAME} =~ /^$onlytest/) {
 269                 $count_tag++;
 270                 $count_total++;
 271                 my @cmd = (qw(../man -l), @{$test->{MOPTS}},
 272                     qw(-I os=OpenBSD -T ascii -O),
 273                     "outfilename=$o,tagfilename=$to", "$i");
 274                 print "@cmd\n" if $targets{verbose};
 275                 system @cmd
 276                     and fail $test->{NAME}, 'tag:man';
 277                 system "sed 's: .*/: :' $to > $tos";
 278                 system @diff, $tw, $tos
 279                     and fail $test->{NAME}, 'tag:diff';
 280                 print "." unless $targets{verbose};
 281                 $diff_ascii = $targets{ascii};
 282         } elsif ($targets{ascii} && !$skip_ascii{$test->{NAME}} &&
 283             $test->{NAME} =~ /^$onlytest/) {
 284                 sysout $o, '../mandoc', @{$test->{MOPTS}},
 285                     qw(-I os=OpenBSD -T ascii), $i
 286                     and fail $test->{NAME}, 'ascii:mandoc';
 287                 $diff_ascii = 1;
 288         }
 289         if ($diff_ascii) {
 290                 $count_ascii++;
 291                 $count_total++;
 292                 system @diff, $w, $o
 293                     and fail $test->{NAME}, 'ascii:diff';
 294                 print "." unless $targets{verbose};
 295         }
 296         my $m = "$test->{NAME}.in_man";
 297         my $mo = "$test->{NAME}.mandoc_man";
 298         if ($targets{man} && !$skip_man{$test->{NAME}} &&
 299             $test->{NAME} =~ /^$onlytest/) {
 300                 $count_man++;
 301                 $count_total++;
 302                 sysout $m, '../mandoc', @{$test->{MOPTS}},
 303                     qw(-I os=OpenBSD -T man), $i
 304                     and fail $test->{NAME}, 'man:man';
 305                 sysout $mo, '../mandoc', @{$test->{MOPTS}},
 306                     qw(-man -I os=OpenBSD -T ascii -O mdoc), $m
 307                     and fail $test->{NAME}, 'man:mandoc';
 308                 system @diff, $w, $mo
 309                     and fail $test->{NAME}, 'man:diff';
 310                 print "." unless $targets{verbose};
 311         }
 312         if ($targets{clean}) {
 313                 print "rm $o $to $tos $m $mo\n" if $targets{verbose};
 314                 $count_rm += unlink $o, $to, $tos, $m, $mo;
 315         }
 316 }
 317 if ($targets{ascii} || $targets{tag} || $targets{man}) {
 318         print "Number of ascii, tag, and man tests:" if $targets{verbose};
 319         print " $count_ascii + $count_tag + $count_man tests run.\n";
 320 }
 321
 322 my $count_utf8 = 0;
 323 if ($targets{utf8}) {
 324         print "Running utf8 tests ";
 325         print "...\n" if $targets{verbose};
 326 }
 327 for my $test (@utf8_tests) {
 328         my $i = "$test->{NAME}.in";
 329         my $o = "$test->{NAME}.mandoc_utf8";
 330         my $w = "$test->{NAME}.out_utf8";
 331         if ($targets{utf8} && $test->{NAME} =~ /^$onlytest/o) {
 332                 $count_utf8++;
 333                 $count_total++;
 334                 sysout $o, '../mandoc', @{$test->{MOPTS}},
 335                     qw(-I os=OpenBSD -T utf8), $i
 336                     and fail $test->{NAME}, 'utf8:mandoc';
 337                 system @diff, $w, $o
 338                     and fail $test->{NAME}, 'utf8:diff';
 339                 print "." unless $targets{verbose};
 340         }
 341         if ($targets{clean}) {
 342                 print "rm $o\n" if $targets{verbose};
 343                 $count_rm += unlink $o;
 344         }
 345 }
 346 if ($targets{utf8}) {
 347         print "Number of utf8 tests:" if $targets{verbose};
 348         print " $count_utf8 tests run.\n";
 349 }
 350
 351 my $count_html = 0;
 352 if ($targets{html}) {
 353         print "Running html tests ";
 354         print "...\n" if $targets{verbose};
 355 }
 356 for my $test (@html_tests) {
 357         my $i = "$test->{NAME}.in";
 358         my $o = "$test->{NAME}.mandoc_html";
 359         my $w = "$test->{NAME}.out_html";
 360         if ($targets{html} && $test->{NAME} =~ /^$onlytest/) {
 361                 $count_html++;
 362                 $count_total++;
 363                 syshtml $o, '../mandoc', @{$test->{MOPTS}},
 364                     qw(-T html), $i
 365                     and fail $test->{NAME}, 'html:mandoc';
 366                 system @diff, $w, $o
 367                     and fail $test->{NAME}, 'html:diff';
 368                 print "." unless $targets{verbose};
 369         }
 370         if ($targets{clean}) {
 371                 print "rm $o\n" if $targets{verbose};
 372                 $count_rm += unlink $o;
 373         }
 374 }
 375 if ($targets{html}) {
 376         print "Number of html tests:" if $targets{verbose};
 377         print " $count_html tests run.\n";
 378 }
 379
 380 my $count_markdown = 0;
 381 if ($targets{markdown}) {
 382         print "Running markdown tests ";
 383         print "...\n" if $targets{verbose};
 384 }
 385 for my $test (@regress_tests) {
 386         my $i = "$test->{NAME}.in";
 387         my $o = "$test->{NAME}.mandoc_markdown";
 388         my $w = "$test->{NAME}.out_markdown";
 389         if ($targets{markdown} && !$skip_markdown{$test->{NAME}} &&
 390             $test->{NAME} =~ /^$onlytest/) {
 391                 $count_markdown++;
 392                 $count_total++;
 393                 sysout $o, '../mandoc', @{$test->{MOPTS}},
 394                     qw(-I os=OpenBSD -T markdown), $i
 395                     and fail $test->{NAME}, 'markdown:mandoc';
 396                 system @diff, $w, $o
 397                     and fail $test->{NAME}, 'markdown:diff';
 398                 print "." unless $targets{verbose};
 399         }
 400         if ($targets{clean}) {
 401                 print "rm $o\n" if $targets{verbose};
 402                 $count_rm += unlink $o;
 403         }
 404 }
 405 if ($targets{markdown}) {
 406         print "Number of markdown tests:" if $targets{verbose};
 407         print " $count_markdown tests run.\n";
 408 }
 409
 410 my $count_lint = 0;
 411 if ($targets{lint}) {
 412         print "Running lint tests ";
 413         print "...\n" if $targets{verbose};
 414 }
 415 for my $test (@lint_tests) {
 416         my $i = "$test->{NAME}.in";
 417         my $o = "$test->{NAME}.mandoc_lint";
 418         my $w = "$test->{NAME}.out_lint";
 419         if ($targets{lint} && $test->{NAME} =~ /^$onlytest/) {
 420                 $count_lint++;
 421                 $count_total++;
 422                 syslint $o, '../mandoc', @{$test->{MOPTS}},
 423                     qw(-I os=OpenBSD -T lint -W all), $i
 424                     and fail $test->{NAME}, 'lint:mandoc';
 425                 system @diff, $w, $o
 426                     and fail $test->{NAME}, 'lint:diff';
 427                 print "." unless $targets{verbose};
 428         }
 429         if ($targets{clean}) {
 430                 print "rm $o\n" if $targets{verbose};
 431                 $count_rm += unlink $o;
 432         }
 433 }
 434 if ($targets{lint}) {
 435         print "Number of lint tests:" if $targets{verbose};
 436         print " $count_lint tests run.\n";
 437 }
 438
 439 # --- final report -----------------------------------------------------
 440
 441 if (@failures) {
 442         print "\nNUMBER OF FAILED TESTS: ", scalar @failures,
 443             " (of $count_total tests run.)\n";
 444         print "@$_\n" for @failures;
 445         print "\n";
 446         exit 1;
 447 }
 448 print "\n" if $targets{verbose};
 449 if ($count_total == 1) {
 450         print "Test succeeded.\n";
 451 } elsif ($count_total) {
 452         print "All $count_total tests OK:";
 453         print " $count_ascii ascii" if $count_ascii;
 454         print " $count_tag tag" if $count_tag;
 455         print " $count_man man" if $count_man;
 456         print " $count_utf8 utf8" if $count_utf8;
 457         print " $count_html html" if $count_html;
 458         print " $count_markdown markdown" if $count_markdown;
 459         print " $count_lint lint" if $count_lint;
 460         print "\n";
 461 } else {
 462         print "No tests were run.\n";
 463 }
 464 if ($targets{clean}) {
 465         if ($count_rm) {
 466                 print "Deleted $count_rm test output files.\n";
 467                 print "The tree is now clean.\n";
 468         } else {
 469                 print "No test output files were found.\n";
 470                 print "The tree was already clean.\n";
 471         }
 472 }
 473 exit 0;