#!/usr/bin/env perl
#
# Copyright 2008-2010 Tim Rayner
# 
# This file is part of Bio::MAGETAB.
# 
# Bio::MAGETAB is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
# 
# Bio::MAGETAB is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with Bio::MAGETAB.  If not, see <http://www.gnu.org/licenses/>.
#
# $Id: CommonTests.pm 333 2010-06-02 16:41:31Z tfrayner $

use strict;
use warnings;

package CommonTests;

use Test::More;
use Test::Exception;
use Storable qw(dclone);

use base qw(Exporter);
our @EXPORT_OK = qw(test_class test_methods test_parse check_term);

sub instantiate {

    my ( $class, $options ) = @_;

    my $obj = $class->new( %{ $options } );

    return $obj;
}

sub test_required_arg_instantiation {

    my ( $class, $required ) = @_;

    my @attr_pairs;
    while ( my ( $key, $value ) = each %{ $required } ) {
        push @attr_pairs, [ $key, $value ];
    }

    foreach my $index ( 0 .. $#attr_pairs ) {
        my @opts = @attr_pairs;
        splice( @opts, $index, 1 );
        my %attr = map { @{$_} } @opts;
        dies_ok( sub { instantiate( $class, \%attr ) },
                 qq{instantiation lacking required attribute "$attr_pairs[$index][0]" fails} );
    }

    return;
}

sub test_instantiation {

    # Test object instantiation under a number of conditions.
    my ( $class, $required, $optional, $bad ) = @_;

    my $obj;

    if ( scalar grep { defined $_ } values %$required ) {

        # Required attributes not set; should fail.
        dies_ok(  sub { $obj = instantiate( $class, $optional ) },
                  "instantiation with only optional args fails" );
    }
    else {

        # No required attributes, so this should pass.
        lives_ok( sub { $obj = instantiate( $class, $optional ) },
                  "instantiation with only optional args succeeds" );
    }

    # Attributes with bad data types; should fail.
    dies_ok(  sub { $obj = instantiate( $class, $bad ) },
              "instantiation with bad args fails" );

    # Test instantiation with $required minus each attribute, one at a
    # time, to confirm that they're really required.
    test_required_arg_instantiation( $class, $required );

    # Required attributes only; should pass.
    lives_ok( sub { $obj = instantiate( $class, $required ) },
              "instantiation with all required args succeeds" );

    # Check predicate method behaviour - before opt attr setting.
    while ( my ( $key, $value ) = each %{ $optional } ) {
        my $predicate = "has_$key";
        ok( ! $obj->$predicate, qq{and optional "$key" attribute predicate method agrees} );
    }

    # Required attributes with an unrecognised impostor; should fail.
    my %with_unrecognised = ( 'this_is_not_a_recognised_attribute' => 1, %{ $required } );
    dies_ok( sub { $obj = instantiate( $class, \%with_unrecognised ) },
              "instantiation with an unrecognised arg fails" );

    # Construct a full instance as our return value.
    my $all = { %{ $optional }, %{ $required } };
    lives_ok( sub { $obj = instantiate( $class, $all      ) },
              "instantiation with all required and optional args succeeds" );

    # Check our fully-constructed object.
    ok( defined $obj,        'and returns an object' );
    ok( $obj->isa( $class ), 'of the correct class' );
    while ( my ( $key, $value ) = each %{ $all } ) {
        my $getter = "get_$key";
        is( $obj->$getter, $value, qq{with the correct "$key" attribute} );
    }
    ok( ! defined $obj->get_ClassContainer(), 'and no container object set' );

    # Check predicate method behaviour - after opt attr setting.
    while ( my ( $key, $value ) = each %{ $optional } ) {
        my $predicate = "has_$key";
        ok( $obj->$predicate, qq{and optional "$key" attribute predicate method agrees} );
    }

    return $obj;
}

sub test_update {

    my ( $obj, $required, $optional, $bad, $secondary ) = @_;

    # Check that updates work as we expect; correct update values first.
    while ( my ( $key, $value ) = each %{ $secondary } ) {
        my $setter = "set_$key";
        lives_ok( sub { $obj->$setter( $value ) }, qq{good "$key" attribute update succeeds} );
        my $getter = "get_$key";
        is( $obj->$getter, $value, 'and sets correct value' );
    }

    # Bad values next.
    while ( my ( $key, $value ) = each %{ $bad } ) {
        my $setter = "set_$key";
        dies_ok( sub { $obj->$setter( $value ) }, qq{bad "$key" attribute update fails} );
    }

    # Update with null values. Required attributes should fail.
    while ( my ( $key, $value ) = each %{ $required } ) {

        # In principle this should fail because the attributes are
        # required. In practice it's more likely they fail because we
        # simply don't provide a "clearer" method for such
        # attributes. Either way, success is bad.
        my $clearer = "clear_$key";
        dies_ok( sub { $obj->$clearer }, qq{clearing required "$key" attribute fails} );
    }
    
    # Optional attributes should be nullable.
    while ( my ( $key, $value ) = each %{ $optional } ) {

        # Clear the key
        my $clearer = "clear_$key";
        ok( $obj->can($clearer), qq{object can clear optional attribute "$key"} );
        lives_ok( sub { $obj->$clearer }, qq{clearing optional "$key" attribute succeeds} );

        # Check the value.
        my $getter = "get_$key";
        is( $obj->$getter, undef, 'and sets undef value' );

        # Check predicate method behaviour - after opt attr clearing.
        my $predicate = "has_$key";
        ok( ! $obj->$predicate, qq{and optional "$key" attribute predicate method agrees} );
    }

    return;
}

sub test_class {

    # Main entry point for the tests in this module.
    my ( $class, $required, $optional, $bad, $secondary ) = @_;

    my $instance = test_instantiation(
        $class,
        $required,
        $optional,
        $bad,
    );

    my $instance2 = dclone( $instance );

    test_update(
        $instance2,
        $required,
        $optional,
        $bad,
        $secondary,
    );

    # This needs to be a valid instance; further tests may be run.
    return $instance;
}

sub test_methods {

    my ( $class, $expected ) = @_;

    foreach my $method ( @{ $expected } ) {
        ok( $class->can( $method ), "$class can $method" );
    }

    return;
}

sub test_parse {

    my ( $reader ) = @_;

    $reader->parse();

    return $reader->get_magetab_object();
}

sub check_term {

    my ( $cat, $val, $attr, $obj, $ts, $builder ) = @_;

    my $method = "get_$attr";

    my $ct;
    lives_ok( sub { $ct = $builder->get_controlled_term({
        category   => $cat,
        value      => $val,
        termSource => $ts,
    }) }, "Builder returns a $cat term" );
    is( $ct->get_termSource(), $ts, 'with the correct termSource' );
    is_deeply( $obj->$method(), $ct, "$attr set correctly" );

    return;
}

1;