File Coverage

blib/lib/Test/WriteVariants.pm
Criterion Covered Total %
statement 155 184 84.2
branch 32 68 47.0
condition 11 28 39.2
subroutine 27 32 84.3
pod 13 13 100.0
total 238 325 73.2


line stmt bran cond sub pod time code
1             package Test::WriteVariants;
2              
3             =head1 NAME
4              
5             Test::WriteVariants - Dynamic generation of tests in nested combinations of contexts
6              
7             =head1 SYNOPSIS
8              
9             use Test::WriteVariants;
10              
11             my $test_writer = Test::WriteVariants->new();
12              
13             $test_writer->write_test_variants(
14              
15             # tests we want to run in various contexts
16             input_tests => {
17             'core/10-foo' => { require => 't/core/10-foo.t' },
18             'core/20-bar' => { require => 't/core/20-bar.t' },
19             },
20              
21             # one or more providers of variant contexts
22             variant_providers => [
23             sub {
24             my ($path, $context, $tests) = @_;
25             my %variants = (
26             plain => $context->new_env_var(MY_MODULE_PUREPERL => 0),
27             pureperl => $context->new_env_var(MY_MODULE_PUREPERL => 1),
28             );
29             return %variants;
30             },
31             sub {
32             my ($path, $context, $tests) = @_;
33             my %variants = map {
34             $_ => $context->new_env_var(MY_MODULE_WIBBLE => $_),
35             } 1..3;
36             delete $variants{3} if $context->get_env_var("MY_MODULE_PUREPERL");
37             return %variants;
38             },
39             ],
40              
41             # where to generate the .t files that wrap the input_tests
42             output_dir => 't/variants',
43             );
44              
45             When run that generates the desired test variants:
46              
47             Writing t/variants/plain/1/core/10-foo.t
48             Writing t/variants/plain/1/core/20-bar.t
49             Writing t/variants/plain/2/core/10-foo.t
50             Writing t/variants/plain/2/core/20-bar.t
51             Writing t/variants/plain/3/core/10-foo.t
52             Writing t/variants/plain/3/core/20-bar.t
53             Writing t/variants/pureperl/1/core/10-foo.t
54             Writing t/variants/pureperl/1/core/20-bar.t
55             Writing t/variants/pureperl/2/core/10-foo.t
56             Writing t/variants/pureperl/2/core/20-bar.t
57              
58             Here's what t/variants/pureperl/2/core/20-bar.t looks like:
59              
60             #!perl
61             $ENV{MY_MODULE_WIBBLE} = 2;
62             END { delete $ENV{MY_MODULE_WIBBLE} } # for VMS
63             $ENV{MY_MODULE_PUREPERL} = 1;
64             END { delete $ENV{MY_MODULE_PUREPERL} } # for VMS
65             require 't/core/20-bar.t';
66              
67              
68             Here's an example that uses plugins to provide the tests and the variants:
69              
70             my $test_writer = Test::WriteVariants->new();
71              
72             # gather set of input tests that we want to run in various contexts
73             # these can come from various sources, including modules and test files
74             my $input_tests = $test_writer->find_input_test_modules(
75             search_path => [ 'DBI::TestCase' ]
76             );
77              
78             $test_writer->write_test_variants(
79              
80             # tests we want to run in various contexts
81             input_tests => $input_tests,
82              
83             # one or more providers of variant contexts
84             # (these can be code refs or plugin namespaces)
85             variant_providers => [
86             "DBI::Test::VariantDBI",
87             "DBI::Test::VariantDriver",
88             "DBI::Test::VariantDBD",
89             ],
90              
91             # where to generate the .t files that wrap the input_tests
92             output_dir => $output_dir,
93             );
94              
95             =head1 DESCRIPTION
96              
97             Test::WriteVariants is a utility to create variants of a common test.
98              
99             Given the situation - like in L where some tests are the same for
100             L and it's drop-in replacement L.
101             Or a distribution duo having a Pure-Perl and an XS variant - and the
102             same test shall be used to ensure XS and PP version are really drop-in
103             replacements for each other.
104              
105             =cut
106              
107 4     4   379640 use strict;
  4         12  
  4         114  
108 4     4   19 use warnings;
  4         6  
  4         116  
109              
110 4     4   17 use Carp qw(croak confess);
  4         8  
  4         231  
111 4     4   21 use Cwd ();
  4         16  
  4         73  
112 4     4   20 use File::Basename;
  4         6  
  4         230  
113 4     4   18 use File::Path;
  4         6  
  4         150  
114 4     4   19 use File::Spec;
  4         11  
  4         88  
115              
116 4     4   1106 use Module::Pluggable::Object;
  4         31353  
  4         159  
117 4     4   34 use Module::Runtime qw(require_module use_module);
  4         13  
  4         33  
118              
119 4     4   1652 use Test::WriteVariants::Context;
  4         12  
  4         147  
120 4     4   1070 use Data::Tumbler;
  4         15234  
  4         532  
121              
122             my $slurper;
123              
124             BEGIN
125             {
126 4   33 4   35 $slurper ||= eval { require_module("File::Slurper"); File::Slurper->can("read_binary"); };
  4         61  
  0         0  
127             $slurper ||= sub {
128 2         6 my $fn = shift;
129 2 50       65 open(my $fh, "<", $fn) or croak("Can't open '$fn': $!");
130             ## no critic (Variables::RequireInitializationForLocalVars)
131 2         13 local $/;
132 2         31 my $cnt = <$fh>;
133 2 50       18 close($fh) or croak("Can't close file-handle for '$fn': $!");
134 2         23 return $cnt;
135 4   50     8762 };
136             }
137              
138             our $VERSION = '0.014';
139              
140             =head1 METHODS
141              
142             =head2 new
143              
144             $test_writer = Test::WriteVariants->new(%attributes);
145              
146             Instanciates a Test::WriteVariants instance and sets the specified attributes, if any.
147              
148             =cut
149              
150             sub new
151             {
152 3     3 1 1938 my ($class, %args) = @_;
153              
154 3         11 my $self = bless {} => $class;
155              
156 3         12 for my $attribute (qw(allow_dir_overwrite allow_file_overwrite))
157             {
158 6 50       23 next unless exists $args{$attribute};
159 0         0 $self->$attribute(delete $args{$attribute});
160             }
161 3 50       9 confess "Unknown $class arguments: @{[ keys %args ]}"
  0         0  
162             if %args;
163              
164 3         11 return $self;
165             }
166              
167             =head2 allow_dir_overwrite
168              
169             $test_writer->allow_dir_overwrite($bool);
170             $bool = $test_writer->allow_dir_overwrite;
171              
172             If the output directory already exists when tumble() is called it'll
173             throw an exception (and warn if it wasn't created during the run).
174             Setting allow_dir_overwrite true disables this safety check.
175              
176             =cut
177              
178             sub allow_dir_overwrite
179             {
180 0     0 1 0 my $self = shift;
181 0 0       0 $self->{allow_dir_overwrite} = shift if @_;
182 0         0 return $self->{allow_dir_overwrite};
183             }
184              
185             =head2 allow_file_overwrite
186              
187             $test_writer->allow_file_overwrite($bool);
188             $bool = $test_writer->allow_file_overwrite;
189              
190             If the test file that's about to be written already exists
191             then write_output_files() will throw an exception.
192             Setting allow_file_overwrite true disables this safety check.
193              
194             =cut
195              
196             sub allow_file_overwrite
197             {
198 0     0 1 0 my $self = shift;
199 0 0       0 $self->{allow_file_overwrite} = shift if @_;
200 0         0 return $self->{allow_file_overwrite};
201             }
202              
203             =head2 write_test_variants
204              
205             $test_writer->write_test_variants(
206             input_tests => \%input_tests,
207             variant_providers => \@variant_providers,
208             output_dir => $output_dir,
209             );
210              
211             Instanciates a L. Sets its C to call:
212              
213             $self->write_output_files($path, $context, $payload, $output_dir)
214              
215             and sets its C to call:
216              
217             $context->new($context, $item);
218              
219             and then calls its C method:
220              
221             $tumbler->tumble(
222             $self->normalize_providers($variant_providers),
223             [],
224             Test::WriteVariants::Context->new(),
225             $input_tests,
226             );
227              
228             =cut
229              
230             sub write_test_variants
231             {
232 3     3 1 46 my ($self, %args) = @_;
233              
234             my $input_tests = delete $args{input_tests}
235 3 50       16 or croak "input_tests not specified";
236             my $variant_providers = delete $args{variant_providers}
237 3 50       12 or croak "variant_providers not specified";
238             my $output_dir = delete $args{output_dir}
239 3 50       11 or croak "output_dir not specified";
240 3 50       11 croak "write_test_variants: unknown arguments: @{[ keys %args ]}"
  0         0  
241             if keys %args;
242              
243 3 50 33     43 croak "write_test_variants: $output_dir already exists"
244             if -d $output_dir and not $self->allow_dir_overwrite;
245              
246             my $tumbler = Data::Tumbler->new(
247             consumer => sub {
248 8     8   87 my ($path, $context, $payload) = @_;
249             # payload is a clone of input_tests possibly modified by providers
250 8         24 $self->write_output_files($path, $context, $payload, $output_dir);
251             },
252             add_context => sub {
253 10     10   498 my ($context, $item) = @_;
254 10         31 return $context->new($context, $item);
255             },
256 3         46 );
257              
258 3         167 $tumbler->tumble(
259             $self->normalize_providers($variant_providers),
260             [],
261             Test::WriteVariants::Context->new(),
262             $input_tests, # payload
263             );
264              
265 3 0 33     62 warn "No tests written to $output_dir!\n"
266             if not -d $output_dir and not $self->allow_dir_overwrite;
267              
268 3         54 return;
269             }
270              
271             # ------
272              
273             # XXX also implement a find_input_test_files - that finds .t files
274              
275             =head2 find_input_test_modules
276              
277             $input_tests = $test_writer->find_input_test_modules(
278             search_path => ["Helper"],
279             search_dirs => "t/lib",
280             test_prefix => "Extra::Helper",
281             input_tests => $input_tests
282             );
283              
284             =cut
285              
286             sub find_input_test_modules
287             {
288 1     1 1 39 my ($self, %args) = @_;
289              
290             my $namespaces = delete $args{search_path}
291 1 50       5 or croak "search_path not specified";
292 1         3 my $search_dirs = delete $args{search_dirs};
293 1         2 my $test_prefix = delete $args{test_prefix};
294 1   50     5 my $input_tests = delete $args{input_tests} || {};
295 1 50       4 croak "find_input_test_modules: unknown arguments: @{[ keys %args ]}"
  0         0  
296             if keys %args;
297              
298 1         1 my $edit_test_name;
299 1 50       3 if (defined $test_prefix)
300             {
301 1         3 my $namespaces_regex = join "|", map { quotemeta($_) } @$namespaces;
  1         4  
302 1         15 my $namespaces_qr = qr/^($namespaces_regex)::/;
303 1     2   5 $edit_test_name = sub { s/$namespaces_qr/$test_prefix/ };
  2         11  
304             }
305              
306 1         7 my @test_case_modules = Module::Pluggable::Object->new(
307             require => 0,
308             search_path => $namespaces,
309             search_dirs => $search_dirs,
310             )->plugins;
311              
312 1         1136 for my $module_name (@test_case_modules)
313             {
314 2         6 $self->add_test_module($input_tests, $module_name, $edit_test_name);
315             }
316              
317 1         12 return $input_tests;
318             }
319              
320             =head2 find_input_test_files
321              
322             Not yet implemented - will file .t files.
323              
324             =cut
325              
326             =head2 find_input_inline_tests
327              
328             $input_tests = $test_writer->find_input_inline_tests(
329             search_patterns => ["*.it"],
330             search_dirs => "t/inl",
331             input_tests => $input_tests
332             );
333              
334             =cut
335              
336             sub find_input_inline_tests
337             {
338 1     1 1 56 my ($self, %args) = @_;
339              
340 1         3 my $search_patterns = delete $args{search_patterns};
341 1         4 my $search_dirs = delete $args{search_dirs};
342 1   50     11 my $input_tests = delete $args{input_tests} || {};
343 1 50       6 croak "find_input_test_modules: unknown arguments: @{[ keys %args ]}"
  0         0  
344             if keys %args;
345              
346 1         8 use_module("File::Find::Rule", "0.34");
347              
348 1   50     78 $search_patterns ||= ["*.it"];
349 1 50 33     8 $search_patterns = [$search_patterns] unless ref $search_patterns and "ARRAY" eq ref $search_patterns;
350 1 50 33     7 $search_dirs = [$search_dirs] unless ref $search_dirs and "ARRAY" eq ref $search_dirs;
351 1         4 $search_dirs = [map { Cwd::abs_path($_) } @$search_dirs];
  1         37  
352              
353 1         5 my $path_rx_str = join('|', map { "\Q$_\E" } @$search_dirs);
  1         7  
354              
355             my $edit_test_name = sub {
356 2     2   180 my ($name, $path, $suffix) = fileparse(Cwd::abs_path($_), qr/\.[^.]*/);
357 2         25 (undef, $path, undef) = File::Spec->splitpath($path, 1);
358 2         27 $path =~ s,^$path_rx_str/,,;
359 2         15 $_ = join("_", File::Spec->splitdir($path), $name);
360 1         7 };
361              
362 1         3 my @test_inlines = File::Find::Rule::find(file => canonpath => name => [@{$search_patterns}])->in(@{$search_dirs});
  1         7  
  1         395  
363              
364 1         954 for my $file_name (@test_inlines)
365             {
366 2         11 $self->add_test_inline($input_tests, $file_name, $edit_test_name);
367             }
368              
369 1         20 return $input_tests;
370             }
371              
372             =head2 add_test
373              
374             $test_writer->add_test(
375             $input_tests, # the \%input_tests to add the test module to
376             $test_name, # the key to use in \%input_tests
377             $test_spec # the details of the test file
378             );
379              
380             Adds the $test_spec to %$input_tests keys by $test_name. In other words:
381              
382             $input_tests->{ $test_name } = $test_spec;
383              
384             An exception will be thrown if a test with $test_name already exists
385             in %$input_tests.
386              
387             This is a low-level interface that's not usually called directly.
388             See L.
389              
390             =cut
391              
392             sub add_test
393             {
394 4     4 1 10 my ($self, $input_tests, $test_name, $test_spec) = @_;
395              
396             confess "Can't add test $test_name because a test with that name exists"
397 4 50       14 if $input_tests->{$test_name};
398              
399 4         11 $input_tests->{$test_name} = $test_spec;
400 4         9 return;
401             }
402              
403             =head2 add_test_module
404              
405             $test_writer->add_test_module(
406             $input_tests, # the \%input_tests to add the test module to
407             $module_name, # the package name of the test module
408             $edit_test_name # a code ref to edit the test module name in $_
409             );
410              
411             =cut
412              
413             sub add_test_module
414             {
415 2     2 1 9 my ($self, $input_tests, $module_name, $edit_test_name) = @_;
416              
417             # map module name, without the namespace prefix, to a dir path
418 2         3 local $_ = $module_name;
419 2 50       7 $edit_test_name->() if $edit_test_name;
420 2         5 s{[^\w:]+}{_}g;
421 2         3 s{::}{/}g;
422              
423 2         9 $self->add_test(
424             $input_tests,
425             $_,
426             {
427             class => $module_name,
428             method => 'run_tests',
429             }
430             );
431              
432 2         4 return;
433             }
434              
435             =head2 add_test_inline
436              
437             $test_writer->add_test_inline(
438             $input_tests, # the \%input_tests to add the test module to
439             $file_name, # the file name of the test code to inline
440             $edit_test_name # a code ref to edit the test file name in $_
441             );
442              
443             =cut
444              
445             sub add_test_inline
446             {
447 2     2 1 7 my ($self, $input_tests, $file_name, $edit_test_name) = @_;
448              
449             # map module name, without the namespace prefix, to a dir path
450 2         6 local $_ = $file_name;
451 2 50       12 $edit_test_name->() if $edit_test_name;
452              
453 2         10 $self->add_test(
454             $input_tests,
455             $_,
456             {
457             code => $slurper->($file_name),
458             }
459             );
460              
461 2         8 return;
462             }
463              
464             =head2 normalize_providers
465              
466             $providers = $test_writer->normalize_providers($providers);
467              
468             Given a reference to an array of providers, returns a reference to a new array.
469             Any code references in the original array are passed through unchanged.
470              
471             Any other value is treated as a package name and passed to
472             L as a namespace C to find plugins.
473             An exception is thrown if no plugins are found.
474              
475             The corresponding element of the original $providers array is replaced with a
476             new provider code reference which calls the C, C,
477             and C methods, if present, for each plugin namespace in turn.
478              
479             Normal L provider subroutines are called with these arguments:
480              
481             ($path, $context, $tests)
482              
483             and the return value is expected to be a hash. Whereas the plugin provider
484             methods are called with these arguments:
485              
486             ($test_writer, $path, $context, $tests, $variants)
487              
488             and the return value is ignored. The $variants argument is a reference to a
489             hash that will be returned to Data::Tumbler and which should be edited by the
490             plugin provider method. This allows a plugin to see, and change, the variants
491             requested by any other plugins that have already been run for this provider.
492              
493             =cut
494              
495             sub normalize_providers
496             {
497 3     3 1 9 my ($self, $input_providers) = @_;
498 3         11 my @providers = @$input_providers;
499              
500             # if a provider is a namespace name instead of a code ref
501             # then replace it with a code ref that uses Module::Pluggable
502             # to load and run the provider classes in that namespace
503              
504 3         9 for my $provider (@providers)
505             {
506 4 50       16 next if ref $provider eq 'CODE';
507              
508             my @test_variant_modules = Module::Pluggable::Object->new(
509             search_path => [$provider],
510             # for sanity:
511             require => 1,
512 0     0   0 on_require_error => sub { croak "@_" },
513 0     0   0 on_instantiate_error => sub { croak "@_" },
514 0         0 )->plugins;
515 0         0 @test_variant_modules = sort @test_variant_modules;
516              
517 0 0       0 croak "No variant providers found in $provider\:: namespace"
518             unless @test_variant_modules;
519              
520             ## no critic (ErrorHandling::RequireCarping,BuiltinFunctions::ProhibitComplexMappings)
521             warn sprintf "Variant providers in %s: %s\n", $provider, join(
522             ", ",
523             map {
524 0         0 (my $n = $_) =~ s/^${provider}:://;
  0         0  
525 0         0 $n
526             } @test_variant_modules
527             );
528              
529             $provider = sub {
530 0     0   0 my ($path, $context, $tests) = @_;
531              
532 0         0 my %variants;
533             # loop over several methods as a basic way of letting plugins
534             # hook in either early or late if they need to
535 0         0 for my $method (qw(provider_initial provider provider_final))
536             {
537 0         0 for my $test_variant_module (@test_variant_modules)
538             {
539 0 0       0 next unless $test_variant_module->can($method);
540             #warn "$test_variant_module $method...\n";
541 0         0 my $fqsn = "$test_variant_module\::$method";
542 0         0 $self->$fqsn($path, $context, $tests, \%variants);
543             #warn "$test_variant_module $method: @{[ keys %variants ]}\n";
544             }
545             }
546              
547 0         0 return %variants;
548 0         0 };
549             }
550              
551 3         27 return \@providers;
552             }
553              
554             =head2 write_output_files
555              
556             $test_writer->write_output_files($path, $context, $input_tests, $output_dir);
557              
558             Writes test files for each test in %$input_tests, for the given $path and $context,
559             into the $output_dir.
560              
561             The $output_dir, @$path, and key of %$input_tests are concatenated to form a
562             file name. A ".t" is added if not already present.
563              
564             Calls L to get the content of the test file, and then
565             calls L to write it.
566              
567             =cut
568              
569             sub write_output_files
570             {
571 8     8 1 20 my ($self, $path, $context, $input_tests, $output_dir) = @_;
572              
573 8         26 my $base_dir_path = join "/", $output_dir, @$path;
574              
575 8         33 for my $testname (sort keys %$input_tests)
576             {
577 16         37 my $test_spec = $input_tests->{$testname};
578              
579             # note that $testname can include a subdirectory path
580 16 50       62 $testname .= ".t" unless $testname =~ m/\.t$/;
581 16         44 my $full_path = "$base_dir_path/$testname";
582              
583 16         427 warn "Writing $full_path\n";
584             #warn "test_spec: @{[ %$test_spec ]}";
585              
586 16         76 my $test_script = $self->get_test_file_body($context, $test_spec);
587              
588 16         44 $self->write_file($full_path, $test_script);
589             }
590              
591 8         32 return;
592             }
593              
594             =head2 write_file
595              
596             $test_writer->write_file($filepath, $content);
597              
598             Throws an exception if $filepath already exists and L is
599             not true.
600              
601             Creates $filepath and writes $content to it.
602             Creates any directories that are needed.
603             Throws an exception on error.
604              
605             =cut
606              
607             sub write_file
608             {
609 16     16 1 35 my ($self, $filepath, $content) = @_;
610              
611 16 50 33     179 croak "$filepath already exists!\n"
612             if -e $filepath and not $self->allow_file_overwrite;
613              
614 16         533 my $full_dir_path = dirname($filepath);
615 16 100       1033 mkpath($full_dir_path, 0)
616             unless -d $full_dir_path;
617              
618 16 50       624 open my $fh, ">", $filepath
619             or croak "Can't write to $filepath: $!";
620 16         83 print $fh $content;
621 16 50       398 close $fh
622             or croak "Error writing to $filepath: $!";
623              
624 16         83 return;
625             }
626              
627             =head2 get_test_file_body
628              
629             $test_body = $test_writer->get_test_file_body($context, $test_spec);
630              
631             XXX This should probably be a method call on an object
632             instanciated by the find_input_test_* methods.
633              
634             =cut
635              
636             sub get_test_file_body
637             {
638 16     16 1 38 my ($self, $context, $test_spec) = @_;
639              
640 16         26 my @body;
641              
642 16   50     72 push @body, $test_spec->{prologue} || qq{#!perl\n\n};
643              
644 16         57 push @body, $context->get_code;
645 16         33 push @body, "\n";
646              
647             push @body, "use lib '$test_spec->{lib}';\n\n"
648 16 50       39 if $test_spec->{lib};
649              
650             push @body, "require '$test_spec->{require}';\n\n"
651 16 50       39 if $test_spec->{require};
652              
653 16 100       36 if (my $class = $test_spec->{class})
654             {
655 4         7 push @body, "require $class;\n\n";
656 4         7 my $method = $test_spec->{method};
657 4 50       10 push @body, "$class->$method;\n\n" if $method;
658             }
659              
660             push @body, "$test_spec->{code}\n\n"
661 16 100       38 if $test_spec->{code};
662              
663 16         50 return join "", @body;
664             }
665              
666             1;
667              
668             __END__