Roll out own _output_is test functions, so we don't have to rely on p…

…arrot. git-svn-id: http://partcl.googlecode.com/svn/trunk@356 6cb8db7d-f34b-0410-8f57-4f83c6281724
partcl · May 21, 2009 · 5920afd · 5920afd
1 parent 0189840
commit 5920afd
Show file tree

Hide file tree

Showing 15 changed files with 301 additions and 355 deletions.
diff --git a/lib/Parrot/Test/Tcl.pm b/lib/Parrot/Test/Tcl.pm
@@ -1,124 +1,93 @@
-package Parrot::Test::Tcl;
-
-# Copyright (C) 2004-2007, The Perl Foundation.
+# Copyright (C) 2009, The Perl Foundation.
 # $Id: Tcl.pm 29434 2008-07-14 15:42:24Z coke $
 
+package Parrot::Test::Tcl;
+
 use strict;
 use warnings;
-use vars qw($language);
-no strict qw(refs);
+our $VERSION = '1.0';
 
-use File::Basename;
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(tcl_output_is pir_output_is);
 
-require Parrot::Test;
+use File::Temp qw(tempfile);
+use Test::More;
+use Parrot::Installed;
+use Parrot::Config;
 
-=head1 Parrot::Test::Tcl
-
-Provide language specific testing routines here...
-
-This is currently alarmingly similar to the generated subs in Parrot::Test.
-Perhaps someone can do a better job of delegation here.
-
-=cut
-
-sub new {
-    return bless {};
+sub tcl_output_is {
+    _output_is( 'tcl', 'tcl.pbc', @_);
 }
 
-my %language_test_map = (
-    output_is   => 'is_eq',
-    output_like => 'like',
-    output_isnt => 'isnt_eq'
-);
-
-foreach my $func ( keys %language_test_map ) {
-
-    *{"Parrot::Test::Tcl::$func"} = sub ($$;$) {
-
-        my ( $self, $code, $output, $desc ) = @_;
-
-        my $count = $self->{builder}->current_test + 1;
-
-        $desc = $language unless $desc;
-
-        # Figure out how many levels we have to go back to get to parrot.
-        # And, conversely, how many levels we have to go down to get to
-        # the tcl binary.
-
-        # There are basically 3 choices: run in one of:
-        #  languages
-        #  languages/tcl
-        #  languages/tcl/t
+sub pir_output_is {
+    _output_is( 'pir', '', @_);
+}
 
-        my $path_to_parrot = $INC{'Parrot/Config.pm'};
-        $path_to_parrot =~ s:/lib/Parrot/Config.pm$::;
-        my $dir_count = scalar( File::Spec->splitdir($path_to_parrot) );
-        my $path_to_tcl;
-        if ( $dir_count == 0 ) {
-            $path_to_tcl = File::Spec->join( 'languages', 'tcl' );
-        }
-        elsif ( $dir_count == 1 ) {
-            $path_to_tcl = 'tcl';
-        }
-        elsif ( $dir_count == 2 ) {
-            $path_to_tcl = '.';
+sub _output_is {
+    my $type        = shift;
+    my $parrot_args = shift;
+    my $code        = shift;
+    my $expected    = shift;
+    my $description = shift;
+    my %options     = @_;
+
+    # Generate a temp file for the code.
+    my ($code_fh,$code_tempfile) = tempfile(
+        SUFFIX => ".$type",
+        UNLINK => 1
+    );
+    print {$code_fh} $code;
+    close $code_fh;
+
+    # Generate a temp file for the code.
+    my (undef, $out_tempfile) = tempfile(
+        SUFFIX => '.out',
+        UNLINK => 1
+    );
+    close $code_fh;
+
+    my $cmd = $PConfig{bindir} ."/parrot $parrot_args $code_tempfile > $out_tempfile";
+
+    TODO: {
+
+        local $TODO = $options{todo} if exists $options{todo};
+
+        if (system($cmd) != 0) {
+            fail("$description\n$cmd");
+            return;
+        } 
+
+        my $actual;
+        {
+            local undef $/;
+            open my $out_fh, '<', $out_tempfile;
+            $actual = <$out_fh>;
         }
-        elsif ( $dir_count > 2 ) {
-            $path_to_tcl = File::Spec->join( File::Spec->updir() x ( $dir_count - 2 ) );
-        }
-
-        my $lang_f = Parrot::Test::per_test( '.tcl', $count );
-        my $out_f  = Parrot::Test::per_test( '.out', $count );
+
+        is ($actual, $expected, $description);
 
-        my $args = $ENV{TEST_PROG_ARGS} || '';
+    }
 
-        Parrot::Test::write_code_to_file( $code, $lang_f );
-
-        my $cmd;
-        my $exit_code = 0;
-        my $pass      = 0;
-
-        my $executable =
-            File::Spec->join( $path_to_parrot, $self->{parrot} )
-            . " $args "
-            . File::Spec->join( $path_to_tcl, 'tcl.pbc' );
-        if ( defined( $ENV{PARROT_TCLSH} ) ) {
-            $executable = $ENV{PARROT_TCLSH};
-        }
-        $cmd = "$executable $lang_f";
+    return;
+}
 
-        $exit_code = Parrot::Test::run_command(
-            $cmd,
-            STDOUT => $out_f,
-            STDERR => $out_f,
+1;
 
-            #CD => $self->{relpath},
-        );
+__END__
 
-        unless ($pass) {
-            my $file         = Parrot::Test::slurp_file($out_f);
-            my $builder_func = $language_test_map{$func};
+=head1 Parrot::Test::Tcl
 
-            {
-                no strict 'refs';
+Test tcl code from perl.
 
-                $pass =
-                    $self->{builder}
-                    ->$builder_func( Parrot::Test::slurp_file($out_f), $output, $desc );
-            }
-            $self->{builder}->diag("'$cmd' failed with exit code $exit_code")
-                if $exit_code and not $pass;
-        }
+Until we can self-host all of testing, we have a need for some of our 
+egression tests to run in perl.
 
-        unless ( $ENV{POSTMORTEM} ) {
-            unlink $out_f;
-        }
+=head1 BUGS
 
-        return $pass;
-        }
-}
+We used to rely on parrot's testing infrastructure and may again.
 
-1;
+=cut
 
 # Local Variables:
 #   mode: cperl

diff --git a/t/cmd_cd.t b/t/cmd_cd.t
@@ -7,14 +7,13 @@ use strict;
 use warnings;
 use lib qw(lib);
 
-use Parrot::Installed;
-use Parrot::Test tests => 3;
-use Test::More;
+use Parrot::Test::Tcl;
+use Test::More tests=>3;
 use File::Temp qw(tempdir);
 use File::Spec;
 use Cwd qw(abs_path);
 
-language_output_is( "tcl", <<'TCL', <<OUT, "cd too many args" );
+tcl_output_is( <<'TCL', <<OUT, "cd too many args" );
  cd a b
 TCL
 wrong # args: should be "cd ?dirName?"
@@ -23,23 +22,20 @@ OUT
 ## tclsh on windows shows unix slashies, so use unix canonpath to get them
 my $homedir = File::Spec::Unix->canonpath( $ENV{HOME} );
 
-TODO: {
-    local $TODO;
-    $TODO = 'pwd is broken on windows' if $^O eq 'MSWin32';
+my $todo = 'pwd is broken on windows' if $^O eq 'MSWin32';
 
-    language_output_is( "tcl", <<'TCL', <<"OUT", "cd home" );
+tcl_output_is( <<'TCL', <<"OUT", "cd home", todo => $todo );
  cd
  puts [pwd]
 TCL
 $homedir
 OUT
-}
 
 {
     my $testdir = tempdir( CLEANUP => 1 );
     my $expdir = File::Spec->canonpath( abs_path($testdir) );
     $^O eq 'MSWin32' and $testdir =~ s/\\/\\\\/g;
-    language_output_is( "tcl", <<"TCL", <<"OUT", "cd home" );
+    tcl_output_is( <<"TCL", <<"OUT", "cd home" );
  cd $testdir
  puts [pwd]
 TCL

diff --git a/t/cmd_exit.t b/t/cmd_exit.t
@@ -7,25 +7,24 @@ use strict;
 use warnings;
 use lib qw(lib);
 
-use Parrot::Installed;
-use Parrot::Test tests => 3;
-use Test::More;
+use Parrot::Test::Tcl;
+use Test::More tests => 3;
 
-language_output_is( "tcl", <<'TCL', <<OUT, "noarg" );
+tcl_output_is( <<'TCL', <<OUT, "noarg" );
  puts here
  exit
  puts nothere
 TCL
 here
 OUT
 
-language_output_is( "tcl", <<'TCL', <<OUT, "bad arg" );
+tcl_output_is( <<'TCL', <<OUT, "bad arg" );
  exit bork
 TCL
 expected integer but got "bork"
 OUT
 
-language_output_is( "tcl", <<'TCL', <<OUT, "too many args" );
+tcl_output_is( <<'TCL', <<OUT, "too many args" );
  exit bork me
 TCL
 wrong # args: should be "exit ?returnCode?"