File Coverage

blib/lib/Test/DBIx/Class.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package Test::DBIx::Class;

use 5.008;
use strict;
use warnings;

use base 'Test::Builder::Module';

our $VERSION = '0.43';
our $AUTHORITY = 'cpan:JJNAPIORK';

use Config::Any;
use Data::Visitor::Callback;
use Digest::MD5;
use Hash::Merge;
use Path::Class;
use Scalar::Util ();
use Sub::Exporter;
use Test::DBIx::Class::SchemaManager;
use Test::Deep ();
use Test::More ();

sub eq_or_diff2 {
    my ($given, $expected, $message) = @_;
    my ($ok, $stack) = Test::Deep::cmp_details($given, $expected);
    if($ok) {
        Test::More::pass($message);
    } else {
        my $diag = Test::Deep::deep_diag($stack);
        Test::More::fail("$message: $diag");
    }
}

sub import {
    my ($class, @opts) = @_;
    my ($schema_manager, $merged_config, @exports) = $class->_initialize(@opts);
    my $exporter = Sub::Exporter::build_exporter({
        exports => [
            dump_settings => sub {
                return sub {
                    return $merged_config, @exports;
                };
            },
            Schema => sub {
                return sub {
                    return $schema_manager->schema;
                }
            },
            ResultSet => sub {
                my ($local_class, $name, $arg) = @_;
                return sub {
                    my $source = shift @_;
                    my $search = shift @_;
                    my $resultset = $schema_manager->schema->resultset($source);

                    if(my $global_search = $arg->{search}) {
                        my @global_search = ref $global_search eq 'ARRAY' ? @$global_search : ($global_search);
                        $resultset = $resultset->search(@global_search);
                    }

                    if(my $global_cb = $arg->{exec}) {
                        $resultset = $global_cb->($resultset);
                    }

                    if($search) {
                        my @search = ref $search eq 'ARRAY' ? @$search : ($search, @_);
                        $resultset = $resultset->search(@search);
                    }

                    return $resultset;
                }
            },
            is_result => sub {
                my ($local_class, $name, $arg) = @_;
                my $global_class = defined $arg->{isa_class} ? $arg->{isa_class} : '';
                return sub {
                    my $rs = shift @_;
                    my $compare = shift @_ || $global_class || "DBIx::Class";
                    my $message = shift @_;
                    Test::More::isa_ok($rs, $compare, $message);
                }
            },
            is_resultset => sub {
                my ($local_class, $name, $arg) = @_;
                my $global_class = defined $arg->{isa_class} ? $arg->{isa_class} : '';
                return sub {
                    my $rs = shift @_;
                    my $compare = shift @_ || $global_class || "DBIx::Class::ResultSet";
                    my $message = shift @_;
                    Test::More::isa_ok($rs, $compare, $message);
                }
            },
            eq_result => sub {
                return sub {
                    my ($result1, $result2, $message) = @_;
                    $message = defined $message ? $message : ref($result1) . " equals " . ref($result2);
                    if( ref($result1) eq ref($result2) ) {
                        eq_or_diff2(
                            {$result2->get_columns},
                            {$result1->get_columns},
                            $message,
                        );
                    } else {
                        Test::More::fail($message ." :Result arguments not of same class");
                    }
                },
            },
            eq_resultset => sub {
                return sub {
                    my ($rs1, $rs2, $message) = @_;
                    $message = defined $message ? $message : ref($rs1) . " equals " . ref($rs2);
                    if( ref($rs1) eq ref($rs2) ) {
                        ($rs1, $rs2) = map {
                            my $me = $_->current_source_alias;
                            my @pks = map { "$me.$_"} $_->result_source->primary_columns;
                            my @result = $_->search({}, {
                                result_class => 'DBIx::Class::ResultClass::HashRefInflator',
                                order_by => [@pks],
                            })->all;
                            [@result];
                        } ($rs1, $rs2);

                        eq_or_diff2([$rs2],[$rs1],$message);
                    } else {
                        Test::More::fail($message ." :ResultSet arguments not of same class");
                    }
                },
            },
            hri_dump => sub {
                return sub {
                    (shift)->search ({}, {
                        result_class => 'DBIx::Class::ResultClass::HashRefInflator'
                    });
                }
            },
            fixtures_ok => sub {
                return sub {
                    my ($arg, $message) = @_;
                    $message = defined $message ? $message : 'Fixtures Installed';

                    if ($arg && ref $arg && (ref $arg eq 'CODE')) {
                        eval {
                            $arg->($schema_manager->schema);
                        }; if($@) {
                            Test::More::fail($message);
                            $schema_manager->builder->diag($@);

                        } else {
                            Test::More::pass($message);
                        }
                    } elsif( $arg && ref $arg && (ref $arg eq 'HASH' || ref $arg eq 'ARRAY') ) {
                        my @return;
                        eval {
                            @return = $schema_manager->install_fixtures($arg);
                        }; if($@) {
                            Test::More::fail($message);
                            $schema_manager->builder->diag($@);
                        } else {
                            Test::More::pass($message);
                            return @return;
                        }
                    } elsif( $arg ) {
                        my @sets = ref $arg ? @$arg : ($arg);
                        my @fixtures = $schema_manager->get_fixture_sets(@sets);
                        my @return;
                        foreach my $fixture (@fixtures) {
                            eval {
                                push @return, $schema_manager->install_fixtures($fixture);
                            }; if($@) {
                                Test::More::fail($message);
                                $schema_manager->builder->diag($@);
                            } else {
                                Test::More::pass($message);
                                return @return;
                            }
                        }
                    } else {
                        Test::More::fail("Can't figure out what fixtures you want");
                    }
                }
            },
            is_fields => sub {
                my ($local_class, $name, $arg) = @_;
                my @default_fields = ();
                if(defined $arg && ref $arg eq 'HASH' && defined $arg->{fields}) {
                    @default_fields = ref $arg->{fields} ? @{$arg->{fields}} : ($arg->{fields});
                }
                return sub {
                    my @args = @_;
                    my @fields = @default_fields;
                    if(!ref($args[0]) || (ref($args[0]) eq 'ARRAY')) {
                        my $fields = shift(@args);
                        @fields = ref $fields ? @$fields : ($fields);
                    }
                    if(Scalar::Util::blessed($args[0]) &&
                        $args[0]->isa('DBIx::Class') &&
                        !$args[0]->isa('DBIx::Class::ResultSet')
                    ) {
                        my $result = shift(@args);
                        unless(@fields) {
                            my @pks = $result->result_source->primary_columns;
                            push @fields, grep {
                                my $field = $_;
                                $field ne ((grep { $field eq $_ } @pks)[0] || '')
                            } ($result->result_source->columns);
                        }
                        my $compare = shift(@args);
                        if(ref $compare eq 'HASH') {
                        } elsif(ref $compare eq 'ARRAY') {
                            my @localfields = @fields;
                            $compare = {map {
                                my $value = $_;
                                my $key = shift(@localfields);
                                $key => $value } @$compare};
                            Test::More::fail('Too many fields!') if @localfields;
                        } elsif(!ref $compare) {
                            my @localfields = @fields;
                            $compare = {map {
                                my $value = $_;
                                my $key = shift(@localfields);
                                $key => $value } ($compare)};
                            Test::More::fail('Too many fields!') if @localfields;
                        }
                        my $message = shift(@args) || 'Fields match';
                        my $compare_rs = {map {
                            die "$_ is not an available field"
                              unless $result->can($_);
                            $_ => $result->$_ } @fields};
                        eq_or_diff2($compare,$compare_rs,$message);
                        return $compare;
                    } elsif (Scalar::Util::blessed($args[0]) && $args[0]->isa('DBIx::Class::ResultSet')) {

                        my $resultset = shift(@args);
                        unless(@fields) {
                            my @pks = $resultset->result_source->primary_columns;
                            push @fields, grep {
                                my $field = $_;
                                $field ne ((grep { $field eq $_ } @pks)[0] || '')
                            } ($resultset->result_source->columns);
                        }
                        my @compare = @{shift(@args)};
                        foreach (@compare) {
                            if(!ref $_) {
                                my @localfields = @fields;
                                $_ = {map {
                                    my $value = $_;
                                    my $key = shift(@localfields);
                                    $key => $value } ($_)};
                                Test::More::fail('Too many fields!') if @localfields;
                            } elsif(ref $_ eq 'ARRAY') {
                                my @localfields = @fields;
                                $_ = {map {
                                    my $value = $_;
                                    my $key = shift(@localfields);
                                    $key => $value } (@$_)};
                                Test::More::fail('Too many fields!') if @localfields;
                            }
                        }
                        my $message = shift(@args) || 'Fields match';

                        my @resultset = $resultset->search({}, {
                                result_class => 'DBIx::Class::ResultClass::HashRefInflator',
                                columns => [@fields],
                            })->all;
                        my %compare_rs;
                        foreach my $row(@resultset) {
                            no warnings 'uninitialized';
                            my $id = Digest::MD5::md5_hex(join('.', map {$row->{$_}} sort keys %$row));
                            $compare_rs{$id} = { map { $_,"$row->{$_}"} keys %$row};
                        }
                        my %compare;
                        foreach my $row(@compare) {
                            no warnings 'uninitialized';
                            my $id = Digest::MD5::md5_hex(join('.', map {$row->{$_}} sort keys %$row));
                            ## Force comparison stuff in stringy form :(
                            $compare{$id} = { map { $_,"$row->{$_}"} keys %$row};
                        }
                        eq_or_diff2(\%compare,\%compare_rs,$message);
                        return \@compare;
                    } else {
                        die "I'm not sure what to do with your arguments";
                    }
                };
            },
            reset_schema => sub {
                return sub {
                    my $message = shift @_ || 'Schema reset complete';
                    $schema_manager->reset;
                    Test::More::pass($message);
                }
            },
            cleanup_schema => sub {
                return sub {
                    my $message = shift @_ || 'Schema cleanup complete';
                    $schema_manager->cleanup;
                    Test::More::pass($message);
                }
            },
            map {
                my $source = $_;
                 $source => sub {
                    my ($local_class, $name, $arg) = @_;
                    my $resultset = $schema_manager->schema->resultset($source);
                    if(my $search = $arg->{search}) {
                        my @search = ref $search eq 'ARRAY' ? @$search : ($search);
                        $resultset = $resultset->search(@search);
                    }
                    return sub {
                        my $search = shift @_;
                        if($search) {
                            my @search = ();
                            if(ref $search && ref $search eq 'HASH') {
                                @search = ($search, @_);
                            } else {
                                @search = ({$search, @_});
                            }
                            return $resultset->search(@search);
                        }
                        return $resultset->search_rs;
                    }
                };
            } $schema_manager->schema->sources,
        ],
        groups => {
            resultsets => [$schema_manager->schema->sources],
        },
        into_level => 1,
    });

    $class->$exporter(
        qw/Schema ResultSet is_result is_resultset hri_dump fixtures_ok reset_schema
            eq_result eq_resultset is_fields dump_settings cleanup_schema /,
         @exports
    );
}

sub _initialize {
    my ($class, @opts) = @_;
    my ($config, @exports) = $class->_normalize_opts(@opts);
    my $merged_config = $class->_prepare_config($config);

    if(my $resultsets = delete $merged_config->{resultsets}) {
        if(ref $resultsets eq 'ARRAY') {
            push @exports, @$resultsets;
        } else {
            die '"resultsets" options must be a Array Reference.';
        }
    }
    my $merged_with_fixtures_config = $class->_prepare_fixtures($merged_config);
    my $visitor = Data::Visitor::Callback->new(plain_value=>\&_visit_config_values);
    $visitor->visit($merged_with_fixtures_config);

    my $schema_manager = $class->_initialize_schema($merged_with_fixtures_config);

    return (
        $schema_manager,
        $merged_config,
        @exports,
    );
}

sub _visit_config_values {
    return unless $_;

    &_config_substitutions($_);

}

sub _config_substitutions {
    my $subs = {};
    $subs->{ ENV } =
        sub {
            my ( $v ) = @_;
            if (! defined($ENV{$v})) {
                Test::More::fail("Missing environment variable: $v");
                return '';
            } else {
                return $ENV{ $v };
            }
        };
    $subs->{ literal } ||= sub { return $_[ 1 ]; };
    my $subsre = join( '|', keys %$subs );

    for ( @_ ) {
        s{__($subsre)(?:\((.+?)\))?__}{ $subs->{ $1 }->( $2 ? split( /,/, $2 ) : () ) }eg;
    }
}

sub _normalize_opts {
    my ($class, @opts) = @_;
    my ($config, @exports) = ({},());

    if(ref $opts[0]) {
        if(ref $opts[0] eq 'HASH') {
            $config = shift(@opts);
        } else {
            die 'First argument to "use Test::DBIx::Class @args" not properly formed.';
        }
    }

    while( my $opt = shift(@opts)) {
        if($opt =~m/^-(.+)/) {
            if($config->{$1}) {
                die "$1 already is defined as $config->{$1}";
            } else {
                $config->{$1} = shift(@opts);
            }
        } else {
            @exports = ($opt, @opts);
            last;
        }
    }

    if(my $resultsets = delete $config->{resultsets}) {
        if(ref $resultsets eq 'ARRAY') {
            push @exports, @$resultsets;
        } else {
            die '"resultsets" options must be a Array Reference.';
        }
    }

    @exports = map { ref $_ && ref $_ eq 'ARRAY' ? @$_:$_ } @exports;

    return ($config, @exports);
}

sub _prepare_fixtures {
    my ($class, $config) = @_;

    my @dirs;
    if(my $fixture_path = delete $config->{fixture_path}) {
        @dirs = $class->_normalize_config_path(
            $class->_default_fixture_paths, $fixture_path,
        );
    } else {
        @dirs = $class->_normalize_config_path($class->_default_fixture_paths);
    }

    my @extensions = $class->_allowed_extensions;
    my @files = (
        grep { $class->_is_allowed_extension($_) }
        map {Path::Class::dir($_)->children}
        grep { -e $_  }
        @dirs
    );

    my $fixture_definitions = Config::Any->load_files({
        files => \@files,
        use_ext => 1,
    });

    my %merged_fixtures;
    foreach my $fixture_definition(@$fixture_definitions) {
        my ($path, $fixture) = %$fixture_definition;
        ## hack to normalize arrayref fixtures.  needs work!!!
        $fixture = ref $fixture eq 'HASH' ? [$fixture] : $fixture;
        my $file = Path::Class::file($path)->basename;
        $file =~s/\..{1,4}$//;
        if($merged_fixtures{$file}) {
            my $old_fixture = $merged_fixtures{$file};
            my $merged_fixture = Hash::Merge::merge($fixture, $old_fixture);
            $merged_fixtures{$file} = $merged_fixture;
        } else {
            $merged_fixtures{$file} = $fixture;
        }
    }

    if(my $old_fixture_sets = delete $config->{fixture_sets}) {
        ## hack to normalize arrayref fixtures.  needs work!!!
        my %normalized_old_fixture_sets = map {
            ref($old_fixture_sets->{$_}) eq 'HASH' ? ($_, [$old_fixture_sets->{$_}]): ($_, $old_fixture_sets->{$_});
        } keys %$old_fixture_sets;
        my $new_fixture_sets = Hash::Merge::merge(\%normalized_old_fixture_sets, \%merged_fixtures );
        $config->{fixture_sets} = $new_fixture_sets;
    } else {
        $config->{fixture_sets} = \%merged_fixtures;
    }

    return $config;
}

sub _is_allowed_extension {
    my ($class, $file) = @_;
    my @extensions = $class->_allowed_extensions;
    foreach my $extension(@extensions) {
        if($file =~ m/\.$extension$/) {
            return $file;
        }
    }
    return;
}

sub _prepare_config {
    my ($class, $config) = @_;

    if(my $extra_config = delete $config->{config_path}) {
        my @config_data = $class->_load_via_config_any($extra_config);
        foreach my $config_datum(reverse @config_data) {
            $config = Hash::Merge::merge($config, $config_datum);
        }
    } else {
        my @config_data = $class->_load_via_config_any();
        foreach my $config_datum(reverse @config_data) {
            $config = Hash::Merge::merge($config, $config_datum);
        }
    }

    if(my $post_config = delete $config->{config_path}) {
        my @post_config_paths = $class->_normalize_external_paths($post_config);
        my @extensions = $class->_allowed_extensions;
        my @post_config_files =  grep { -e $_} map {
            my $path = $_;
            map {
            $ENV{TEST_DBIC_CONFIG_SUFFIX} ?
              ("$path.$_", "$path$ENV{TEST_DBIC_CONFIG_SUFFIX}.$_") :
              ("$path.$_");
            } @extensions;
        } map {
            my @local_path = ref $_ ? @$_ : ($_);
            Path::Class::file(@local_path);
        } @post_config_paths;

        my $post_config = $class->_config_any_load_files(@post_config_files);
        foreach my $config_datum(reverse map { values %$_ } @$post_config) {
            $config = Hash::Merge::merge($config, $config_datum);
        }
    }

    return $config;
}

sub _load_via_config_any {
    my ($class, $extra_paths) = @_;
    my @files = $class->_valid_config_files($class->_default_paths, $extra_paths);
    my $config = $class->_config_any_load_files(@files);

    my @config_data = map { values %$_ } @$config;
    return @config_data;
}

sub _config_any_load_files {
    my ($class, @files) = @_;

    return Config::Any->load_files({
        files => \@files,
        use_ext => 1,
    });
}

sub _valid_config_files {
    my ($class, $default_paths, $extra_paths) = @_;
    my @extensions = $class->_allowed_extensions;
    my @paths = $class->_normalize_config_path($default_paths, $extra_paths);
    my @config_files = grep { -e $_} map {
        my $path = $_;
        map {
            $ENV{TEST_DBIC_CONFIG_SUFFIX} ?
              ("$path.$_", "$path$ENV{TEST_DBIC_CONFIG_SUFFIX}.$_") :
              ("$path.$_");
        } @extensions;
     } @paths;

    return @config_files;
}

sub _allowed_extensions {
    return @{ Config::Any->extensions };
}

sub _normalize_external_paths {
    my ($class, $extra_paths) = @_;
    my @extra_paths;
    if(!ref $extra_paths) {
        @extra_paths = ([$extra_paths]); ## "t/etc" => (["t/etc"])
    } elsif(ref $extra_paths eq 'ARRAY') {
        if(!ref $extra_paths->[0]) {
            @extra_paths = ($extra_paths); ## [qw( t etc )]
        } elsif( ref $extra_paths->[0] eq 'ARRAY') {
            @extra_paths = @$extra_paths;
        }
    }
    return @extra_paths;
}

sub _normalize_config_path {
    my ($class, $default_paths, $extra_paths) = @_;

    if(defined $extra_paths) {
        my @extra_paths = map { "$_" eq "+" ? @$default_paths : $_ } map {
            my @local_path = ref $_ ? @$_ : ($_);
            Path::Class::file(@local_path);
        } $class->_normalize_external_paths($extra_paths);

        return @extra_paths;
    } else {
        return @$default_paths;
    }
}

sub _script_path {
    return ($0 =~m/^(.+)\.t$/)[0];
}

sub _default_fixture_paths {
    my ($class) = @_;
    my $script_path = Path::Class::file($class->_script_path);
    my $script_dir = $script_path->dir;
    my @dir_parts = $script_dir->dir_list(1);

    return [
        Path::Class::file(qw/t etc fixtures/),
        Path::Class::file(qw/t etc fixtures/, @dir_parts, $script_path->basename),
    ];

}

sub _default_paths {
    my ($class) = @_;
    my $script_path = Path::Class::file($class->_script_path);
    my $script_dir = $script_path->dir;
    my @dir_parts = $script_dir->dir_list(1);

    if(
        $script_path->basename eq 'schema' &&
        (scalar(@dir_parts) == 0 )
    ) {
      return [
        Path::Class::file(qw/t etc schema/),
      ];

    } else {
      return [
        Path::Class::file(qw/t etc schema/),
        Path::Class::file(qw/t etc /, @dir_parts, $script_path->basename),
      ];
}
}

sub _initialize_schema {
    my $class = shift @_;
    my $config  = shift @_;
    my $builder = __PACKAGE__->builder;

    my $fail_on_schema_break = delete $config->{fail_on_schema_break};
    my $schema_manager;
     eval {
        $schema_manager = Test::DBIx::Class::SchemaManager->initialize_schema({
            %$config,
            builder => $builder,
        });
    }; if ($@ or !$schema_manager) {
        Test::More::diag("Can't initialize a schema with the given configuration");
        Test::More::diag("Returned Error: ".$@) if $@;
        Test::More::diag(
            Test::More::explain("configuration: " => $config)
        );
        # FIXME: make this optional.
        if($fail_on_schema_break)
        {
            Test::More::fail("Failed remaining tests since we don't have a schema");
            Test::More::done_testing();
            $builder->finalize();
            exit(0);
        }
        else
        {
            $builder->skip_all("Skipping remaining tests since we don't have a schema");
        }
    }

    return $schema_manager
}

1;

__END__