#============================================================= -*-perl-*-
#
# t/class/methods.t
#
# Test the Badger::Class::Methods module.
#
# Written by Andy Wardley <abw@wardley.org>
#
# This is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
#========================================================================

use lib qw( t/core/lib ../t/core/lib ./lib ../lib ../../lib );
use Badger::Test
    tests => 55,
    debug => 'Badger::Class::Methods',
    args  => \@ARGV;

#-----------------------------------------------------------------------
# test using Badger::Class::Methods directly
#-----------------------------------------------------------------------

package Badger::Test::Methods1;

use Badger::Class::Methods
    accessors => 'foo bar',
    mutators  => 'flic flac',
    get       => 'a',           # short aliases for above
    set       => 'b',
    hash      => 'users';

package main;

my $obj = bless { 
    foo   => 10, 
    bar   => 20, 
    flic  => 30,
    a     => 31,
    b     => 32,
    users => {
        tom => 'tom@example.com',
    },
}, 'Badger::Test::Methods1';

is( $obj->foo, 10, 'foo accessor' );
is( $obj->bar, 20, 'bar accessor' );
is( $obj->bar(100), 20, 'bar accessor with arg' );
is( $obj->bar, 20, 'bar unchanged accessor' );
is( $obj->flic, 30, 'flic mutator' );
is( $obj->flic(40), 40, 'flic mutator with arg' );
is( $obj->flic, 40, 'flic updated' );
is( $obj->flac(50), 50, 'flac set' );
is( $obj->flac, 50, 'flac get' );
is( $obj->a, 31, 'a get' );
is( $obj->a(33), 31, 'a set' );
is( $obj->a, 31, 'a get again' );
is( $obj->b, 32, 'b get' );
is( $obj->b(33), 33, 'b set' );
is( $obj->b, 33, 'b get again' );
is( $obj->users->{ tom }, 'tom@example.com', 'got users hash' );
is( $obj->users('tom'), 'tom@example.com', 'got users item' );

# add users via hash ref
$obj->users({ dick => 'richard@example.com' });
is( $obj->users('dick'), 'richard@example.com', 'dick added to users' );
is( $obj->users('tom'), 'tom@example.com', 'tom is still in users' );

# add users via named params
$obj->users( harry => 'harold@example.com' );
is( $obj->users('harry'), 'harold@example.com', 'harold added to users' );
is( $obj->users('dick'), 'richard@example.com', 'richard is still in users' );


#-----------------------------------------------------------------------
# test using Badger::Class via delegation
#-----------------------------------------------------------------------

package Badger::Test::Methods2;

use Badger::Class
    base        => 'Badger::Base',
    accessors   => 'wiz waz',
    mutators    => 'ding dong',
    get_methods => 'x',
    set_methods => 'y',
    init_method => 'configure',
    config      => 'x y wiz waz ding';

package main;

$obj = Badger::Test::Methods2->new(
    wiz  => 50, 
    waz  => 60, 
    ding => 70,
    x    => 101,
    y    => 202,
);

is( $obj->wiz, '50', 'wiz accessor' );
is( $obj->waz, '60', 'waz accessor' );
is( $obj->waz(100), '60', 'waz accessor with arg' );
is( $obj->waz, '60', 'waz unchanged accessor' );
is( $obj->ding, '70', 'ding mutator' );
is( $obj->ding(80), '80', 'ding mutator with arg' );
is( $obj->ding, '80', 'ding updated' );
is( $obj->dong(90), '90', 'dong set' );
is( $obj->dong, '90', 'dong get' );
is( $obj->x, 101, 'x get' );
is( $obj->x(102), 101, 'x set' );
is( $obj->x, 101, 'x get again' );
is( $obj->y, 202, 'y get' );
is( $obj->y(203), 203, 'y set' );
is( $obj->y, 203, 'y get again' );


#-----------------------------------------------------------------------
# test generation of slot methods for list based objects
#-----------------------------------------------------------------------

package Badger::Test::Slots1;

use Badger::Class::Methods
    slots => 'size colour object';

sub new {
    my ($class, @stuff) = @_;
    bless \@stuff, $class;
}

package main;
my $bus = Badger::Test::Slots1->new(qw(big red bus));
ok( $bus, 'Created slot test object' );
is( $bus->size,   'big', 'big slot' );
is( $bus->colour, 'red', 'red slot' );
is( $bus->object, 'bus', 'bus slot' );


#-----------------------------------------------------------------------
# and again via Badger::Class
#-----------------------------------------------------------------------

package Badger::Test::Slots2;

use Badger::Class
    slots => 'subject, predicate, object';

sub new {
    my ($class, @stuff) = @_;
    bless \@stuff, $class;
}

package main;
my $sentence = Badger::Test::Slots2->new('the cat', 'sat on', 'the mat');
ok( $sentence, 'Created slot test object' );
is( $sentence->subject,   'the cat', 'subject slot' );
is( $sentence->predicate, 'sat on',  'predicate slot' );
is( $sentence->object,    'the mat', 'object slot' );


#-----------------------------------------------------------------------
# we should be able to create accessor/mutator code refs directly
#-----------------------------------------------------------------------

my $dummy = { pi => 3.14 };

my $access = Badger::Class::Methods->accessor('pi');
ok( $access, 'created accessor method' );
is( $access->($dummy), 3.14, 'accessor works' );

my $mutate = Badger::Class::Methods->mutator('pi');
ok( $mutate, 'created mutator method' );
is( $mutate->($dummy, 3.14159), 3.14159, 'mutator works' );
is( $access->($dummy), 3.14159, 'value updated' );



#-----------------------------------------------------------------------
# test the auto_can() method
#-----------------------------------------------------------------------

package Badger::Test::Autocan;

use Badger::Class
    base        => 'Badger::Base',
    auto_can    => 'test_method',
    accessors   => 'x y',
    config      => 'x=10 y=20',
    init_method => 'configure';

sub test_method {
    my ($self, $name) = @_;
    
    if ($name =~ /^test_/) {
        return sub {
            my $this = shift;
            return "You called $name(" . join(', ', @_) . ')';
        }
    }
}

package main;

use constant AUTOCAN => 'Badger::Test::Autocan';

my $xy = AUTOCAN->new;
ok( $xy, 'created auto_can object' );
is( $xy->x, 10, 'x is 10' );
is( $xy->y, 20, 'y is 20' );
is( $xy->test_foo(30), 'You called test_foo(30)', 'called test_foo()' );
ok( ! $xy->try->bad_foo(30), 'failed to call bad_foo()' );
like( $xy->reason->info, "Invalid method 'bad_foo' called on Badger::Test::Autocan", 'got error message' );


__END__

# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# vim: expandtab shiftwidth=4: