lib/Pod/Simple/t/render.t

   1 BEGIN {
   2     chdir 't';
   3     if($ENV{PERL_CORE}) {
   4         @INC = '../lib';
   5     }
   6 }
   7
   8 use strict;
   9 use Test;
  10 BEGIN { plan tests => 26 };
  11 use Pod::Simple::TextContent;
  12 use Pod::Simple::Text;
  13
  14 BEGIN {
  15   *mytime = defined(&Win32::GetTickCount)
  16     ? sub () {Win32::GetTickCount() / 1000}
  17     : sub () {time()}
  18 }
  19
  20 $Pod::Simple::Text::FREAKYMODE = 1;
  21 use Pod::Simple::TiedOutFH ();
  22
  23 sub source_path {
  24     my $file = shift;
  25     if ($ENV{PERL_CORE}) {
  26         require File::Spec;
  27         my $updir = File::Spec->updir;
  28         my $dir = File::Spec->catdir ($updir, 'lib', 'Pod', 'Simple', 't');
  29         return File::Spec->catfile ($dir, $file);
  30     } else {
  31         return $file;
  32     }
  33 }
  34
  35 my $outfile = '10000';
  36
  37 foreach my $file (
  38   "test_junk1.pod",
  39   "test_junk2.pod",
  40   "test_old_perlcygwin.pod",
  41   "test_old_perlfaq3.pod",
  42   "test_old_perlvar.pod",
  43 ) {
  44
  45   unless(-e source_path($file)) {
  46     ok 0;
  47     print "# But $file doesn't exist!!\n";
  48     exit 1;
  49   }
  50
  51   my @out;
  52   my $precooked = source_path($file);
  53   $precooked =~ s<\.pod><_out.txt>s;
  54   unless(-e $precooked) {
  55     ok 0;
  56     print "# But $precooked doesn't exist!!\n";
  57     exit 1;
  58   }
  59
  60   print "#\n#\n#\n###################\n# $file\n";
  61   foreach my $class ('Pod::Simple::TextContent', 'Pod::Simple::Text') {
  62     my $p = $class->new;
  63     push @out, '';
  64     $p->output_string(\$out[-1]);
  65     my $t = mytime();
  66     $p->parse_file(source_path($file));
  67     printf "# %s %s %sb, %.03fs\n",
  68      ref($p), source_path($file), length($out[-1]), mytime() - $t ;
  69     ok 1;
  70   }
  71
  72   print "# Reading $precooked...\n";
  73   open(IN, $precooked) or die "Can't read-open $precooked: $!";
  74   {
  75     local $/;
  76     push @out, <IN>;
  77   }
  78   close(IN);
  79   print "#   ", length($out[-1]), " bytes pulled in.\n";
  80
  81
  82   for (@out) { s/\s+/ /g; s/^\s+//s; s/\s+$//s; }
  83
  84   my $faily = 0;
  85   print "#\n#Now comparing 1 and 2...\n";
  86   $faily += compare2($out[0], $out[1]);
  87   print "#\n#Now comparing 2 and 3...\n";
  88   $faily += compare2($out[1], $out[2]);
  89   print "#\n#Now comparing 1 and 3...\n";
  90   $faily += compare2($out[0], $out[2]);
  91
  92   if($faily) {
  93     ++$outfile;
  94
  95     my @outnames = map $outfile . $_ , qw(0 1);
  96     open(OUT2, ">$outnames[0].~out.txt") || die "Can't write-open $outnames[0].txt: $!";
  97
  98     foreach my $out (@out) { push @outnames, $outnames[-1];  ++$outnames[-1] };
  99     pop @outnames;
 100     printf "# Writing to %s.txt .. %s.txt\n", $outnames[0], $outnames[-1];
 101     shift @outnames;
 102
 103     binmode(OUT2);
 104     foreach my $out (@out) {
 105       my $outname = shift @outnames;
 106       open(OUT, ">$outname.txt") || die "Can't write-open $outname.txt: $!";
 107       binmode(OUT);
 108       print OUT  $out, "\n";
 109       print OUT2 $out, "\n";
 110       close(OUT);
 111     }
 112     close(OUT2);
 113   }
 114 }
 115
 116 print "# Wrapping up... one for the road...\n";
 117 ok 1;
 118 print "# --- Done with ", __FILE__, " --- \n";
 119 exit;
 120
 121
 122 sub compare2 {
 123   my @out = @_;
 124   if($out[0] eq $out[1]) {
 125     ok 1;
 126     return 0;
 127   } elsif( do{
 128     for ($out[0], $out[1]) { tr/ //d; };
 129     $out[0] eq $out[1];
 130   }){
 131     print "# Differ only in whitespace.\n";
 132     ok 1;
 133     return 0;
 134   } else {
 135     #ok $out[0], $out[1];
 136
 137     my $x = $out[0] ^ $out[1];
 138     $x =~ m/^(\x00*)/s or die;
 139     my $at = length($1);
 140     print "# Difference at byte $at...\n";
 141     if($at > 10) {
 142       $at -= 5;
 143     }
 144     {
 145       print "# ", substr($out[0],$at,20), "\n";
 146       print "# ", substr($out[1],$at,20), "\n";
 147       print "#      ^...";
 148     }
 149
 150
 151
 152     ok 0;
 153     printf "# Unequal lengths %s and %s\n", length($out[0]), length($out[1]);
 154     return 1;
 155   }
 156 }
 157
 158
 159 __END__
 160