Annotation of mandoc/regress/regress.pl, Revision 1.1
1.1 ! schwarze 1: #!/usr/bin/env perl
! 2: #
! 3: # $Id$
! 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;
CVSweb
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to regress.pl CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [cvsweb.bsd.lv] / mandoc / regress