From: Stevan Little Date: Thu, 6 Apr 2006 21:34:51 +0000 (+0000) Subject: ROLES X-Git-Tag: 0_05~48 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=78cd1d3bb0bf969a5d60e9ba32601c22290e744a;p=gitmo%2FMoose.git ROLES --- diff --git a/MANIFEST b/MANIFEST index 632f611..7a72ae5 100644 --- a/MANIFEST +++ b/MANIFEST @@ -37,6 +37,7 @@ t/031_attribute_writer_generation.t t/032_attribute_accessor_generation.t t/040_meta_role.t t/041_role.t +t/042_apply_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 e8bb16b..260db75 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -15,9 +15,9 @@ use UNIVERSAL::require; use Class::MOP; use Moose::Meta::Class; -use Moose::Meta::Attribute; use Moose::Meta::TypeConstraint; use Moose::Meta::TypeCoercion; +use Moose::Meta::Attribute; use Moose::Object; use Moose::Util::TypeConstraints; @@ -60,14 +60,20 @@ sub import { # handle superclasses $meta->alias_method('extends' => subname 'Moose::extends' => sub { - _load_all_superclasses(@_); + _load_all_classes(@_); $meta->superclasses(@_) }); + # handle roles + $meta->alias_method('with' => subname 'Moose::with' => sub { + my ($role) = @_; + _load_all_classes($role); + $role->meta->apply($meta); + }); + # handle attributes $meta->alias_method('has' => subname 'Moose::has' => sub { my ($name, %options) = @_; - _process_has_options($name, \%options); $meta->add_attribute($name, %options) }); @@ -88,13 +94,13 @@ sub import { $meta->alias_method('super' => subname 'Moose::super' => sub {}); $meta->alias_method('override' => subname 'Moose::override' => sub { my ($name, $method) = @_; - $meta->add_method($name => _create_override_sub($meta, $name, $method)); + $meta->add_override_method_modifier($name => $method); }); $meta->alias_method('inner' => subname 'Moose::inner' => sub {}); $meta->alias_method('augment' => subname 'Moose::augment' => sub { my ($name, $method) = @_; - $meta->add_method($name => _create_augment_sub($meta, $name, $method)); + $meta->add_augment_method_modifier($name => $method); }); # make sure they inherit from Moose::Object @@ -109,36 +115,7 @@ sub import { ## Utility functions -sub _process_has_options { - my ($attr_name, $options) = @_; - if (exists $options->{is}) { - if ($options->{is} eq 'ro') { - $options->{reader} = $attr_name; - } - elsif ($options->{is} eq 'rw') { - $options->{accessor} = $attr_name; - } - } - if (exists $options->{isa}) { - # allow for anon-subtypes here ... - if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) { - $options->{type_constraint} = $options->{isa}; - } - else { - # otherwise assume it is a constraint - my $constraint = find_type_constraint($options->{isa}); - # if the constraing it not found .... - unless (defined $constraint) { - # assume it is a foreign class, and make - # an anon constraint for it - $constraint = subtype Object => where { $_->isa($options->{isa}) }; - } - $options->{type_constraint} = $constraint; - } - } -} - -sub _load_all_superclasses { +sub _load_all_classes { foreach my $super (@_) { # see if this is already # loaded in the symbol table @@ -160,34 +137,6 @@ sub _is_class_already_loaded { return 0; } -sub _create_override_sub { - my ($meta, $name, $method) = @_; - my $super = $meta->find_next_method_by_name($name); - (defined $super) - || confess "You cannot override '$name' because it has no super method"; - return sub { - my @args = @_; - no strict 'refs'; - no warnings 'redefine'; - local *{$meta->name . '::super'} = sub { $super->(@args) }; - return $method->(@args); - }; -} - -sub _create_augment_sub { - my ($meta, $name, $method) = @_; - my $super = $meta->find_next_method_by_name($name); - (defined $super) - || confess "You cannot augment '$name' because it has no super method"; - return sub { - my @args = @_; - no strict 'refs'; - no warnings 'redefine'; - local *{$super->package_name . '::inner'} = sub { $method->(@args) }; - return $super->(@args); - }; -} - 1; __END__ diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 005e323..21ce718 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -4,10 +4,12 @@ package Moose::Meta::Attribute; use strict; use warnings; -use Scalar::Util 'weaken', 'reftype'; +use Scalar::Util 'blessed', 'weaken', 'reftype'; use Carp 'confess'; -our $VERSION = '0.02'; +our $VERSION = '0.03'; + +use Moose::Util::TypeConstraints '-no-export'; use base 'Class::MOP::Attribute'; @@ -20,19 +22,53 @@ __PACKAGE__->meta->add_attribute('type_constraint' => ( predicate => 'has_type_constraint', )); -__PACKAGE__->meta->add_before_method_modifier('new' => sub { - my (undef, undef, %options) = @_; +sub new { + my ($class, $name, %options) = @_; + + if (exists $options{is}) { + if ($options{is} eq 'ro') { + $options{reader} = $name; + } + elsif ($options{is} eq 'rw') { + $options{accessor} = $name; + } + } + + if (exists $options{isa}) { + # allow for anon-subtypes here ... + if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { + $options{type_constraint} = $options{isa}; + } + else { + # otherwise assume it is a constraint + my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa}); + # if the constraing it not found .... + unless (defined $constraint) { + # assume it is a foreign class, and make + # an anon constraint for it + $constraint = Moose::Util::TypeConstraints::subtype( + 'Object', + Moose::Util::TypeConstraints::where { $_->isa($options{isa}) } + ); + } + $options{type_constraint} = $constraint; + } + } + if (exists $options{coerce} && $options{coerce}) { (exists $options{type_constraint}) || confess "You cannot have coercion without specifying a type constraint"; confess "You cannot have a weak reference to a coerced value" if $options{weak_ref}; } + if (exists $options{lazy} && $options{lazy}) { (exists $options{default}) || confess "You cannot have lazy attribute without specifying a default value for it"; - } -}); + } + + $class->SUPER::new($name, %options); +} sub generate_accessor_method { my ($self, $attr_name) = @_; diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index addebf3..37c8552 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -7,7 +7,7 @@ use warnings; use Carp 'confess'; use Scalar::Util 'weaken'; -our $VERSION = '0.03'; +our $VERSION = '0.04'; use base 'Class::MOP::Class'; @@ -50,6 +50,36 @@ sub construct_instance { return $instance; } +sub add_override_method_modifier { + my ($self, $name, $method, $_super_package) = @_; + # need this for roles ... + $_super_package ||= $self->name; + my $super = $self->find_next_method_by_name($name); + (defined $super) + || confess "You cannot override '$name' because it has no super method"; + $self->add_method($name => sub { + my @args = @_; + no strict 'refs'; + no warnings 'redefine'; + local *{$_super_package . '::super'} = sub { $super->(@args) }; + return $method->(@args); + }); +} + +sub add_augment_method_modifier { + my ($self, $name, $method) = @_; + my $super = $self->find_next_method_by_name($name); + (defined $super) + || confess "You cannot augment '$name' because it has no super method"; + $self->add_method($name => sub { + my @args = @_; + no strict 'refs'; + no warnings 'redefine'; + local *{$super->package_name . '::inner'} = sub { $method->(@args) }; + return $super->(@args); + }); +} + 1; __END__ @@ -83,6 +113,10 @@ you are doing. This method makes sure to handle the moose weak-ref, type-constraint and type coercion features. +=item B + +=item B + =back =head1 BUGS diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm index 3cfff5e..a7f284e 100644 --- a/lib/Moose/Meta/Role.pm +++ b/lib/Moose/Meta/Role.pm @@ -25,8 +25,7 @@ __PACKAGE__->meta->add_attribute('method_modifier_map' => ( before => {}, after => {}, around => {}, - override => {}, - augment => {}, + override => {} }; } )); @@ -39,6 +38,63 @@ sub new { return $self; } +sub apply { + my ($self, $other) = @_; + + foreach my $attribute_name ($self->get_attribute_list) { + # skip it if it has one already + next if $other->has_attribute($attribute_name); + # add it, although it could be overriden + $other->add_attribute( + $attribute_name, + %{$self->get_attribute($attribute_name)} + ); + } + + foreach my $method_name ($self->get_method_list) { + # skip it if it has one already + next if $other->has_method($method_name); + # add it, although it could be overriden + $other->add_method( + $method_name, + $self->get_method($method_name) + ); + } + + foreach my $method_name ($self->get_method_modifier_list('override')) { + # skip it if it has one already + next if $other->has_method($method_name); + # add it, although it could be overriden + $other->add_override_method_modifier( + $method_name, + $self->get_method_modifier('override' => $method_name), + $self->name + ); + } + + foreach my $method_name ($self->get_method_modifier_list('before')) { + $other->add_before_method_modifier( + $method_name, + $self->get_method_modifier('before' => $method_name) + ); + } + + foreach my $method_name ($self->get_method_modifier_list('after')) { + $other->add_after_method_modifier( + $method_name, + $self->get_method_modifier('after' => $method_name) + ); + } + + foreach my $method_name ($self->get_method_modifier_list('around')) { + $other->add_around_method_modifier( + $method_name, + $self->get_method_modifier('around' => $method_name) + ); + } + +} + # NOTE: # we delegate to some role_meta methods for convience here # the Moose::Meta::Role is meant to be a read-only interface @@ -135,6 +191,8 @@ Moose::Meta::Role - The Moose Role metaclass =item B +=item B + =back =over 4 diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index 5e39395..70ed5ac 100644 --- a/lib/Moose/Role.pm +++ b/lib/Moose/Role.pm @@ -28,9 +28,7 @@ sub import { || confess "Whoops, not møøsey enough"; } else { - $meta = Moose::Meta::Role->new( - role_name => $pkg - ); + $meta = Moose::Meta::Role->new(role_name => $pkg); $meta->role_meta->add_method('meta' => sub { $meta }) } @@ -69,10 +67,11 @@ sub import { $meta->add_method_modifier('override' => $name, $code); }); - $meta->role_meta->alias_method('inner' => subname 'Moose::Role::inner' => sub {}); + $meta->role_meta->alias_method('inner' => subname 'Moose::Role::inner' => sub { + confess "Moose::Role does not currently support 'inner'"; + }); $meta->role_meta->alias_method('augment' => subname 'Moose::Role::augment' => sub { - my ($name, $code) = @_; - $meta->add_method_modifier('augment' => $name, $code); + confess "Moose::Role does not currently support 'augment'"; }); # we recommend using these things diff --git a/t/006_basic.t b/t/006_basic.t index 7c5f475..05cdfdd 100644 --- a/t/006_basic.t +++ b/t/006_basic.t @@ -10,11 +10,7 @@ BEGIN { use_ok('Moose'); } -=pod - -This test will eventually be for the code shown below. -Moose::Role is on the TODO list for 0.04. - +{ package Constraint; use strict; use warnings; @@ -93,12 +89,11 @@ Moose::Role is on the TODO list for 0.04. extends 'Constraint::NoMoreThan'; with 'Constraint::OnLength'; - package Constraint::LengthAtLeast; - use strict; - use warnings; - use Moose; - - extends 'Constraint::AtLeast'; - with 'Constraint::OnLength'; - -=cut \ No newline at end of file + package Constraint::LengthAtLeast; + use strict; + use warnings; + use Moose; + + extends 'Constraint::AtLeast'; + with 'Constraint::OnLength'; +} diff --git a/t/042_apply_role.t b/t/042_apply_role.t new file mode 100644 index 0000000..21bcd8b --- /dev/null +++ b/t/042_apply_role.t @@ -0,0 +1,99 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 28; +use Test::Exception; + +BEGIN { + use_ok('Moose::Role'); +} + +{ + package FooRole; + use strict; + use warnings; + use Moose::Role; + + has 'bar' => (is => 'rw', isa => 'FooClass'); + has 'baz' => (is => 'ro'); + + sub goo { 'FooRole::goo' } + sub foo { 'FooRole::foo' } + + override 'boo' => sub { 'FooRole::boo -> ' . super() }; + + around 'blau' => sub { + my $c = shift; + 'FooRole::blau -> ' . $c->(); + }; + + package BarClass; + use strict; + use warnings; + use Moose; + + sub boo { 'BarClass::boo' } + sub foo { 'BarClass::foo' } # << the role overrides this ... + + package FooClass; + use strict; + use warnings; + use Moose; + + extends 'BarClass'; + with 'FooRole'; + + sub blau { 'FooClass::blau' } + + sub goo { 'FooClass::goo' } # << overrides the one from the role ... +} + +my $foo_class_meta = FooClass->meta; +isa_ok($foo_class_meta, 'Moose::Meta::Class'); + +foreach my $method_name (qw(bar baz foo boo blau goo)) { + ok($foo_class_meta->has_method($method_name), '... FooClass has the method ' . $method_name); +} + +foreach my $attr_name (qw(bar baz)) { + ok($foo_class_meta->has_attribute($attr_name), '... FooClass has the attribute ' . $attr_name); +} + +my $foo = FooClass->new(); +isa_ok($foo, 'FooClass'); + +can_ok($foo, 'bar'); +can_ok($foo, 'baz'); +can_ok($foo, 'foo'); +can_ok($foo, 'boo'); +can_ok($foo, 'goo'); +can_ok($foo, 'blau'); + +is($foo->foo, 'FooRole::foo', '... got the right value of foo'); +is($foo->goo, 'FooClass::goo', '... got the right value of goo'); + +ok(!defined($foo->baz), '... $foo->baz is undefined'); +ok(!defined($foo->bar), '... $foo->bar is undefined'); + +dies_ok { + $foo->baz(1) +} '... baz is a read-only accessor'; + +dies_ok { + $foo->bar(1) +} '... bar is a read-write accessor with a type constraint'; + +my $foo2 = FooClass->new(); +isa_ok($foo2, 'FooClass'); + +lives_ok { + $foo->bar($foo2) +} '... bar is a read-write accessor with a type constraint'; + +is($foo->bar, $foo2, '... got the right value for bar now'); + +is($foo->boo, 'FooRole::boo -> BarClass::boo', '... got the right value from ->boo'); +is($foo->blau, 'FooRole::blau -> FooClass::blau', '... got the right value from ->blau'); +