Add basic WriteTestVariants.pm and use it to simplify the two tumbler…

….pl's

sandbox/jens/tumbler.pl

@@ -18,7 +18,7 @@
 use FindBin qw();
 
 use Context;
-use Data::Tumbler;
+use WriteTestVariants;
 
 $| = 1;
 my $input_dir  = "in";
@@ -27,18 +27,18 @@
 rename $output_dir, $output_dir.'-'.time
     if -d $output_dir;
 
-my $tumbler = Data::Tumbler->new(
-    consumer => \&write_test_file,
-    add_context => sub {
-        my ($context, $item) = @_;
-        return $context->new($context, $item);
-    },
-);
 
 my %tc_classes = ( MXCT => 1 );
 my $plug_dir = Cwd::abs_path( File::Spec->catdir( $FindBin::RealBin, "plug" ) );
 
-sub get_test_cases
+
+# XXX this WriteTestVariants subclass is a temporary hack till WriteTestVariants
+# gains some kind of plugin mechanism, or at least the hooks for one.
+{
+    package My::WriteTestVariants;
+    use parent 'WriteTestVariants';
+
+sub get_input_tests
 {
     my ($template_dir) = @_;
     my %templates;
@@ -73,66 +73,23 @@ sub get_test_cases
     return \%templates;
 }
 
-sub write_test_file {
-    my ($path, $context, $leaf) = @_;
-
-    my $dirpath = join "/", $output_dir, @$path;
-
-    my $pre  = $context->pre_code;
-    my $post = $context->post_code;
-
-    for my $testname (sort keys %$leaf) {
-        my $testinfo = $leaf->{$testname};
-
-        $testname .= ".t" unless $testname =~ m/\.t$/;
-        mkfilepath("$dirpath/$testname");
-
-        warn "Write $dirpath/$testname\n";
-        open my $fh, ">", "$dirpath/$testname";
-        print $fh qq{#!perl\n};
-        print $fh qq{use lib "lib";\n};
-        print $fh $pre;
-        print $fh "require '$testinfo->{require}';\n"
-            if $testinfo->{require};
-        print $fh "$testinfo->{code}\n"
-            if $testinfo->{code};
-        if ($testinfo->{module}) {
-            print $fh "use lib '$testinfo->{lib}';\n" if $testinfo->{lib};
-            print $fh "require $testinfo->{module};\n";
-            print $fh "$testinfo->{module}->run_tests;\n";
-        }
-        print $fh $post;
-        close $fh;
-    }
 }
 
-my $providers = [ 
+my $test_writer = My::WriteTestVariants->new();
+
+$test_writer->write_test_variants(
+    $input_dir,
+    $output_dir,
+    [ 
         \&oo_implementations,
         \&moox_cooperations,
-    ];
-my $test_cases = get_test_cases($input_dir);
-
-$tumbler->tumble(
-    # providers
-    $providers,
-
-    # path
-    [],
-    # context
-    Context->new,
-    # payload
-    $test_cases,
+    ],
 );
 
 
+
 exit 0;
 
-sub mkfilepath
-{
-    my ($name) = @_;
-    my $dirpath = dirname($name);
-    mkpath($dirpath, 0) unless -d $dirpath;
-}
 
 sub oo_implementations
 {
@@ -161,8 +118,9 @@ sub moox_cooperations
 	$settings{mxo} = Context->new( Context->new_module_use('MooX::Options'), $use_lib_setting);
 	$tc_classes{MXCOT} = 1;
     };
+    warn $@ if $@;
     use DDP;
-    p(%tc_classes);
+    #p(%tc_classes);
 
     return %settings;
 }

sandbox/tim/in/DBIT_dbh_ro/SelectMultiThread.pm

@@ -7,6 +7,8 @@ use Test::More;
 use base 'DBITestCaseBase';
 
 
+my $threads = 4;
+
 sub setup {
 
     plan skip_all => "threads not supported"
@@ -18,6 +20,9 @@ sub setup {
     require DBI;
 
     shift->SUPER::setup(@_);
+
+    # use an explicit plan here as protection against thread-induced strangeness
+    plan tests => 4 + 6 * $threads;
 }
 
 
@@ -29,10 +34,6 @@ sub get_subtest_method_names {
 sub test_with_threads {
     my ($test) = @_;
 
-    # use an explicit plan here as protection against thread-induced strangeness
-    my $threads = 4;
-    plan tests => 4 + 6 * $threads;
-
     # alter a DBI global - we'll check it has the same value in threads
     $DBI::neat_maxlen = 12345;
     cmp_ok($DBI::neat_maxlen, '==', 12345, '... assignment of neat_maxlen was successful');
@@ -45,9 +46,10 @@ sub test_with_threads {
 
     # start multiple threads, each running the test subroutine 
     my @thr;
-    push @thr, threads->create( sub { _test_a_thread($test) } )
-            or die "thread->create failed ($!)"
-        foreach (1..$threads);
+    foreach (1..$threads) {
+        push @thr, threads->create( sub { _test_a_thread($test) } )
+            or die "thread->create failed ($!)";
+    }
 
     # join all the threads
     foreach my $thread (@thr) {

sandbox/tim/lib/WriteTestVariants.pm

@@ -0,0 +1,154 @@
+package WriteTestVariants;
+
+use strict;
+use warnings;
+use autodie;
+
+use File::Find;
+use File::Path;
+use File::Basename;
+use Carp qw(croak);
+
+use lib 'lib';
+
+use Context;
+use Data::Tumbler;
+
+use Class::Tiny {
+    initial_path => sub {
+        return []
+    },
+    initial_context => sub {
+        use Context;
+        return Context->new
+    },
+    add_context => sub {
+        return sub {
+            my ($context, $item) = @_;
+            return $context->new($context, $item);
+        }
+    },
+};
+
+
+sub write_test_variants {
+    my ($self, $input_dir, $output_dir, $providers) = @_;
+
+    croak "output_test_dir $output_dir already exists"
+        if -d $output_dir;
+
+    my $input_tests = $self->get_input_tests($input_dir);
+
+    my $tumbler = Data::Tumbler->new(
+        consumer => sub {
+            my ($path, $context, $payload) = @_;
+            # payload is a clone of input_tests possibly modified by providers
+            $self->write_test_file($path, $context, $payload, $output_dir);
+        },
+        add_context => $self->add_context,
+    );
+
+    $tumbler->tumble(
+        $providers,
+        $self->initial_path,
+        $self->initial_context,
+        $input_tests, # payload
+    );
+
+    die "No tests written to $output_dir!\n"
+        unless -d $output_dir;
+
+    return;
+}
+
+
+
+# ------
+
+
+sub get_input_tests {
+    my ($self, $template_dir) = @_;
+
+    my %input_tests;
+    my $wanted = sub {
+        return unless m/\.pm$/;
+
+        my $name = $File::Find::name;
+        $name =~ s!\Q$template_dir\E/!!;    # remove prefix to just get relative path
+        $name =~ s!\.pm$!!;                 # remove the .pm suffix
+        (my $module_name = $name) =~ s!/!::!g; # convert to module name
+
+        $input_tests{ $name } = {             # use relative path as key
+            lib => $template_dir,
+            module => $module_name,
+        };
+    };
+    find($wanted, $template_dir);
+
+    return \%input_tests;
+}
+
+
+
+sub write_test_file {
+    my ($self, $path, $context, $input_tests, $output_dir) = @_;
+
+    my $dirpath = join "/", $output_dir, @$path;
+
+    for my $testname (sort keys %$input_tests) {
+        my $testinfo = $input_tests->{$testname};
+
+        $testname .= ".t" unless $testname =~ m/\.t$/;
+        warn "Writing $dirpath/$testname\n";
+
+        my $test_script = $self->get_test_file_body($context, $testinfo);
+
+        mkfilepath("$dirpath/$testname");
+        open my $fh, ">", "$dirpath/$testname";
+        print $fh $test_script;
+        close $fh;
+    }
+
+    return;
+}
+
+
+sub get_test_file_body {
+    my ($self, $context, $testinfo) = @_;
+
+    my $pre  = $context->pre_code;
+    my $post = $context->post_code;
+
+    my @body;
+    push @body, qq{#!perl\n};
+    push @body, qq{use lib "lib";\n}; # XXX remove
+
+    push @body, $pre;
+
+    push @body, "require '$testinfo->{require}';\n"
+        if $testinfo->{require};
+
+    if (my $module = $testinfo->{module}) {
+        push @body, "use lib '$testinfo->{lib}';\n"
+            if $testinfo->{lib};
+        push @body, "require $module;\n";
+        push @body, "$module->run_tests;\n";
+    }
+
+    push @body, "$testinfo->{code}\n"
+        if $testinfo->{code};
+
+    push @body, $post;
+
+    return join "", @body;
+}
+
+
+sub mkfilepath {
+    my ($name) = @_;
+    my $dirpath = dirname($name);
+    mkpath($dirpath, 0) unless -d $dirpath;
+}
+
+
+1;