home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / pod / testpchk.pl < prev   
Perl Script  |  2000-03-16  |  4KB  |  130 lines
  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;
  130.