From 42649bc1d2194c0c0cb1d49645066fc6b6d1be64 Mon Sep 17 00:00:00 2001 From: Brian Fraser Date: Fri, 13 Jul 2012 00:43:17 -0300 Subject: [PATCH] Add t/lib/Mo and a bunch of tests --- t/lib/Mo/Bar.pm | 4 + t/lib/Mo/Boo.pm | 6 + t/lib/Mo/Foo.pm | 6 + t/lib/Mo/build.t | 51 +++++ t/lib/Mo/buildargs.t | 62 ++++++ t/lib/Mo/coerce.t | 26 +++ t/lib/Mo/extends.t | 24 +++ t/lib/Mo/handles.t | 480 +++++++++++++++++++++++++++++++++++++++++++ t/lib/Mo/init_arg.t | 91 ++++++++ t/lib/Mo/is.t | 26 +++ t/lib/Mo/isa.t | 121 +++++++++++ t/lib/Mo/object.t | 18 ++ t/lib/Mo/required.t | 39 ++++ t/lib/Mo/strict.t | 17 ++ t/lib/Mo/test.t | 140 +++++++++++++ 15 files changed, 1111 insertions(+) create mode 100644 t/lib/Mo/Bar.pm create mode 100644 t/lib/Mo/Boo.pm create mode 100644 t/lib/Mo/Foo.pm create mode 100644 t/lib/Mo/build.t create mode 100644 t/lib/Mo/buildargs.t create mode 100644 t/lib/Mo/coerce.t create mode 100644 t/lib/Mo/extends.t create mode 100644 t/lib/Mo/handles.t create mode 100644 t/lib/Mo/init_arg.t create mode 100644 t/lib/Mo/is.t create mode 100644 t/lib/Mo/isa.t create mode 100644 t/lib/Mo/object.t create mode 100644 t/lib/Mo/required.t create mode 100644 t/lib/Mo/strict.t create mode 100644 t/lib/Mo/test.t diff --git a/t/lib/Mo/Bar.pm b/t/lib/Mo/Bar.pm new file mode 100644 index 00000000..1a4a2410 --- /dev/null +++ b/t/lib/Mo/Bar.pm @@ -0,0 +1,4 @@ +package Bar; +use Mo; +extends 'Foo'; +1; diff --git a/t/lib/Mo/Boo.pm b/t/lib/Mo/Boo.pm new file mode 100644 index 00000000..b6a716ee --- /dev/null +++ b/t/lib/Mo/Boo.pm @@ -0,0 +1,6 @@ +package Boo; +use Mo; + +has 'buff'; + +1; diff --git a/t/lib/Mo/Foo.pm b/t/lib/Mo/Foo.pm new file mode 100644 index 00000000..728da69d --- /dev/null +++ b/t/lib/Mo/Foo.pm @@ -0,0 +1,6 @@ +package Foo; +use Mo; + +has 'stuff'; + +1; diff --git a/t/lib/Mo/build.t b/t/lib/Mo/build.t new file mode 100644 index 00000000..1aa70c0b --- /dev/null +++ b/t/lib/Mo/build.t @@ -0,0 +1,51 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More; + +$main::count = 1; + +package Foo; +use Mo 'build'; +has 'foo' => (is => 'rw'); +sub BUILD { + my $self = shift; + ::is_deeply(\@_, [qw(stuff 1)], "Foo's BUILD doesn't get the class name"); + $self->foo($main::count++); +} + +package Bar; +use Mo; +extends 'Foo'; +has 'bar' => (is => 'rw'); + +package Baz; +use Mo; +extends 'Bar'; +has 'baz' => (is => 'rw'); +sub BUILD { + my $self = shift; + ::is_deeply(\@_, [qw(stuff 1)], "Baz's BUILD doesn't get the class name"); + $self->baz($main::count++); +} + +package Gorch; +use Mo; +extends 'Baz'; +has 'gorch' => (is => 'rw'); + +package main; + +my $g = Gorch->new(stuff => 1); +is $g->foo, 1, 'foo builds first'; +is $g->baz, 2, 'baz builds second'; + +done_testing; diff --git a/t/lib/Mo/buildargs.t b/t/lib/Mo/buildargs.t new file mode 100644 index 00000000..403bd55d --- /dev/null +++ b/t/lib/Mo/buildargs.t @@ -0,0 +1,62 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More; + +$main::count = 0; + +{ + package Nothing; + use Mo; + has nothing_special => ( is => 'rw' ); +} +ok(Nothing->can("BUILDARGS"), "Every class automatically gets buildargs"); + +package Foo; +use Mo; +has 'foo' => (is => 'rw'); +sub BUILDARGS { + my $class = shift; + $main::count++; + $class->SUPER::BUILDARGS(@_); +} + +package Bar; +use Mo; +extends 'Foo'; +has 'bar' => (is => 'rw'); + +package Baz; +use Mo; +extends 'Bar'; +has 'baz' => (is => 'rw'); +sub BUILDARGS { + my $class = shift; + $main::count++; + $class->SUPER::BUILDARGS(@_) +} + +package Gorch; +use Mo; +extends 'Baz'; +has 'gorch' => (is => 'rw'); + +package main; + +$main::count = 0; +my $g = Foo->new; +is $main::count, 1, "A class with no explicit parent inherits SUPER::BUILDARGS from Mo::Object"; + +$main::count = 0; +$g = Gorch->new; +is $main::count, 2, "As does one with a parent that defines it's own BUILDARGS"; + +done_testing; diff --git a/t/lib/Mo/coerce.t b/t/lib/Mo/coerce.t new file mode 100644 index 00000000..2a69fcfa --- /dev/null +++ b/t/lib/Mo/coerce.t @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More; + +plan tests => 2; + +package Foo::coerce; +use Mo; + +has 'stuff' => (coerce => sub { uc $_[0] }); + +package main; + +my $f = Foo::coerce->new(stuff => 'fubar'); +is $f->stuff, 'FUBAR', 'values passed to constructor are successfully coerced'; +$f->stuff('barbaz'); +is $f->stuff, 'BARBAZ', 'values passed to setters are successfully coerced'; diff --git a/t/lib/Mo/extends.t b/t/lib/Mo/extends.t new file mode 100644 index 00000000..4cc738d8 --- /dev/null +++ b/t/lib/Mo/extends.t @@ -0,0 +1,24 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More tests => 4; + +use lib "$ENV{PERCONA_TOOLKIT_BRANCH}/t/lib/Mo"; +use Bar; + +my $b = Bar->new; + +ok $b->isa('Foo'), 'Bar is a subclass of Foo'; + +is "@Bar::ISA", "Foo", 'Extends with multiple classes not supported'; + +ok 'Foo'->can('stuff'), 'Foo is loaded'; +ok not('Bar'->can('buff')), 'Boo is not loaded'; diff --git a/t/lib/Mo/handles.t b/t/lib/Mo/handles.t new file mode 100644 index 00000000..47a283b3 --- /dev/null +++ b/t/lib/Mo/handles.t @@ -0,0 +1,480 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More tests => 82; + + +# ------------------------------------------------------------------- +# HASH handles +# ------------------------------------------------------------------- +# the canonical form of of the 'handles' +# option is the hash ref mapping a +# method name to the delegated method name + +{ + package Foo; + use Mo qw(is required handles default builder); + + has 'bar' => (is => 'rw', default => sub { 10 }); + + sub baz { 42 } + + package Bar; + use Mo qw(is required handles default builder); + + has 'foo' => ( + is => 'rw', + default => sub { Foo->new }, + handles => { + 'foo_bar' => 'bar', + foo_baz => 'baz', + 'foo_bar_to_20' => [ bar => 20 ], + }, + ); +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +ok($bar->foo, '... we have something in bar->foo'); +isa_ok($bar->foo, 'Foo'); + +is($bar->foo->bar, 10, '... bar->foo->bar returned the right default'); + +can_ok($bar, 'foo_bar'); +is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly'); + +# change the value ... + +$bar->foo->bar(30); + +# and make sure the delegation picks it up + +is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); +is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); + +# change the value through the delegation ... + +$bar->foo_bar(50); + +# and make sure everyone sees it + +is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); +is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); + +# change the object we are delegating too + +my $foo = Foo->new(bar => 25); +isa_ok($foo, 'Foo'); + +is($foo->bar, 25, '... got the right foo->bar'); + +local $@; +eval { $bar->foo($foo) }; +is $@, '', '... assigned the new Foo to Bar->foo'; + +is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); + +is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); +is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); + +# curried handles +$bar->foo_bar_to_20; +is($bar->foo_bar, 20, '... correctly curried a single argument'); + +# ------------------------------------------------------------------- +# ARRAY handles +# ------------------------------------------------------------------- +# we also support an array based format +# which assumes that the name is the same +# on either end + +{ + package Engine; + use Mo qw(is required handles default builder); + + sub go { 'Engine::go' } + sub stop { 'Engine::stop' } + + package Car; + use Mo qw(is required handles default builder); + + has 'engine' => ( + is => 'rw', + default => sub { Engine->new }, + handles => [ 'go', 'stop' ] + ); +} + +my $car = Car->new; +isa_ok($car, 'Car'); + +isa_ok($car->engine, 'Engine'); +can_ok($car->engine, 'go'); +can_ok($car->engine, 'stop'); + +is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go'); +is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop'); + +can_ok($car, 'go'); +can_ok($car, 'stop'); + +is($car->go, 'Engine::go', '... got the right value from ->go'); +is($car->stop, 'Engine::stop', '... got the right value from ->stop'); + +# ------------------------------------------------------------------- +# REGEXP handles +# ------------------------------------------------------------------- +# and we support regexp delegation + +{ + package Baz; + use Mo qw(is required handles default builder); + + sub foo { 'Baz::foo' } + sub bar { 'Baz::bar' } + sub boo { 'Baz::boo' } + + package Baz::Proxy1; + use Mo qw(is required handles default builder); + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/.*/ + ); + + package Baz::Proxy2; + use Mo qw(is required handles default builder); + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/.oo/ + ); + + package Baz::Proxy3; + use Mo qw(is required handles default builder); + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/b.*/ + ); +} + +{ + my $baz_proxy = Baz::Proxy1->new; + isa_ok($baz_proxy, 'Baz::Proxy1'); + + can_ok($baz_proxy, 'baz'); + isa_ok($baz_proxy->baz, 'Baz'); + + can_ok($baz_proxy, 'foo'); + can_ok($baz_proxy, 'bar'); + can_ok($baz_proxy, 'boo'); + + is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); + is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); + is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); +} +{ + my $baz_proxy = Baz::Proxy2->new; + isa_ok($baz_proxy, 'Baz::Proxy2'); + + can_ok($baz_proxy, 'baz'); + isa_ok($baz_proxy->baz, 'Baz'); + + can_ok($baz_proxy, 'foo'); + can_ok($baz_proxy, 'boo'); + + is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); + is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); +} +{ + my $baz_proxy = Baz::Proxy3->new; + isa_ok($baz_proxy, 'Baz::Proxy3'); + + can_ok($baz_proxy, 'baz'); + isa_ok($baz_proxy->baz, 'Baz'); + + can_ok($baz_proxy, 'bar'); + can_ok($baz_proxy, 'boo'); + + is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); + is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); +} + +# ------------------------------------------------------------------- +# ROLE handles +# ------------------------------------------------------------------- +=begin +{ + package Foo::Bar; + use Moose::Role; + + requires 'foo'; + requires 'bar'; + + package Foo::Baz; + use Mo qw(is required handles default builder); + + sub foo { 'Foo::Baz::FOO' } + sub bar { 'Foo::Baz::BAR' } + sub baz { 'Foo::Baz::BAZ' } + + package Foo::Thing; + use Mo qw(is required handles default builder); + + has 'thing' => ( + is => 'rw', + isa => 'Foo::Baz', + handles => 'Foo::Bar', + ); + + package Foo::OtherThing; + use Mo qw(is required handles default builder); + use Moose::Util::TypeConstraints; + + has 'other_thing' => ( + is => 'rw', + isa => 'Foo::Baz', + handles => Mooose::Util::TypeConstraints::find_type_constraint('Foo::Bar'), + ); +} + +{ + my $foo = Foo::Thing->new(thing => Foo::Baz->new); + isa_ok($foo, 'Foo::Thing'); + isa_ok($foo->thing, 'Foo::Baz'); + + ok($foo->meta->has_method('foo'), '... we have the method we expect'); + ok($foo->meta->has_method('bar'), '... we have the method we expect'); + ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect'); + + is($foo->foo, 'Foo::Baz::FOO', '... got the right value'); + is($foo->bar, 'Foo::Baz::BAR', '... got the right value'); + is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value'); +} + +{ + my $foo = Foo::OtherThing->new(other_thing => Foo::Baz->new); + isa_ok($foo, 'Foo::OtherThing'); + isa_ok($foo->other_thing, 'Foo::Baz'); + + ok($foo->meta->has_method('foo'), '... we have the method we expect'); + ok($foo->meta->has_method('bar'), '... we have the method we expect'); + ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect'); + + is($foo->foo, 'Foo::Baz::FOO', '... got the right value'); + is($foo->bar, 'Foo::Baz::BAR', '... got the right value'); + is($foo->other_thing->baz, 'Foo::Baz::BAZ', '... got the right value'); +} +=cut +# ------------------------------------------------------------------- +# AUTOLOAD & handles +# ------------------------------------------------------------------- + +{ + package Foo::Autoloaded; + use Mo qw(is required handles default builder); + + sub AUTOLOAD { + my $self = shift; + + my $name = our $AUTOLOAD; + $name =~ s/.*://; # strip fully-qualified portion + + if (@_) { + return $self->{$name} = shift; + } else { + return $self->{$name}; + } + } + + package Bar::Autoloaded; + use Mo qw(is required handles default builder); + + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => { 'foo_bar' => 'bar' } + ); + + package Baz::Autoloaded; + use Mo qw(is required handles default builder); + + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => ['bar'] + ); + + package Goorch::Autoloaded; + use Mo qw(is required handles default builder); + + eval { + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => qr/bar/ + ); + }; + ::isnt($@, '', '... you cannot delegate to AUTOLOADED class with regexp' ); +} + +# check HASH based delegation w/ AUTOLOAD + +{ + my $bar = Bar::Autoloaded->new; + isa_ok($bar, 'Bar::Autoloaded'); + + ok($bar->foo, '... we have something in bar->foo'); + isa_ok($bar->foo, 'Foo::Autoloaded'); + + # change the value ... + + $bar->foo->bar(30); + + # and make sure the delegation picks it up + + is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); + is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); + + # change the value through the delegation ... + + $bar->foo_bar(50); + + # and make sure everyone sees it + + is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); + is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); + + # change the object we are delegating too + + my $foo = Foo::Autoloaded->new; + isa_ok($foo, 'Foo::Autoloaded'); + + $foo->bar(25); + + is($foo->bar, 25, '... got the right foo->bar'); + + local $@; + eval { $bar->foo($foo) }; + is($@, '', '... assigned the new Foo to Bar->foo' ); + + is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); + + is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); + is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); +} + +# check ARRAY based delegation w/ AUTOLOAD + +{ + my $baz = Baz::Autoloaded->new; + isa_ok($baz, 'Baz::Autoloaded'); + + ok($baz->foo, '... we have something in baz->foo'); + isa_ok($baz->foo, 'Foo::Autoloaded'); + + # change the value ... + + $baz->foo->bar(30); + + # and make sure the delegation picks it up + + is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value'); + is($baz->bar, 30, '... baz->foo_bar delegated correctly'); + + # change the value through the delegation ... + + $baz->bar(50); + + # and make sure everyone sees it + + is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value'); + is($baz->bar, 50, '... baz->foo_bar delegated correctly'); + + # change the object we are delegating too + + my $foo = Foo::Autoloaded->new; + isa_ok($foo, 'Foo::Autoloaded'); + + $foo->bar(25); + + is($foo->bar, 25, '... got the right foo->bar'); + + is( exception { + $baz->foo($foo); + }, undef, '... assigned the new Foo to Baz->foo' ); + + is($baz->foo, $foo, '... assigned baz->foo with the new Foo'); + + is($baz->foo->bar, 25, '... baz->foo->bar returned the right result'); + is($baz->bar, 25, '... and baz->foo_bar delegated correctly again'); +} + +# Make sure that a useful error message is thrown when the delegation target is +# not an object +{ + my $i = Bar->new(foo => undef); + local $@; + eval { $i->foo_bar }; + like($@, qr/is not defined/, 'useful error from unblessed reference' ); + + my $j = Bar->new(foo => []); + local $@; + eval { $j->foo_bar }; + like($@, qr/is not an object \(got 'ARRAY/, 'useful error from unblessed reference' ); + + my $k = Bar->new(foo => "Foo"); + local $@; + eval { $k->foo_baz }; + is( $@, '', "but not for class name" ); +} + +{ + package Delegator; + use Mo qw(is required handles default builder); + + sub full { 1 } + sub stub; + + local $@; + eval { + has d1 => ( + isa => 'X', + handles => ['full'], + ); + }; + ::like( + $@, + qr/\QYou cannot overwrite a locally defined method (full) with a delegation/, + 'got an error when trying to declare a delegation method that overwrites a local method' + ); + + local $@; + eval { has d2 => ( + isa => 'X', + handles => ['stub'], + ); + }; + ::is( + $@, + '', + 'no error when trying to declare a delegation method that overwrites a stub method' + ); +} + diff --git a/t/lib/Mo/init_arg.t b/t/lib/Mo/init_arg.t new file mode 100644 index 00000000..b6fab8d4 --- /dev/null +++ b/t/lib/Mo/init_arg.t @@ -0,0 +1,91 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More; + + + +{ + package Foo; + use Mo qw( is init_arg ); + + eval { + has 'foo' => ( + is => "rw", + init_arg => undef, + ); + }; + ::ok(!$@, '... created the attr okay'); +} + +{ + my $foo = Foo->new( foo => "bar" ); + isa_ok($foo, 'Foo'); + + is( $foo->foo, undef, "field is not set via init arg" ); + + $foo->foo("blah"); + + is( $foo->foo, "blah", "field is set via setter" ); +} + +{ + package Foo; + + eval { + has 'foo2' => ( + is => "rw", + init_arg => undef, + ); + }; + ::ok(!$@, '... adding a second attribute with init_arg works'); +} + +{ + my $foo = Foo->new( foo => "bar", foo2 => "baz" ); + + is( $foo->foo, undef, "foo is not set via init arg" ); + is( $foo->foo2, undef, "foo2 is not set via init arg" ); + + $foo->foo("blah"); + $foo->foo2("bluh"); + + is( $foo->foo, "blah", "foo is set via setter" ); + is( $foo->foo2, "bluh", "foo2 is set via setter" ); +} + +{ + package Foo2; + use Mo qw( is init_arg clearer default ); + + my $counter; + eval { + has 'auto_foo' => ( + is => "ro", + init_arg => undef, + default => sub { $counter++ ? "Foo" : "Bar" }, + clearer => 'clear_auto_foo', + ); + }; + ::ok(!$@, '... attribute with init_arg+default+clearer+is works'); +} + +{ + my $foo = Foo2->new( auto_foo => 1234 ); + + is( $foo->auto_foo, "Bar", "auto_foo is not set via init arg, but by the default" ); + + $foo->clear_auto_foo(); + + is( $foo->auto_foo, "Foo", "auto_foo calls default again if cleared" ); +} + +done_testing; diff --git a/t/lib/Mo/is.t b/t/lib/Mo/is.t new file mode 100644 index 00000000..154f86a4 --- /dev/null +++ b/t/lib/Mo/is.t @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More; + +plan tests => 2; + +package Foo::is; +use Mo qw(is); + +has 'stuff' => (is => 'ro'); + +package main; + +my $f = Foo::is->new(stuff => 'foo'); +is $f->stuff, 'foo', 'values passed to constructor are successfully accepted'; +eval { $f->stuff('barbaz') }; +ok $@, 'setting values after initialization throws an exception'; diff --git a/t/lib/Mo/isa.t b/t/lib/Mo/isa.t new file mode 100644 index 00000000..e90519dc --- /dev/null +++ b/t/lib/Mo/isa.t @@ -0,0 +1,121 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More tests => 80; + +sub dies_ok (&;$) { + my $code = shift; + my $name = shift; + + ok( !eval{ $code->() }, $name ) + or diag( "expected an exception but none was raised" ); +} + +sub lives_ok (&;$) { + my $code = shift; + my $name = shift; + + eval{ $code->() }; + is($@, '', $name ); +} + +package Foo::isa; +use Mo qw(isa); + +my @types = qw(Bool Num Int Str ArrayRef CodeRef HashRef RegexpRef); +my @refs = ([], sub { }, {}, qr( )); +has( "my$_" => ( isa => $_ ) ) for @types; +has( myFoo => ( isa => "Foo::isa" ) ); + +package main; + +my $foo = Foo::isa->new( myStr => "abcdefg" ); + +# Bool: +lives_ok { ok !$foo->myBool(undef) } "Bool attr set to undef"; +lives_ok { is $foo->myBool(1), 1 } "Bool attr set to 1"; +is $foo->myBool, 1, "new value of \$foo->myBool as expected"; +lives_ok { is $foo->myBool(1e0), 1 } "Bool attr set to 1e0"; +dies_ok { $foo->myBool("1f0") } "Bool attr set to 1f0 dies"; +lives_ok { is $foo->myBool(""), "" } "Bool attr set to empty string"; +is $foo->myBool, "", "new value of \$foo->myBool as expected"; +lives_ok { is $foo->myBool(0), 0 } "Bool attr set to 0"; +lives_ok { is $foo->myBool(0.0), 0 } "Bool attr set to 0.0"; +lives_ok { is $foo->myBool(0e0), 0 } "Bool attr set to 0e0"; +dies_ok { $foo->myBool("0.0") } "Bool attr set to stringy 0.0 dies"; + +# Bool tests from Mouse: +open(my $FH, "<", $0) or die "Could not open $0 for the test"; +my $msg = q(Bool rejects anything which is not a 1 or 0 or "" or undef"); +lives_ok { $foo->myBool(0) } $msg; +lives_ok { $foo->myBool(1) } $msg; +dies_ok { $foo->myBool(100) } $msg; +lives_ok { $foo->myBool("") } $msg; +dies_ok { $foo->myBool("Foo") } $msg; +dies_ok { $foo->myBool([]) } $msg; +dies_ok { $foo->myBool({}) } $msg; +dies_ok { $foo->myBool(sub {}) } $msg; +dies_ok { $foo->myBool(\"") } $msg; +dies_ok { $foo->myBool(*STDIN) } $msg; +dies_ok { $foo->myBool(\*STDIN) } $msg; +dies_ok { $foo->myBool($FH) } $msg; +dies_ok { $foo->myBool(qr/../) } $msg; +dies_ok { $foo->myBool(bless {}, "Foo") } $msg; +lives_ok { $foo->myBool(undef) } $msg; + +# Num: +lives_ok { is $foo->myNum(5.5), 5.5 } "Num attr set to decimal"; +is $foo->myNum, 5.5, "new value of \$foo->myNum as expected"; +lives_ok { is $foo->myNum(5), 5 } "Num attr set to integer"; +lives_ok { is $foo->myNum(5e0), 5 } "Num attr set to 5e0"; +dies_ok { $foo->myBool("5f0") } "Bool attr set to 5f0 dies"; +lives_ok { is $foo->myNum("5.5"), 5.5 } "Num attr set to stringy decimal"; + +# Int: +lives_ok { is $foo->myInt(0), 0 } "Int attr set to 0"; +lives_ok { is $foo->myInt(1), 1 } "Int attr set to 1"; +lives_ok { is $foo->myInt(1e0), 1 } "Int attr set to 1e0"; +is $foo->myInt, 1, "new value of \$foo->myInt as expected"; +dies_ok { $foo->myInt("") } "Int attr set to empty string dies"; +dies_ok { $foo->myInt(5.5) } "Int attr set to decimal dies"; + +# Str: +is $foo->myStr, "abcdefg", "Str passed to constructor accepted"; +lives_ok { is $foo->myStr("hijklmn"), "hijklmn" } "Str attr set to a string"; +is $foo->myStr, "hijklmn", "new value of \$foo->myStr as expected"; +lives_ok { is $foo->myStr(5.5), 5.5 } "Str attr set to a decimal value"; + +# Class instance: +lives_ok { is $foo->myFoo($foo), $foo } "Class instance attr set to self"; +isa_ok $foo->myFoo, "Foo::isa", "new value of \$foo->myFoo as expected"; +dies_ok { $foo->myFoo({}) } "Class instance attr set to hash dies"; + +# Class name: +my $class = ref($foo); +lives_ok { is $foo->myFoo($class), $class } "Class instance attr set to classname"; +is $foo->myFoo, $class, "new value of \$foo->myFoo as expected"; + +# Refs: +for my $i (4..7) { + my $method = "my" . $types[$i]; + lives_ok( + sub { $foo->$method($refs[$i - 4]) }, + "$types[$i] attr set to correct reference type" ); } +for my $i (4..7) { + my $method = "my" . $types[$i]; + dies_ok( + sub { $foo->$method($refs[(3 + $i) % 4]) }, + "$types[$i] attr set to incorrect reference type dies" ); } + +# All but Bool vs undef: +for my $type (@types[1..$#types]) { + my $method = "my$type"; + dies_ok { $foo->$method(undef) } "$type attr set to undef dies" } diff --git a/t/lib/Mo/object.t b/t/lib/Mo/object.t new file mode 100644 index 00000000..9aee9a21 --- /dev/null +++ b/t/lib/Mo/object.t @@ -0,0 +1,18 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More tests => 2; +use lib "$ENV{PERCONA_TOOLKIT_BRANCH}/t/lib/Mo"; + +{ package Clean; use Foo; } + +is_deeply([ @Clean::ISA ], [], "Didn't mess with caller's ISA"); +is(Clean->can('has'), undef, "Didn't export anything"); diff --git a/t/lib/Mo/required.t b/t/lib/Mo/required.t new file mode 100644 index 00000000..569f46cb --- /dev/null +++ b/t/lib/Mo/required.t @@ -0,0 +1,39 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More; + +plan tests => 3; + +#============ +package Foo::required; +use Mo qw(required); + +has 'stuff' => (required => 1); +has 'stuff2' => (required => 1); +has 'foo' => (); +#============ +package Foo::required_is; +use Mo qw(required); + +has 'stuff' => (required => 1, is => 'ro'); +#============ + +package main; + +my $f0 = eval { Foo::required->new(stuff2 => 'foobar') }; +like $@, qr/^\QAttribute (stuff) is required/, 'Mo dies when a required value is not provided'; + +my $f = Foo::required->new(stuff => 'fubar', stuff2 => 'foobar'); +is $f->stuff, 'fubar', 'Object is correctly initialized when required values are provided'; + +my $f2 = Foo::required_is->new(stuff => 'fubar'); +is $f2->stuff, 'fubar', 'Object is correctly initialized when required is combined with is'; diff --git a/t/lib/Mo/strict.t b/t/lib/Mo/strict.t new file mode 100644 index 00000000..8669ca43 --- /dev/null +++ b/t/lib/Mo/strict.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More tests => 1; + +eval 'package Foo; use Mo; $x = 1'; + +like $@, qr/Global symbol "\$x" requires explicit package name/, + 'Mo is strict'; diff --git a/t/lib/Mo/test.t b/t/lib/Mo/test.t new file mode 100644 index 00000000..80239654 --- /dev/null +++ b/t/lib/Mo/test.t @@ -0,0 +1,140 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More; + +plan tests => 39; + +#============ +package Foo; +use Mo; + +has 'this'; + +#============ +package main; + +ok defined(&Foo::has), 'Mo exports has'; +ok defined(&Foo::extends), 'Mo exports extends'; +ok not(defined(&Foo::new)), 'Mo does not export new'; +ok 'Foo'->isa('Mo::Object'), 'Foo isa Mo::Object'; +is "@Foo::ISA", "Mo::Object", '@Foo::ISA is Mo::Object'; +ok 'Foo'->can('new'), 'Foo can new'; +ok 'Foo'->can('this'), 'Foo can this'; + +my $f = 'Foo'->new; + +ok not(exists($f->{this})), 'this does not exist'; +ok not(defined($f->this)), 'this is not defined'; + +$f->this("it"); + +is $f->this, 'it', 'this is it'; +is $f->{this}, 'it', '{this} is it'; + +$f->this("that"); + +is $f->this, 'that', 'this is that'; +is $f->{this}, 'that', '{this} is that'; + +$f->this(undef); + +ok not(defined($f->this)), 'this is not defined'; +ok not(defined($f->{this})), '{this} is not defined'; + +#============ +package Bar; +use Mo 'builder', 'default'; +extends 'Foo'; + +has 'that'; +has them => default => sub {[]}; +has plop => ( + is => 'xy', + default => sub { my $self = shift; "plop: " . $self->that }, +); +has 'plip'; +has bridge => builder => 'bridge_builder'; +use constant bridge_builder => 'A Bridge'; +has guess => ( + default => sub {'me me me'}, + builder => 'bridge_builder', +); + +#============ +package main; + +ok 'Bar'->isa('Mo::Object'), 'Bar isa Mo::Object'; +ok 'Bar'->isa('Foo'), 'Bar isa Foo'; +is "@Bar::ISA", 'Foo', '@Bar::ISA is Foo'; +ok 'Bar'->can('new'), 'Bar can new'; +ok 'Bar'->can('this'), 'Bar can this'; +ok 'Bar'->can('that'), 'Bar can that'; +ok 'Bar'->can('them'), 'Bar can them'; + +my $b = Bar->new( + this => 'thing', + that => 'thong', +); + +is ref($b), 'Bar', 'Object created'; +ok $b->isa('Foo'), 'Inheritance works'; +ok $b->isa('Mo::Object'), 'Bar isa Mo::Object since Foo isa Mo::Object'; +is $b->this, 'thing', 'Read works in parent class'; +is $b->that, 'thong', 'Read works in current class'; +is ref($b->them), 'ARRAY', 'default works'; +is $b->plop, 'plop: thong', 'default works as a method call'; +$b->that("thung"); +$b->plop(undef); +ok not(defined $b->plop), 'plop is undef'; +delete $b->{plop}; +is $b->plop, 'plop: thung', 'default works again'; +$b->that("thyng"); +is $b->plop, 'plop: thung', 'default works again'; +is $b->plip, undef, 'no default is undef'; +is $b->bridge, 'A Bridge', 'builder works'; +is $b->guess, 'me me me', 'default trumps builder'; + +#============ +package Baz; +use Mo 'build'; + +has 'foo'; + +sub BUILD { + my $self = shift; + $self->foo(5); +} + +#============ +package Maz; +use Mo; +extends 'Baz'; + +has 'bar'; + +sub BUILD { + my $self = shift; + $self->SUPER::BUILD(); + $self->bar(7); +} + +#============ +package main; + +my $baz = Baz->new; +is $baz->foo, 5, 'BUILD works'; + +$_ = 5; +my $maz = Maz->new; +is $_, 5, '$_ is untouched'; +is $maz->foo, 5, 'BUILD works again'; +is $maz->bar, 7, 'BUILD works in parent class';