view release on metacpan or  search on metacpan

lib/Test/WriteVariants.pm  view on Meta::CPAN

=head1 DESCRIPTION

Test::WriteVariants is a utility to create variants of a common test.

Given the situation - like in L<DBI> where some tests are the same for
L<DBI::SQL::Nano> and it's drop-in replacement L<SQL::Statement>.
Or a distribution duo having a Pure-Perl and an XS variant - and the
same test shall be used to ensure XS and PP version are really drop-in
replacements for each other.

=cut

use strict;
use warnings;

use Carp qw(croak confess);
use Cwd ();
use File::Basename;
use File::Path;
use File::Spec;

use Module::Pluggable::Object;
use Module::Runtime qw(require_module use_module);

use Test::WriteVariants::Context;
use Data::Tumbler;

my $slurper;

BEGIN
{
    $slurper ||= eval { require_module("File::Slurper"); File::Slurper->can("read_binary"); };
    $slurper ||= sub {
        my $fn = shift;
        open(my $fh, "<", $fn) or croak("Can't open '$fn': $!");
        ## no critic (Variables::RequireInitializationForLocalVars)
        local $/;
        my $cnt = <$fh>;
        close($fh) or croak("Can't close file-handle for '$fn': $!");
        return $cnt;
    };
}

our $VERSION = '0.014';

=head1 METHODS

=head2 new

    $test_writer = Test::WriteVariants->new(%attributes);

Instanciates a Test::WriteVariants instance and sets the specified attributes, if any.

=cut

sub new
{
    my ($class, %args) = @_;

    my $self = bless {} => $class;

    for my $attribute (qw(allow_dir_overwrite allow_file_overwrite))
    {
        next unless exists $args{$attribute};
        $self->$attribute(delete $args{$attribute});
    }
    confess "Unknown $class arguments: @{[ keys %args ]}"
      if %args;

    return $self;
}

=head2 allow_dir_overwrite

    $test_writer->allow_dir_overwrite($bool);
    $bool = $test_writer->allow_dir_overwrite;

If the output directory already exists when tumble() is called it'll
throw an exception (and warn if it wasn't created during the run).
Setting allow_dir_overwrite true disables this safety check.

=cut

sub allow_dir_overwrite
{
    my $self = shift;
    $self->{allow_dir_overwrite} = shift if @_;
    return $self->{allow_dir_overwrite};
}

=head2 allow_file_overwrite

    $test_writer->allow_file_overwrite($bool);
    $bool = $test_writer->allow_file_overwrite;

If the test file that's about to be written already exists
then write_output_files() will throw an exception.
Setting allow_file_overwrite true disables this safety check.

=cut

sub allow_file_overwrite
{
    my $self = shift;
    $self->{allow_file_overwrite} = shift if @_;
    return $self->{allow_file_overwrite};
}

=head2 write_test_variants

    $test_writer->write_test_variants(
        input_tests => \%input_tests,
        variant_providers => \@variant_providers,
        output_dir => $output_dir,
    );

Instanciates a L<Data::Tumbler>. Sets its C<consumer> to call:

    $self->write_output_files($path, $context, $payload, $output_dir)