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