From: Stevan Little Date: Thu, 6 Apr 2006 20:05:34 +0000 (+0000) Subject: adding-basic-role-support X-Git-Tag: 0_05~49 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e185c0275ed444aca27d4255757d3ed673811ff4;p=gitmo%2FMoose.git adding-basic-role-support --- diff --git a/Changes b/Changes index 2b9ff0a..9c9057f 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,7 @@ Revision history for Perl extension Moose +0.04 + 0.03 Thurs. March 30, 2006 * Moose::Cookbook - added the Moose::Cookbook with 5 recipes, diff --git a/MANIFEST b/MANIFEST index 2a1368e..632f611 100644 --- a/MANIFEST +++ b/MANIFEST @@ -8,6 +8,7 @@ README lib/Moose.pm lib/Moose/Cookbook.pod lib/Moose/Object.pm +lib/Moose/Role.pm lib/Moose/Cookbook/Recipe1.pod lib/Moose/Cookbook/Recipe2.pod lib/Moose/Cookbook/Recipe3.pod @@ -15,6 +16,7 @@ lib/Moose/Cookbook/Recipe4.pod lib/Moose/Cookbook/Recipe5.pod lib/Moose/Meta/Attribute.pm lib/Moose/Meta/Class.pm +lib/Moose/Meta/Role.pm lib/Moose/Meta/TypeCoercion.pm lib/Moose/Meta/TypeConstraint.pm lib/Moose/Util/TypeConstraints.pm @@ -33,6 +35,8 @@ t/020_foreign_inheritence.t t/030_attribute_reader_generation.t t/031_attribute_writer_generation.t t/032_attribute_accessor_generation.t +t/040_meta_role.t +t/041_role.t t/050_util_type_constraints.t t/051_util_type_constraints_export.t t/052_util_std_type_constraints.t diff --git a/lib/Moose.pm b/lib/Moose.pm index 2b5297f..e8bb16b 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -4,7 +4,7 @@ package Moose; use strict; use warnings; -our $VERSION = '0.03'; +our $VERSION = '0.04'; use Scalar::Util 'blessed', 'reftype'; use Carp 'confess'; @@ -40,7 +40,7 @@ sub import { if ($pkg->can('meta')) { $meta = $pkg->meta(); (blessed($meta) && $meta->isa('Class::MOP::Class')) - || confess "Whoops, not møøsey enough"; + || confess "Whoops, not møøsey enough"; } else { $meta = Moose::Meta::Class->initialize($pkg => ( diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm new file mode 100644 index 0000000..3cfff5e --- /dev/null +++ b/lib/Moose/Meta/Role.pm @@ -0,0 +1,211 @@ + +package Moose::Meta::Role; + +use strict; +use warnings; +use metaclass; + +use Carp 'confess'; + +our $VERSION = '0.01'; + +__PACKAGE__->meta->add_attribute('role_meta' => ( + reader => 'role_meta' +)); + +__PACKAGE__->meta->add_attribute('attribute_map' => ( + reader => 'get_attribute_map', + default => sub { {} } +)); + +__PACKAGE__->meta->add_attribute('method_modifier_map' => ( + reader => 'get_method_modifier_map', + default => sub { + return { + before => {}, + after => {}, + around => {}, + override => {}, + augment => {}, + }; + } +)); + +sub new { + my $class = shift; + my %options = @_; + $options{role_meta} = Class::MOP::Class->initialize($options{role_name}); + my $self = $class->meta->new_object(%options); + return $self; +} + +# NOTE: +# we delegate to some role_meta methods for convience here +# the Moose::Meta::Role is meant to be a read-only interface +# to the underlying role package, if you want to manipulate +# that, just use ->role_meta + +sub name { (shift)->role_meta->name } +sub version { (shift)->role_meta->version } + +sub get_method { (shift)->role_meta->get_method(@_) } +sub has_method { (shift)->role_meta->has_method(@_) } +sub get_method_list { + my ($self) = @_; + # meta is not applicable in this context, + # if you want to see it use the ->role_meta + grep { !/^meta$/ } $self->role_meta->get_method_list; +} + +# ... however the items in statis (attributes & method modifiers) +# can be removed and added to through this API + +# attributes + +sub add_attribute { + my ($self, $name, %attr_desc) = @_; + $self->get_attribute_map->{$name} = \%attr_desc; +} + +sub has_attribute { + my ($self, $name) = @_; + exists $self->get_attribute_map->{$name} ? 1 : 0; +} + +sub get_attribute { + my ($self, $name) = @_; + $self->get_attribute_map->{$name} +} + +sub remove_attribute { + my ($self, $name) = @_; + delete $self->get_attribute_map->{$name} +} + +sub get_attribute_list { + my ($self) = @_; + keys %{$self->get_attribute_map}; +} + +# method modifiers + +sub add_method_modifier { + my ($self, $modifier_type, $method_name, $method) = @_; + $self->get_method_modifier_map->{$modifier_type}->{$method_name} = $method; +} + +sub has_method_modifier { + my ($self, $modifier_type, $method_name) = @_; + exists $self->get_method_modifier_map->{$modifier_type}->{$method_name} ? 1 : 0 +} + +sub get_method_modifier { + my ($self, $modifier_type, $method_name) = @_; + $self->get_method_modifier_map->{$modifier_type}->{$method_name}; +} + +sub remove_method_modifier { + my ($self, $modifier_type, $method_name) = @_; + delete $self->get_method_modifier_map->{$modifier_type}->{$method_name}; +} + +sub get_method_modifier_list { + my ($self, $modifier_type) = @_; + keys %{$self->get_method_modifier_map->{$modifier_type}}; +} + + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::Meta::Role - The Moose Role metaclass + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=back + +=over 4 + +=item B + +=item B + +=item B + +=back + +=over 4 + +=item B + +=item B + +=item B + +=back + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug +to cpan-RT. + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm new file mode 100644 index 0000000..5e39395 --- /dev/null +++ b/lib/Moose/Role.pm @@ -0,0 +1,121 @@ + +package Moose::Role; + +use strict; +use warnings; + +use Scalar::Util (); +use Carp 'confess'; +use Sub::Name 'subname'; + +our $VERSION = '0.01'; + +use Moose::Meta::Role; + +sub import { + shift; + my $pkg = caller(); + + # we should never export to main + return if $pkg eq 'main'; + + Moose::Util::TypeConstraints->import($pkg); + + my $meta; + if ($pkg->can('meta')) { + $meta = $pkg->meta(); + (blessed($meta) && $meta->isa('Moose::Meta::Role')) + || confess "Whoops, not møøsey enough"; + } + else { + $meta = Moose::Meta::Role->new( + role_name => $pkg + ); + $meta->role_meta->add_method('meta' => sub { $meta }) + } + + # NOTE: + # &alias_method will install the method, but it + # will not name it with + + # handle superclasses + $meta->role_meta->alias_method('extends' => subname 'Moose::Role::extends' => sub { + confess "Moose::Role does not currently support 'extends'" + }); + + # handle attributes + $meta->role_meta->alias_method('has' => subname 'Moose::Role::has' => sub { + my ($name, %options) = @_; + $meta->add_attribute($name, %options) + }); + + # handle method modifers + $meta->role_meta->alias_method('before' => subname 'Moose::Role::before' => sub { + my $code = pop @_; + $meta->add_method_modifier('before' => $_, $code) for @_; + }); + $meta->role_meta->alias_method('after' => subname 'Moose::Role::after' => sub { + my $code = pop @_; + $meta->add_method_modifier('after' => $_, $code) for @_; + }); + $meta->role_meta->alias_method('around' => subname 'Moose::Role::around' => sub { + my $code = pop @_; + $meta->add_method_modifier('around' => $_, $code) for @_; + }); + + $meta->role_meta->alias_method('super' => subname 'Moose::Role::super' => sub {}); + $meta->role_meta->alias_method('override' => subname 'Moose::Role::override' => sub { + my ($name, $code) = @_; + $meta->add_method_modifier('override' => $name, $code); + }); + + $meta->role_meta->alias_method('inner' => subname 'Moose::Role::inner' => sub {}); + $meta->role_meta->alias_method('augment' => subname 'Moose::Role::augment' => sub { + my ($name, $code) = @_; + $meta->add_method_modifier('augment' => $name, $code); + }); + + # we recommend using these things + # so export them for them + $meta->role_meta->alias_method('confess' => \&Carp::confess); + $meta->role_meta->alias_method('blessed' => \&Scalar::Util::blessed); +} + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::Role - The Moose Role + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug +to cpan-RT. + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/t/040_meta_role.t b/t/040_meta_role.t new file mode 100644 index 0000000..205b0df --- /dev/null +++ b/t/040_meta_role.t @@ -0,0 +1,111 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 27; +use Test::Exception; + +BEGIN { + use_ok('Moose::Meta::Role'); +} + +{ + package FooRole; + + our $VERSION = '0.01'; + + sub foo { 'FooRole::foo' } +} + +my $foo_role = Moose::Meta::Role->new( + role_name => 'FooRole' +); +isa_ok($foo_role, 'Moose::Meta::Role'); + +isa_ok($foo_role->role_meta, 'Class::MOP::Class'); + +is($foo_role->name, 'FooRole', '... got the right name of FooRole'); +is($foo_role->version, '0.01', '... got the right version of FooRole'); + +# methods ... + +ok($foo_role->has_method('foo'), '... FooRole has the foo method'); +is($foo_role->get_method('foo'), \&FooRole::foo, '... FooRole got the foo method'); + +is_deeply( + [ $foo_role->get_method_list() ], + [ 'foo' ], + '... got the right method list'); + +# attributes ... + +is_deeply( + [ $foo_role->get_attribute_list() ], + [], + '... got the right attribute list'); + +ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute'); + +lives_ok { + $foo_role->add_attribute('bar' => (is => 'rw', isa => 'Foo')); +} '... added the bar attribute okay'; + +is_deeply( + [ $foo_role->get_attribute_list() ], + [ 'bar' ], + '... got the right attribute list'); + +ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute'); + +is_deeply( + $foo_role->get_attribute('bar'), + { is => 'rw', isa => 'Foo' }, + '... got the correct description of the bar attribute'); + +lives_ok { + $foo_role->add_attribute('baz' => (is => 'ro')); +} '... added the baz attribute okay'; + +is_deeply( + [ sort $foo_role->get_attribute_list() ], + [ 'bar', 'baz' ], + '... got the right attribute list'); + +ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute'); + +is_deeply( + $foo_role->get_attribute('baz'), + { is => 'ro' }, + '... got the correct description of the baz attribute'); + +lives_ok { + $foo_role->remove_attribute('bar'); +} '... removed the bar attribute okay'; + +is_deeply( + [ $foo_role->get_attribute_list() ], + [ 'baz' ], + '... got the right attribute list'); + +ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute'); +ok($foo_role->has_attribute('baz'), '... FooRole does still have the baz attribute'); + +# method modifiers + +ok(!$foo_role->has_method_modifier('before' => 'boo'), '... no boo:before modifier'); + +my $method = sub { "FooRole::boo:before" }; +lives_ok { + $foo_role->add_method_modifier('before' => ( + 'boo' => $method + )); +} '... added a method modifier okay'; + +ok($foo_role->has_method_modifier('before' => 'boo'), '... now we have a boo:before modifier'); +is($foo_role->get_method_modifier('before' => 'boo'), $method, '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('before') ], + [ 'boo' ], + '... got the right list of before method modifiers'); diff --git a/t/041_role.t b/t/041_role.t new file mode 100644 index 0000000..8992173 --- /dev/null +++ b/t/041_role.t @@ -0,0 +1,80 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 16; +use Test::Exception; + +BEGIN { + use_ok('Moose::Role'); +} + +{ + package FooRole; + + use strict; + use warnings; + use Moose::Role; + + our $VERSION = '0.01'; + + has 'bar' => (is => 'rw', isa => 'Foo'); + has 'baz' => (is => 'ro'); + + sub foo { 'FooRole::foo' } + + before 'boo' => sub { "FooRole::boo:before" }; +} + +my $foo_role = FooRole->meta; +isa_ok($foo_role, 'Moose::Meta::Role'); + +isa_ok($foo_role->role_meta, 'Class::MOP::Class'); + +is($foo_role->name, 'FooRole', '... got the right name of FooRole'); +is($foo_role->version, '0.01', '... got the right version of FooRole'); + +# methods ... + +ok($foo_role->has_method('foo'), '... FooRole has the foo method'); +is($foo_role->get_method('foo'), \&FooRole::foo, '... FooRole got the foo method'); + +is_deeply( + [ $foo_role->get_method_list() ], + [ 'foo' ], + '... got the right method list'); + +# attributes ... + +is_deeply( + [ sort $foo_role->get_attribute_list() ], + [ 'bar', 'baz' ], + '... got the right attribute list'); + +ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute'); + +is_deeply( + $foo_role->get_attribute('bar'), + { is => 'rw', isa => 'Foo' }, + '... got the correct description of the bar attribute'); + +ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute'); + +is_deeply( + $foo_role->get_attribute('baz'), + { is => 'ro' }, + '... got the correct description of the baz attribute'); + +# method modifiers + +ok($foo_role->has_method_modifier('before' => 'boo'), '... now we have a boo:before modifier'); +is($foo_role->get_method_modifier('before' => 'boo')->(), + "FooRole::boo:before", + '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('before') ], + [ 'boo' ], + '... got the right list of before method modifiers'); +