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