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
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;
# 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)
});
$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
## 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
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__
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';
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) = @_;
use Carp 'confess';
use Scalar::Util 'weaken';
-our $VERSION = '0.03';
+our $VERSION = '0.04';
use base 'Class::MOP::Class';
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__
This method makes sure to handle the moose weak-ref, type-constraint
and type coercion features.
+=item B<add_override_method_modifier ($name, $method)>
+
+=item B<add_augment_method_modifier ($name, $method)>
+
=back
=head1 BUGS
before => {},
after => {},
around => {},
- override => {},
- augment => {},
+ override => {}
};
}
));
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
=item B<new>
+=item B<apply>
+
=back
=over 4
|| 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 })
}
$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
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;
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';
+}
--- /dev/null
+#!/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');
+
projects / gitmo/Moose.git / commitdiff