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