languages/tcl/lib/Parrot/Test/Tcl.pm

   1 package Parrot::Test::Tcl;
   2
   3 # Copyright (C) 2004-2007, The Perl Foundation.
   4 # $Id$
   5
   6 use strict;
   7 use warnings;
   8 use vars qw($language);
   9 no strict qw(refs);
  10
  11 use File::Basename;
  12
  13 require Parrot::Test;
  14
  15 =head1 Parrot::Test::Tcl
  16
  17 Provide language specific testing routines here...
  18
  19 This is currently alarmingly similar to the generated subs in Parrot::Test.
  20 Perhaps someone can do a better job of delegation here.
  21
  22 =cut
  23
  24 sub new {
  25     return bless {};
  26 }
  27
  28 my %language_test_map = (
  29     output_is   => 'is_eq',
  30     output_like => 'like',
  31     output_isnt => 'isnt_eq'
  32 );
  33
  34 foreach my $func ( keys %language_test_map ) {
  35
  36     *{"Parrot::Test::Tcl::$func"} = sub ($$;$) {
  37
  38         my ( $self, $code, $output, $desc ) = @_;
  39
  40         my $count = $self->{builder}->current_test + 1;
  41
  42         $desc = $language unless $desc;
  43
  44         # Figure out how many levels we have to go back to get to parrot.
  45         # And, conversely, how many levels we have to go down to get to
  46         # the tcl binary.
  47
  48         # There are basically 3 choices: run in one of:
  49         #  languages
  50         #  languages/tcl
  51         #  languages/tcl/t
  52
  53         my $path_to_parrot = $INC{'Parrot/Config.pm'};
  54         $path_to_parrot =~ s:/lib/Parrot/Config.pm$::;
  55         my $dir_count = scalar( File::Spec->splitdir($path_to_parrot) );
  56         my $path_to_tcl;
  57         if ( $dir_count == 0 ) {
  58             $path_to_tcl = File::Spec->join( 'languages', 'tcl' );
  59         }
  60         elsif ( $dir_count == 1 ) {
  61             $path_to_tcl = 'tcl';
  62         }
  63         elsif ( $dir_count == 2 ) {
  64             $path_to_tcl = '.';
  65         }
  66         elsif ( $dir_count > 2 ) {
  67             $path_to_tcl = File::Spec->join( File::Spec->updir() x ( $dir_count - 2 ) );
  68         }
  69
  70         my $lang_f = Parrot::Test::per_test( '.tcl', $count );
  71         my $out_f  = Parrot::Test::per_test( '.out', $count );
  72
  73         my $args = $ENV{TEST_PROG_ARGS} || '';
  74
  75         Parrot::Test::write_code_to_file( $code, $lang_f );
  76
  77         my $cmd;
  78         my $exit_code = 0;
  79         my $pass      = 0;
  80
  81         my $executable =
  82             File::Spec->join( $path_to_parrot, $self->{parrot} )
  83             . " $args "
  84             . File::Spec->join( $path_to_tcl, 'tcl.pbc' );
  85         if ( defined( $ENV{PARROT_TCLSH} ) ) {
  86             $executable = $ENV{PARROT_TCLSH};
  87         }
  88         $cmd = "$executable $lang_f";
  89
  90         $exit_code = Parrot::Test::run_command(
  91             $cmd,
  92             STDOUT => $out_f,
  93             STDERR => $out_f,
  94
  95             #CD => $self->{relpath},
  96         );
  97
  98         unless ($pass) {
  99             my $file         = Parrot::Test::slurp_file($out_f);
 100             my $builder_func = $language_test_map{$func};
 101
 102             {
 103                 no strict 'refs';
 104
 105                 $pass =
 106                     $self->{builder}
 107                     ->$builder_func( Parrot::Test::slurp_file($out_f), $output, $desc );
 108             }
 109             $self->{builder}->diag("'$cmd' failed with exit code $exit_code")
 110                 if $exit_code and not $pass;
 111         }
 112
 113         unless ( $ENV{POSTMORTEM} ) {
 114             unlink $out_f;
 115         }
 116
 117         return $pass;
 118         }
 119 }
 120
 121 1;
 122
 123 # Local Variables:
 124 #   mode: cperl
 125 #   cperl-indent-level: 4
 126 #   fill-column: 100
 127 # End:
 128 # vim: expandtab shiftwidth=4: