t/pod/testp2pt.pl

   1 package TestPodIncPlainText;
   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::PlainText;
  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(Pod::PlainText);
  24 @EXPORT = qw(&testpodplaintext);
  25 $MYPKG = eval { (caller)[0] };
  26
  27 ## Hardcode settings for TERMCAP and COLUMNS so we can try to get
  28 ## reproducible results between environments
  29 @ENV{qw(TERMCAP COLUMNS)} = ('co=72:do=^J', 72);
  30
  31 sub catfile(@) { File::Spec->catfile(@_); }
  32
  33 ## Find the path to the file to =include
  34 sub findinclude {
  35     my $self    = shift;
  36     my $incname = shift;
  37
  38     ## See if its already found w/out any "searching;
  39     return  $incname if (-r $incname);
  40
  41     ## Need to search for it. Look in the following directories ...
  42     ##   1. the directory containing this pod file
  43     my $thispoddir = dirname $self->input_file;
  44     ##   2. the parent directory of the above
  45     my $parentdir  = ($thispoddir eq '.') ? '..' : dirname $thispoddir;
  46     ##   3. any Pod/ or scripts/ subdirectory of these two
  47     my @dirs = ();
  48     for ($thispoddir, $parentdir) {
  49        my $dir = $_;
  50        for ( qw(scripts lib) ) {
  51           push @dirs, $dir, catfile($dir, $_),
  52                             catfile($dir, 'Pod'),
  53                             catfile($dir, $_, 'Pod');
  54        }
  55     }
  56     my %dirs = (map { ($_ => 1) } @dirs);
  57     my @podincdirs = (sort keys %dirs);
  58
  59     for (@podincdirs) {
  60        my $incfile = catfile($_, $incname);
  61        return $incfile  if (-r $incfile);
  62     }
  63     warn("*** Can't find =include file $incname in @podincdirs\n");
  64     return "";
  65 }
  66
  67 sub command {
  68     my $self = shift;
  69     my ($cmd, $text, $line_num, $pod_para)  = @_;
  70     $cmd     = ''  unless (defined $cmd);
  71     local $_ = $text || '';
  72     my $out_fh  = $self->output_handle;
  73
  74     ## Defer to the superclass for everything except '=include'
  75     return  $self->SUPER::command(@_) unless ($cmd eq "include");
  76
  77     ## We have an '=include' command
  78     my $incdebug = 1; ## debugging
  79     my @incargs = split;
  80     if (@incargs == 0) {
  81         warn("*** No filename given for '=include'\n");
  82         return;
  83     }
  84     my $incfile  = $self->findinclude(shift @incargs)  or  return;
  85     my $incbase  = basename $incfile;
  86     print $out_fh "###### begin =include $incbase #####\n"  if ($incdebug);
  87     $self->parse_from_file( {-cutting => 1}, $incfile );
  88     print $out_fh "###### end =include $incbase #####\n"    if ($incdebug);
  89 }
  90
  91 sub podinc2plaintext( $ $ ) {
  92     my ($infile, $outfile) = @_;
  93     local $_;
  94     my $text_parser = $MYPKG->new;
  95     $text_parser->parse_from_file($infile, $outfile);
  96 }
  97
  98 sub testpodinc2plaintext( @ ) {
  99    my %args = @_;
 100    my $infile  = $args{'-In'}  || croak "No input file given!";
 101    my $outfile = $args{'-Out'} || croak "No output file given!";
 102    my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!";
 103
 104    my $different = '';
 105    my $testname = basename $cmpfile, '.t', '.xr';
 106
 107    unless (-e $cmpfile) {
 108       my $msg = "*** Can't find comparison file $cmpfile for testing $infile";
 109       warn  "$msg\n";
 110       return  $msg;
 111    }
 112
 113    print "+ Running testpodinc2plaintext for '$testname'...\n";
 114    ## Compare the output against the expected result
 115    podinc2plaintext($infile, $outfile);
 116    if ( testcmp($outfile, $cmpfile) ) {
 117        $different = "$outfile is different from $cmpfile";
 118    }
 119    else {
 120        unlink($outfile);
 121    }
 122    return  $different;
 123 }
 124
 125 sub testpodplaintext( @ ) {
 126    my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : ();
 127    my @testpods = @_;
 128    my ($testname, $testdir) = ("", "");
 129    my ($podfile, $cmpfile) = ("", "");
 130    my ($outfile, $errfile) = ("", "");
 131    my $passes = 0;
 132    my $failed = 0;
 133    local $_;
 134
 135    print "1..", scalar @testpods, "\n"  unless ($opts{'-xrgen'});
 136
 137    for $podfile (@testpods) {
 138       ($testname, $_) = fileparse($podfile);
 139       $testdir ||=  $_;
 140       $testname  =~ s/\.t$//;
 141       $cmpfile   =  $testdir . $testname . '.xr';
 142       $outfile   =  $testdir . $testname . '.OUT';
 143
 144       if ($opts{'-xrgen'}) {
 145           if ($opts{'-force'} or ! -e $cmpfile) {
 146              ## Create the comparison file
 147              print "+ Creating expected result for \"$testname\"" .
 148                    " pod2plaintext test ...\n";
 149              podinc2plaintext($podfile, $cmpfile);
 150           }
 151           else {
 152              print "+ File $cmpfile already exists" .
 153                    " (use '-force' to regenerate it).\n";
 154           }
 155           next;
 156       }
 157
 158       my $failmsg = testpodinc2plaintext
 159                         -In  => $podfile,
 160                         -Out => $outfile,
 161                         -Cmp => $cmpfile;
 162       if ($failmsg) {
 163           ++$failed;
 164           print "+\tFAILED. ($failmsg)\n";
 165           print "not ok ", $failed+$passes, "\n";
 166       }
 167       else {
 168           ++$passes;
 169           unlink($outfile);
 170           print "+\tPASSED.\n";
 171           print "ok ", $failed+$passes, "\n";
 172       }
 173    }
 174    return  $passes;
 175 }
 176
 177 1;