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       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    }
  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
  66    print "# Running podchecker for '$testname'...\n";
  67    ## Compare the output against the expected result
  68    if ($^O eq 'VMS') {
  69       for ($infile, $outfile, $cmpfile) {
  70          $_ = VMS::Filespec::unixify($_)  unless  ref;
  71       }
  72    }
  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
 105              print "# Creating expected result for \"$testname\"" .
 106                    " podchecker test ...\n";
 107              podchecker($podfile, $cmpfile);
 108           }
 109           else {
 110              print "# File $cmpfile already exists" .
 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;
 122           print "#\tFAILED. ($failmsg)\n";
 123           print "not ok ", $failed+$passes, "\n";
 124       }
 125       else {
 126           ++$passes;
 127           unlink($outfile);
 128           print "#\tPASSED.\n";
 129           print "ok ", $failed+$passes, "\n";
 130       }
 131    }
 132    return  $passes;
 133 }
 134
 135 1;