languages/urm/lib/URM/Test.pm

   1 # $Id$
   2
   3 # Copyright (C) 2005-2007, The Perl Foundation.
   4
   5 package URM::Test;
   6
   7 use strict;
   8 use warnings;
   9 use vars qw(@EXPORT @ISA);
  10
  11 use Parrot::Config;
  12
  13 require Exporter;
  14 require Parrot::Test;
  15
  16 @EXPORT = ( qw(output_is output_like output_isnt), @Test::More::EXPORT );
  17 @ISA = qw(Exporter Test::More);
  18
  19 sub import {
  20     my ( $class, $plan, @args ) = @_;
  21
  22     Test::More->import( $plan, @args );
  23
  24     # __PACKAGE__->_export_to_level( 2, __PACKAGE__ );
  25     my $callpkg = caller(2);
  26     __PACKAGE__->export($callpkg);
  27 }
  28
  29 my $count;
  30
  31 foreach my $meth (qw(is isnt like)) {
  32     no strict 'refs';
  33
  34     *{"URM::Test::output_$meth"} = sub {
  35         my ( $lang_code, $output, $desc, @other ) = @_;
  36
  37         ++$count;
  38         my ( $lang_f, $pasm_f, $by_f, $out_f ) = map {    # JMG
  39             my $t = $0;
  40             $t =~ s/\.t$/_$count\.$_/;
  41             $t
  42         } (qw(urm pasm pbc out));    # JMG
  43
  44         # STDERR is written into same output file
  45         open LANG, ">", "$lang_f" or die "Unable to open '$lang_f'";    # JMG
  46         binmode LANG;                                                   # JMG
  47         print LANG $lang_code;                                          # JMG
  48         close LANG;                                                     # JMG
  49
  50         Parrot::Test::run_command(
  51             "$PConfig{perl} languages/urm/urmc -s languages/$lang_f",
  52             CD     => '..',                                             # $self->{relpath},
  53             STDOUT => $pasm_f,
  54             STDERR => $pasm_f,
  55         );
  56         Parrot::Test::run_command(
  57             "./parrot languages/$pasm_f @other",
  58             CD     => '..',                                             # $self->{relpath},
  59             STDOUT => $out_f,
  60             STDERR => $out_f,
  61         );
  62         my $prog_output = Parrot::Test::slurp_file("$out_f");
  63
  64         @_ = ( $prog_output, $output, $desc );
  65
  66         #goto &{"Test::More::$meth"};
  67         my $ok = &{"Test::More::$meth"}(@_);
  68
  69         # if( $ok ) { foreach my $meth ( $lang_f, $pasm_f, $by_f, $out_f ) { unlink $meth } } # JMG
  70         }
  71 }
  72
  73 1;
  74
  75 my $urmc    = "$PConfig{perl} $FindBin::RealBin$PConfig{slash}..$PConfig{slash}urmc";
  76 my $compile = "-c -s";
  77 my $run     = "-s";
  78
  79 sub compile_test {
  80     my $file = shift;
  81
  82     my $ret = system("$urmc $compile $FindBin::RealBin$PConfig{slash}$file");
  83     if ($ret) {
  84         print STDERR "TEST FAILED: $file ($ret)\n";
  85         return;
  86     }
  87     print "OK: $file\n";
  88 }
  89
  90 sub run_test {
  91     my ( $file, $expect ) = @_;
  92     my $ret = `$urmc $run $FindBin::RealBin$PConfig{slash}$file`;
  93     if ( !$ret ) {
  94         print STDERR "TEST FAILED: $file didn't return a value, Parrot crashed?\n";
  95         return;
  96     }
  97     if ( $ret != $expect ) {
  98         print STDERR "TEST FAILED: $file (got $ret expected $expect)\n";
  99         return;
 100     }
 101     print "OK: $file\n";
 102 }
 103
 104 # Local Variables:
 105 #   mode: cperl
 106 #   cperl-indent-level: 4
 107 #   fill-column: 100
 108 # End:
 109 # vim: expandtab shiftwidth=4: