t/pod/testp2pt.pl

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