Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
executable file 110 lines (101 sloc) 2.46 KB
#!/usr/bin/env perl
use Term::ANSIColor qw(:constants);
use STD;
use utf8;
use YAML::XS;
use Encode;
use strict;
use feature 'say';
my $fail = 0;
my @files = sort `find ../roast/ -name '*.t'`;
chomp(@files);
$| = 1;
our $foo = 2;
our %foo = (a=>7);
{ package foo;
our $foo = 1;
}
{ package foo::bar;
our $bar = 1;
our %foo = (a=>6,b=>4);
our %bar = (A=>6,B=>4);
}
{ package foo::bar::baz;
our $baz = 1;
}
sub traverse {
my $package = shift;
my $callback = shift;
for (sort keys %{$package}) {
next if /^main::$/;
if (/::$/) {
next if /^Config/;
next if /^DB/;
next if /^utf8/;
#say "descending into $_";
traverse($package->{$_},$callback);
#say "ascending";
} elsif ($package->{$_} =~ /^\*/) {
#say "callback on $_:",$package->{$_},;
$callback->($package->{$_});
}
}
}
traverse(\%main::,sub {
my $sym=shift;
});
my %pristine;
use Data::Dumper;
traverse(\%main::,sub {
my $sym=shift;
$pristine{'$'.$sym} = Dumper(*{$sym}{SCALAR});
$pristine{'%'.$sym} = Dumper(*{$sym}{HASH});
$pristine{'@'.$sym} = Dumper(*{$sym}{ARRAY});
});
#warn Dumper(\%pristine);
my $dump_limit = 100;
sub part {
return $_[0] if length $_[0] < $dump_limit+3;
return substr($_[0],0,$dump_limit)."...";
}
sub check {
my ($name,$what_raw) = @_;
my $what = Dumper($what_raw);
if (!$what_raw || (ref $what_raw eq 'SCALAR' && !${$what_raw})) {
next unless $pristine{$name};
#say RED,"undefined $name\n",RESET;
}
say YELLOW,$name,RESET,":",RED," ",part($what),RESET," ne ",GREEN,part($pristine{$name}),RESET unless $pristine{$name} eq $what;
}
sub globals {
traverse(\%main::,sub {
my $sym=shift;
check(('%'.$sym),*{$sym}{HASH});
#check(('@'.$sym),*{$sym}{HASH});
check(('$'.$sym),*{$sym}{SCALAR});
});
}
#$foo::bar::foo{asadas} = 123;
#globals;
my $total = 0+@files;
for my $file (@files) {
$::HIGHWATER = 0;
%{$::HIGHEXPECT} = ();
%CursorBase::lexers = ();
globals;
print $file, "...";
#system "./tryfile $file >tryfile.out";
eval {
my $what = 'comp_unit';
my $text = Encode::decode('utf8', `cat $file`);
my $r = Perl->new($text)->$what();
};
if ($@) {
$fail++;
die if $fail > 1;
warn;
} else {
print "ok\n";
}
}
print "Failed $fail/$total, ", int $fail/$total * 100, "%\n";