Avoid negating an unsigned value. (The offset in the SV body table)
[p5sagit/p5-mst-13.2.git] / t / pod / testpchk.pl
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);
13    require VMS::Filespec if $^O eq 'VMS';
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( $ $ ) {
34    ## filter out platform-dependent aspects of error messages
35    my ($line1, $line2) = @_;
36    for ($line1, $line2) {
37       ## remove filenames from error messages to avoid any
38       ## filepath naming differences between OS platforms
39       s/(at line \S+ in file) .*\W(\w+\.[tT])\s*$/$1 \L$2\E/;
40       s/.*\W(\w+\.[tT]) (has \d+ pod syntax error)/\L$1\E $2/;
41    }
42    return ($line1 ne $line2);
43 }
44
45 sub testpodcheck( @ ) {
46    my %args = @_;
47    my $infile  = $args{'-In'}  || croak "No input file given!";
48    my $outfile = $args{'-Out'} || croak "No output file given!";
49    my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!";
50
51    my $different = '';
52    my $testname = basename $cmpfile, '.t', '.xr';
53
54    unless (-e $cmpfile) {
55       my $msg = "*** Can't find comparison file $cmpfile for testing $infile";
56       warn  "$msg\n";
57       return  $msg;
58    }
59
60    print "# Running podchecker for '$testname'...\n";
61    ## Compare the output against the expected result
62    if ($^O eq 'VMS') {
63       for ($infile, $outfile, $cmpfile) {
64          $_ = VMS::Filespec::unixify($_)  unless  ref;
65       }
66    }
67    podchecker($infile, $outfile);
68    if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) {
69        $different = "$outfile is different from $cmpfile";
70    }
71    else {
72        unlink($outfile);
73    }
74    return  $different;
75 }
76
77 sub testpodchecker( @ ) {
78    my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : ();
79    my @testpods = @_;
80    my ($testname, $testdir) = ("", "");
81    my ($podfile, $cmpfile) = ("", "");
82    my ($outfile, $errfile) = ("", "");
83    my $passes = 0;
84    my $failed = 0;
85    local $_;
86
87    print "1..", scalar @testpods, "\n"  unless ($opts{'-xrgen'});
88
89    for $podfile (@testpods) {
90       ($testname, $_) = fileparse($podfile);
91       $testdir ||=  $_;
92       $testname  =~ s/\.t$//;
93       $cmpfile   =  $testdir . $testname . '.xr';
94       $outfile   =  $testdir . $testname . '.OUT';
95
96       if ($opts{'-xrgen'}) {
97           if ($opts{'-force'} or ! -e $cmpfile) {
98              ## Create the comparison file
99              print "# Creating expected result for \"$testname\"" .
100                    " podchecker test ...\n";
101              podchecker($podfile, $cmpfile);
102           }
103           else {
104              print "# File $cmpfile already exists" .
105                    " (use '-force' to regenerate it).\n";
106           }
107           next;
108       }
109
110       my $failmsg = testpodcheck
111                         -In  => $podfile,
112                         -Out => $outfile,
113                         -Cmp => $cmpfile;
114       if ($failmsg) {
115           ++$failed;
116           print "#\tFAILED. ($failmsg)\n";
117           print "not ok ", $failed+$passes, "\n";
118       }
119       else {
120           ++$passes;
121           unlink($outfile);
122           print "#\tPASSED.\n";
123           print "ok ", $failed+$passes, "\n";
124       }
125    }
126    return  $passes;
127 }
128
129 1;