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