use strict;
use warnings;
-use Test::More tests => 50;
+use Test::More;
BEGIN {
use_ok('Class::MOP');
);
isa_ok(Class::MOP::Class->meta, 'Class::MOP::Class');
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 23;
+use Test::More;
use Test::Exception;
use Class::MOP;
use Class::MOP::Class;
-{
+{
package Foo;
use metaclass;
our $VERSION = '0.01';
-
+
package Bar;
our @ISA = ('Foo');
-
+
our $AUTHORITY = 'cpan:JRANDOM';
}
is_deeply([$Foo->superclasses], ['UNIVERSAL'], '... Foo->superclasses == (UNIVERSAL) now');
is_deeply(
- [ $Foo->class_precedence_list ],
- [ 'Foo', 'UNIVERSAL' ],
+ [ $Foo->class_precedence_list ],
+ [ 'Foo', 'UNIVERSAL' ],
'... Foo->class_precedence_list == (Foo, UNIVERSAL)');
is_deeply(
- [ $Bar->class_precedence_list ],
- [ 'Bar', 'Foo', 'UNIVERSAL' ],
+ [ $Bar->class_precedence_list ],
+ [ 'Bar', 'Foo', 'UNIVERSAL' ],
'... Bar->class_precedence_list == (Bar, Foo, UNIVERSAL)');
-
+
# create a class using Class::MOP::Class ...
my $Baz = Class::MOP::Class->create(
is_deeply([$Baz->superclasses], ['Bar'], '... Baz->superclasses == (Bar)');
is_deeply(
- [ $Baz->class_precedence_list ],
- [ 'Baz', 'Bar', 'Foo', 'UNIVERSAL' ],
+ [ $Baz->class_precedence_list ],
+ [ 'Baz', 'Bar', 'Foo', 'UNIVERSAL' ],
'... Baz->class_precedence_list == (Baz, Bar, Foo, UNIVERSAL)');
+done_testing;
use strict;
use warnings;
-use Test::More tests => 6;
+use Test::More;
use Class::MOP;
use Class::MOP::Class;
package My::B;
our @ISA = ('My::A');
package My::C;
- our @ISA = ('My::A');
- package My::D;
- our @ISA = ('My::B', 'My::C');
+ our @ISA = ('My::A');
+ package My::D;
+ our @ISA = ('My::B', 'My::C');
}
is_deeply(
- [ My::D->meta->class_precedence_list ],
- [ 'My::D', 'My::B', 'My::A', 'My::C', 'My::A' ],
+ [ My::D->meta->class_precedence_list ],
+ [ 'My::D', 'My::B', 'My::A', 'My::C', 'My::A' ],
'... My::D->meta->class_precedence_list == (D B A C A)');
is_deeply(
- [ My::D->meta->linearized_isa ],
- [ 'My::D', 'My::B', 'My::A', 'My::C' ],
+ [ My::D->meta->linearized_isa ],
+ [ 'My::D', 'My::B', 'My::A', 'My::C' ],
'... My::D->meta->linearized_isa == (D B A C)');
=pod
eval {
{
package My::2::A;
- use metaclass;
+ use metaclass;
our @ISA = ('My::2::C');
-
+
package My::2::B;
our @ISA = ('My::2::A');
-
+
package My::2::C;
- our @ISA = ('My::2::B');
+ our @ISA = ('My::2::B');
}
My::2::B->meta->class_precedence_list
{
package My::3::A;
- use metaclass;
+ use metaclass;
package My::3::B;
our @ISA = ('My::3::A');
package My::3::C;
- our @ISA = ('My::3::A', 'My::3::B');
- package My::3::D;
- our @ISA = ('My::3::B', 'My::3::C');
+ our @ISA = ('My::3::A', 'My::3::B');
+ package My::3::D;
+ our @ISA = ('My::3::B', 'My::3::C');
}
is_deeply(
- [ My::3::D->meta->class_precedence_list ],
- [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C', 'My::3::A', 'My::3::B', 'My::3::A' ],
+ [ My::3::D->meta->class_precedence_list ],
+ [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C', 'My::3::A', 'My::3::B', 'My::3::A' ],
'... My::3::D->meta->class_precedence_list == (D B A C A B A)');
is_deeply(
- [ My::3::D->meta->linearized_isa ],
- [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C' ],
+ [ My::3::D->meta->linearized_isa ],
+ [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C' ],
'... My::3::D->meta->linearized_isa == (D B A C B)');
=pod
{
package Foo;
- use metaclass;
-
- sub CPL { push @CLASS_PRECEDENCE_LIST => 'Foo' }
-
+ use metaclass;
+
+ sub CPL { push @CLASS_PRECEDENCE_LIST => 'Foo' }
+
package Bar;
our @ISA = ('Foo');
-
- sub CPL {
+
+ sub CPL {
push @CLASS_PRECEDENCE_LIST => 'Bar';
$_[0]->SUPER::CPL();
- }
-
+ }
+
package Baz;
- use metaclass;
+ use metaclass;
our @ISA = ('Bar');
-
- sub CPL {
+
+ sub CPL {
push @CLASS_PRECEDENCE_LIST => 'Baz';
$_[0]->SUPER::CPL();
- }
-
+ }
+
package Foo::Bar;
our @ISA = ('Baz');
-
- sub CPL {
+
+ sub CPL {
push @CLASS_PRECEDENCE_LIST => 'Foo::Bar';
$_[0]->SUPER::CPL();
- }
-
+ }
+
package Foo::Bar::Baz;
our @ISA = ('Foo::Bar');
-
- sub CPL {
+
+ sub CPL {
push @CLASS_PRECEDENCE_LIST => 'Foo::Bar::Baz';
$_[0]->SUPER::CPL();
- }
+ }
}
Foo::Bar::Baz->CPL();
is_deeply(
- [ Foo::Bar::Baz->meta->class_precedence_list ],
- [ @CLASS_PRECEDENCE_LIST ],
+ [ Foo::Bar::Baz->meta->class_precedence_list ],
+ [ @CLASS_PRECEDENCE_LIST ],
'... Foo::Bar::Baz->meta->class_precedence_list == @CLASS_PRECEDENCE_LIST');
+done_testing;
use strict;
use warnings;
-use Test::More tests => 69;
+use Test::More;
use Test::Exception;
use Scalar::Util qw/reftype/;
ok( $method, 'Got the foo method back' );
}
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 11;
+use Test::More;
use Test::Exception;
use Class::MOP;
=pod
-The following class hierarhcy is very contrived
+The following class hierarhcy is very contrived
and totally horrid (it won't work under C3 even),
but it tests a number of aspect of this module.
{
package Foo;
-
- sub BUILD { 'Foo::BUILD' }
+
+ sub BUILD { 'Foo::BUILD' }
sub foo { 'Foo::foo' }
-
+
package Bar;
our @ISA = ('Foo');
-
- sub BUILD { 'Bar::BUILD' }
- sub bar { 'Bar::bar' }
-
+
+ sub BUILD { 'Bar::BUILD' }
+ sub bar { 'Bar::bar' }
+
package Baz;
our @ISA = ('Bar');
-
+
sub baz { 'Baz::baz' }
- sub foo { 'Baz::foo' }
-
+ sub foo { 'Baz::foo' }
+
package Foo::Bar;
our @ISA = ('Foo', 'Bar');
-
- sub BUILD { 'Foo::Bar::BUILD' }
- sub foobar { 'Foo::Bar::foobar' }
-
+
+ sub BUILD { 'Foo::Bar::BUILD' }
+ sub foobar { 'Foo::Bar::foobar' }
+
package Foo::Bar::Baz;
our @ISA = ('Foo', 'Bar', 'Baz');
-
- sub BUILD { 'Foo::Bar::Baz::BUILD' }
- sub bar { 'Foo::Bar::Baz::bar' }
- sub foobarbaz { 'Foo::Bar::Baz::foobarbaz' }
+
+ sub BUILD { 'Foo::Bar::Baz::BUILD' }
+ sub bar { 'Foo::Bar::Baz::bar' }
+ sub foobarbaz { 'Foo::Bar::Baz::foobarbaz' }
}
-ok(!defined(Class::MOP::Class->initialize('Foo')->find_next_method_by_name('BUILD')),
+ok(!defined(Class::MOP::Class->initialize('Foo')->find_next_method_by_name('BUILD')),
'... Foo::BUILD has not next method');
-is(Class::MOP::Class->initialize('Bar')->find_next_method_by_name('BUILD'),
- Class::MOP::Class->initialize('Foo')->get_method('BUILD'),
+is(Class::MOP::Class->initialize('Bar')->find_next_method_by_name('BUILD'),
+ Class::MOP::Class->initialize('Foo')->get_method('BUILD'),
'... Bar::BUILD does have a next method');
-
-is(Class::MOP::Class->initialize('Baz')->find_next_method_by_name('BUILD'),
- Class::MOP::Class->initialize('Bar')->get_method('BUILD'),
- '... Baz->BUILD does have a next method');
-
-is(Class::MOP::Class->initialize('Foo::Bar')->find_next_method_by_name('BUILD'),
- Class::MOP::Class->initialize('Foo')->get_method('BUILD'),
- '... Foo::Bar->BUILD does have a next method');
-
-is(Class::MOP::Class->initialize('Foo::Bar::Baz')->find_next_method_by_name('BUILD'),
- Class::MOP::Class->initialize('Foo')->get_method('BUILD'),
- '... Foo::Bar::Baz->BUILD does have a next method');
+
+is(Class::MOP::Class->initialize('Baz')->find_next_method_by_name('BUILD'),
+ Class::MOP::Class->initialize('Bar')->get_method('BUILD'),
+ '... Baz->BUILD does have a next method');
+
+is(Class::MOP::Class->initialize('Foo::Bar')->find_next_method_by_name('BUILD'),
+ Class::MOP::Class->initialize('Foo')->get_method('BUILD'),
+ '... Foo::Bar->BUILD does have a next method');
+
+is(Class::MOP::Class->initialize('Foo::Bar::Baz')->find_next_method_by_name('BUILD'),
+ Class::MOP::Class->initialize('Foo')->get_method('BUILD'),
+ '... Foo::Bar::Baz->BUILD does have a next method');
is_deeply(
[ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Foo')->get_all_methods() ],
Class::MOP::Class->initialize('Foo')->get_method('foo'),
],
'... got the right list of applicable methods for Foo');
-
+
is_deeply(
[ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Bar')->get_all_methods() ],
[
Class::MOP::Class->initialize('Foo')->get_method('foo'),
],
'... got the right list of applicable methods for Bar');
-
+
is_deeply(
[ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Baz')->get_all_methods() ],
- [
+ [
Class::MOP::Class->initialize('Bar')->get_method('BUILD'),
Class::MOP::Class->initialize('Bar')->get_method('bar'),
Class::MOP::Class->initialize('Baz')->get_method('baz'),
name => 'BUILD',
class => 'Foo::Bar',
code => Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD')
- },
+ },
{
name => 'BUILD',
class => 'Foo',
code => Class::MOP::Class->initialize('Foo')->get_method('BUILD')
- },
+ },
{
name => 'BUILD',
class => 'Bar',
name => 'BUILD',
class => 'Foo::Bar::Baz',
code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('BUILD')
- },
+ },
{
name => 'BUILD',
class => 'Foo',
code => Class::MOP::Class->initialize('Foo')->get_method('BUILD')
- },
+ },
{
name => 'BUILD',
class => 'Bar',
- code => Class::MOP::Class->initialize('Bar')->get_method('BUILD')
- },
+ code => Class::MOP::Class->initialize('Bar')->get_method('BUILD')
+ },
],
'... got the right list of BUILD methods for Foo::Bar::Baz');
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 90;
+use Test::More;
use Test::Exception;
use Class::MOP;
Buzz->meta->make_immutable();
}
+
+done_testing;
use FindBin;
use File::Spec::Functions;
-use Test::More tests => 35;
+use Test::More;
use Test::Exception;
use Class::MOP;
$attr_clone->associated_class,
'... we successfully did not clone our associated metaclass');
+done_testing;
use strict;
use warnings;
-use Test::More tests => 306;
+use Test::More;
use Test::Exception;
use Class::MOP;
is_pristine
initialize create
-
+
update_package_cache_flag
reset_package_cache_flag
is($class_mop_class_meta->method_metaclass, 'Class::MOP::Method', '... got the right value for method_metaclass');
is($class_mop_class_meta->instance_metaclass, 'Class::MOP::Instance', '... got the right value for instance_metaclass');
+done_testing;
use strict;
use warnings;
-use Test::More tests => 27;
+use Test::More;
use Test::Exception;
use Class::MOP;
Class::MOP::Attribute->new('y' => (
accessor => 'y',
init_arg => 'y'
- )),
+ )),
],
methods => {
'new' => sub {
'clear' => sub {
my $self = shift;
$self->{'x'} = 0;
- $self->{'y'} = 0;
+ $self->{'y'} = 0;
}
}
));
my $Point3D = Class::MOP::Class->create('Point3D' => (
- version => '0.01',
+ version => '0.01',
superclasses => [ 'Point' ],
attributes => [
Class::MOP::Attribute->new('z' => (
{
my $point3d = Point3D->new();
isa_ok($point3d, 'Point3D');
-
+
is($point3d->x, undef, '... the x attribute was not initialized');
is($point3d->y, undef, '... the y attribute was not initialized');
- is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject');
-
-}
+ is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject');
+}
+done_testing;
use strict;
use warnings;
-use Test::More tests => 86;
+use Test::More;
use Test::Exception;
use Class::MOP;
=pod
-This is the same test as 080_meta_package.t just here
+This is the same test as 080_meta_package.t just here
we call all the methods through Class::MOP::Class.
=cut
Foo->meta->add_package_symbol('%foo' => { one => 1 });
} '... created %Foo::foo successfully';
-# ... scalar should NOT be created here
+# ... scalar should NOT be created here
ok(!Foo->meta->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too');
ok(!Foo->meta->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too');
{
no strict 'refs';
is(\%{'Foo::foo'}, Foo->meta->get_package_symbol('%foo'), '... our %foo is the same as the metas');
-
+
ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly');
- is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly');
+ is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly');
}
# ----------------------------------------------------------------------
ok(defined($Foo::{bar}), '... the @bar slot was created successfully');
ok(Foo->meta->has_package_symbol('@bar'), '... the meta agrees');
-# ... why does this not work ...
+# ... why does this not work ...
ok(!Foo->meta->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too');
ok(!Foo->meta->has_package_symbol('%bar'), '... HASH shouldnt have been created too');
ok(!Foo->meta->has_package_symbol('%baz'), '... HASH shouldnt have been created too');
ok(!Foo->meta->has_package_symbol('&baz'), '... CODE shouldnt have been created too');
-is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back');
+is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back');
{
no strict 'refs';
${'Foo::baz'} = 1;
is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly');
- is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees');
+ is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees');
}
# ----------------------------------------------------------------------
{
no strict 'refs';
ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
- ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
- ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed');
- ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+ ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed');
+ ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
}
lives_ok {
{
no strict 'refs';
- ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
- ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
- ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
- ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+ ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
}
lives_ok {
{
no strict 'refs';
- ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
- ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
- ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed');
- ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
+ ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
}
dies_ok {
Foo->meta->has_package_symbol('bar');
} '... no sigil for bar';
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 27;
+use Test::More;
use Test::Exception;
use Class::MOP;
sub clear {
my $self = shift;
$self->{'x'} = 0;
- $self->{'y'} = 0;
+ $self->{'y'} = 0;
}
package Point3D;
our @ISA = ('Point');
-
+
Point3D->meta->add_attribute('z' => (
default => 123
));
{
my $point3d = Point3D->new();
isa_ok($point3d, 'Point3D');
-
+
is($point3d->x, undef, '... the x attribute was not initialized');
is($point3d->y, undef, '... the y attribute was not initialized');
- is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject');
-
+ is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject');
+
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 71;
+use Test::More;
use Test::Exception;
use Class::MOP;
# wont worry about it for now. Maybe if I get
# bored I will do it.
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More;
use Test::Exception;
use Class::MOP;
=pod
-Test that a default set up will cause metaclasses to inherit
+Test that a default set up will cause metaclasses to inherit
the same metaclass type, but produce different metaclasses.
=cut
{
package Foo;
use metaclass;
-
+
package Bar;
use base 'Foo';
-
+
package Baz;
use base 'Bar';
}
isnt($baz_meta, $bar_meta, '... Baz->meta != Bar->meta');
isnt($baz_meta, $foo_meta, '... Baz->meta != Foo->meta');
+done_testing;
use strict;
use warnings;
-use Test::More tests => 43;
+use Test::More;
use Test::Exception;
use Class::MOP;
dies_ok {
Class::MOP::Class->initialize();
} '... initialize requires a name parameter';
-
+
dies_ok {
Class::MOP::Class->initialize('');
- } '... initialize requires a name valid parameter';
+ } '... initialize requires a name valid parameter';
dies_ok {
Class::MOP::Class->initialize(bless {} => 'Foo');
dies_ok {
Class::MOP::Class->_construct_class_instance();
} '... _construct_class_instance requires an :package parameter';
-
+
dies_ok {
Class::MOP::Class->_construct_class_instance(':package' => undef);
- } '... _construct_class_instance requires a defined :package parameter';
-
+ } '... _construct_class_instance requires a defined :package parameter';
+
dies_ok {
Class::MOP::Class->_construct_class_instance(':package' => '');
- } '... _construct_class_instance requires a valid :package parameter';
+ } '... _construct_class_instance requires a valid :package parameter';
}
dies_ok {
Class::MOP::Class->create();
} '... create requires an package_name parameter';
-
+
dies_ok {
Class::MOP::Class->create(undef);
- } '... create requires a defined package_name parameter';
-
+ } '... create requires a defined package_name parameter';
+
dies_ok {
Class::MOP::Class->create('');
- } '... create requires a valid package_name parameter';
-
+ } '... create requires a valid package_name parameter';
+
throws_ok {
Class::MOP::Class->create('+++');
- } qr/^creation of \+\+\+ failed/, '... create requires a valid package_name parameter';
-
+ } qr/^creation of \+\+\+ failed/, '... create requires a valid package_name parameter';
+
}
{
dies_ok {
Class::MOP::Class->add_method();
} '... add_method dies as expected';
-
+
dies_ok {
Class::MOP::Class->add_method('');
- } '... add_method dies as expected';
+ } '... add_method dies as expected';
dies_ok {
Class::MOP::Class->add_method('foo' => 'foo');
} '... add_method dies as expected';
-
+
dies_ok {
Class::MOP::Class->add_method('foo' => []);
- } '... add_method dies as expected';
+ } '... add_method dies as expected';
}
{
dies_ok {
Class::MOP::Class->has_method();
} '... has_method dies as expected';
-
+
dies_ok {
Class::MOP::Class->has_method('');
} '... has_method dies as expected';
dies_ok {
Class::MOP::Class->get_method();
} '... get_method dies as expected';
-
+
dies_ok {
Class::MOP::Class->get_method('');
} '... get_method dies as expected';
dies_ok {
Class::MOP::Class->remove_method();
} '... remove_method dies as expected';
-
+
dies_ok {
Class::MOP::Class->remove_method('');
} '... remove_method dies as expected';
dies_ok {
Class::MOP::Class->find_all_methods_by_name();
} '... find_all_methods_by_name dies as expected';
-
+
dies_ok {
Class::MOP::Class->find_all_methods_by_name('');
} '... find_all_methods_by_name dies as expected';
dies_ok {
Class::MOP::Class->has_attribute();
} '... has_attribute dies as expected';
-
+
dies_ok {
Class::MOP::Class->has_attribute('');
} '... has_attribute dies as expected';
dies_ok {
Class::MOP::Class->get_attribute();
} '... get_attribute dies as expected';
-
+
dies_ok {
Class::MOP::Class->get_attribute('');
} '... get_attribute dies as expected';
dies_ok {
Class::MOP::Class->remove_attribute();
} '... remove_attribute dies as expected';
-
+
dies_ok {
Class::MOP::Class->remove_attribute('');
} '... remove_attribute dies as expected';
dies_ok {
Class::MOP::Class->add_package_symbol();
} '... add_package_symbol dies as expected';
-
+
dies_ok {
Class::MOP::Class->add_package_symbol('');
} '... add_package_symbol dies as expected';
-
+
dies_ok {
Class::MOP::Class->add_package_symbol('foo');
- } '... add_package_symbol dies as expected';
-
+ } '... add_package_symbol dies as expected';
+
dies_ok {
Class::MOP::Class->add_package_symbol('&foo');
- } '... add_package_symbol dies as expected';
-
+ } '... add_package_symbol dies as expected';
+
# throws_ok {
# Class::MOP::Class->meta->add_package_symbol('@-');
-# } qr/^Could not create package variable \(\@\-\) because/,
-# '... add_package_symbol dies as expected';
+# } qr/^Could not create package variable \(\@\-\) because/,
+# '... add_package_symbol dies as expected';
}
{
dies_ok {
Class::MOP::Class->has_package_symbol('foo');
- } '... has_package_symbol dies as expected';
+ } '... has_package_symbol dies as expected';
}
{
dies_ok {
Class::MOP::Class->get_package_symbol('foo');
- } '... get_package_symbol dies as expected';
+ } '... get_package_symbol dies as expected';
}
{
dies_ok {
Class::MOP::Class->remove_package_symbol('foo');
- } '... remove_package_symbol dies as expected';
+ } '... remove_package_symbol dies as expected';
}
+done_testing;
use strict;
use warnings;
-use Test::More tests => 21;
+use Test::More;
use Test::Exception;
use Class::MOP;
is( $savings_account->balance, 200,
'... got the right savings balance after overdraft withdrawal' );
+done_testing;
use strict;
use warnings;
-use Test::More tests => 18;
+use Test::More;
use Test::Exception;
use Class::MOP;
use strict;
use warnings;
use metaclass;
-
+
sub bar { 'Foo::bar' }
}
{
my $anon_class = Class::MOP::Class->create_anon_class();
isa_ok($anon_class, 'Class::MOP::Class');
-
+
($anon_class_id) = ($anon_class->name =~ /Class::MOP::Class::__ANON__::SERIAL::(\d+)/);
-
+
ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package exists');
like($anon_class->name, qr/Class::MOP::Class::__ANON__::SERIAL::[0-9]+/, '... got an anon class package name');
lives_ok {
$anon_class->add_method('foo' => sub { "__ANON__::foo" });
} '... added a method to my anon-class';
- ok($anon_class->has_method('foo'), '... we have a foo method now');
+ ok($anon_class->has_method('foo'), '... we have a foo method now');
$instance = $anon_class->new_object();
- isa_ok($instance, $anon_class->name);
- isa_ok($instance, 'Foo');
+ isa_ok($instance, $anon_class->name);
+ isa_ok($instance, 'Foo');
is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method');
- is($instance->bar, 'Foo::bar', '... got the right return value of our bar method');
+ is($instance->bar, 'Foo::bar', '... got the right return value of our bar method');
}
ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package still exists');
ok(!$instance_2->isa('Foo'), '... but the new instance is not a Foo');
ok(!$instance_2->can('foo'), '... and it can no longer call the foo method');
-
+done_testing;
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More;
use Test::Exception;
use Class::MOP;
[$anon_class_name, 'Foo'],
'... Anonymous instance has class precedence list',
);
+
+done_testing;
use Scalar::Util 'reftype', 'blessed';
-use Test::More tests => 104;
+use Test::More;
use Test::Exception;
use Class::MOP;
{
my $reader = $attr->get_read_method_ref;
- my $writer = $attr->get_write_method_ref;
-
+ my $writer = $attr->get_write_method_ref;
+
ok(!blessed($reader), '... it is a plain old sub');
- ok(!blessed($writer), '... it is a plain old sub');
-
+ ok(!blessed($writer), '... it is a plain old sub');
+
is(reftype($reader), 'CODE', '... it is a plain old sub');
- is(reftype($writer), 'CODE', '... it is a plain old sub');
+ is(reftype($writer), 'CODE', '... it is a plain old sub');
}
my $class = Class::MOP::Class->initialize('Foo');
} '... attached a class successfully';
is($attr->associated_class, $class, '... the class was associated correctly');
-
+
ok(!$attr->get_read_method, '... $attr does not have an read method');
- ok(!$attr->get_write_method, '... $attr does not have an write method');
-
+ ok(!$attr->get_write_method, '... $attr does not have an write method');
+
{
my $reader = $attr->get_read_method_ref;
- my $writer = $attr->get_write_method_ref;
-
+ my $writer = $attr->get_write_method_ref;
+
ok(blessed($reader), '... it is a plain old sub');
- ok(blessed($writer), '... it is a plain old sub');
-
+ ok(blessed($writer), '... it is a plain old sub');
+
isa_ok($reader, 'Class::MOP::Method');
- isa_ok($writer, 'Class::MOP::Method');
+ isa_ok($writer, 'Class::MOP::Method');
}
my $attr_clone = $attr->clone();
ok(!$attr->has_accessor, '... $attr does not have an accessor');
ok(!$attr->has_reader, '... $attr does not have an reader');
ok(!$attr->has_writer, '... $attr does not have an writer');
-
+
ok(!$attr->get_read_method, '... $attr does not have an read method');
- ok(!$attr->get_write_method, '... $attr does not have an write method');
-
+ ok(!$attr->get_write_method, '... $attr does not have an write method');
+
{
my $reader = $attr->get_read_method_ref;
- my $writer = $attr->get_write_method_ref;
-
+ my $writer = $attr->get_write_method_ref;
+
ok(!blessed($reader), '... it is a plain old sub');
- ok(!blessed($writer), '... it is a plain old sub');
-
+ ok(!blessed($writer), '... it is a plain old sub');
+
is(reftype($reader), 'CODE', '... it is a plain old sub');
- is(reftype($writer), 'CODE', '... it is a plain old sub');
- }
+ is(reftype($writer), 'CODE', '... it is a plain old sub');
+ }
my $attr_clone = $attr->clone();
isa_ok($attr_clone, 'Class::MOP::Attribute');
ok(!$attr->has_reader, '... $attr does not have an reader');
ok(!$attr->has_writer, '... $attr does not have an writer');
-
+
is($attr->get_read_method, 'foo', '... $attr does not have an read method');
- is($attr->get_write_method, 'foo', '... $attr does not have an write method');
-
+ is($attr->get_write_method, 'foo', '... $attr does not have an write method');
+
{
my $reader = $attr->get_read_method_ref;
- my $writer = $attr->get_write_method_ref;
-
+ my $writer = $attr->get_write_method_ref;
+
ok(!blessed($reader), '... it is not a plain old sub');
- ok(!blessed($writer), '... it is not a plain old sub');
-
+ ok(!blessed($writer), '... it is not a plain old sub');
+
is(reftype($reader), 'CODE', '... it is a plain old sub');
- is(reftype($writer), 'CODE', '... it is a plain old sub');
- }
+ is(reftype($writer), 'CODE', '... it is a plain old sub');
+ }
my $attr_clone = $attr->clone();
isa_ok($attr_clone, 'Class::MOP::Attribute');
is($attr->writer, 'set_foo', '... $attr->writer == set_foo');
ok(!$attr->has_accessor, '... $attr does not have an accessor');
-
+
is($attr->get_read_method, 'get_foo', '... $attr does not have an read method');
- is($attr->get_write_method, 'set_foo', '... $attr does not have an write method');
-
+ is($attr->get_write_method, 'set_foo', '... $attr does not have an write method');
+
{
my $reader = $attr->get_read_method_ref;
- my $writer = $attr->get_write_method_ref;
-
+ my $writer = $attr->get_write_method_ref;
+
ok(!blessed($reader), '... it is not a plain old sub');
- ok(!blessed($writer), '... it is not a plain old sub');
-
+ ok(!blessed($writer), '... it is not a plain old sub');
+
is(reftype($reader), 'CODE', '... it is a plain old sub');
- is(reftype($writer), 'CODE', '... it is a plain old sub');
- }
+ is(reftype($writer), 'CODE', '... it is a plain old sub');
+ }
my $attr_clone = $attr->clone();
isa_ok($attr_clone, 'Class::MOP::Attribute');
is($attr->default(42), 42, 'passthrough for default on attribute');
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 27;
+use Test::More;
use Test::Exception;
-BEGIN {use Class::MOP;use Class::MOP::Attribute;
-}
+use Class::MOP;
+use Class::MOP::Attribute;
# most values are static
));
} '... can create accessors with reader/writers';
}
+
+done_testing;
use Scalar::Util;
-use Test::More tests => 16;
+use Test::More;
use Class::MOP;
{
package Foo;
use metaclass;
-
- Foo->meta->add_attribute('bar' =>
+
+ Foo->meta->add_attribute('bar' =>
reader => 'get_bar',
writer => 'set_bar',
);
-
+
::can_ok('Foo', 'get_bar');
- ::can_ok('Foo', 'set_bar');
+ ::can_ok('Foo', 'set_bar');
::ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar');
-
+
my $bar_attr = Foo->meta->get_attribute('bar');
-
+
::is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar');
- ::is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar');
- ::is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta');
-
- Foo->meta->add_attribute('bar' =>
+ ::is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar');
+ ::is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta');
+
+ Foo->meta->add_attribute('bar' =>
reader => 'assign_bar'
- );
+ );
::ok(!Foo->can('get_bar'), '... Foo no longer has the get_bar method');
- ::ok(!Foo->can('set_bar'), '... Foo no longer has the set_bar method');
- ::can_ok('Foo', 'assign_bar');
+ ::ok(!Foo->can('set_bar'), '... Foo no longer has the set_bar method');
+ ::can_ok('Foo', 'assign_bar');
::ok(Foo->meta->has_attribute('bar'), '... Foo still has the attribute bar');
-
- my $bar_attr2 = Foo->meta->get_attribute('bar');
-
+
+ my $bar_attr2 = Foo->meta->get_attribute('bar');
+
::isnt($bar_attr, $bar_attr2, '... this is a new bar attribute');
- ::isnt($bar_attr->associated_class, Foo->meta, '... and the old bar attribute is no longer associated with Foo->meta');
-
- ::is($bar_attr2->associated_class, Foo->meta, '... and the new bar attribute *is* associated with Foo->meta');
-
+ ::isnt($bar_attr->associated_class, Foo->meta, '... and the old bar attribute is no longer associated with Foo->meta');
+
+ ::is($bar_attr2->associated_class, Foo->meta, '... and the new bar attribute *is* associated with Foo->meta');
+
::isnt($bar_attr2->reader, 'get_bar', '... the bar attribute no longer has the reader get_bar');
- ::isnt($bar_attr2->reader, 'set_bar', '... the bar attribute no longer has the reader set_bar');
- ::is($bar_attr2->reader, 'assign_bar', '... the bar attribute now has the reader assign_bar');
+ ::isnt($bar_attr2->reader, 'set_bar', '... the bar attribute no longer has the reader set_bar');
+ ::is($bar_attr2->reader, 'assign_bar', '... the bar attribute now has the reader assign_bar');
}
+done_testing;
use Scalar::Util 'blessed', 'reftype';
-use Test::More tests => 36;
+use Test::More;
use Class::MOP;
{
package Foo;
use metaclass;
-
- Foo->meta->add_attribute('bar' =>
+
+ Foo->meta->add_attribute('bar' =>
reader => 'get_bar',
writer => 'set_bar',
- );
-
- Foo->meta->add_attribute('baz' =>
+ );
+
+ Foo->meta->add_attribute('baz' =>
accessor => 'baz',
- );
-
- Foo->meta->add_attribute('gorch' =>
+ );
+
+ Foo->meta->add_attribute('gorch' =>
reader => { 'get_gorch', => sub { (shift)->{gorch} } }
- );
+ );
package Bar;
use metaclass;
}
can_ok('Foo', 'get_bar');
-can_ok('Foo', 'set_bar');
-can_ok('Foo', 'baz');
-can_ok('Foo', 'get_gorch');
+can_ok('Foo', 'set_bar');
+can_ok('Foo', 'baz');
+can_ok('Foo', 'get_gorch');
ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar');
ok(Foo->meta->has_attribute('baz'), '... Foo has the attribute baz');
my $gorch_attr = Foo->meta->get_attribute('gorch');
is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar');
-is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar');
+is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar');
is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta');
is($bar_attr->get_read_method, 'get_bar', '... $attr does have an read method');
-is($bar_attr->get_write_method, 'set_bar', '... $attr does have an write method');
+is($bar_attr->get_write_method, 'set_bar', '... $attr does have an write method');
{
my $reader = $bar_attr->get_read_method_ref;
- my $writer = $bar_attr->get_write_method_ref;
-
+ my $writer = $bar_attr->get_write_method_ref;
+
isa_ok($reader, 'Class::MOP::Method');
- isa_ok($writer, 'Class::MOP::Method');
-
+ isa_ok($writer, 'Class::MOP::Method');
+
is($reader->fully_qualified_name, 'Foo::get_bar', '... it is the sub we are looking for');
is($writer->fully_qualified_name, 'Foo::set_bar', '... it is the sub we are looking for');
-
+
is(reftype($reader->body), 'CODE', '... it is a plain old sub');
- is(reftype($writer->body), 'CODE', '... it is a plain old sub');
+ is(reftype($writer->body), 'CODE', '... it is a plain old sub');
}
is($baz_attr->accessor, 'baz', '... the bar attribute has the accessor baz');
is($baz_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta');
is($baz_attr->get_read_method, 'baz', '... $attr does have an read method');
-is($baz_attr->get_write_method, 'baz', '... $attr does have an write method');
+is($baz_attr->get_write_method, 'baz', '... $attr does have an write method');
{
my $reader = $baz_attr->get_read_method_ref;
- my $writer = $baz_attr->get_write_method_ref;
-
+ my $writer = $baz_attr->get_write_method_ref;
+
isa_ok($reader, 'Class::MOP::Method');
- isa_ok($writer, 'Class::MOP::Method');
-
- is($reader, $writer, '... they are the same method');
-
+ isa_ok($writer, 'Class::MOP::Method');
+
+ is($reader, $writer, '... they are the same method');
+
is($reader->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for');
- is($writer->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for');
+ is($writer->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for');
}
is(ref($gorch_attr->reader), 'HASH', '... the gorch attribute has the reader get_gorch (HASH ref)');
is($gorch_attr->associated_class, Foo->meta, '... and the gorch attribute is associated with Foo->meta');
is($gorch_attr->get_read_method, 'get_gorch', '... $attr does have an read method');
-ok(!$gorch_attr->get_write_method, '... $attr does not have an write method');
+ok(!$gorch_attr->get_write_method, '... $attr does not have an write method');
{
my $reader = $gorch_attr->get_read_method_ref;
- my $writer = $gorch_attr->get_write_method_ref;
-
+ my $writer = $gorch_attr->get_write_method_ref;
+
isa_ok($reader, 'Class::MOP::Method');
- ok(blessed($writer), '... it is not a plain old sub');
- isa_ok($writer, 'Class::MOP::Method');
-
+ ok(blessed($writer), '... it is not a plain old sub');
+ isa_ok($writer, 'Class::MOP::Method');
+
is($reader->fully_qualified_name, 'Foo::get_gorch', '... it is the sub we are looking for');
- is($writer->fully_qualified_name, 'Foo::__ANON__', '... it is the sub we are looking for');
+ is($writer->fully_qualified_name, 'Foo::__ANON__', '... it is the sub we are looking for');
}
+
+done_testing;
use Scalar::Util 'blessed', 'reftype';
-use Test::More tests => 9;
+use Test::More;
use Class::MOP;
{
package Foo;
use metaclass;
-
- Foo->meta->add_attribute('bar' =>
+
+ Foo->meta->add_attribute('bar' =>
reader => 'get_bar',
writer => 'set_bar',
initializer => sub {
my ($self, $value, $callback, $attr) = @_;
-
+
::isa_ok($attr, 'Class::MOP::Attribute');
::is($attr->name, 'bar', '... the attribute is our own');
-
+
$callback->($value * 2);
},
- );
+ );
}
can_ok('Foo', 'get_bar');
-can_ok('Foo', 'set_bar');
+can_ok('Foo', 'set_bar');
my $foo = Foo->meta->new_object(bar => 10);
is($foo->get_bar, 20, "... initial argument was doubled as expected");
ok($bar->has_initializer, '... bar has an initializer');
is(reftype $bar->initializer, 'CODE', '... the initializer is a CODE ref');
-
-
-
-
-
-
-
-
+done_testing;
use strict;
use warnings;
-use Test::More tests => 53;
+use Test::More;
use Test::Exception;
use Class::MOP;
my $wrapped2 = Method::Subclass->wrap($method, foo => 'baz', name => 'FOO');
is($wrapped2->name, 'FOO', 'got a new method name');
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 28;
+use Test::More;
use Test::Exception;
use Class::MOP;
'check around_modifiers' );
}
+done_testing;
my @universal_methods = qw/isa can VERSION/;
push @universal_methods, 'DOES' if $] >= 5.010;
-plan tests => scalar @universal_methods;
-
TODO: {
local $TODO = 'UNIVERSAL methods should be available';
ok $meta_class->find_method_by_name($method), "has UNIVERSAL method $method";
}
};
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 11;
+use Test::More;
-BEGIN {use metaclass;
-}
+use metaclass;
{
package FooMeta;
use base 'Class::MOP::Class';
-
+
package Foo;
use metaclass 'FooMeta';
}
{
package BarMeta;
use base 'Class::MOP::Class';
-
+
package BarMeta::Attribute;
use base 'Class::MOP::Attribute';
-
+
package BarMeta::Method;
- use base 'Class::MOP::Method';
-
+ use base 'Class::MOP::Method';
+
package Bar;
use metaclass 'BarMeta' => (
'attribute_metaclass' => 'BarMeta::Attribute',
- 'method_metaclass' => 'BarMeta::Method',
+ 'method_metaclass' => 'BarMeta::Method',
);
}
can_ok('Baz', 'meta');
isa_ok(Baz->meta, 'Class::MOP::Class');
-eval {
+eval {
package Boom;
metaclass->import('Foo');
};
ok($@, '... metaclasses must be subclass of Class::MOP::Class');
+done_testing;
use strict;
use warnings;
-use Test::More tests => 6;
+use Test::More;
-BEGIN {use metaclass;
-}
+use metaclass;
# meta classes
{
package Foo::Meta;
use base 'Class::MOP::Class';
-
+
package Bar::Meta;
use base 'Class::MOP::Class';
-
+
package FooBar::Meta;
use base 'Foo::Meta', 'Bar::Meta';
}
};
ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@;
-
+done_testing;
use strict;
use warnings;
-use Test::More tests => 6;
+use Test::More;
-BEGIN {use metaclass;
-}
+use metaclass;
# meta classes
{
package Foo::Meta;
use base 'Class::MOP::Class';
-
+
package Bar::Meta;
use base 'Class::MOP::Class';
-
+
package FooBar::Meta;
use base 'Foo::Meta', 'Bar::Meta';
}
eval {
package Foo::Foo;
metaclass->import('Bar::Meta');
- Foo::Foo->meta->superclasses('Foo');
+ Foo::Foo->meta->superclasses('Foo');
};
ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@;
eval {
package FooBar;
metaclass->import('FooBar::Meta');
- FooBar->meta->superclasses('Foo');
+ FooBar->meta->superclasses('Foo');
};
ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@;
eval {
package FooBar2;
metaclass->import('FooBar::Meta');
- FooBar2->meta->superclasses('Bar');
+ FooBar2->meta->superclasses('Bar');
};
ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@;
-
+done_testing;
use strict;
use warnings;
-use Test::More tests => 6;
+use Test::More;
-BEGIN {use metaclass;
-}
+use metaclass;
# meta classes
-{
+{
package Foo::Meta::Instance;
- use base 'Class::MOP::Instance';
-
+ use base 'Class::MOP::Instance';
+
package Bar::Meta::Instance;
- use base 'Class::MOP::Instance';
-
+ use base 'Class::MOP::Instance';
+
package FooBar::Meta::Instance;
use base 'Foo::Meta::Instance', 'Bar::Meta::Instance';
}
eval {
package Bar::Bar;
use base 'Bar';
- metaclass->import('instance_metaclass' => 'Foo::Meta::Instance');
+ metaclass->import('instance_metaclass' => 'Foo::Meta::Instance');
};
ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@;
eval {
package FooBar;
use base 'Foo';
- metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance');
+ metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance');
};
ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@;
eval {
package FooBar2;
use base 'Bar';
- metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance');
+ metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance');
};
ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@;
-
+done_testing;
use strict;
use warnings;
-use Test::More tests => 6;
+use Test::More;
-BEGIN {use metaclass;
-}
+use metaclass;
# meta classes
-{
+{
package Foo::Meta::Instance;
- use base 'Class::MOP::Instance';
-
+ use base 'Class::MOP::Instance';
+
package Bar::Meta::Instance;
- use base 'Class::MOP::Instance';
-
+ use base 'Class::MOP::Instance';
+
package FooBar::Meta::Instance;
use base 'Foo::Meta::Instance', 'Bar::Meta::Instance';
}
eval {
package Foo::Foo;
metaclass->import('instance_metaclass' => 'Bar::Meta::Instance');
- Foo::Foo->meta->superclasses('Foo');
+ Foo::Foo->meta->superclasses('Foo');
};
ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@;
$@ = undef;
eval {
package Bar::Bar;
- metaclass->import('instance_metaclass' => 'Foo::Meta::Instance');
+ metaclass->import('instance_metaclass' => 'Foo::Meta::Instance');
Bar::Bar->meta->superclasses('Bar');
};
ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@;
$@ = undef;
eval {
package FooBar;
- metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance');
- FooBar->meta->superclasses('Foo');
+ metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance');
+ FooBar->meta->superclasses('Foo');
};
ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@;
$@ = undef;
eval {
package FooBar2;
- metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance');
- FooBar2->meta->superclasses('Bar');
+ metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance');
+ FooBar2->meta->superclasses('Bar');
};
ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@;
-
+done_testing;
use FindBin;
use File::Spec::Functions;
-use Test::More tests => 8;
+use Test::More;
use Class::MOP;
is($meta->method_metaclass, 'MyMetaClass::Method', '... Correct method metaclass');
ok(Class::MOP::is_class_loaded('MyMetaClass::Method'), '... method metaclass loaded');
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 27;
+use Test::More;
use Test::Exception;
use Scalar::Util 'blessed';
is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child');
+done_testing;
use strict;
use warnings;
-use Test::More tests => 21;
+use Test::More;
use Test::Exception;
use Class::MOP;
package Foo;
use metaclass;
Foo->meta->add_attribute('bar' => (reader => 'bar'));
-
+
sub new { (shift)->meta->new_object(@_) }
-
+
package Bar;
use metaclass;
use base 'Foo';
- Bar->meta->add_attribute('baz' => (reader => 'baz', default => 'BAZ'));
+ Bar->meta->add_attribute('baz' => (reader => 'baz', default => 'BAZ'));
}
# normal ...
is($foo->baz, 'FOO-BAZ', '... got the expect value');
}
-
+done_testing;
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More;
use Class::MOP;
my $anon = MyMeta->create_anon_class( foo => 'this' );
isa_ok( $anon, 'MyMeta' );
+done_testing;
use strict;
use warnings;
-use Test::More tests => 14;
+use Test::More;
use Test::Exception;
{
throws_ok {
$meta->reinitialize($meta->new_object);
} qr/You must pass a package name or an existing Class::MOP::Package instance/;
+
+done_testing;
BEGIN {
eval "use SUPER 1.10";
plan skip_all => "SUPER 1.10 required for this test" if $@;
- plan tests => 4;
}
=pod
-This test demonstrates how simple it is to create Scala Style
-Class Mixin Composition. Below is an example taken from the
+This test demonstrates how simple it is to create Scala Style
+Class Mixin Composition. Below is an example taken from the
Scala web site's example section, and trancoded to Class::MOP.
NOTE:
We require SUPER for this test to handle the issue with SUPER::
-being determined at compile time.
+being determined at compile time.
L<http://scala.epfl.ch/intro/mixin.html>
-A class can only be used as a mixin in the definition of another
-class, if this other class extends a subclass of the superclass
-of the mixin. Since ColoredPoint3D extends Point3D and Point3D
-extends Point2D which is the superclass of ColoredPoint2D, the
+A class can only be used as a mixin in the definition of another
+class, if this other class extends a subclass of the superclass
+of the mixin. Since ColoredPoint3D extends Point3D and Point3D
+extends Point2D which is the superclass of ColoredPoint2D, the
code above is well-formed.
class Point2D(xc: Int, yc: Int) {
val y = yc;
override def toString() = "x = " + x + ", y = " + y;
}
-
+
class ColoredPoint2D(u: Int, v: Int, c: String) extends Point2D(u, v) {
val color = c;
def setColor(newCol: String): Unit = color = newCol;
override def toString() = super.toString() + ", col = " + color;
}
-
+
class Point3D(xc: Int, yc: Int, zc: Int) extends Point2D(xc, yc) {
val z = zc;
override def toString() = super.toString() + ", z = " + z;
}
-
+
class ColoredPoint3D(xc: Int, yc: Int, zc: Int, col: String)
extends Point3D(xc, yc, zc)
with ColoredPoint2D(xc, yc, col);
-
-
+
+
Console.println(new ColoredPoint3D(1, 2, 3, "blue").toString())
-
+
"x = 1, y = 2, z = 3, col = blue"
-
+
=cut
use Scalar::Util 'blessed';
use Carp 'confess';
sub ::with ($) {
- # fetch the metaclass for the
+ # fetch the metaclass for the
# caller and the mixin arg
my $metaclass = (caller)->meta;
my $mixin = (shift)->meta;
-
- # according to Scala, the
+
+ # according to Scala, the
# the superclass of our class
- # must be a subclass of the
+ # must be a subclass of the
# superclass of the mixin (see above)
my ($super_meta) = $metaclass->superclasses();
- my ($super_mixin) = $mixin->superclasses();
+ my ($super_mixin) = $mixin->superclasses();
($super_meta->isa($super_mixin))
|| confess "The superclass must extend a subclass of the superclass of the mixin";
-
+
# collect all the attributes
- # and clone them so they can
+ # and clone them so they can
# associate with the new class
- my @attributes = map {
- $mixin->get_attribute($_)->clone()
- } $mixin->get_attribute_list;
-
- my %methods = map {
+ my @attributes = map {
+ $mixin->get_attribute($_)->clone()
+ } $mixin->get_attribute_list;
+
+ my %methods = map {
my $method = $mixin->get_method($_);
# we want to ignore accessors since
# they will be created with the attrs
(blessed($method) && $method->isa('Class::MOP::Method::Accessor'))
? () : ($_ => $method)
- } $mixin->get_method_list;
+ } $mixin->get_method_list;
# NOTE:
- # I assume that locally defined methods
+ # I assume that locally defined methods
# and attributes get precedence over those
# from the mixin.
# add all the attributes in ....
foreach my $attr (@attributes) {
- $metaclass->add_attribute($attr)
+ $metaclass->add_attribute($attr)
unless $metaclass->has_attribute($attr->name);
}
- # add all the methods in ....
+ # add all the methods in ....
foreach my $method_name (keys %methods) {
- $metaclass->add_method($method_name => $methods{$method_name})
+ $metaclass->add_method($method_name => $methods{$method_name})
unless $metaclass->has_method($method_name);
- }
+ }
}
{
package Point2D;
use metaclass;
-
+
Point2D->meta->add_attribute('$x' => (
accessor => 'x',
init_arg => 'x',
));
-
+
Point2D->meta->add_attribute('$y' => (
accessor => 'y',
init_arg => 'y',
- ));
-
+ ));
+
sub new {
my $class = shift;
$class->meta->new_object(@_);
- }
-
+ }
+
sub toString {
my $self = shift;
"x = " . $self->x . ", y = " . $self->y;
}
-
+
package ColoredPoint2D;
our @ISA = ('Point2D');
-
+
ColoredPoint2D->meta->add_attribute('$color' => (
accessor => 'color',
init_arg => 'color',
- ));
-
+ ));
+
sub toString {
my $self = shift;
$self->SUPER() . ', col = ' . $self->color;
}
-
+
package Point3D;
our @ISA = ('Point2D');
-
+
Point3D->meta->add_attribute('$z' => (
accessor => 'z',
init_arg => 'z',
- ));
+ ));
sub toString {
my $self = shift;
$self->SUPER() . ', z = ' . $self->z;
}
-
+
package ColoredPoint3D;
- our @ISA = ('Point3D');
-
+ our @ISA = ('Point3D');
+
::with('ColoredPoint2D');
-
+
}
my $colored_point_3d = ColoredPoint3D->new(x => 1, y => 2, z => 3, color => 'blue');
'x = 1, y = 2, z = 3, col = blue',
'... got the right toString method');
-
+done_testing;
use strict;
use warnings;
-use Test::More tests => 45;
+use Test::More;
use Test::Exception;
use Scalar::Util qw/isweak reftype/;
use Class::MOP::Instance;
can_ok( "Class::MOP::Instance", $_ ) for qw/
- new
+ new
create_instance
bless_instance_structure
- get_all_slots
+ get_all_slots
initialize_all_slots
deinitialize_all_slots
ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot");
+done_testing;
use strict;
use warnings;
-use Test::More tests => 8;
+use Test::More;
use Test::Exception;
use Class::MOP::Instance;
'... got the right code for rebless_instance_structure');
}
-
+done_testing;
use strict;
use warnings;
-use Test::More tests => 76;
+use Test::More;
use Test::Exception;
use Class::MOP;
'custom immutable_options are returned by immutable_options accessor'
);
}
+
+done_testing;
use FindBin;
use File::Spec::Functions;
-use Test::More tests => 14;
+use Test::More;
use Test::Exception;
use Scalar::Util;
lives_ok { $meta->make_mutable } "Baz is now mutable";
ok( $meta->is_mutable, '... Baz is mutable again' );
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 91;
+use Test::More;
use Test::Exception;
use Class::MOP;
::is($buzz2->bah, undef, '...bah is undef');
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 95;
+use Test::More;
use Test::Exception;
use Scalar::Util;
ok($meta->is_immutable, '... our class is now immutable');
ok(!$meta->make_immutable, '... make immutable now returns nothing');
ok($meta->get_method('new'), '... inlined constructor created');
- ok($meta->has_method('new'), '... inlined constructor created for sure');
+ ok($meta->has_method('new'), '... inlined constructor created for sure');
is_deeply([ map { $_->name } $meta->_inlined_methods ], [ 'new' ], '... really, i mean it');
lives_ok { $meta->make_mutable; } '... changed Baz to be mutable';
ok(!$meta->is_immutable, '... our class is not immutable');
ok(!$meta->make_mutable, '... make mutable now returns nothing');
ok(!$meta->get_method('new'), '... inlined constructor created');
- ok(!$meta->has_method('new'), '... inlined constructor removed for sure');
+ ok(!$meta->has_method('new'), '... inlined constructor removed for sure');
my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta;
is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys');
Bar->meta->make_immutable;
Bar->meta->make_mutable;
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 4;
+use Test::More;
use Test::Exception;
use Class::MOP;
'Bar->meta->superclasses returns expected value after immutabilization'
);
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 97;
+use Test::More;
use Test::Exception;
use Class::MOP;
package Foo;
use constant SOME_CONSTANT => 1;
-
+
sub meta { Class::MOP::Package->initialize('Foo') }
}
Foo->meta->add_package_symbol('%foo' => { one => 1 });
} '... created %Foo::foo successfully';
-# ... scalar should NOT be created here
+# ... scalar should NOT be created here
ok(!Foo->meta->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too');
ok(!Foo->meta->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too');
{
no strict 'refs';
is(\%{'Foo::foo'}, Foo->meta->get_package_symbol('%foo'), '... our %foo is the same as the metas');
-
+
ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly');
- is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly');
+ is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly');
}
# ----------------------------------------------------------------------
ok(defined($Foo::{bar}), '... the @bar slot was created successfully');
ok(Foo->meta->has_package_symbol('@bar'), '... the meta agrees');
-# ... why does this not work ...
+# ... why does this not work ...
ok(!Foo->meta->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too');
ok(!Foo->meta->has_package_symbol('%bar'), '... HASH shouldnt have been created too');
ok(!Foo->meta->has_package_symbol('%baz'), '... HASH shouldnt have been created too');
ok(!Foo->meta->has_package_symbol('&baz'), '... CODE shouldnt have been created too');
-is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back');
+is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back');
{
no strict 'refs';
${'Foo::baz'} = 1;
is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly');
- is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees');
+ is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees');
}
# ----------------------------------------------------------------------
{
no strict 'refs';
ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
- ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
- ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed');
- ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+ ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed');
+ ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
}
lives_ok {
{
no strict 'refs';
- ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
- ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
- ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
- ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+ ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed');
}
lives_ok {
{
no strict 'refs';
- ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
- ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
- ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed');
- ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
+ ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully');
+ ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed');
+ ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed');
+ ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
}
# get_all_package_symbols
[ sort keys %{ $syms } ],
[ sort Foo->meta->list_all_package_symbols ],
'... the fetched symbols are the same as the listed ones'
- );
+ );
}
{
[ sort Foo->meta->list_all_package_symbols('CODE') ],
'... the fetched symbols are the same as the listed ones'
);
-
+
foreach my $symbol (keys %{ $syms }) {
is($syms->{$symbol}, Foo->meta->get_package_symbol('&' . $symbol), '... got the right symbol');
- }
+ }
}
{
dies_ok {
Foo->meta->has_package_symbol('bar');
} '... no sigil for bar';
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 15;
+use Test::More;
use Test::Exception;
-BEGIN {use Class::MOP;
-}
+use Class::MOP;
{
package My::Meta::Package;
-
+
use strict;
use warnings;
-
+
use Carp 'confess';
use Symbol 'gensym';
-
+
use base 'Class::MOP::Package';
-
+
__PACKAGE__->meta->add_attribute(
'namespace' => (
reader => 'namespace',
default => sub { {} }
)
- );
-
+ );
+
sub add_package_symbol {
my ($self, $variable, $initial_value) = @_;
-
- my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
-
+
+ my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
+
my $glob = gensym();
*{$glob} = $initial_value if defined $initial_value;
- $self->namespace->{$name} = *{$glob};
- }
+ $self->namespace->{$name} = *{$glob};
+ }
}
# No actually package Foo exists :)
ok(!defined($Foo::{baz}), '... the %baz slot has still not been created');
+done_testing;
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More;
use Sub::Name 'subname';
BEGIN {
sub foo : Bar {}
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 32;
+use Test::More;
use Test::Exception;
require Class::MOP;
'an @ISA with members does mean a class is loaded' );
}
+done_testing;
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More;
use Test::Exception;
use Class::MOP;
lives_ok {
TestClassLoaded->a_method;
-}
+};
+
+done_testing;
#!/usr/bin/env perl
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More;
use Class::MOP;
my @calls;
is($calls[0][4], 1);
splice @calls;
+done_testing;
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More;
use Class::MOP;
do {
is_deeply([sort Daughter->meta->direct_subclasses], []);
is_deeply([sort Cousin->meta->direct_subclasses], []);
+done_testing;
use FindBin;
use File::Spec::Functions;
-use Test::More tests => 69;
+use Test::More;
use Test::Exception;
use Class::MOP;
'... this should be the reverse of the original');
}
+done_testing;
use strict;
use warnings;
-use Test::More tests => 11;
+use Test::More;
use File::Spec;
-BEGIN {use Class::MOP;
+use Class::MOP;
+
+BEGIN {
require_ok(File::Spec->catfile('examples', 'InstanceCountingClass.pod'));
}
=pod
-This is a trivial and contrived example of how to
+This is a trivial and contrived example of how to
make a metaclass which will count all the instances
-created. It is not meant to be anything more than
+created. It is not meant to be anything more than
a simple demonstration of how to make a metaclass.
=cut
{
package Foo;
-
+
use metaclass 'InstanceCountingClass';
-
+
sub new {
my $class = shift;
$class->meta->new_object(@_);
}
-
+
package Bar;
-
+
our @ISA = ('Foo');
}
Foo->new();
}
-is(Foo->meta->get_count(), 10, '... our Foo count is now 10');
+is(Foo->meta->get_count(), 10, '... our Foo count is now 10');
is(Bar->meta->get_count(), 1, '... our Bar count is still 1');
+done_testing;
use strict;
use warnings;
-use Test::More tests => 88;
+use Test::More;
use File::Spec;
use Scalar::Util 'reftype';
-BEGIN {use Class::MOP;
+BEGIN {use Class::MOP;
require_ok(File::Spec->catfile('examples', 'InsideOutClass.pod'));
}
{
package Foo;
-
+
use strict;
- use warnings;
-
+ use warnings;
+
use metaclass (
'attribute_metaclass' => 'InsideOutClass::Attribute',
'instance_metaclass' => 'InsideOutClass::Instance'
);
-
+
Foo->meta->add_attribute('foo' => (
accessor => 'foo',
predicate => 'has_foo',
));
-
+
Foo->meta->add_attribute('bar' => (
reader => 'get_bar',
writer => 'set_bar',
- default => 'FOO is BAR'
+ default => 'FOO is BAR'
));
-
+
sub new {
my $class = shift;
$class->meta->new_object(@_);
}
-
+
package Bar;
use metaclass (
'attribute_metaclass' => 'InsideOutClass::Attribute',
'instance_metaclass' => 'InsideOutClass::Instance'
);
-
+
use strict;
use warnings;
-
+
use base 'Foo';
-
+
Bar->meta->add_attribute('baz' => (
accessor => 'baz',
predicate => 'has_baz',
- ));
-
+ ));
+
package Baz;
-
+
use strict;
use warnings;
- use metaclass (
+ use metaclass (
'attribute_metaclass' => 'InsideOutClass::Attribute',
'instance_metaclass' => 'InsideOutClass::Instance'
);
-
+
Baz->meta->add_attribute('bling' => (
accessor => 'bling',
default => 'Baz::bling'
- ));
-
+ ));
+
package Bar::Baz;
use metaclass (
'attribute_metaclass' => 'InsideOutClass::Attribute',
'instance_metaclass' => 'InsideOutClass::Instance'
);
-
+
use strict;
use warnings;
-
- use base 'Bar', 'Baz';
+
+ use base 'Bar', 'Baz';
}
my $foo = Foo->new();
{
no strict 'refs';
-
+
ok(*{'Foo::foo'}{HASH}, '... there is a foo package variable in Foo');
ok(*{'Foo::bar'}{HASH}, '... there is a bar package variable in Foo');
is(scalar(keys(%{'Foo::foo'})), 4, '... got the right number of entries for Foo::foo');
- is(scalar(keys(%{'Foo::bar'})), 4, '... got the right number of entries for Foo::bar');
+ is(scalar(keys(%{'Foo::bar'})), 4, '... got the right number of entries for Foo::bar');
ok(!*{'Bar::foo'}{HASH}, '... no foo package variable in Bar');
ok(!*{'Bar::bar'}{HASH}, '... no bar package variable in Bar');
is(scalar(keys(%{'Bar::foo'})), 0, '... got the right number of entries for Bar::foo');
is(scalar(keys(%{'Bar::bar'})), 0, '... got the right number of entries for Bar::bar');
is(scalar(keys(%{'Bar::baz'})), 2, '... got the right number of entries for Bar::baz');
-
+
ok(*{'Baz::bling'}{HASH}, '... there is a bar package variable in Baz');
- is(scalar(keys(%{'Baz::bling'})), 1, '... got the right number of entries for Baz::bling');
-
+ is(scalar(keys(%{'Baz::bling'})), 1, '... got the right number of entries for Baz::bling');
+
ok(!*{'Bar::Baz::foo'}{HASH}, '... no foo package variable in Bar::Baz');
ok(!*{'Bar::Baz::bar'}{HASH}, '... no bar package variable in Bar::Baz');
ok(!*{'Bar::Baz::baz'}{HASH}, '... no baz package variable in Bar::Baz');
is(scalar(keys(%{'Bar::Baz::foo'})), 0, '... got the right number of entries for Bar::Baz::foo');
is(scalar(keys(%{'Bar::Baz::bar'})), 0, '... got the right number of entries for Bar::Baz::bar');
- is(scalar(keys(%{'Bar::Baz::baz'})), 0, '... got the right number of entries for Bar::Baz::baz');
- is(scalar(keys(%{'Bar::Baz::bling'})), 0, '... got the right number of entries for Bar::Baz::bling');
+ is(scalar(keys(%{'Bar::Baz::baz'})), 0, '... got the right number of entries for Bar::Baz::baz');
+ is(scalar(keys(%{'Bar::Baz::bling'})), 0, '... got the right number of entries for Bar::Baz::bling');
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More;
use File::Spec;
-BEGIN {use Class::MOP;
+use Class::MOP;
+
+BEGIN {
require_ok(File::Spec->catfile('examples', 'Perl6Attribute.pod'));
}
{
package Foo;
-
+
use metaclass;
-
+
Foo->meta->add_attribute(Perl6Attribute->new('$.foo'));
- Foo->meta->add_attribute(Perl6Attribute->new('@.bar'));
- Foo->meta->add_attribute(Perl6Attribute->new('%.baz'));
-
+ Foo->meta->add_attribute(Perl6Attribute->new('@.bar'));
+ Foo->meta->add_attribute(Perl6Attribute->new('%.baz'));
+
sub new {
my $class = shift;
$class->meta->new_object(@_);
- }
+ }
}
my $foo = Foo->new();
is_deeply($foo->bar, [], '... Foo.bar == []');
is_deeply($foo->baz, {}, '... Foo.baz == {}');
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 27;
+use Test::More;
use File::Spec;
-BEGIN {use Class::MOP;
+use Class::MOP;
+
+BEGIN {
require_ok(File::Spec->catfile('examples', 'AttributesWithHistory.pod'));
}
{
package Foo;
use metaclass;
-
+
Foo->meta->add_attribute(AttributesWithHistory->new('foo' => (
accessor => 'foo',
history_accessor => 'get_foo_history',
- )));
-
+ )));
+
Foo->meta->add_attribute(AttributesWithHistory->new('bar' => (
reader => 'get_bar',
writer => 'set_bar',
history_accessor => 'get_bar_history',
- )));
-
+ )));
+
sub new {
my $class = shift;
$class->meta->new_object(@_);
- }
+ }
}
my $foo = Foo->new();
[ $foo->get_foo_history() ],
[ ],
'... got correct empty history for foo');
-
+
is($foo2->foo, undef, '... foo2 is not yet defined');
is_deeply(
[ $foo2->get_foo_history() ],
[ ],
- '... got correct empty history for foo2');
+ '... got correct empty history for foo2');
$foo->foo(42);
is($foo->foo, 42, '... foo == 42');
[ $foo2->get_foo_history() ],
[ ],
'... still got correct empty history for foo2');
-
+
$foo2->foo(100);
is($foo->foo, 42, '... foo is still == 42');
is_deeply(
is_deeply(
[ $foo->get_foo_history() ],
[ 42, 43, 44, 45, 46 ],
- '... got correct history for foo');
+ '... got correct history for foo');
is($foo->get_bar, undef, '... bar is not yet defined');
is_deeply(
[ $foo->get_foo_history() ],
[ 42, 43, 44, 45, 46 ],
'... still have the correct history for foo');
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 28;
+use Test::More;
use File::Spec;
-BEGIN {use Class::MOP;
+use Class::MOP;
+
+BEGIN {
require_ok(File::Spec->catfile('examples', 'ClassEncapsulatedAttributes.pod'));
}
{
package Foo;
-
+
use metaclass 'ClassEncapsulatedAttributes';
-
+
Foo->meta->add_attribute('foo' => (
accessor => 'foo',
- predicate => 'has_foo',
+ predicate => 'has_foo',
default => 'init in FOO'
));
-
+
Foo->meta->add_attribute('bar' => (
reader => 'get_bar',
writer => 'set_bar',
default => 'init in FOO'
));
-
+
sub new {
my $class = shift;
$class->meta->new_object(@_);
}
-
+
package Bar;
our @ISA = ('Foo');
-
+
Bar->meta->add_attribute('foo' => (
accessor => 'foo',
predicate => 'has_foo',
- default => 'init in BAR'
+ default => 'init in BAR'
));
-
+
Bar->meta->add_attribute('bar' => (
reader => 'get_bar',
writer => 'set_bar',
- default => 'init in BAR'
+ default => 'init in BAR'
));
-
+
sub SUPER_foo { (shift)->SUPER::foo(@_) }
- sub SUPER_has_foo { (shift)->SUPER::foo(@_) }
- sub SUPER_get_bar { (shift)->SUPER::get_bar() }
- sub SUPER_set_bar { (shift)->SUPER::set_bar(@_) }
-
+ sub SUPER_has_foo { (shift)->SUPER::foo(@_) }
+ sub SUPER_get_bar { (shift)->SUPER::get_bar() }
+ sub SUPER_set_bar { (shift)->SUPER::set_bar(@_) }
+
}
{
is($foo->foo, 'init in FOO', '... got the right default value for Foo::foo');
is($bar->foo, 'init in BAR', '... got the right default value for Bar::foo');
-
- is($bar->SUPER_foo(), 'init in FOO', '... got the right default value for Bar::SUPER::foo');
-
+
+ is($bar->SUPER_foo(), 'init in FOO', '... got the right default value for Bar::SUPER::foo');
+
$bar->SUPER_foo(undef);
- is($bar->SUPER_foo(), undef, '... successfully set Foo::foo through Bar::SUPER::foo');
- ok(!$bar->SUPER_has_foo, '... BAR::SUPER::has_foo == 0');
+ is($bar->SUPER_foo(), undef, '... successfully set Foo::foo through Bar::SUPER::foo');
+ ok(!$bar->SUPER_has_foo, '... BAR::SUPER::has_foo == 0');
ok($foo->has_foo, '... Foo::has_foo (is still) 1');
}
{
my $bar = Bar->new(
'Foo' => { 'foo' => 'Foo::foo' },
- 'Bar' => { 'foo' => 'Bar::foo' }
+ 'Bar' => { 'foo' => 'Bar::foo' }
);
isa_ok($bar, 'Bar');
can_ok($bar, 'set_bar');
ok($bar->has_foo, '... Bar::has_foo == 1');
- ok($bar->SUPER_has_foo, '... Bar::SUPER_has_foo == 1');
+ ok($bar->SUPER_has_foo, '... Bar::SUPER_has_foo == 1');
- is($bar->foo, 'Bar::foo', '... got the right default value for Bar::foo');
- is($bar->SUPER_foo(), 'Foo::foo', '... got the right default value for Bar::SUPER::foo');
+ is($bar->foo, 'Bar::foo', '... got the right default value for Bar::foo');
+ is($bar->SUPER_foo(), 'Foo::foo', '... got the right default value for Bar::SUPER::foo');
}
+done_testing;
use strict;
use warnings;
-use Test::More tests => 25;
+use Test::More;
use File::Spec;
-BEGIN {use Class::MOP;
+use Class::MOP;
+
+BEGIN {
require_ok(File::Spec->catfile('examples', 'LazyClass.pod'));
}
{
package BinaryTree;
-
+
use metaclass (
'attribute_metaclass' => 'LazyClass::Attribute',
- 'instance_metaclass' => 'LazyClass::Instance',
+ 'instance_metaclass' => 'LazyClass::Instance',
);
BinaryTree->meta->add_attribute('node' => (
accessor => 'node',
init_arg => 'node'
));
-
+
BinaryTree->meta->add_attribute('left' => (
reader => 'left',
default => sub { BinaryTree->new() }
));
-
+
BinaryTree->meta->add_attribute('right' => (
reader => 'right',
- default => sub { BinaryTree->new() }
- ));
+ default => sub { BinaryTree->new() }
+ ));
sub new {
my $class = shift;
ok(!exists($root->right->{'left'}), '... left attribute still has not been initialized yet');
ok(!exists($root->right->{'right'}), '... right attribute still has not been initialized yet');
+done_testing;
use Test::More;
use File::Spec;
+use Class::MOP;
BEGIN {
eval "use Algorithm::C3";
plan skip_all => "Algorithm::C3 required for this test" if $@;
- plan tests => 4;use Class::MOP;
require_ok(File::Spec->catfile('examples', 'C3MethodDispatchOrder.pod'));
}
{
package Diamond_A;
- use metaclass 'C3MethodDispatchOrder';
-
+ use metaclass 'C3MethodDispatchOrder';
+
sub hello { 'Diamond_A::hello' }
package Diamond_B;
- use metaclass 'C3MethodDispatchOrder';
- __PACKAGE__->meta->superclasses('Diamond_A');
-
+ use metaclass 'C3MethodDispatchOrder';
+ __PACKAGE__->meta->superclasses('Diamond_A');
+
package Diamond_C;
- use metaclass 'C3MethodDispatchOrder';
- __PACKAGE__->meta->superclasses('Diamond_A');
-
+ use metaclass 'C3MethodDispatchOrder';
+ __PACKAGE__->meta->superclasses('Diamond_A');
+
sub hello { 'Diamond_C::hello' }
package Diamond_D;
- use metaclass 'C3MethodDispatchOrder';
+ use metaclass 'C3MethodDispatchOrder';
__PACKAGE__->meta->superclasses('Diamond_B', 'Diamond_C');
}
is(Diamond_D->hello, 'Diamond_C::hello', '... got the right dispatch order');
is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
-
+done_testing;
use strict;
use warnings;
-use Test::More tests => 72;
+use Test::More;
use File::Spec;
use Scalar::Util 'reftype';
+use Class::MOP;
-BEGIN {use Class::MOP;
+BEGIN {
require_ok(File::Spec->catfile('examples', 'ArrayBasedStorage.pod'));
}
cmp_ok( scalar(@$new_baz), ">", scalar(@$baz), "additional slot due to refreshed meta instance" );
+done_testing;
use strict;
use warnings;
-use Test::More tests => 7;
+use Test::More;
=pod
-This tests that Class::MOP works correctly
-with Class::C3 and it's somewhat insane
+This tests that Class::MOP works correctly
+with Class::C3 and it's somewhat insane
approach to method resolution.
=cut
-BEGIN {use Class::MOP;
-}
+use Class::MOP;
{
package Diamond_A;
use mro 'c3';
use metaclass; # everyone will just inherit this now :)
-
+
sub hello { 'Diamond_A::hello' }
}
{
package Diamond_B;
- use mro 'c3';
+ use mro 'c3';
use base 'Diamond_A';
}
{
package Diamond_C;
use mro 'c3';
- use base 'Diamond_A';
-
+ use base 'Diamond_A';
+
sub hello { 'Diamond_C::hello' }
}
{
package Diamond_D;
- use mro 'c3';
+ use mro 'c3';
use base ('Diamond_B', 'Diamond_C');
}
-# we have to manually initialize
-# Class::C3 since we potentially
+# we have to manually initialize
+# Class::C3 since we potentially
# skip this test if it is not present
Class::C3::initialize();
ok(defined &Diamond_B::hello, '... B does have an alias to the method hello');
ok(defined &Diamond_D::hello, '... D does have an alias to the method hello');
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 1;
+use Test::More;
use Class::MOP;
$c->employees();
};
ok( $@, '... we die correctly with bad args' );
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 8;
+use Test::More;
use Class::MOP;
{
package Foo;
use metaclass;
-
+
Foo->meta->add_attribute('foo' => (
init_arg => 'foo',
reader => 'get_foo',
default => 'BAR',
));
-
+
}
my $foo = Foo->meta->new_object;
my $clone = $foo->meta->clone_object($foo, foo => 'BAZ');
isa_ok($clone, 'Foo');
isnt($clone, $foo, '... and it is a clone');
-
+
is($clone->get_foo, 'BAZ', '... got the right cloned value');
}
my $clone = $foo->meta->clone_object($foo, foo => undef);
isa_ok($clone, 'Foo');
isnt($clone, $foo, '... and it is a clone');
-
+
ok(!defined($clone->get_foo), '... got the right cloned value');
}
-
-
-
-
-
+done_testing;
use strict;
use warnings;
-use Test::More tests => 4;
+use Test::More;
use Test::Exception;
use Class::MOP;
);
}
+done_testing;
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More;
use Test::Exception;
use Class::MOP;
Bar->meta->superclasses('Foo');
} qr/^Recursive inheritance detected/, "error occurs when Bar extends Foo, when Foo is a Bar";
+done_testing;
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More;
use Class::MOP;
$syms = $meta->get_all_package_symbols('CODE');
is(ref $syms->{FOO}, 'CODE', 'constant symbol still there, although we dropped our reference');
+
+done_testing;
use strict;
-use Test::More tests => 20;
+use Test::More;
use Test::Exception;
use Class::MOP;
is $meta_method->fully_qualified_name, "Derived::${name}";
lives_ok { $meta_method->execute };
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More;
use Class::MOP;
do {
$meta->rebless_instance($without);
is("$without", "overloaded", "overloading after reblessing works");
+done_testing;
#!/usr/bin/env perl
use strict;
use warnings;
-use Test::More tests => 1;
+use Test::More;
use Class::MOP;
my $non = Class::MOP::Class->initialize('Non::Existent::Package');
$non->get_method('foo');
pass("empty stashes don't segfault");
+
+done_testing;
+use strict;
+use warnings;
+use Test::More;
use Class::MOP;
-use Test::More('tests', 2);
-
-
my $Point = Class::MOP::Class->create('Point' => (
version => '0.01',
attributes => [
Class::MOP::Attribute->new('y' => (
accessor => 'y',
init_arg => 'y'
- )),
+ )),
],
methods => {
'new' => sub {
'clear' => sub {
my $self = shift;
$self->{'x'} = 0;
- $self->{'y'} = 0;
+ $self->{'y'} = 0;
}
}
));
is($Point->get_attribute('x')->insertion_order, 0, 'Insertion order of Attribute "x"');
is($Point->get_attribute('y')->insertion_order, 1, 'Insertion order of Attribute "y"');
-1;
+done_testing;
use strict;
use warnings;
-use Test::More tests => 6;
+use Test::More;
use Class::MOP;
is( Foo->bar, "Origin::bar", "caller aggrees" );
is( Origin->bar, "Origin::bar", "unrelated class untouched" );
+
+done_testing;
BEGIN {
eval "use Test::Output;";
plan skip_all => "Test::Output is required for this test" if $@;
- plan tests => 15;
}
use Class::MOP;
'got a warning when trying to inline a destructor in a class that inherits an unexpected DESTROY'
);
}
+
+done_testing;
use strict;
use warnings;
-
use Test::More;
-
-plan tests => 1;
-
use Class::MOP;
::is( $@, 'dollar at', '$@ is untouched after immutablization' );
}
+
+done_testing;
plan skip_all => "Test::LeakTrace is required for this test" if $@;
}
-plan tests => 2;
-
# 5.10.0 has a bug on weaken($hash_ref) which leaks an AV.
my $expected = ( $] == 5.010_000 ? 1 : 0 );
}
'<=', $expected, 'create_anon_class(superclass => [...])';
+done_testing;
use Class::MOP;
use Class::MOP::Class;
-use Test::More tests => 9;
+use Test::More;
use Test::Exception;
my %results;
'saw expected calls to wrappers'
);
}
+
+done_testing;
use warnings;
use Class::MOP;
-
-use Test::More tests => 3;
+use Test::More;
{
package Foo;
$meta->add_attribute( name => 'attr', reader => 'get_attr' );
ok( ! $meta->is_pristine, 'Foo is not pristine after add_attribute' );
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More;
use Test::Exception;
use Class::MOP;
package Foo;
use metaclass;
- Foo->meta->add_attribute('bar' =>
+ Foo->meta->add_attribute('bar' =>
reader => 'get_bar',
writer => 'set_bar',
- );
+ );
- Foo->meta->add_attribute('baz' =>
+ Foo->meta->add_attribute('baz' =>
accessor => 'baz',
- );
+ );
Foo->meta->make_immutable();
}
is_deeply [Class::MOP::get_code_info($value)], [qw(Class::MOP get_code_info)], 'get_code_info(tied scalar)';
}
}
+
+done_testing;
use strict;
use warnings;
-use Test::More tests => 7;
+use Test::More;
use Test::Exception;
use Carp;
'get_method_map returns expected methods'
);
}
+
+done_testing;
projects / gitmo/Class-MOP.git / commitdiff