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