Test::DBIx::Class::Schema - DBIx::Class schema sanity checking tests

    #!/usr/bin/perl
    # vim: ts=8 sts=4 et sw=4 sr sta
    use strict;
    use warnings;

    # load the module that provides all of the common test functionality
    use Test::DBIx::Class::Schema;

    # create a new test object
    my $schematest = Test::DBIx::Class::Schema->new(
        {
            # required
            dsn       => 'dbi:Pg:dbname=mydb',
            namespace => 'MyDB::Schema',
            moniker   => 'SomeTable',
            # optional
            username  => 'some_user',
            password  => 'opensesame',
        }
    );

    # tell it what to test
    $schematest->methods(
        {
            columns => [
                qw[
                    id
                    column1
                    column2
                    columnX
                    foo_id
                ]
            ],

            relations => [
                qw[
                    foo
                ]
            ],

            custom => [
                qw[
                    some_method
                ]
            ],

            resultsets => [
                qw[
                ]
            ],
        }
    );

    # run the tests
    $schematest->run_tests();

  prove -l t/schematest/xx.mydb.t

  done_testing;

package Test::DBIx::Class::Schema;
BEGIN {
  $Test::DBIx::Class::Schema::VERSION = '0.01015';
}
BEGIN {
  $Test::DBIx::Class::Schema::DIST = 'Test-DBIx-Class-Schema';
}
# vim: ts=8 sts=4 et sw=4 sr sta
use strict;
use warnings;

# ensure we have "done_testing"
use Test::More 0.92;

sub new {
    my ($proto, $options) = @_;
    my $self = (defined $options) ? $options : {};
    bless $self, ref($proto) || $proto;
    return $self;
}

# for populating the correct part of $self
sub methods {
    my ($self, $hashref) = @_;

    $self->{methods} = $hashref;

    return;
}

sub run_tests {
    my ($self) = @_;
    my ($schema, $rs, $record);

    # make sure we can use the schema (namespace) module
    use_ok( $self->{namespace} );

    # let users pass in an existing $schema if they (somehow) have one
    if (defined $self->{schema}) {
        $schema = $self->{schema};
    }
    else {
        # get a schema to query
        $schema = $self->{namespace}->connect(
            $self->{dsn},
            $self->{username},
            $self->{password},
        );
    }
    isa_ok($schema, $self->{namespace});

    # create a new resultset object and perform tests on it
    # - this allows us to test ->my_column() without requiring data
    $rs = $schema->resultset( $self->{moniker} );
    $record = $schema->resultset( $self->{moniker} )->new({});

    # make sure our record presents itself as the correct object type
    if (defined $self->{glue}) {
        isa_ok(
            $record,
                $self->{namespace}
            . '::' . $self->{glue}
            . '::' . $self->{moniker}
        );
    }
    else {
        isa_ok($record, $self->{namespace} . '::' . $self->{moniker});
    }

    $self->_test_normal_methods($rs);
    $self->_test_special_methods($record);
    $self->_test_resultset_methods($rs);

    done_testing
        unless $ENV{TEST_AGGREGATE};
}

sub _test_normal_methods {
    my $self    = shift;
    my $rs  = shift;

    my @std_method_types        = qw(columns relations);

    # 'normal' methods; row & relation
    # we can try calling these as they gave no side-effects
    my @proxied;
    foreach my $method_type (@std_method_types) {
        SKIP: {
            if (not @{ $self->{methods}{$method_type} }) {
                skip qq{no $method_type methods}, 1;
            }

            # try calling each method
            METHOD: foreach my $method ( @{ $self->{methods}{$method_type} } ) {
                # make sure we can call the method
                my $source = $rs->result_source;
                my $related_source;

                # 'normal' relationship
                if ($source->has_relationship($method)) {
                    eval {
                        $related_source = $source->related_source($method);
                    };
                    is($@, q{}, qq{related source for '$method' exists});

                    # test self.* and foreign.* columns are valid
                    my $cond_ref = $source->relationship_info($method)->{cond};
                    $cond_ref = ref $cond_ref eq 'ARRAY' ? $cond_ref : [ $cond_ref ];
                    foreach my $cond ( @$cond_ref ) {
                        foreach my $foreign_col (keys %{$cond} ) {
                            my $self_col = $cond->{$foreign_col};
                            s{^\w+\.}{} for ( $self_col, $foreign_col );
                            eval {
                                $source->resultset->slice(0,0)->get_column($self_col)->all;
                            };
                            is($@, q{}, qq{self.$self_col valid for '$method' relationship});
                            eval {
                                $related_source->resultset->slice(0,0)->get_column($foreign_col)->all;
                            };
                            is($@, q{}, qq{foreign.$foreign_col valid for '$method' relationship});
                        }
                    }
                }

                # many_to_many and proxy
                elsif ( $method_type eq 'relations' ) {
                    # TODO: Factor this out with the same code under proxied
                    # 'columns' accessors
                    RELATIONSHIP:
                    for my $relationship ( $source->relationships ) {
                        my $proxy = $source->relationship_info($relationship)->{attrs}{proxy};
                        next RELATIONSHIP if not $proxy;
                        if ( grep m{$method}, @$proxy ) {
                            pass qq{'$method' relationship exists via proxied relationship '$relationship'};
                            next METHOD;
                        }
                    }
                    my $result = $rs->new({});
                    # many_to_many
                    if ( $result->can($method)
                     and $result->$method->isa('DBIx::Class::ResultSet') ) {
                        pass("'$method' relation is a many-to-many");
                    }
                    else {
                        fail("'$method' is not a valid relationship" );
                    }
                }

                # column accessor
                elsif ( $method_type eq 'columns' ) {
                    if ( $source->has_column($method) ) {
                        pass qq{'$method' column defined in result_source};
                        eval {
                            # https://rt.cpan.org/Ticket/Display.html?id=65521
                            my $col = $rs->slice(0,0)->get_column($method)->all;
                        };
                        is($@, q{}, qq{'$method' column exists in database});
                        next METHOD;
                    }
                    # Proxied columns
                    RELATIONSHIP:
                    for my $relationship ( $source->relationships ) {
                        my $proxy = $source->relationship_info($relationship)->{attrs}{proxy};
                        next RELATIONSHIP if not $proxy;
                        if ( grep m{$method}, @$proxy ) {
                            pass(qq{'$method' column exists via proxied relationship '$relationship'});
                            next METHOD;
                        }
                    }
                    fail qq{'$method' column does not exist and is not proxied};
                }
                # ... erm ... what's this?
                else {
                    die qq{unknown method type: $method_type};
                }
            }
        }
    } # foreach
    return;
}

sub _test_special_methods {
    shift->_test_methods(shift, [qw/custom/]);
}

sub _test_resultset_methods {
    shift->_test_methods(shift, [qw/resultsets/]);
}

sub _test_methods {
    my $self            = shift;
    my $thingy          = shift;
    my $method_types    = shift;

    # 'special' methods; custom
    # we can't call these as they may have unknown parameters,
    # side effects, etc
    foreach my $method_type (@{ $method_types} ) {
        SKIP: {
            skip qq{no $method_type methods}, 1
                    unless @{ $self->{methods}{$method_type} };
            ok(
                @{ $self->{methods}{$method_type} },
                qq{$method_type list found for testing}
            );
        }

        # call can on each method to make it obvious what's being tested
        foreach my $method (@{ $self->{methods}{$method_type} } ) {
            can_ok( $thingy, $method );
        }
    } # foreach
    return;
}

1;

__END__