Revision history for Perl extension Moose
+0.04
+
0.03 Thurs. March 30, 2006
* Moose::Cookbook
- added the Moose::Cookbook with 5 recipes,
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
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
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
use strict;
use warnings;
-our $VERSION = '0.03';
+our $VERSION = '0.04';
use Scalar::Util 'blessed', 'reftype';
use Carp 'confess';
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 => (
--- /dev/null
+
+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<meta>
+
+=item B<new>
+
+=back
+
+=over 4
+
+=item B<name>
+
+=item B<version>
+
+=item B<role_meta>
+
+=back
+
+=over 4
+
+=item B<get_method>
+
+=item B<has_method>
+
+=item B<get_method_list>
+
+=back
+
+=over 4
+
+=item B<add_attribute>
+
+=item B<has_attribute>
+
+=item B<get_attribute>
+
+=item B<get_attribute_list>
+
+=item B<get_attribute_map>
+
+=item B<remove_attribute>
+
+=back
+
+=over 4
+
+=item B<add_method_modifier>
+
+=item B<get_method_modifier>
+
+=item B<has_method_modifier>
+
+=item B<get_method_modifier_list>
+
+=item B<get_method_modifier_map>
+
+=item B<remove_method_modifier>
+
+=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 E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+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
--- /dev/null
+
+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 E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+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
--- /dev/null
+#!/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');
--- /dev/null
+#!/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');
+
projects / gitmo/Moose.git / commitdiff