Author: bernhard
Date: Mon May 2 15:31:55 2005
New Revision: 7955
Modified:
trunk/config/gen/makefiles/scheme.in
trunk/languages/m4/t/harness
trunk/languages/scheme/Scheme/Test.pm
trunk/languages/scheme/schemec
trunk/languages/scheme/t/harness
trunk/lib/Parrot/Test.pm
trunk/lib/Parrot/Test/m4.pm
Log:
Prepare 'scheme' for unified languages testing.
Use more functionality from Parrot::Test.
Parrot::Test::language_output_is() is not used yet.
Modified: trunk/config/gen/makefiles/scheme.in
==============================================================================
--- trunk/config/gen/makefiles/scheme.in (original)
+++ trunk/config/gen/makefiles/scheme.in Mon May 2 15:31:55 2005
@@ -70,7 +70,7 @@
@$(MAKE) all
test:
- $(PERL) t/harness
+ cd .. && $(PERL) scheme/t/harness
# cd $(TOOL_DIR); $(INTERP) $(DIR)/test.pbc
# cd $(TOOL_DIR); $(INTERP) $(DIR)/and.pbc
# cd $(TOOL_DIR); $(INTERP) $(DIR)/foo.pbc
Modified: trunk/languages/m4/t/harness
==============================================================================
--- trunk/languages/m4/t/harness (original)
+++ trunk/languages/m4/t/harness Mon May 2 15:31:55 2005
@@ -16,56 +16,47 @@
=head1 DESCRIPTION
-Conformant to a recent post on p6i, if I'm called with a single
+If I'm called with a single
argument of "-files", I just return a list of files to process.
This list is one per line, and is relative to the languages dir.
-If I'm called with no args, I run all tests.
+If I'm called with no args, I run the complete suite.
-Otherwise I try to run the list of passed tests.
+Otherwise I run the tests that were passed on the command line.
=cut
# pragmata
use strict;
+use lib '..';
use Cwd();
-use Data::Dumper;
use File::Spec;
use Test::Harness();
my $language = 'm4';
-if ( grep { m/^-files$/ } @ARGV )
-{
- # Only the Makefile in 'parrot/languages' uses -file
- my $dir = File::Spec->catfile( $language, 't' );
- my @files = glob( File::Spec->catfile( $dir, '*/*.t' ) );
- print join( "\n", @files );
- print "\n" if scalar(@files);
-}
-else
-{
- my @files;
- if ( scalar(@ARGV) )
- {
- # Someone specified tests for me to run.
- @files = grep { -f $_ } @ARGV
- }
- else
- {
- ( undef, undef, my $current_dir ) = File::Spec->splitpath( Cwd::getcwd() );
- if ( $current_dir eq 'languages' )
- {
- @files = glob( File::Spec->catfile( $language, 't', '*', '*.t' ) );
- }
- elsif ( $current_dir eq $language )
- {
- @files = glob( File::Spec->catfile( 't', '*', '*.t' ) );
+if ( grep { m/^-files$/ } @ARGV ) {
+ # Only the Makefile in 'parrot/languages' uses -file
+ my $dir = File::Spec->catfile( $language, 't' );
+ my @files = glob( File::Spec->catfile( $dir, '*/*.t' ) );
+ print join( "\n", @files );
+ print "\n" if scalar(@files);
+} else {
+ my @files;
+ if ( scalar(@ARGV) ) {
+ # Someone specified tests for me to run.
+ @files = grep { -f $_ } @ARGV
+ } else {
+ ( undef, undef, my $current_dir ) = File::Spec->splitpath(
Cwd::getcwd() );
+ if ( $current_dir eq 'languages' ) {
+ @files = glob( File::Spec->catfile( $language, 't', '*', '*.t' ) );
+ }
+ elsif ( $current_dir eq $language ) {
+ @files = glob( File::Spec->catfile( 't', '*', '*.t' ) );
+ }
}
- }
- # die Dumper( [EMAIL PROTECTED] );
- Test::Harness::runtests( @files ) if scalar( @files );
+ Test::Harness::runtests( @files ) if scalar( @files );
}
=head1 HISTORY
@@ -78,6 +69,6 @@
=head1 AUTHOR
- [EMAIL PROTECTED]
+Bernhard Schmalhofer - <[EMAIL PROTECTED]>
=cut
Modified: trunk/languages/scheme/Scheme/Test.pm
==============================================================================
--- trunk/languages/scheme/Scheme/Test.pm (original)
+++ trunk/languages/scheme/Scheme/Test.pm Mon May 2 15:31:55 2005
@@ -1,81 +1,62 @@
-#
+# $Id$
package Scheme::Test;
use strict;
use vars qw(@EXPORT @ISA);
-use lib '../../lib';
+use lib '../lib';
use Parrot::Config;
require Exporter;
-require Test::More;
+require Parrot::Test;
@EXPORT = ( qw(output_is output_like output_isnt), @Test::More::EXPORT );
@ISA = qw(Exporter Test::More);
sub import {
- my( $class, $plan, @args ) = @_;
+ my( $class, $plan, @args ) = @_;
- Test::More->import( $plan, @args );
+ Test::More->import( $plan, @args );
- __PACKAGE__->_export_to_level( 2, __PACKAGE__ );
-}
-
-# this kludge is an hopefully portable way of having
-# redirections ( tested on Linux and Win2k )
-sub _run_command {
- my( $command, %redir ) = @_;
- my( $redir_string ) = '';
-
- while( my @dup = each %redir ) {
- my( $from, $to ) = @dup;
- if( $to eq 'STDERR' ) { $to = "qq{>&STDERR}" }
- elsif( $to eq 'STDOUT' ) { $to = "qq{>&STDOUT}" }
- elsif( $to eq '/dev/null' ) { $to = ( $^O eq 'MSWin32' ) ?
- 'qq{> NUL:}' : "qq{> $to}" }
- else { $to = "qq{> $to}" }
-
- $redir_string .= "open $from, $to;"
- }
-
- system "$^X -e \"$redir_string;system q{$command};\"";
+ __PACKAGE__->_export_to_level( 2, __PACKAGE__ );
}
my $count;
foreach my $i ( qw(is isnt like) ) {
- no strict 'refs';
+ no strict 'refs';
- *{"Scheme::Test::output_$i"} = sub ($$;$) {
- ++$count;
- my( $assembly, $output, $desc ) = @_;
- local( *SCHEME, *OUTPUT ); # JMG
- my( $scheme_f, $as_f, $by_f, $out_f ) = map { # JMG
- my $t = $0; $t =~ s/\.t$/$count\.$_/; $t
- } ( qw(scheme pasm pbc out) ); # JMG
-
- open SCHEME, "> $scheme_f" or die "Unable to open '$scheme_f'"; # JMG
- binmode SCHEME; # JMG
- print SCHEME $assembly; # JMG
- close SCHEME; # JMG
-
- _run_command("$PConfig{perl} schemec $scheme_f >$as_f"); # JMG
- my $parrot = "../../parrot";
- _run_command( "${parrot} $as_f", 'STDOUT' => $out_f, 'STDERR' => $out_f);
-
- my $prog_output;
- open OUTPUT, "< $out_f";
- {
- local $/ = undef;
- $prog_output = <OUTPUT>;
- }
- close OUTPUT;
+ *{"Scheme::Test::output_$i"} = sub ($$;$) {
+ my( $assembly, $output, $desc ) = @_;
- @_ = ( $prog_output, $output, $desc );
- #goto &{"Test::More::$i"};
- my $ok = &{"Test::More::$i"}( @_ );
- # if( $ok ) { foreach my $i ( $scheme_f, $as_f, $by_f, $out_f ) { unlink
$i } } # JMG
- }
+ ++$count;
+ my( $scheme_f, $as_f, $by_f, $out_f ) = map { # JMG
+ my $t = $0; $t =~ s/\.t$/$count\.$_/; $t
+ } ( qw(scheme pasm pbc out) ); # JMG
+
+ # STDERR is written into same output file
+ open SCHEME, "> $scheme_f" or die "Unable to open '$scheme_f'"; # JMG
+ binmode SCHEME; # JMG
+ print SCHEME $assembly; # JMG
+ close SCHEME; # JMG
+
+ Parrot::Test::run_command(
+ "$PConfig{perl} languages/scheme/schemec languages/$scheme_f",
+ CD => '..', # $self->{relpath},
+ STDOUT => $as_f, STDERR => $as_f,
+ );
+ Parrot::Test::run_command(
+ "./parrot languages/$as_f",
+ CD => '..', # $self->{relpath},
+ STDOUT => $out_f, STDERR => $out_f,
+ );
+ my $prog_output = Parrot::Test::slurp_file( "$out_f" );
+
+ @_ = ( $prog_output, $output, $desc );
+ #goto &{"Test::More::$i"};
+ my $ok = &{"Test::More::$i"}( @_ );
+ # if( $ok ) { foreach my $i ( $scheme_f, $as_f, $by_f, $out_f ) {
unlink $i } } # JMG
+ }
}
1;
Modified: trunk/languages/scheme/schemec
==============================================================================
--- trunk/languages/scheme/schemec (original)
+++ trunk/languages/scheme/schemec Mon May 2 15:31:55 2005
@@ -2,7 +2,7 @@
# $Id$
use strict;
-use lib '.';
+use lib 'languages/scheme';
use Scheme;
sub Usage {
Modified: trunk/languages/scheme/t/harness
==============================================================================
--- trunk/languages/scheme/t/harness (original)
+++ trunk/languages/scheme/t/harness Mon May 2 15:31:55 2005
@@ -1,9 +1,20 @@
#! perl -w
+# $Id$
=head1 NAME
scheme/t/harness - a harness for scheme
+=head1 SYNOPSIS
+
+ cd languages && perl -I../lib scheme/t/harness -files
+
+ cd languages && perl -I../lib scheme/t/harness
+
+ cd languages && perl -I../lib scheme/t/harness \
+ scheme/t/logic/basic.t \
+ scheme/t/logic/defines.t
+
=head1 DESCRIPTION
If I'm called with a single
@@ -17,27 +28,39 @@
=cut
use strict;
-use lib '../..';
+use lib '../lib', 'scheme';
+use Cwd();
use File::Spec;
-use Test::Harness qw(runtests);
+use Test::Harness();
-my $language = "scheme";
+my $language = 'scheme';
-my @files = map { glob( File::Spec->catfile( 't', $_, '*.t' ) ) } qw(io arith
logic);
-if ( grep { /^-files$/ } @ARGV ) {
- # I must be running out of languages/
- my $dir = File::Spec->catfile( $language, "t" );
- print join("\n", @files);
- print "\n" if @files;
- exit;
-} elsif (@ARGV) {
- # Someone specified tests for me to run.
- @files = grep {-f $_} @ARGV
-} else {
- # I must be running out of languages/$language
+if ( grep { m/^-files$/ } @ARGV ) {
+ # Only the Makefile in 'parrot/languages' uses -file
+ my $dir = File::Spec->catfile( $language, 't' );
+ my @files = glob( File::Spec->catfile( $dir, '*/*.t' ) );
+ print join( "\n", @files );
+ print "\n" if scalar(@files);
+} else {
+ my @files;
+ if ( scalar(@ARGV) ) {
+ # Someone specified tests for me to run.
+ @files = grep { -f $_ } @ARGV
+ } else {
+ ( undef, undef, my $current_dir ) = File::Spec->splitpath(
Cwd::getcwd() );
+ if ( $current_dir eq 'languages' ) {
+ @files = glob( File::Spec->catfile( $language, 't', '*', '*.t' ) );
+ }
+ elsif ( $current_dir eq $language ) {
+ @files = glob( File::Spec->catfile( 't', '*', '*.t' ) );
+ }
+ }
+ Test::Harness::runtests( @files ) if scalar( @files );
}
+=head1 SEE ALSO
+
+ L<languages/m4/t/harness>
-exit unless scalar( @files );
-runtests(@files);
+=cut
Modified: trunk/lib/Parrot/Test.pm
==============================================================================
--- trunk/lib/Parrot/Test.pm (original)
+++ trunk/lib/Parrot/Test.pm Mon May 2 15:31:55 2005
@@ -216,8 +216,8 @@
open OLDOUT, ">&STDOUT" or die "Can't save stdout" if $out;
open OLDERR, ">&STDERR" or die "Can't save stderr" if $err;
- open STDOUT, ">$out" or die "Can't redirect stdout" if $out;
- open STDERR, ">$err" or die "Can't redirect stderr" if $err;
+ open STDOUT, ">$out" or die "Can't redirect stdout to $out" if $out;
+ open STDERR, ">$err" or die "Can't redirect stderr to $err" if $err;
$command = "$ENV{VALGRIND} $command" if defined $ENV{VALGRIND};
Modified: trunk/lib/Parrot/Test/m4.pm
==============================================================================
--- trunk/lib/Parrot/Test/m4.pm (original)
+++ trunk/lib/Parrot/Test/m4.pm Mon May 2 15:31:55 2005
@@ -24,9 +24,8 @@
=cut
-sub new
-{
- return bless {};
+sub new {
+ return bless {};
}
@@ -36,53 +35,52 @@
=cut
-sub output_is
-{
- my $self = shift;
- my ( $code, $output, $desc ) = @_;
+sub output_is {
+ my $self = shift;
+ my ( $code, $output, $desc ) = @_;
- my $count = $self->{builder}->current_test + 1;
+ my $count = $self->{builder}->current_test + 1;
- # flatten filenames (don't use directories)
- my $lang_f = Parrot::Test::per_test( '.m4', $count );
- my $parrot_m4_out_f = Parrot::Test::per_test( '.parrot_out', $count );
- my $gnu_m4_out_f = Parrot::Test::per_test( '.gnu_out', $count );
-
- my $test_prog_args = $ENV{TEST_PROG_ARGS} || '';
- my $parrot_m4 = "$self->{parrot} languages/m4/m4.pbc ${test_prog_args}
languages/${lang_f}";
- my $gnu_m4 = "m4 ${test_prog_args} languages/${lang_f}";
-
- # This does nor create byte code, but m4 code
- my $parrotdir = dirname( $self->{parrot} );
- Parrot::Test::generate_code( $code, $parrotdir, $count, $lang_f );
-
- # STDERR is written into same output file
- my $parrot_exit_code = Parrot::Test::run_command(
- $parrot_m4,
- CD => $self->{relpath},
- STDOUT => $parrot_m4_out_f, STDERR => $parrot_m4_out_f
- );
- my $gnu_exit_code = Parrot::Test::run_command(
- $gnu_m4,
- CD => $self->{relpath},
- STDOUT => $gnu_m4_out_f, STDERR => $gnu_m4_out_f
- );
+ # flatten filenames (don't use directories)
+ my $lang_f = Parrot::Test::per_test( '.m4', $count );
+ my $parrot_m4_out_f = Parrot::Test::per_test( '.parrot_out', $count );
+ my $gnu_m4_out_f = Parrot::Test::per_test( '.gnu_out', $count );
+
+ my $test_prog_args = $ENV{TEST_PROG_ARGS} || '';
+ my $parrot_m4 = "$self->{parrot} languages/m4/m4.pbc
${test_prog_args} languages/${lang_f}";
+ my $gnu_m4 = "m4 ${test_prog_args} languages/${lang_f}";
+
+ # This does nor create byte code, but m4 code
+ my $parrotdir = dirname( $self->{parrot} );
+ Parrot::Test::generate_code( $code, $parrotdir, $count, $lang_f );
+
+ # STDERR is written into same output file
+ my $parrot_exit_code = Parrot::Test::run_command(
+ $parrot_m4,
+ CD => $self->{relpath},
+ STDOUT => $parrot_m4_out_f, STDERR => $parrot_m4_out_f
+ );
+ my $gnu_exit_code = Parrot::Test::run_command(
+ $gnu_m4,
+ CD => $self->{relpath},
+ STDOUT => $gnu_m4_out_f, STDERR => $gnu_m4_out_f
+ );
- my $pass = $self->{builder}->is_eq(
Parrot::Test::slurp_file($parrot_m4_out_f) .
Parrot::Test::slurp_file($gnu_m4_out_f),
- $output . $output,
- $desc );
- unless ( $pass )
- {
- my $diag = '';
- $diag .= "'$parrot_m4' failed with exit code $parrot_exit_code." if
$parrot_exit_code;
- $diag .= "'$gnu_m4' failed with exit code $gnu_exit_code.";
- $self->{builder}->diag( $diag ) if $diag;
- }
+ my $pass = $self->{builder}->is_eq(
Parrot::Test::slurp_file($parrot_m4_out_f) .
Parrot::Test::slurp_file($gnu_m4_out_f),
+ $output . $output,
+ $desc );
+ unless ( $pass )
+ {
+ my $diag = '';
+ $diag .= "'$parrot_m4' failed with exit code $parrot_exit_code." if
$parrot_exit_code;
+ $diag .= "'$gnu_m4' failed with exit code $gnu_exit_code.";
+ $self->{builder}->diag( $diag ) if $diag;
+ }
- # The generated files are left in the t/* directories.
- # Let 'make clean' and '.cvsignore' take care of them.
+ # The generated files are left in the t/* directories.
+ # Let 'make clean' and '.cvsignore' take care of them.
- return $pass;
+ return $pass;
}
1;
