util/t/01-smartlinks.t

   1 # This test script serves as a regression test suite harness
   2 # for util/smartlinks.pl
   3 # Because smartlinks.pl depends on many changing things like
   4 # the Pugs test suite and Perl 6 Synopses, we have to freeze
   5 # the dependencies in order to do an effiective regression.
   6 # To save the room in the SVN repos, this script downloads
   7 # a tarball from feather itself, which contains a particular version
   8 # of the test suite and Synopses, as well as the reference outputs
   9 # in HTML.
  10 #
  11 # Dependencies:
  12 #   LWP::UserAgent
  13 #   Archive::Tar
  14 #   Text::Diff
  15
  16 use strict;
  17 use warnings;
  18
  19 #use Smart::Comments;
  20 use Test::More tests => 19;
  21 use File::Slurp;
  22 use POSIX;
  23 use FindBin qw( $Bin );
  24 use File::Copy;
  25
  26 BEGIN {
  27     eval "use LWP::UserAgent;";
  28     if ($@) { die "LWP::UserAgent is required to run this test script"; }
  29     eval "use Archive::Tar;";
  30     if ($@) { die "Archive::Tar is required to run this test script"; }
  31     eval "use Text::Diff;";
  32     if ($@) { die "Text::Diff is required to run this test script"; }
  33 };
  34
  35 my $tmpfile = POSIX::tmpnam();
  36
  37 my $data_path = "$Bin/smartlinks_data";
  38 ### $data_path;
  39 if (-d $data_path) {
  40     warn "warning: Removing the exising $data_path...\n";
  41     system("$^X -MExtUtils::Command -e rm_rf $data_path");
  42 }
  43
  44 my $ua = LWP::UserAgent->new;
  45 my $url = 'http://feather.perl6.nl/~agentzh/smartlinks_data.tar.gz';
  46 warn "info: Updating $url...\n";
  47 my $tarball = "$Bin/smartlinks_data.tar.gz";
  48 my $res = $ua->mirror($url, $tarball);
  49 if ($res->is_error) {
  50     die "Failed to get $url: ", $res->status_line;
  51 }
  52 ok -f $tarball, 'tarball downloaded okay';
  53
  54 warn "info: Extracting $tarball...\n";
  55 my $tar = Archive::Tar->new;
  56 $tar->read($tarball);
  57 chdir $Bin;
  58 $tar->extract;
  59
  60 ok -d $data_path, 'tarball extracted successfully';
  61 ok -d "$data_path/Spec", 'Spec/ okay';
  62 ok -d "$data_path/expected", 'expected/ okay';
  63 ok -d "$data_path/t", 't/ okay';
  64
  65 chdir $data_path;
  66
  67 my @args = qw(t/*.t t/*/*.t t/*/*/*.t t/*/*/*/*.t);
  68 my @t_files = sort map glob, @args;
  69 ### @t_files
  70
  71 # Test synopses w/o smoke results
  72 system("$^X $Bin/../smartlinks.pl --fast " .
  73     "--syn-dir Spec --out-dir got " .
  74     join(" ", @t_files));
  75 is $? >> 8, 0, "smartlinks.pl returned zero status";
  76
  77 for my $path (glob "expected/*.html") {
  78     next if $path =~ /\bS26\b/;
  79     my $file;
  80     if ($path =~ m{/([^/]+)$}) {
  81         $file = $1;
  82     }
  83     fix_randomness("got/$file");
  84     fix_randomness("expected/$file");
  85     my $cmd = "diff got/$file expected/$file";
  86     my ($file1, $file2) = ("got/$file", "expected/$file");
  87     warn "$file1 <=> $file2\n";
  88     my $out = diff $file1, $file2, {STYLE => 'OldStyle'};
  89     $out =~ s/^\s+|\s+$//g;
  90     is $out, '', 'no diff';
  91 }
  92
  93 sub fix_randomness {
  94     my $fname = shift;
  95     open my $in, $fname or die "Can't open $fname for reading: $!";
  96     open my $out, "> $tmpfile" or die "Can't write to $tmpfile: $!";
  97     while (<$in>) {
  98         s/\r//g;
  99         s/\br\d+\b/rXXXX/g;
 100         s/\d{4}-\d{2}-\d{2} \d+:\d+:\d+ GMT/XXXX-XX-XX XX:XX:XX GMT/g;
 101         s/\bsmartlink_\d+\b/smartlink_XX/g;
 102         s/\bsmartlink_skip_\d+\b/smartlink_skip_XX/g;
 103         s/\bsmartlink_skipto_\d+\b/smartlink_skipto_XX/g;
 104         s/\bPerl v5\.\d+\b at [^\n<>]+/Perl v5.XXX at XXX./g;
 105         s/\btog_quote\(\d+\)/tog_quote(XX)/g;
 106         s/(generated by Pod::Simple::HTML) v[\d\.]+/$1 vX.XX/g;
 107         s/(using Pod::Simple::PullParser) v[\d\.]+/$1 vX.XX/g;
 108         s/\s+$/\n/gms;
 109         print $out $_;
 110     }
 111     close $out;
 112     close $in;
 113     #system("sudo cp $tmpfile $fname");
 114     copy $tmpfile, $fname;
 115     unlink $tmpfile;
 116 }
 117