Annotation of mandoc/regress/regress.pl, Revision 1.3
1.1 schwarze 1: #!/usr/bin/env perl
2: #
1.3 ! schwarze 3: # $Id: regress.pl,v 1.2 2017/02/08 16:56:15 schwarze Exp $
1.1 schwarze 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:
1.2 schwarze 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:
1.1 schwarze 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|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{lint} || $targets{clean};
123: $targets{ascii} = $targets{utf8} = $targets{man} = $targets{html} =
124: $targets{lint} = 1 if $targets{all};
125: $displaylevel = 3 if $targets{verbose};
126:
127:
128: # --- parse Makefiles --------------------------------------------------
129:
130: my %vars = (MOPTS => '');
131: sub parse_makefile ($) {
132: my $filename = shift;
133: open my $fh, '<', $filename or die "$filename: $!";
134: while (<$fh>) {
135: chomp;
136: next unless /\S/;
137: last if /^# OpenBSD only/;
138: next if /^#/;
139: next if /^\.include/;
140: /^(\w+)\s*([?+]?)=\s*(.*)/
141: or die "$filename: parse error: $_";
142: my $var = $1;
143: my $opt = $2;
144: my $val = $3;
1.3 ! schwarze 145: $val =~ s/\$\{(\w+)\}/$vars{$1}/;
1.1 schwarze 146: $val = "$vars{$var} $val" if $opt eq '+';
147: $vars{$var} = $val
148: unless $opt eq '?' && defined $vars{$var};
149: }
150: close $fh;
151: }
152:
153: if ($subdir eq '.') {
154: $vars{SUBDIR} = 'roff char mdoc man tbl eqn';
155: } else {
156: parse_makefile "$subdir/Makefile";
157: parse_makefile "$subdir/../Makefile.inc"
158: if -e "$subdir/../Makefile.inc";
159: }
160:
161: my @mandoc = '../mandoc';
162: my @subdir_names;
163: my (@regress_testnames, @utf8_testnames, @html_testnames, @lint_testnames);
164: my (%skip_ascii, %skip_man);
165:
166: push @mandoc, split ' ', $vars{MOPTS} if $vars{MOPTS};
167: delete $vars{MOPTS};
168: delete $vars{SKIP_GROFF};
169: delete $vars{SKIP_GROFF_ASCII};
170: delete $vars{TBL};
171: delete $vars{EQN};
172: if (defined $vars{SUBDIR}) {
173: @subdir_names = split ' ', $vars{SUBDIR};
174: delete $vars{SUBDIR};
175: }
176: if (defined $vars{REGRESS_TARGETS}) {
177: @regress_testnames = split ' ', $vars{REGRESS_TARGETS};
178: delete $vars{REGRESS_TARGETS};
179: }
180: if (defined $vars{UTF8_TARGETS}) {
181: @utf8_testnames = split ' ', $vars{UTF8_TARGETS};
182: delete $vars{UTF8_TARGETS};
183: }
184: if (defined $vars{HTML_TARGETS}) {
185: @html_testnames = split ' ', $vars{HTML_TARGETS};
186: delete $vars{HTML_TARGETS};
187: }
188: if (defined $vars{LINT_TARGETS}) {
189: @lint_testnames = split ' ', $vars{LINT_TARGETS};
190: delete $vars{LINT_TARGETS};
191: }
192: if (defined $vars{SKIP_ASCII}) {
193: for (split ' ', $vars{SKIP_ASCII}) {
194: $skip_ascii{$_} = 1;
195: $skip_man{$_} = 1;
196: }
197: delete $vars{SKIP_ASCII};
198: }
199: if (defined $vars{SKIP_TMAN}) {
200: $skip_man{$_} = 1 for split ' ', $vars{SKIP_TMAN};
201: delete $vars{SKIP_TMAN};
202: }
203: if (keys %vars) {
204: my @vars = keys %vars;
205: die "unknown var(s) @vars";
206: }
207: map { $skip_ascii{$_} = 1; } @regress_testnames if $skip_ascii{ALL};
208: map { $skip_man{$_} = 1; } @regress_testnames if $skip_man{ALL};
209:
210: # --- run targets ------------------------------------------------------
211:
212: my $count_total = 0;
213: for my $dirname (@subdir_names) {
214: $count_total++;
215: print "\n" if $targets{verbose};
216: system './regress.pl', "$subdir/$dirname", keys %targets,
217: ($displaylevel ? $displaylevel - 1 : 0),
218: and fail $subdir, $dirname, 'subdir';
219: }
220:
221: my $count_ascii = 0;
222: my $count_man = 0;
223: for my $testname (@regress_testnames) {
224: next if $onlytest && $testname ne $onlytest;
225: my $i = "$subdir/$testname.in";
226: my $o = "$subdir/$testname.mandoc_ascii";
227: my $w = "$subdir/$testname.out_ascii";
228: if ($targets{ascii} && !$skip_ascii{$testname}) {
229: $count_ascii++;
230: $count_total++;
231: print "@mandoc -T ascii $i\n" if $targets{verbose};
232: sysout $o, @mandoc, qw(-T ascii), $i
233: and fail $subdir, $testname, 'ascii:mandoc';
1.2 schwarze 234: system @diff, $w, $o
1.1 schwarze 235: and fail $subdir, $testname, 'ascii:diff';
236: }
237: my $m = "$subdir/$testname.in_man";
238: my $mo = "$subdir/$testname.mandoc_man";
239: if ($targets{man} && !$skip_man{$testname}) {
240: $count_man++;
241: $count_total++;
242: print "@mandoc -T man $i\n" if $targets{verbose};
243: sysout $m, @mandoc, qw(-T man), $i
244: and fail $subdir, $testname, 'man:man';
245: print "@mandoc -man -T ascii $m\n" if $targets{verbose};
246: sysout $mo, @mandoc, qw(-man -T ascii -O mdoc), $m
247: and fail $subdir, $testname, 'man:mandoc';
1.2 schwarze 248: system @diff, $w, $mo
1.1 schwarze 249: and fail $subdir, $testname, 'man:diff';
250: }
251: if ($targets{clean}) {
252: print "rm $o\n"
253: if $targets{verbose} && !$skip_ascii{$testname};
254: unlink $o;
255: print "rm $m $mo\n"
256: if $targets{verbose} && !$skip_man{$testname};
257: unlink $m, $mo;
258: }
259: }
260:
261: my $count_utf8 = 0;
262: for my $testname (@utf8_testnames) {
263: next if $onlytest && $testname ne $onlytest;
264: my $i = "$subdir/$testname.in";
265: my $o = "$subdir/$testname.mandoc_utf8";
266: my $w = "$subdir/$testname.out_utf8";
267: if ($targets{utf8}) {
268: $count_utf8++;
269: $count_total++;
270: print "@mandoc -T utf8 $i\n" if $targets{verbose};
271: sysout $o, @mandoc, qw(-T utf8), $i
272: and fail $subdir, $testname, 'utf8:mandoc';
1.2 schwarze 273: system @diff, $w, $o
1.1 schwarze 274: and fail $subdir, $testname, 'utf8:diff';
275: }
276: if ($targets{clean}) {
277: print "rm $o\n" if $targets{verbose};
278: unlink $o;
279: }
280: }
281:
282: my $count_html = 0;
283: for my $testname (@html_testnames) {
284: next if $onlytest && $testname ne $onlytest;
285: my $i = "$subdir/$testname.in";
286: my $o = "$subdir/$testname.mandoc_html";
287: my $w = "$subdir/$testname.out_html";
288: if ($targets{html}) {
289: $count_html++;
290: $count_total++;
291: print "@mandoc -T html $i\n" if $targets{verbose};
292: syshtml $o, @mandoc, qw(-T html), $i
293: and fail $subdir, $testname, 'html:mandoc';
1.2 schwarze 294: system @diff, $w, $o
1.1 schwarze 295: and fail $subdir, $testname, 'html:diff';
296: }
297: if ($targets{clean}) {
298: print "rm $o\n" if $targets{verbose};
299: unlink $o;
300: }
301: }
302:
303: my $count_lint = 0;
304: for my $testname (@lint_testnames) {
305: next if $onlytest && $testname ne $onlytest;
306: my $i = "$subdir/$testname.in";
307: my $o = "$subdir/$testname.mandoc_lint";
308: my $w = "$subdir/$testname.out_lint";
309: if ($targets{lint}) {
310: $count_lint++;
311: $count_total++;
312: print "@mandoc -T lint $i\n" if $targets{verbose};
313: syslint $o, @mandoc, qw(-T lint), $i
314: and fail $subdir, $testname, 'lint:mandoc';
1.2 schwarze 315: system @diff, $w, $o
1.1 schwarze 316: and fail $subdir, $testname, 'lint:diff';
317: }
318: if ($targets{clean}) {
319: print "rm $o\n" if $targets{verbose};
320: unlink $o;
321: }
322: }
323:
324: exit 0 unless $displaylevel or @failures;
325:
326: print "\n" if $targets{verbose};
327: if ($onlytest) {
328: print "test $subdir:$onlytest finished";
329: } else {
330: print "testsuite $subdir finished";
331: }
332: print ' ', (scalar @subdir_names), ' subdirectories' if @subdir_names;
333: print " $count_ascii ascii" if $count_ascii;
334: print " $count_man man" if $count_man;
335: print " $count_utf8 utf8" if $count_utf8;
336: print " $count_html html" if $count_html;
337: print " $count_lint lint" if $count_lint;
338:
339: if (@failures) {
340: print " (FAIL)\n\nSOME TESTS FAILED:\n\n";
341: print "@$_\n" for @failures;
342: print "\n";
343: exit 1;
344: } elsif ($count_total == 1) {
345: print " (OK)\n";
346: } elsif ($count_total) {
347: print " (all $count_total tests OK)\n";
348: } else {
349: print " (no tests run)\n";
350: }
351: 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