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 }
  14
  15 use Pod::Checker;
  16 use vars qw(@ISA @EXPORT $MYPKG);
  17 #use strict;
  18 #use diagnostics;
  19 use Carp;
  20 use Exporter;
  21 #use File::Compare;
  22
  23 @ISA = qw(Exporter);
  24 @EXPORT = qw(&testpodchecker);
  25 $MYPKG = eval { (caller)[0] };
  26
  27 sub stripname( $ ) {
  28    local $_ = shift;
  29    return /(\w[.\w]*)\s*$/ ? $1 : $_;
  30 }
  31
  32 sub msgcmp( $ $ ) {
  33    my ($line1, $line2) = @_;
  34    return $line1 ne $line2;
  35 }
  36
  37 sub testpodcheck( @ ) {
  38    my %args = @_;
  39    my $infile  = $args{'-In'}  || croak "No input file given!";
  40    my $outfile = $args{'-Out'} || croak "No output file given!";
  41    my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!";
  42
  43    my $different = '';
  44    my $testname = basename $cmpfile, '.t', '.xr';
  45
  46    unless (-e $cmpfile) {
  47       my $msg = "*** Can't find comparison file $cmpfile for testing $infile";
  48       warn  "$msg\n";
  49       return  $msg;
  50    }
  51
  52    print "# Running podchecker for '$testname'...\n";
  53    ## Compare the output against the expected result
  54    podchecker($infile, $outfile);
  55    if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) {
  56        $different = "$outfile is different from $cmpfile";
  57    }
  58    else {
  59        unlink($outfile);
  60    }
  61    return  $different;
  62 }
  63
  64 sub testpodchecker( @ ) {
  65    my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : ();
  66    my @testpods = @_;
  67    my ($testname, $testdir) = ("", "");
  68    my ($podfile, $cmpfile) = ("", "");
  69    my ($outfile, $errfile) = ("", "");
  70    my $passes = 0;
  71    my $failed = 0;
  72    local $_;
  73
  74    print "1..", scalar @testpods, "\n"  unless ($opts{'-xrgen'});
  75
  76    for $podfile (@testpods) {
  77       ($testname, $_) = fileparse($podfile);
  78       $testdir ||=  $_;
  79       $testname  =~ s/\.t$//;
  80       $cmpfile   =  $testdir . $testname . '.xr';
  81       $outfile   =  $testdir . $testname . '.OUT';
  82
  83       if ($opts{'-xrgen'}) {
  84           if ($opts{'-force'} or ! -e $cmpfile) {
  85              ## Create the comparison file
  86              print "# Creating expected result for \"$testname\"" .
  87                    " podchecker test ...\n";
  88              podchecker($podfile, $cmpfile);
  89           }
  90           else {
  91              print "# File $cmpfile already exists" .
  92                    " (use '-force' to regenerate it).\n";
  93           }
  94           next;
  95       }
  96
  97       my $failmsg = testpodcheck
  98                         -In  => $podfile,
  99                         -Out => $outfile,
 100                         -Cmp => $cmpfile;
 101       if ($failmsg) {
 102           ++$failed;
 103           print "#\tFAILED. ($failmsg)\n";
 104           print "not ok ", $failed+$passes, "\n";
 105       }
 106       else {
 107           ++$passes;
 108           unlink($outfile);
 109           print "#\tPASSED.\n";
 110           print "ok ", $failed+$passes, "\n";
 111       }
 112    }
 113    return  $passes;
 114 }
 115
 116 1;