Commit | Line | Data |
351625bd |
1 | BEGIN { |
2 | if($ENV{PERL_CORE}) { |
3 | chdir 't'; |
4 | @INC = '../lib'; |
5 | } |
cd08456d |
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 | } |
351625bd |
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 | |
90cd13a2 |
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"; |
351625bd |
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 | |