Commit | Line | Data |
360aca43 |
1 | package TestPodChecker; |
2 | |
3 | BEGIN { |
4 | use File::Basename; |
5 | use File::Spec; |
6 | push @INC, '..'; |
7 | my $THISDIR = dirname $0; |
8 | unshift @INC, $THISDIR; |
9 | require "testcmp.pl"; |
10 | import TestCompare; |
11 | my $PARENTDIR = dirname $THISDIR; |
12 | push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); |
828c4421 |
13 | require VMS::Filespec if $^O eq 'VMS'; |
360aca43 |
14 | } |
15 | |
16 | use Pod::Checker; |
17 | use vars qw(@ISA @EXPORT $MYPKG); |
18 | #use strict; |
19 | #use diagnostics; |
20 | use Carp; |
21 | use Exporter; |
22 | #use File::Compare; |
23 | |
24 | @ISA = qw(Exporter); |
25 | @EXPORT = qw(&testpodchecker); |
26 | $MYPKG = eval { (caller)[0] }; |
27 | |
28 | sub stripname( $ ) { |
29 | local $_ = shift; |
30 | return /(\w[.\w]*)\s*$/ ? $1 : $_; |
31 | } |
32 | |
33 | sub msgcmp( $ $ ) { |
828c4421 |
34 | ## filter out platform-dependent aspects of error messages |
360aca43 |
35 | my ($line1, $line2) = @_; |
828c4421 |
36 | for ($line1, $line2) { |
37 | if ( /^#*\s*(\S.*?)\s+(?:has \d+\s*)?pod syntax (?:error|OK)/ ) { |
38 | my $fname = $1; |
39 | s/^#*\s*// if ($^O eq 'MacOS'); |
40 | s/^\s*\Q$fname\E/stripname($fname)/e; |
41 | } |
42 | elsif ( /^#*\s*\*+\s*(?:ERROR|Unterminated)/ ) { |
43 | s/^#*\s*// if ($^O eq 'MacOS'); |
44 | s/of file\s+(\S.*?)\s*$/"of file ".stripname($1)/e; |
45 | s/at\s+(\S.*?)\s+line/"at ".stripname($1)." line"/e; |
46 | } |
47 | } |
360aca43 |
48 | return $line1 ne $line2; |
49 | } |
50 | |
51 | sub testpodcheck( @ ) { |
52 | my %args = @_; |
53 | my $infile = $args{'-In'} || croak "No input file given!"; |
54 | my $outfile = $args{'-Out'} || croak "No output file given!"; |
55 | my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; |
56 | |
57 | my $different = ''; |
58 | my $testname = basename $cmpfile, '.t', '.xr'; |
59 | |
60 | unless (-e $cmpfile) { |
61 | my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; |
62 | warn "$msg\n"; |
63 | return $msg; |
64 | } |
65 | |
27f805f4 |
66 | print "# Running podchecker for '$testname'...\n"; |
360aca43 |
67 | ## Compare the output against the expected result |
828c4421 |
68 | if ($^O eq 'VMS') { |
69 | for ($infile, $outfile, $cmpfile) { |
70 | $_ = VMS::Filespec::unixify($_) unless ref; |
71 | } |
72 | } |
360aca43 |
73 | podchecker($infile, $outfile); |
74 | if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) { |
75 | $different = "$outfile is different from $cmpfile"; |
76 | } |
77 | else { |
78 | unlink($outfile); |
79 | } |
80 | return $different; |
81 | } |
82 | |
83 | sub testpodchecker( @ ) { |
84 | my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); |
85 | my @testpods = @_; |
86 | my ($testname, $testdir) = ("", ""); |
87 | my ($podfile, $cmpfile) = ("", ""); |
88 | my ($outfile, $errfile) = ("", ""); |
89 | my $passes = 0; |
90 | my $failed = 0; |
91 | local $_; |
92 | |
93 | print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); |
94 | |
95 | for $podfile (@testpods) { |
96 | ($testname, $_) = fileparse($podfile); |
97 | $testdir ||= $_; |
98 | $testname =~ s/\.t$//; |
99 | $cmpfile = $testdir . $testname . '.xr'; |
100 | $outfile = $testdir . $testname . '.OUT'; |
101 | |
102 | if ($opts{'-xrgen'}) { |
103 | if ($opts{'-force'} or ! -e $cmpfile) { |
104 | ## Create the comparison file |
27f805f4 |
105 | print "# Creating expected result for \"$testname\"" . |
360aca43 |
106 | " podchecker test ...\n"; |
107 | podchecker($podfile, $cmpfile); |
108 | } |
109 | else { |
27f805f4 |
110 | print "# File $cmpfile already exists" . |
360aca43 |
111 | " (use '-force' to regenerate it).\n"; |
112 | } |
113 | next; |
114 | } |
115 | |
116 | my $failmsg = testpodcheck |
117 | -In => $podfile, |
118 | -Out => $outfile, |
119 | -Cmp => $cmpfile; |
120 | if ($failmsg) { |
121 | ++$failed; |
27f805f4 |
122 | print "#\tFAILED. ($failmsg)\n"; |
360aca43 |
123 | print "not ok ", $failed+$passes, "\n"; |
124 | } |
125 | else { |
126 | ++$passes; |
127 | unlink($outfile); |
27f805f4 |
128 | print "#\tPASSED.\n"; |
360aca43 |
129 | print "ok ", $failed+$passes, "\n"; |
130 | } |
131 | } |
132 | return $passes; |
133 | } |
134 | |
135 | 1; |