This should enable writing tests which call parrot C functions directly, which could be useful for increasing coverage to things which aren't easy to call via opcodes.
-- Josh Wilmes ([EMAIL PROTECTED]) | http://www.hitchhiker.org Index: Makefile.in =================================================================== RCS file: /cvs/public/parrot/Makefile.in,v retrieving revision 1.141 diff -u -r1.141 Makefile.in --- Makefile.in 21 Mar 2002 23:47:22 -0000 1.141 +++ Makefile.in 29 Mar 2002 05:29:24 -0000 @@ -388,7 +388,7 @@ # ############################################################################### -test: $(TEST_PROG) assemble.pl .test_dummy +test: $(TEST_PROG) libparrot.a assemble.pl .test_dummy .test_dummy: $(PERL) t/harness Index: lib/Parrot/Test.pm =================================================================== RCS file: /cvs/public/parrot/lib/Parrot/Test.pm,v retrieving revision 1.19 diff -u -r1.19 Test.pm --- lib/Parrot/Test.pm 21 Mar 2002 23:47:25 -0000 1.19 +++ lib/Parrot/Test.pm 29 Mar 2002 05:29:25 -0000 @@ -11,7 +11,8 @@ require Test::Builder; my $Builder = Test::Builder->new; -@EXPORT = ( qw(output_is output_like output_isnt) ); +@EXPORT = ( qw(output_is output_like output_isnt), + qw(c_output_is c_output_like c_output_isnt) ); @ISA = qw(Exporter); sub import { @@ -102,6 +103,55 @@ unless($ENV{POSTMORTEM}) { unlink $out_f; + } + + return $pass; + } +} + + + +my %C_Test_Map = ( c_output_is => 'is_eq', + c_output_isnt => 'isnt_eq', + c_output_like => 'like' + ); + +foreach my $func ( keys %C_Test_Map ) { + no strict 'refs'; + + *{'Parrot::Test::'.$func} = sub ($$;$) { + ++$count; + my( $source, $output, $desc ) = @_; + $output =~ s/\cM\cJ/\n/g; + local( *SOURCE ); + my( $source_f, $obj_f, $exe_f, $out_f ) = map { + my $t = $0; $t =~ s/\.t$/$count$_/; $t + } ('.c', $PConfig{o}, $PConfig{exe}, '.out'); + + open SOURCE, "> $source_f" or die "Unable to open '$source_f'"; + binmode SOURCE; + print SOURCE $source; + close SOURCE; + + _run_command("$PConfig{cc} $PConfig{ccflags} -I./include -c +$PConfig{ld_out}$obj_f $source_f"); + _run_command("$PConfig{ld} $PConfig{ldflags} $obj_f $PConfig{cc_exe_out}$exe_f +$PConfig{libs} -L. -lparrot"); + + _run_command("./$exe_f", 'STDOUT' => $out_f, 'STDERR' => $out_f); + + my $prog_output; + open OUTPUT, "< $out_f"; + { + local $/ = undef; + $prog_output = <OUTPUT> . ''; + $prog_output =~ s/\cM\cJ/\n/g; + } + close OUTPUT; + + my $meth = $C_Test_Map{$func}; + my $pass = $Builder->$meth( $prog_output, $output, $desc ); + + unless($ENV{POSTMORTEM}) { + unlink $source_f, $obj_f, $exe_f, $out_f; } return $pass; Index: t/harness =================================================================== RCS file: /cvs/public/parrot/t/harness,v retrieving revision 1.10 diff -u -r1.10 harness --- t/harness 21 Mar 2002 23:47:37 -0000 1.10 +++ t/harness 29 Mar 2002 05:29:25 -0000 @@ -18,5 +18,5 @@ @ARGV = grep $_ ne 'quick', @ARGV; # Pass in a list of tests to run on the command line, else run all the tests. -my @tests = @ARGV ? @ARGV : map { glob( "t/$_/*.t" ) } ( qw(op pmc) ); +my @tests = @ARGV ? @ARGV : map { glob( "t/$_/*.t" ) } ( qw(op pmc src) ); runtests(@tests); --- /dev/null Wed Feb 27 00:25:17 2002 +++ t/src/basic.t Fri Mar 29 00:28:14 2002 @@ -0,0 +1,26 @@ +#! perl -w + +use Parrot::Test tests => 2; + +c_output_is(<<'CODE', <<'OUTPUT', "hello world"); + #include <stdio.h> + + int main(int argc, char* argv[]) { + printf("Hello, World!\n"); + } +CODE +Hello, World! +OUTPUT + +c_output_is(<<'CODE', <<'OUTPUT', "direct internal_exception call"); + #include <parrot/parrot.h> + #include <parrot/exceptions.h> + + int main(int argc, char* argv[]) { + internal_exception(0, "Blow'd Up(tm)\n"); + } +CODE +Blow'd Up(tm) +OUTPUT + +1;
