[svn:parrot] r9866 - in trunk: lib/Parrot t/examples

Wed, 09 Nov 2005 11:45:12 -0800 

Author: bernhard
Date: Wed Nov  9 11:44:52 2005
New Revision: 9866

Modified:
   trunk/lib/Parrot/Test.pm
   trunk/t/examples/pasm.t
   trunk/t/examples/past.t
   trunk/t/examples/pir.t
Log:
Teach Parrot::Test::language_output_\w+ about PIR, PAST and PASM.
Add Parrot::Test::example_output_is() that calls language_output_is().


Modified: trunk/lib/Parrot/Test.pm
==============================================================================
--- trunk/lib/Parrot/Test.pm    (original)
+++ trunk/lib/Parrot/Test.pm    Wed Nov  9 11:44:52 2005
@@ -26,6 +26,7 @@ This module provides various Parrot-spec
 
 =head2 Functions
 
+The parameter C<$language> is the language of the code.
 The parameter C<$code> is the code that should be executed or transformed.
 The parameter C<$expected> is the expected result.
 The parameter C<$unexpected> is the unexpected result.
@@ -40,6 +41,26 @@ C<unimplemented>, and so on.
 
 =over 4
 
+=item C<language_output_is( $language, $code, $expected, $description)> 
+
+Runs a langugage test and passes the test if a string comparison
+of the output with the expected result it true.
+
+=item C<language_output_like( $language, $code, $expected, $description)> 
+
+Runs a langugage test and passes the test
+if the  output matches the expected result.
+
+=item C<language_output_isnt( $language, $code, $expected, $description)> 
+
+Runs a langugage test and passes the test if a string comparison
+if a string comparison of the output with the unexpected result is false.
+
+=item C<pasm_output_isnt($code, $unexpected, $description)> or 
C<output_isnt($code, $unexpected, $description)>
+
+Runs the Parrot Assembler code and passes the test
+if a string comparison of the output with the unexpected result is false.
+
 =item C<pasm_output_is($code, $expected, $description)> or C<output_is($code, 
$expected, $description)>
 
 Runs the Parrot Assembler code and passes the test if a string comparison
@@ -130,6 +151,11 @@ expected result.
 Compiles and runs the C code, passing the test if a string comparison of
 output with the unexpected result is false.
 
+=item C<example_output_is( $example_fn, $expected )
+
+Determine the language from the extension of C<$example_fn> and
+runs language_output_is().
+
 =item C<skip($why, $how_many)>
 
 Use within a C<SKIP: { ... }> block to indicate why and how many test
@@ -173,14 +199,16 @@ require Test::Builder;
 require Test::More;
 
 
[EMAIL PROTECTED] = qw( output_is          output_like          output_isnt
[EMAIL PROTECTED] = qw( 
+              language_output_is language_output_like language_output_isnt
+              example_output_is
+              output_is          output_like          output_isnt
               pasm_output_is     pasm_output_like     pasm_output_isnt
               past_output_is     past_output_like     past_output_isnt
               pir_output_is      pir_output_like      pir_output_isnt
               pir_2_pasm_is      pir_2_pasm_like      pir_2_pasm_isnt
               pbc_output_is      pbc_output_like      pbc_output_isnt
               c_output_is        c_output_like        c_output_isnt
-              language_output_is language_output_like language_output_isnt
               plan
               skip
               slurp_file
@@ -468,39 +496,54 @@ sub _generate_functions {
         }
     }
 
+    my %builtin_language_prefix = (
+        IMC   => 'pir',
+        PASM  => 'pasm',
+        PAST  => 'past',
+        PIR   => 'pir',
+                                  );
+
     my %language_test_map = (
         language_output_is   => 'output_is',
         language_output_like => 'output_like',
         language_output_isnt => 'output_isnt',
-                             );
+                            );
 
     foreach my $func ( keys %language_test_map ) {
         no strict 'refs';
 
         *{$package.'::'.$func} = sub ($$$;$) {
-            # TODO: $language should be the name of the test Module
-            #       that would open the door for Scheme::Test
-            my $language = $_[0];
-            $language = ucfirst($language) unless ( $language eq 'm4' );
-
-            # make sure TODO will work, by telling Test::Builder which package
-            # the .t file is in (one more than usual, due to the extra layer
-            # of package indirection
-            my $level = $builder->level();
-            $builder->level(2);
-
-            # get modified parrot command.
-            require "Parrot/Test/$language.pm";
-            # set the builder object, and parrot config.
-            my $obj = eval "Parrot::Test::${language}->new()";
-            $obj->{builder} = $builder;
-            $obj->{relpath} = $path_to_parrot;
-            $obj->{parrot}  = $parrot;
+            my ( $language, @remaining ) = @_;
+
             my $meth = $language_test_map{$func};
-            $obj->$meth(@_[1..$#_]);
+            if ( my $prefix = $builtin_language_prefix{$language} ) { 
+                my $test_func = "${package}::${prefix}_${meth}";
+                &$test_func( @remaining );
+            }
+            else {
+                # TODO: $language should be the name of the test Module
+                #       that would open the door for Scheme::Test
+                # try it both ways
+                $language = ucfirst($language) unless ( $language eq 'm4' );
+
+                # make sure TODO will work, by telling Test::Builder which 
package
+                # the .t file is in (one more than usual, due to the extra 
layer
+                # of package indirection
+                my $level = $builder->level();
+                $builder->level(2);
+
+                # get modified parrot command.
+                require "Parrot/Test/$language.pm";
+                # set the builder object, and parrot config.
+                my $obj = eval "Parrot::Test::${language}->new()";
+                $obj->{builder} = $builder;
+                $obj->{relpath} = $path_to_parrot;
+                $obj->{parrot}  = $parrot;
+                $obj->$meth(@remaining);
 
-            # restore prior level, just in case.
-            $builder->level($level);
+                # restore prior level, just in case.
+                $builder->level($level);
+            }
         }
     }
 
@@ -607,6 +650,28 @@ sub _generate_functions {
     }
 }
 
+sub example_output_is {
+    my ($example_fn, $expected) = @_;
+
+    my %lang_for_extension 
+        = ( pasm => 'PASM',
+            past => 'PAST',
+            pir  => 'PIR',
+            imc  => 'PIR', );
+
+    my ( $extension ) = $example_fn =~ m{ [.]                         # 
introducing extension
+                                          ( pasm | pir | imc | past ) # match 
and capture the extension
+                                          \z                          # at end 
of string
+                                        }ixms or Usage();
+    if ( defined $extension ) { 
+        my $code = slurp_file($example_fn);
+        language_output_is( $lang_for_extension{$extension}, $code, $expected, 
$example_fn );
+    }
+    else {
+      fail( defined $extension, "no extension recognized for $example_fn" );
+    }
+}
+
 Parrot::Test::_generate_functions(__PACKAGE__, \&generate_code );
 
 =head1 TODO

Modified: trunk/t/examples/pasm.t
==============================================================================
--- trunk/t/examples/pasm.t     (original)
+++ trunk/t/examples/pasm.t     Wed Nov  9 11:44:52 2005
@@ -28,10 +28,10 @@ F<t/examples/pir.t>
 
 use strict;
 use Parrot::Test tests => 6;
-use Test::More;
 
 # Set up expected output for examples
-my %expected = (
+my %expected
+  = (
 
     'fact.pasm'        =>  << 'END_EXPECTED',
 fact of 0 is: 1
@@ -101,25 +101,8 @@ Close inner
 Close top
 END_EXPECTED
 
-                          );
-
-# Do the testing
-my %test_func = ( pasm => \&pasm_output_is,
-                  pir  => \&pir_output_is,
-                  imc  => \&pir_output_is );
+    );
 
 while ( my ( $example, $expected ) = each %expected ) {
-    my $code_fn   = "examples/pasm/$example";
-    my $code = Parrot::Test::slurp_file($code_fn);
-
-    my ( $extension ) = $example =~ m{ [.]                  # introducing 
extension
-                                       ( pasm | pir | imc ) # match and 
capture the extension
-                                       \z                   # at end of string
-                                     }ixms or Usage();
-    if ( defined $extension ) { 
-      $test_func{$extension}->($code, $expected, $code_fn);
-    }
-    else {
-      ok( defined $extension, "no extension recognized for $code_fn" );
-    }
+    example_output_is( "examples/pasm/$example", $expected );
 }

Modified: trunk/t/examples/past.t
==============================================================================
--- trunk/t/examples/past.t     (original)
+++ trunk/t/examples/past.t     Wed Nov  9 11:44:52 2005
@@ -32,36 +32,15 @@ Bernhard Schmalhofer - <Bernhard.Schmalh
 
 use strict;
 use Parrot::Test tests => 1;
-use Test::More;
-use Parrot::Config;
-
-my $PARROT = ".$PConfig{slash}$PConfig{test_prog}";
 
 # Set up expected output for examples
-my %expected = (
+my %expected
+  = (
     'hello.past'        =>  << 'END_EXPECTED',
 Hello PAST
 END_EXPECTED
-                          );
-
-# Do the testing
-my %test_func = ( pasm => \&pasm_output_is,
-                  past => \&past_output_is,
-                  pir  => \&pir_output_is,
-                  imc  => \&pir_output_is );
+    );
 
 while ( my ( $example, $expected ) = each %expected ) {
-    my $code_fn   = "examples/past/$example";
-    my $code = Parrot::Test::slurp_file($code_fn);
-
-    my ( $extension ) = $example =~ m{ [.]                         # 
introducing extension
-                                       ( pasm | pir | imc | past ) # match and 
capture the extension
-                                       \z                          # at end of 
string
-                                     }ixms or Usage();
-    if ( defined $extension ) { 
-      $test_func{$extension}->($code, $expected, $code_fn);
-    }
-    else {
-      ok( defined $extension, "no extension recognized for $code_fn" );
-    }
+    example_output_is( "examples/past/$example", $expected );
 }

Modified: trunk/t/examples/pir.t
==============================================================================
--- trunk/t/examples/pir.t      (original)
+++ trunk/t/examples/pir.t      Wed Nov  9 11:44:52 2005
@@ -19,7 +19,6 @@ Test the examples in F<examples/pir>.
 =head1 TODO
 
 Check on remaining examples.
-Perhaps use Parrot::Test::run_command().
 
 =head1 SEE ALSO
 
@@ -36,10 +35,10 @@ use Parrot::Test tests => 11;
 use Test::More;
 use Parrot::Config;
 
-my $PARROT = ".$PConfig{slash}$PConfig{test_prog}";
 
 # Set up expected output for examples
-my %expected = (
+my %expected
+  = (
     'circle.pir'        =>  << 'END_EXPECTED',
 
********************************************************************************************************************************************************************************************************************************************************************************************************************************************************************************************************************
 END_EXPECTED
@@ -187,29 +186,14 @@ init ok
 +---------+---------+---------+
 solved
 END_EXPECTED
-                          );
-
-# Do the testing
-my %test_func = ( pasm => \&pasm_output_is,
-                  pir  => \&pir_output_is,
-                  imc  => \&pir_output_is );
+   );
 
 while ( my ( $example, $expected ) = each %expected ) {
-    my $code_fn   = "examples/pir/$example";
-    my $code = Parrot::Test::slurp_file($code_fn);
-
-    my ( $extension ) = $example =~ m{ [.]                  # introducing 
extension
-                                       ( pasm | pir | imc ) # match and 
capture the extension
-                                       \z                   # at end of string
-                                     }ixms or Usage();
-    if ( defined $extension ) { 
-      $test_func{$extension}->($code, $expected, $code_fn);
-    }
-    else {
-      ok( defined $extension, "no extension recognized for $code_fn" );
-    }
+    example_output_is( "examples/pir/$example", $expected );
 }
 
+my $PARROT = ".$PConfig{slash}$PConfig{test_prog}";
+
 # For testing life.pir, the number of generations should be small,
 # because users should not get bored.
 {

Reply via email to