perl-compiler/t/testcore.pl

# -*- cperl -*-
# t/testcore.t - run the core testsuite with the compilers C, CC and ByteCode
# Usage:
#   t/testcore.t -fail             known failing tests only
#   t/testcore.t -c                run C compiler tests only (also -bc or -cc)
#   t/testcore.t t/CORE/op/goto.t  run this test only
#
# Prereq:
# Copy your matching CORE t dirs into t/CORE.
# For now we test qw(base comp lib op run)
# Then fixup the @INC setters, and various require ./test.pl calls.
#
#   perl -pi -e 's/^(\s*\@INC = )/# $1/' t/CORE/*/*.t
#   perl -pi -e "s|^(\s*)chdir 't' if -d|\$1chdir 't/CORE' if -d|" t/CORE/*/*.t
#   perl -pi -e "s|require './|use lib "CORE"; require '|" `grep -l "require './" t/CORE/*/*.t`
#
# See TESTS for recent results


use Cwd;
use File::Copy;

BEGIN {
  unless (-d "t/CORE" or $ENV{NO_AUTHOR}) {
    print "1..0 #skip t/CORE missing. Read t/testcore.t how to setup.\n";
    exit 0;
  }
  unshift @INC, ("t");
}

require "test.pl";

sub vcmd {
  my $cmd = join "", @_;
  print "#",$cmd,"\n";
  run_cmd($cmd, 120); # timeout 2min
}

my $dir = getcwd();

#unlink ("t/perl", "t/CORE/perl", "t/CORE/test.pl", "t/CORE/harness");
#symlink "t/perl", $^X;
#symlink "t/CORE/perl", $^X;
#symlink "t/CORE/test.pl", "t/test.pl" unless -e "t/CORE/test.pl";
#symlink "t/CORE/harness", "t/test.pl" unless -e "t/CORE/harness";
`ln -sf $^X t/perl`;
`ln -sf $^X t/CORE/perl`;
# CORE t/test.pl would be better, but this fails only on 2 tests
-e "t/CORE/test.pl" or `ln -s $dir/t/test.pl t/CORE/test.pl`;
-e "t/CORE/harness" or `ln -s test.pl t/CORE/harness`; # better than nothing
#`ln -s $dir/t/test.pl harness`; # base/term
#`ln -s $dir/t/test.pl TEST`;    # cmd/mod 8

my %ALLOW_PERL_OPTIONS;
for (qw(
        comp/cpp.t
        run/runenv.t
       )) {
  $ALLOW_PERL_OPTIONS{"t/CORE/$_"} = 1;
}
my $SKIP = { "CC" =>
             { "t/CORE/op/bop.t" => "hangs",
               "t/CORE/op/die.t" => "hangs",
             }
           };

my @fail = map { "t/CORE/$_" }
  qw{
     base/rs.t
     base/term.t
     cmd/for.t
     cmd/subval.t
     cmd/while.t
     comp/colon.t
     comp/hints.t
     comp/multiline.t
     comp/packagev.t
     comp/parser.t
     comp/require.t
     comp/retainedlines.t
     comp/script.t
     comp/uproto.t
     comp/use.t
     io/argv.t
     io/binmode.t
     io/crlf.t
     io/crlf_through.t
     io/errno.t
     io/fflush.t
     io/fs.t
     io/inplace.t
     io/iprefix.t
     io/layers.t
     io/nargv.t
     io/open.t
     io/openpid.t
     io/perlio.t
     io/perlio_fail.t
     io/perlio_leaks.t
     io/perlio_open.t
     io/pipe.t
     io/print.t
     io/pvbm.t
     io/read.t
     io/say.t
     io/tell.t
     io/through.t
     io/utf8.t
     op/anonsub.t
     op/array.t
     op/attrs.t
     op/avhv.t
     op/bop.t
     op/chop.t
     op/closure.t
     op/concat.t
     op/defins.t
     op/do.t
     op/eval.t
     op/filetest.t
     op/flip.t
     op/fork.t
     op/goto.t
     op/goto_xs.t
     op/grent.t
     op/gv.t
     op/hashwarn.t
     op/index.t
     op/join.t
     op/length.t
     op/local.t
     op/lfs.t
     op/magic.t
     op/method.t
     op/misc.t
     op/mkdir.t
     op/my_stash.t
     op/numconvert.t
     op/pwent.t
     op/regmesg.t
     op/runlevel.t
     op/sort.t
     op/split.t
     op/sprintf.t
     op/stat.t
     op/study.t
     op/subst.t
     op/substr.t
     op/tie.t
     op/tr.t
     op/universal.t
     op/utf8decode.t
     op/vec.t
     op/ver.t
     uni/cache.t
     uni/chomp.t
     uni/chr.t
     uni/class.t
     uni/fold.t
     uni/greek.t
     uni/latin2.t
     uni/lex_utf8.t
     uni/lower.t
     uni/sprintf.t
     uni/tie.t
     uni/title.t
     uni/tr_7jis.t
     uni/tr_eucjp.t
     uni/tr_sjis.t
     uni/tr_utf8.t
     uni/upper.t
     uni/write.t
   };

my @tests = $ARGV[0] eq '-fail'
  ? @fail
  : ((@ARGV and $ARGV[0] !~ /^-/)
     ? @ARGV
     : <t/CORE/*/*.t>);
shift if $ARGV[0] eq '-fail';
my $Mblib = $^O eq 'MSWin32' ? '-Iblib\arch -Iblib\lib' : "-Iblib/arch -Iblib/lib";

sub run_c {
  my ($t, $backend) = @_;
  chdir $dir;
  my $result = $t; $result =~ s/\.t$/-c.result/;
  $result =~ s/-c.result$/-cc.result/ if $backend eq 'CC';
  my $a = $result; $a =~ s/\.result$//;
  unlink ($a, "$a.c", "t/$a.c", "t/CORE/$a.c", $result);
  # perlcc 2.06 should now work also: omit unneeded B::Stash -u<> and fixed linking
  # see t/c_argv.t
  my $backopts = $backend eq 'C' ? "-qq,C,-O3" : "-qq,CC";
  $backopts .= ",-fno-warnings" if $backend =~ /^C/ and $] >= 5.013005;
  $backopts .= ",-fno-fold"     if $backend =~ /^C/ and $] >= 5.013009;
  vcmd "$^X $Mblib -MO=$backopts,-o$a.c $t";
  # CORE often does BEGIN chdir "t", patched to chdir "t/CORE"
  chdir $dir;
  move ("t/$a.c", "$a.c") if -e "t/$a.c";
  move ("t/CORE/$a.c", "$a.c") if -e "t/CORE/$a.c";
  my $d = "";
  $d = "-DALLOW_PERL_OPTIONS" if $ALLOW_PERL_OPTIONS{$t};
  vcmd "$^X $Mblib script/cc_harness -q $d $a.c -o $a" if -e "$a.c";
  vcmd "./$a | tee $result" if -e "$a";
  prove ($a, $result, $i, $t, $backend);
  $i++;
}

sub prove {
  my ($a, $result, $i, $t, $backend) = @_;
  if ( -e "$a" and -s $result) {
    system(qq[prove -Q --exec cat $result || echo -n "n";echo "ok $i - $backend $t"]);
  } else {
    print "not ok $i - $backend $t\n";
  }
}

my @runtests = qw(C CC BC);
if ($ARGV[0] and $ARGV[0] =~ /^-(c|cc|bc)$/i) {
  @runtests = ( uc(substr($ARGV[0],1) ) );
}
my $numtests = scalar @tests * scalar @runtests;
my %runtests = map {$_ => 1} @runtests;

print "1..", $numtests, "\n";
my $i = 1;

for my $t (@tests) {
 C:
  if ($runtests{C}) {
    (print "ok $i #skip $SKIP->{C}->{$t}\n" and goto CC)
      if exists $SKIP->{C}->{$t};
    run_c($t, "C");
    }

 CC:
  if ($runtests{CC}) {
    (print "ok $i #skip $SKIP->{CC}->{$t}\n" and goto BC)
      if exists $SKIP->{CC}->{$t};
    run_c($t, "CC");
  }

 BC:
  if ($runtests{BC}) {
    (print "ok $i #skip $SKIP->{BC}->{$t}\n" and next)
      if exists $SKIP->{BC}->{$t};

    my $backend = 'Bytecode';
    chdir $dir;
    $result = $t; $result =~ s/\.t$/-bc.result/;
    unlink ("b.plc", "t/b.plc", "t/CORE/b.plc", $result);
    vcmd "$^X $Mblib -MO=-qq,Bytecode,-H,-s,-ob.plc $t";
    chdir $dir;
    move ("t/b.plc", "b.plc") if -e "t/b.plc";
    move ("t/CORE/b.plc", "b.plc") if -e "t/CORE/b.plc";
    vcmd "$^X $Mblib b.plc > $result" if -e "b.plc";
    prove ("b.plc", $result, $i, $t, $backend);
    $i++;
  }
}

END {
  unlink ( "t/perl", "t/CORE/perl", "harness", "TEST" );
  unlink ("a","a.c","t/a.c","t/CORE/a.c","aa.c","aa","t/aa.c","t/CORE/aa.c","b.plc");
}