#============================================================= -*-perl-*-
#
# t/core/class.t
#
# Test the Badger::Class 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 );
BEGIN { $Badger::Class::DEBUG = 1 if grep /-d/, @ARGV }
use Badger::Class;
use Badger::Test
tests => 133,
debug => 'Badger::Class Badger::Exporter',
args => \@ARGV;
#-----------------------------------------------------------------------
# test simple inheritance
#-----------------------------------------------------------------------
package Alice;
use Badger::Class
version => 2.718,
import => qw( class classes CLASS );
main::is( $VERSION, 2.718, 'Alice defines $VERSION as 2.718' );
our $NAME = 'Alice';
our $GIRLS_NAME = 'Alice';
our $ALIASES = ['Ally', 'Ali'];
our $FRIENDS = {
sue => 'Susan',
};
our $TWO = '22 Acacia Avenue';
sub new {
my ($class, %self) = @_;
bless \%self, $class;
}
sub my_class { CLASS }
package Bob;
use Badger::Class
base => 'Alice',
version => 3.142;
our $NAME = 'Bob';
our $BOYS_NAME = 'Bob';
our $ALIASES = ['Robert', 'Rob'];
our $FRIENDS = {
jim => 'Jim',
};
our $ONE = '2 Minutes to Midnight';
package main;
# base methods
my $alice = Alice->new();
ok( $alice, 'Alice is alive' );
is( $alice->class, 'Alice', "Alice's class is Alice" );
is( $alice->VERSION, 2.718, "Alice's version is 2.718" );
is( $Alice::VERSION, 2.718, "Alice's VERSION is 2.718" );
# derived methods
my $bob = Bob->new();
ok( $bob, 'Bob is alive' );
is( $bob->class, 'Bob', "Bob's class is Bob" );
is( $bob->class->parents->[0], 'Alice', "Bob's parent is Alice" );
is( join(', ', $bob->class->heritage), 'Bob, Alice', "Bob's heritage is Bob, Alice" );
is( join(', ', $bob->classes), 'Bob, Alice', "Bob's classes are Bob, Alice" );
is( $bob->VERSION, 3.142, "Bob has version of 3.142" );
# base vars
is( $alice->class->var('NAME'), 'Alice', 'Alice var $NAME' );
is( $alice->class->var('GIRLS_NAME'), 'Alice', 'Alice var $GIRLS_NAME' );
# derived vars
is( $bob->class->var('NAME'), 'Bob', 'Bob var $NAME' );
is( $bob->class->var('BOYS_NAME'), 'Bob', 'Bob var $BOYS_NAME' );
is( join(', ', $alice->class->any_var('NAME')), 'Alice', 'Alice any_var $NAME' );
is( join(', ', $bob->class->any_var('NAME')), 'Bob', 'Bob any_var $NAME' );
is( join(', ', $alice->class->any_var_in('ONE', 'TWO')), '22 Acacia Avenue', 'Alice is Charlotte' );
is( join(', ', $alice->class->any_var_in('ONE TWO')), '22 Acacia Avenue', 'She lives at 22 Acacia Avenue' );
is( join(', ', $alice->class->any_var_in(['ONE', 'TWO'])), '22 Acacia Avenue', "That's the place where we all go" );
is( join(', ', $bob->class->any_var_in('ONE', 'TWO')), '2 Minutes to Midnight', "Bob says it's 2 minutes to midnight" );
is( join(', ', $bob->class->any_var_in('ONE TWO')), '2 Minutes to Midnight', "The hand that threatens doom" );
is( join(', ', $bob->class->any_var_in(['ONE', 'TWO'])), '2 Minutes to Midnight', "Kill the unborn in the womb" );
is( join(', ', $alice->class->all_vars('NAME')), 'Alice', 'Alice all_vars $NAME' );
is( join(', ', $bob->class->all_vars('NAME')), 'Bob, Alice', 'Bob all_vars $NAME' );
# merged list var
is( join(', ', @{ $alice->class->list_vars('ALIASES') }), 'Ally, Ali', 'Alice ALIASES' );
is( join(', ', @{ $bob->class->list_vars('ALIASES') }), 'Robert, Rob, Ally, Ali', 'Bob ALIASES' );
# merged hash var
my $friends = $alice->class->hash_vars('FRIENDS');
is( join(', ', keys %$friends), 'sue', 'Alice FRIENDS with sue' );
is( join(', ', values %$friends), 'Susan', 'Alice FRIENDS with Susan' );
$friends = $bob->class->hash_vars('FRIENDS');
is( join(', ', sort keys %$friends), 'jim, sue', 'Bob FRIENDS with jim and sue' );
is( join(', ', sort values %$friends), 'Jim, Susan', 'Bob FRIENDS with Jim and Susan' );
# check that CLASS works
is( $alice->my_class, 'Alice', 'Alice has my_class set to Alice' );
is( $bob->my_class, 'Alice', "Bob also has my_class set to Alice, but that's OK" );
#-----------------------------------------------------------------------
# test inheritance via the base() method
#-----------------------------------------------------------------------
package Charlie;
use Badger::Class
import => 'class';
class->base('Alice');
package main;
my $chas = Charlie->new();
ok( $chas, 'Created Charlie' );
is( $chas->VERSION, 2.718, 'Charlie inherits version from Alice' );
package David;
use Badger::Class 'class', base => 'Charlie';
class->version(42);
class->constant( volume => 11 );
package main;
my $dave = David->new();
ok( $dave, 'Created David' );
is( $dave->VERSION, 42, "David's version is at level 42" );
is( $dave->volume, 11, "David's volume goes up to 11" ); # should be Nigel!
#-----------------------------------------------------------------------
# test a crazy inheritance model
#-----------------------------------------------------------------------
package Ten; use Badger::Class version => 1;
package Nine; use Badger::Class version => 1;
package Eight; use Badger::Class version => 1, base => 'Nine';
package Seven; use Badger::Class version => 1, base => 'Eight Ten';
package Six; use Badger::Class version => 1, base => 'Seven';
package Five; use Badger::Class version => 1, base => 'Eight';
package Four; use Badger::Class version => 1;
package Three; use Badger::Class version => 1, base => 'Four';
package Two; use Badger::Class version => 1, base => 'Three Five';
package One; use Badger::Class version => 1, base => 'Two Six', import => 'classes';
sub new {
my ($class, %self) = @_;
bless \%self, $class;
}
package main;
my $one = One->new();
ok( $one, 'Created One object' );
is( join(', ', $one->classes),
'One, Two, Three, Four, Five, Six, Seven, Eight, Nine, Ten',
'Got heritage classes for One' );
#-----------------------------------------------------------------------
# test regular class/classes import
#-----------------------------------------------------------------------
package Frank;
use Badger::Class qw( class classes );
main::is( class, 'Frank', 'class is Frank' );
package main;
ok( 1, 'Created Frank' );
is ( Frank->class, 'Frank', "Frank's class is Frank" );
#-----------------------------------------------------------------------
# test loading constants from T::Constants
#-----------------------------------------------------------------------
package Constantine;
use Badger::Class constants => 'HASH';
*is = \&main::is;
is( HASH, HASH, 'HASH is defined' );
#-----------------------------------------------------------------------
# test constant generation
#-----------------------------------------------------------------------
package Harry;
use Badger::Class
base => 'Alice',
constant => {
pi => 3.14,
e => 2.718,
},
import => 'class';
class->constant( phi => 1.618 );
*is = \&main::is;
is( pi, 3.14, 'In Harry, pi is a constant' );
is( e, 2.718, 'In Harry, e is a constant' );
is( phi(), 1.618, 'In Harry, phi is a constant' );
package main;
my $haz = Harry->new;
ok( $haz, 'Created Harry' );
is( $haz->pi, 3.14, "Harry's pi is a constant" );
is( $haz->e, 2.718, "Harry's e is a constant" );
is( $haz->phi, 1.618, "Harry's phi is a constant" );
#-----------------------------------------------------------------------
# test debug option
#-----------------------------------------------------------------------
package Danny;
use Badger::Class
base => 'Alice',
debug => 0;
main::is( $DEBUG, 0, 'Danny debugging is off' );
package main;
is( Danny->debugging, 0, 'Danny is not debugging' );
is( $Danny::DEBUG, 0, 'Danny $DEBUG is 0' );
is( Danny->debugging(1), 1, 'Danny is now debugging' );
is( $Danny::DEBUG, 1, 'Danny $DEBUG is 1' );
is( Danny->debugging, 1, 'Danny is still debugging' );
#-----------------------------------------------------------------------
# debug => $n should not overwrite an existing $DEBUG value;
#-----------------------------------------------------------------------
package Donny;
use Badger::Class
base => 'Alice',
debug => 0;
main::is( $DEBUG, 0, 'Donny debugging is off' );
package main;
is( Donny->debugging(1), 1, 'Donny is now debugging' );
is( Donny->debugging, 1, 'Donny is debugging' );
is( $Donny::DEBUG, 1, 'Donny $DEBUG is 1' );
is( Donny->debugging(0), 0, 'Donny is not debugging' );
is( $Donny::DEBUG, 0, 'Donny $DEBUG is 0' );
is( Donny->debugging, 0, 'Donny is still not debugging' );
#-----------------------------------------------------------------------
# test throws option
#-----------------------------------------------------------------------
package Chucker;
use Badger::Class
base => 'Alice Badger::Base',
debug => 0,
throws => 'food';
my $test = $THROWS; # should be defined
package main;
is( $Chucker::THROWS, 'food', "Initially food" );
is( Chucker->throws, 'food', 'Chucker throws food' );
is( $Chucker::THROWS, 'food', "It's very bad behaviour" );
is( Chucker->throws('egg'), 'egg', 'Chucky Egg' );
is( $Chucker::THROWS, 'egg', 'Now that was a great game' );
is( Chucker->throws, 'egg', 'So was Manic Miner' );
#-----------------------------------------------------------------------
# test messages option
#-----------------------------------------------------------------------
package Nigel;
use Badger::Class
base => 'Alice Badger::Base',
debug => 0,
import => 'class',
messages => {
one_louder => "Well, it's %s louder",
do_you_wear => "Do you wear %0?",
};
class->messages( goes_up_to => 'This <1> goes up to <2>' );
package main;
my $nigel = Nigel->new;
is( $nigel->message( one_louder => 'one' ),
"Well, it's one louder", "It's One louder"
);
is( $nigel->message( goes_up_to => amp => 'eleven' ),
"This amp goes up to eleven", 'Goes up to eleven'
);
#-----------------------------------------------------------------------
# test classes get autoloaded
#-----------------------------------------------------------------------
use Class::Top;
my $top = Class::Top->new;
my $mid = Class::Middle->new;
my $bot = Class::Bottom->new;
if ($DEBUG) {
print "HERITAGE: ", join(', ', $top->class->heritage), "\n";
print "Top ISA: ", join(', ', @Class::Top::ISA), "\n";
print "Middle ISA: ", join(', ', @Class::Middle::ISA), "\n";
print "Bottom ISA: ", join(', ', @Class::Bottom::ISA), "\n";
}
is( $bot->bottom, 'on the bottom', 'bot is on the bottom' );
is( $mid->bottom, 'on the bottom', 'mid is on the bottom' );
is( $top->bottom, 'on the bottom', 'top is on the bottom' );
is( $mid->middle, 'in the middle', 'mid is in the middle' );
is( $top->middle, 'in the middle', 'top is in the middle' );
is( $top->top, 'on the top', 'op on the top' );
is( $bot->class->id, 'class.bottom', 'bot id' );
is( $mid->class->id, 'class.middle', 'mid id' );
is( $top->class->id, 'class.top', 'top id' );
#-----------------------------------------------------------------------
# test codec/codecs
#-----------------------------------------------------------------------
package Test::Codec1;
use Badger::Test;
use Badger::Class codec => 'base64';
my $enc = encode('Hello World');
is( $enc, "SGVsbG8gV29ybGQ=\n", 'encoded base64' );
my $dec = decode($enc);
is( $dec, 'Hello World', 'decoded base64' );
#-----------------------------------------------------------------------
# test method() method
#-----------------------------------------------------------------------
package Test::Method1;
use Badger::Class
base => 'Badger::Base',
import => 'class';
sub init {
my ($self, $config) = @_;
$self->{ foo } = $config->{ foo };
$self->{ bar } = $config->{ bar };
return $self;
}
class->method( hello => sub { 'hello world' } );
class->methods( goodbye => sub { "see ya!" } );
class->get_methods('foo bar');
class->set_methods('wiz');
package main;
is( Test::Method1->hello, 'hello world', 'method() test' );
is( Test::Method1->goodbye, 'see ya!', 'methods() test' );
my $t1 = Test::Method1->new( foo => 'Hello', bar => 'World' );
is( $t1->foo, 'Hello', 'generated foo get method' );
is( $t1->bar, 'World', 'generated bar get method' );
is( $t1->wiz('waz'), 'waz', 'set wiz' );
is( $t1->wiz, 'waz', 'get wiz' );
#-----------------------------------------------------------------------
# and again via Badger::Class import hooks
#-----------------------------------------------------------------------
package Test::Method2;
use Badger::Class
base => 'Badger::Base',
import => 'class',
get_methods => 'ding dong',
set_methods => 'dang',
methods => {
welcome => sub { 'Hello World' },
farewell => 'Goodbye cruel world',
};
sub init {
my ($self, $config) = @_;
$self->{ ding } = $config->{ ding };
$self->{ dong } = $config->{ dong };
return $self;
}
package main;
is( Test::Method2->welcome, 'Hello World', 'welcome method' );
is( Test::Method2->farewell, 'Goodbye cruel world', 'farewell method' );
my $t2 = Test::Method2->new( ding => 'Wrong', dong => 'Number' );
is( $t2->ding, 'Wrong', 'generated ding get method' );
is( $t2->dong, 'Number', 'generated dong get method' );
is( $t2->dang('Ding-A-Ling'), 'Ding-A-Ling', 'set dang' );
is( $t2->dang, 'Ding-A-Ling', 'get dang' );
#-----------------------------------------------------------------------
# test generation of slot methods for list based objects
#-----------------------------------------------------------------------
package Badger::Test::Slots;
use Badger::Class
slots => 'size colour object';
sub new {
my ($class, @stuff) = @_;
bless \@stuff, $class;
}
package main;
my $bus = Badger::Test::Slots->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' );
#-----------------------------------------------------------------------
# test words
#-----------------------------------------------------------------------
package Test::Words1;
use Badger::Class words => 'Hubbins Tufnel Smalls';
use Badger::Test;
is( Hubbins, 'Hubbins', 'David St Hubbins' );
is( Tufnel, 'Tufnel', 'Nigel Tufnel' );
is( Smalls, 'Smalls', 'Derek Smalls' );
#-----------------------------------------------------------------------
# test class construction
#-----------------------------------------------------------------------
package Test::Amp::Construction;
use Badger::Class 'class';
use Badger::Test;
my $amp1 = class('Guitar::Amplifier')
->base('Badger::Base')
->constant( max_volume => 10 )
->method( about => sub { "This amp goes up to " . shift->max_volume } )
->instance;
is( $amp1->about, 'This amp goes up to 10', $amp1->about );
my $amp2 = class('Nigels::Guitar::Amplifier')
->base('Guitar::Amplifier')
->constant( max_volume => 11 )
->instance;
is( $amp2->about, 'This amp goes up to 11', $amp2->about );
my $method = $amp2->class->method('about');
ok( $method, 'got about() method' );
is( $method->($amp2), 'This amp goes up to 11', 'method reference call' );
#-----------------------------------------------------------------------
# test loaded()
#
# Like a river we will flow, on towards the sea we go, when all you do
# can only bring you sadness, out on the sea of madneeeeeeeessssss...
#-----------------------------------------------------------------------
# define this before
package Wasted::Years;
use base 'Badger::Base';
package main;
use Badger::Class 'class';
# both Wasted::Years and Heaven::Can::Wait should be deemed loaded by
# virtue of the fact that they define base classes which affects @ISA
ok( class('Wasted::Years')->loaded, 'Wasted Years is loaded' );
ok( ! class('Sea::Of::Madness')->loaded, 'Sea of Madness is not loaded' );
ok( class('Heaven::Can::Wait')->loaded, 'Heaven Can Wait is loaded' );
# define this after
package Heaven::Can::Wait;
use base 'Badger::Base';
#-----------------------------------------------------------------------
# subclass Badger::Class
#-----------------------------------------------------------------------
package Test::My::Class;
use My::Class
version => 11,
import => 'class',
constants => 'black none',
wibble => 'This is mic number one',
wobble => "Isn't this a lot of fun?";
sub colour {
black
}
main::is( $VERSION, 11, 'inside version 11' );
main::is( ref class(), 'My::Class', 'class returns My::Class object' );
package main;
is( $Test::My::Class::VERSION, 11, 'outside version 11' );
is( Test::My::Class->colour, 'black', 'How much more black could this be?' );
is( Test::My::Class->none, 'none', 'None, none more black' );
is( Test::My::Class->wibble, 'wibble: This is mic number one', 'wibble hook worked' );
is( Test::My::Class->wobble, "wobble: Isn't this a lot of fun?", 'wobble hook worked' );
#-----------------------------------------------------------------------
# test filesystem hooks
#-----------------------------------------------------------------------
package Test::My::Filesystem;
use Badger::Class
version => 1,
filesystem => 'FS VFS';
package main;
is( Test::My::Filesystem->FS, 'Badger::Filesystem', 'FS loaded' );
is( Test::My::Filesystem->VFS, 'Badger::Filesystem::Virtual', 'VFS loaded' );
#-----------------------------------------------------------------------
# test load() and maybe_load()
#-----------------------------------------------------------------------
is( class('No::Such::Module')->maybe_load, 0, 'cannot load No::Such::Module' );
#$Badger::Class::DEBUG = 1;
ok( ! eval { class('My::BadModule')->maybe_load }, 'maybe_load threw error' );
like( $@, qr/^Can't locate object method/, "Can't locate object method error" );
#-----------------------------------------------------------------------
# test overload
#-----------------------------------------------------------------------
package Badger::Test::Overload;
use Badger::Class
base => 'Badger::Base',
constants => 'TRUE',
accessors => 'text',
overload => {
'""' => \&text,
bool => sub { 1 },
fallback => 1,
};
sub init {
my ($self, $config) = @_;
$self->{ text } = $config->{ text };
return $self;
}
package main;
my $text = Badger::Test::Overload->new( text => 'Hello World' );
is( $text, 'Hello World', 'overloaded text method' );
$text = Badger::Test::Overload->new( text => '' );
ok( $text, 'boolean overload true' );
#-----------------------------------------------------------------------
# test as_text
#-----------------------------------------------------------------------
package Badger::Test::AsText;
use Badger::Class
base => 'Badger::Base',
constants => 'TRUE',
accessors => 'text',
as_text => 'text';
sub init {
my ($self, $config) = @_;
$self->{ text } = $config->{ text };
return $self;
}
package main;
$text = Badger::Test::AsText->new( text => 'Hello Badger' );
is( $text, 'Hello Badger', 'as_text method' );
$text = Badger::Test::AsText->new( text => '0' );
ok( ! $text, 'no boolean overload' );
#-----------------------------------------------------------------------
# test is_true
#-----------------------------------------------------------------------
package Badger::Test::AsBool;
use Badger::Class
base => 'Badger::Base',
accessors => 'text',
as_text => 'text',
is_true => 1;
sub init {
my ($self, $config) = @_;
$self->{ text } = $config->{ text };
return $self;
}
package main;
$text = Badger::Test::AsBool->new( text => 'Hello Moose' );
is( $text, 'Hello Moose', 'is true as_text method' );
$text = Badger::Test::AsBool->new( text => '0' );
ok( $text, 'is true boolean overload' );
#-----------------------------------------------------------------------
# should be able to export bclass() as an alias for class()
#-----------------------------------------------------------------------
package Badger::Test::BClass;
use Badger::Class
import => 'bclass';
our $THINGY = 'frusset pouch';
sub thingy {
shift->bclass->var('THINGY');
}
package main;
is( Badger::Test::BClass->thingy, 'frusset pouch',
'you have pleasantly wibbled my frusset pouch' );
#-----------------------------------------------------------------------
# test alias method
#-----------------------------------------------------------------------
package Badger::Test::Alias;
use Badger::Class
base => 'Badger::Base',
debug => 0,
import => 'class';
sub foo {
'this is foo';
}
class->alias( bar => 'foo' );
package main;
my $alias = Badger::Test::Alias->new;
is( $alias->foo, 'this is foo', 'alias foo' );
is( $alias->bar, 'this is foo', 'alias bar' );
package Badger::Test::SubAlias;
use Badger::Class
base => 'Badger::Test::Alias',
alias => {
wiz => 'foo',
};
package main;
$alias = Badger::Test::SubAlias->new;
is( $alias->foo, 'this is foo', 'sub alias foo' );
is( $alias->bar, 'this is foo', 'sub alias bar' );
is( $alias->wiz, 'this is foo', 'sub alias wiz' );
__END__
#-----------------------------------------------------------------------
# test CLASS
#-----------------------------------------------------------------------
package Test::Badger::Amp;
use Badger::Class
constant => { max_volume => 10 };
sub volume { shift->max_volume }
package Test::Badger::Amp::Louder;
use Badger::Class
base => 'Test::Badger::Amp',
constant => { max_volume => 11 };
package main;
is( Test::Badger::Amp->volume, 10, 'This amp goes up to 10' );
is( Test::Badger::Amp::Louder->volume, 11, 'This amp goes up to 11' );
__END__
__END__
# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# vim: expandtab shiftwidth=4: