291edd649a9927002dac88c3f1b4b9464dd84dfb
[perl.git] / ext / Pod-Simple / t / corpus.t
1 BEGIN {
2     if($ENV{PERL_CORE}) {
3         chdir 't';
4         @INC = '../lib';
5     }
6
7     use Config;
8     if ($Config::Config{'extensions'} !~ /\bEncode\b/) {
9       print "1..0 # Skip: Encode was not built\n";
10       exit 0;
11     }
12 }
13
14 #use Pod::Simple::Debug (10);
15 use Test qw(plan ok skip);
16
17 use File::Spec;
18 #use utf8;
19 use strict;
20 my(@testfiles, %xmlfiles, %wouldxml);
21 #use Pod::Simple::Debug (10);
22 BEGIN { 
23
24 sub source_path {
25     my $file = shift;
26     if ($ENV{PERL_CORE}) {
27         require File::Spec;
28         my $updir = File::Spec->updir;
29         my $dir = File::Spec->catdir($updir, 'lib', 'Pod', 'Simple', 't');
30         return File::Spec->catdir ($dir, $file);
31     } else {
32         return $file;
33     }
34
35   my @bits;
36   if(-e( File::Spec::->catdir( @bits =
37     source_path('corpus') ) ) )
38    {
39     # OK
40     print "# 1Bits: @bits\n";
41   } elsif( -e (File::Spec::->catdir( @bits =
42     (File::Spec::->curdir, 'corpus') ) )
43   ) {
44     # OK
45     print "# 2Bits: @bits\n";
46   } elsif ( -e (File::Spec::->catdir( @bits =
47     (File::Spec::->curdir, 't', 'corpus') ) )
48   ) {
49     # OK
50     print "# 3Bits: @bits\n";
51   } else {
52     die "Can't find the corpusdir";
53   }
54   my $corpusdir = File::Spec::->catdir( @bits);
55   print "#Corpusdir: $corpusdir\n";
56
57   opendir(INDIR, $corpusdir) or die "Can't opendir corpusdir : $!";
58   my @f = map File::Spec::->catfile(@bits, $_), readdir(INDIR);
59   closedir(INDIR);
60   my %f;
61   @f{@f} = ();
62   foreach my $maybetest (sort @f) {
63     my $xml = $maybetest;
64     $xml =~ s/\.(txt|pod)$/\.xml/is  or  next;
65     $wouldxml{$maybetest} = $xml;
66     push @testfiles, $maybetest;
67     foreach my $x ($xml, uc($xml), lc($xml)) {
68       next unless exists $f{$x};
69       $xmlfiles{$maybetest} = $x;
70       last;
71     }
72   }
73   die "Too few test files (".@testfiles.")" unless @ARGV or @testfiles > 20;
74
75   @testfiles = @ARGV if @ARGV and !grep !m/\.txt/, @ARGV;
76
77   plan tests => (2 + 2*@testfiles - 1);
78 }
79
80 my $HACK = 1;
81 #@testfiles = ('nonesuch.txt');
82
83 ok 1;
84
85 my $skippy =  ($] < 5.008) ? "skip because perl ($]) pre-dates v5.8.0" : 0;
86 if($skippy) {
87   print "# This is just perl v$], so I'm skipping many many tests.\n";
88 }
89
90 {
91   my @x = @testfiles;
92   print "# Files to test:\n";
93   while(@x) {  print "#  ", join(' ', splice @x,0,3), "\n" }
94 }
95
96 require Pod::Simple::DumpAsXML;
97
98
99 foreach my $f (@testfiles) {
100   my $xml = $xmlfiles{$f};
101   if($xml) {
102     print "#\n#To test $f against $xml\n";
103   } else {
104     print "#\n# $f has no xml to test it against\n";
105   }
106
107   my $outstring;
108   eval {
109     my $p = Pod::Simple::DumpAsXML->new;
110     $p->output_string( \$outstring );
111     $p->parse_file( $f );
112     undef $p;
113   };
114   
115   if($@) {
116     my $x = "#** Couldn't parse $f:\n $@";
117     $x =~ s/([\n\r]+)/\n#** /g;
118     print $x, "\n";
119     ok 0;
120     ok 0;
121     next;
122   } else {
123     print "# OK, parsing $f generated ", length($outstring), " bytes\n";
124     ok 1;
125   }
126   
127   die "Null outstring?" unless $outstring;
128   
129   next if $f =~ /nonesuch/;
130
131   # foo.xml.out is not a portable filename. foo.xml_out may be a bit more portable
132
133   my $outfilename = ($HACK > 1) ? $wouldxml{$f} : "$wouldxml{$f}_out";
134   if($HACK) {
135     open OUT, ">$outfilename" or die "Can't write-open $outfilename: $!\n";
136     binmode(OUT);
137     print OUT $outstring;
138     close(OUT);
139   }
140   unless($xml) {
141     print "#  (no comparison done)\n";
142     ok 1;
143     next;
144   }
145   
146   open(IN, "<$xml") or die "Can't read-open $xml: $!";
147   #binmode(IN);
148   local $/;
149   my $xmlsource = <IN>;
150   close(IN);
151   
152   print "# There's errata!\n" if $outstring =~ m/start_line="-321"/;
153   
154   if(
155     $xmlsource eq $outstring
156     or do {
157       $xmlsource =~ s/[\n\r]+/\n/g;
158       $outstring =~ s/[\n\r]+/\n/g;
159       $xmlsource eq $outstring;
160     }
161   ) {
162     print "#  (Perfect match to $xml)\n";
163     unlink $outfilename unless $outfilename =~ m/\.xml$/is;
164     ok 1;
165     next;
166   }
167
168   if($skippy) {
169     skip $skippy, 0;
170   } else {
171     print "#  $outfilename and $xml don't match!\n";
172     ok 0;
173   }
174
175 }
176
177
178 print "#\n# I've been using Encode v",
179   $Encode::VERSION ? $Encode::VERSION : "(NONE)", "\n";
180 print "# Byebye\n";
181 ok 1;
182 print "# --- Done with ", __FILE__, " --- \n";
183