From: Stevan Little Date: Tue, 11 Apr 2006 16:36:26 +0000 (+0000) Subject: updatin X-Git-Tag: 0_05~42 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=05d9eaf69da40fa42f0a507e2d9bd29dac31a016;p=gitmo%2FMoose.git updatin --- diff --git a/Changes b/Changes index db23ff6..8064b09 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,14 @@ Revision history for Perl extension Moose -0.03_01 +0.03_02 + * Moose + - you must now explictly use Moose::Util::TypeConstraints + it no longer gets exported for you automatically + + * Moose::Object + - new() now accepts hash-refs as well as key/value lists + +0.03_01 Mon. March 10, 2006 * Moose::Cookbook - added new Role recipe (no content yet, only code) diff --git a/MANIFEST b/MANIFEST index 6081947..3740e43 100644 --- a/MANIFEST +++ b/MANIFEST @@ -32,6 +32,8 @@ t/010_basic_class_setup.t t/011_require_superclasses.t t/012_super_and_override.t t/013_inner_and_augment.t +t/014_override_augment_inner_super.t +t/015_override_and_foreign_classes.t t/020_foreign_inheritence.t t/030_attribute_reader_generation.t t/031_attribute_writer_generation.t diff --git a/lib/Moose.pm b/lib/Moose.pm index 372a96f..fcae992 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -29,7 +29,7 @@ sub import { # we should never export to main return if $pkg eq 'main'; - Moose::Util::TypeConstraints->import($pkg); + #Moose::Util::TypeConstraints->import($pkg); # make a subtype for each Moose class subtype $pkg @@ -343,6 +343,27 @@ C anywhere you need to test for an object's class name. =back +=head1 CAVEATS + +=over 4 + +=item * + +It should be noted that C and C can B be used in the same +method. However, they can be combined together with the same class hierarchy, +see F for an example. + +The reason that this is so is because C is only valid within a method +with the C modifier, and C will never be valid within an +C method. In fact, C will skip over any C methods +when searching for it's appropriate C. + +This might seem like a restriction, but I am of the opinion that keeping these +two features seperate (but interoperable) actually makes them easy to use since +their behavior is then easier to predict. Time will tell if I am right or not. + +=back + =head1 ACKNOWLEDGEMENTS =over 4 diff --git a/lib/Moose/Cookbook/Recipe4.pod b/lib/Moose/Cookbook/Recipe4.pod index 36e1e92..644de4f 100644 --- a/lib/Moose/Cookbook/Recipe4.pod +++ b/lib/Moose/Cookbook/Recipe4.pod @@ -11,6 +11,7 @@ Moose::Cookbook::Recipe4 - Subtypes, and modeling a simple B class hier use strict; use warnings; use Moose; + use Moose::Util::TypeConstraints; use Locale::US; use Regexp::Common 'zip'; @@ -39,6 +40,7 @@ Moose::Cookbook::Recipe4 - Subtypes, and modeling a simple B class hier use strict; use warnings; use Moose; + use Moose::Util::TypeConstraints; has 'name' => (is => 'rw', isa => 'Str', required => 1); has 'address' => (is => 'rw', isa => 'Address'); diff --git a/lib/Moose/Cookbook/Recipe5.pod b/lib/Moose/Cookbook/Recipe5.pod index 4287c9c..c3b0368 100644 --- a/lib/Moose/Cookbook/Recipe5.pod +++ b/lib/Moose/Cookbook/Recipe5.pod @@ -11,6 +11,7 @@ Moose::Cookbook::Recipe5 - More subtypes, coercion in a B class use strict; use warnings; use Moose; + use Moose::Util::TypeConstraints; use HTTP::Headers (); use Params::Coerce (); diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 5277d44..6709a40 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -73,29 +73,59 @@ sub add_override_method_modifier { 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 { + $self->add_method($name => bless sub { my @args = @_; no strict 'refs'; no warnings 'redefine'; local *{$_super_package . '::super'} = sub { $super->(@args) }; return $method->(@args); - }); + } => 'Moose::Meta::Method::Overriden'); } sub add_augment_method_modifier { - my ($self, $name, $method) = @_; + 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"; + || confess "You cannot augment '$name' because it has no super method"; + my $_super_package = $super->package_name; + # BUT!,... if this is an overriden method .... + if ($super->isa('Moose::Meta::Method::Overriden')) { + # we need to be sure that we actually + # find the next method, which is not + # an 'override' method, the reason is + # that an 'override' method will not + # be the one calling inner() + my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name); + $_super_package = $real_super->package_name; + } $self->add_method($name => sub { my @args = @_; no strict 'refs'; no warnings 'redefine'; - local *{$super->package_name . '::inner'} = sub { $method->(@args) }; + local *{$_super_package . '::inner'} = sub { $method->(@args) }; return $super->(@args); }); } +sub _find_next_method_by_name_which_is_not_overridden { + my ($self, $name) = @_; + my @methods = $self->find_all_methods_by_name($name); + foreach my $method (@methods) { + return $method->{code} + if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden'); + } + return undef; +} + +package Moose::Meta::Method::Overriden; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use base 'Class::MOP::Method'; + 1; __END__ diff --git a/lib/Moose/Object.pm b/lib/Moose/Object.pm index 2fdf89d..64b9eeb 100644 --- a/lib/Moose/Object.pm +++ b/lib/Moose/Object.pm @@ -7,10 +7,11 @@ use metaclass 'Moose::Meta::Class' => ( ':attribute_metaclass' => 'Moose::Meta::Attribute' ); -our $VERSION = '0.02'; +our $VERSION = '0.03'; sub new { - my ($class, %params) = @_; + my $class = shift; + my %params = (scalar @_ == 1) ? %{$_[0]} : @_; my $self = $class->meta->new_object(%params); $self->BUILDALL(\%params); return $self; diff --git a/t/001_basic.t b/t/001_basic.t index 8c022c2..71784eb 100644 --- a/t/001_basic.t +++ b/t/001_basic.t @@ -81,7 +81,7 @@ dies_ok { # Point3D -my $point3d = Point3D->new(x => 10, y => 15, z => 3); +my $point3d = Point3D->new({ x => 10, y => 15, z => 3 }); isa_ok($point3d, 'Point3D'); isa_ok($point3d, 'Point'); isa_ok($point3d, 'Moose::Object'); diff --git a/t/004_basic.t b/t/004_basic.t index 4a68090..a3a36da 100644 --- a/t/004_basic.t +++ b/t/004_basic.t @@ -23,6 +23,7 @@ BEGIN { use strict; use warnings; use Moose; + use Moose::Util::TypeConstraints; use Locale::US; use Regexp::Common 'zip'; @@ -50,6 +51,7 @@ BEGIN { use strict; use warnings; use Moose; + use Moose::Util::TypeConstraints; has 'name' => (is => 'rw', isa => 'Str', required => 1); has 'address' => (is => 'rw', isa => 'Address'); @@ -116,7 +118,7 @@ BEGIN { my $ii; lives_ok { - $ii = Company->new( + $ii = Company->new({ name => 'Infinity Interactive', address => Address->new( street => '565 Plandome Rd., Suite 307', @@ -151,7 +153,7 @@ lives_ok { address => Address->new(city => 'Marysville', state => 'OH') ), ] - ); + }); } '... created the entire company successfully'; isa_ok($ii, 'Company'); diff --git a/t/005_basic.t b/t/005_basic.t index 726f211..e3e6861 100644 --- a/t/005_basic.t +++ b/t/005_basic.t @@ -22,6 +22,7 @@ BEGIN { use strict; use warnings; use Moose; + use Moose::Util::TypeConstraints; use HTTP::Headers (); use Params::Coerce (); diff --git a/t/010_basic_class_setup.t b/t/010_basic_class_setup.t index de2a463..b75e1e8 100644 --- a/t/010_basic_class_setup.t +++ b/t/010_basic_class_setup.t @@ -13,6 +13,7 @@ BEGIN { { package Foo; use Moose; + use Moose::Util::TypeConstraints; } can_ok('Foo', 'meta'); diff --git a/t/014_override_augment_inner_super.t b/t/014_override_augment_inner_super.t new file mode 100644 index 0000000..2d04dd1 --- /dev/null +++ b/t/014_override_augment_inner_super.t @@ -0,0 +1,78 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 6; + +BEGIN { + use_ok('Moose'); +} + +{ + package Foo; + use strict; + use warnings; + use Moose; + + sub foo { 'Foo::foo(' . (inner() || '') . ')' }; + sub bar { 'Foo::bar(' . (inner() || '') . ')' } + + package Bar; + use strict; + use warnings; + use Moose; + + extends 'Foo'; + + augment 'foo' => sub { 'Bar::foo' }; + override 'bar' => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use strict; + use warnings; + use Moose; + + extends 'Bar'; + + override 'foo' => sub { 'Baz::foo -> ' . super() }; + augment 'bar' => sub { 'Baz::bar' }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +=pod + +Let em clarify what is happening here. Baz::foo is calling +super(), which calls Bar::foo, which is an augmented sub +that calls Foo::foo, then calls inner() which actually +then calls Bar::foo. Confusing I know,.. but this is +*exactly* what is it supposed to do :) + +=cut + +is($baz->foo, + 'Baz::foo -> Foo::foo(Bar::foo)', + '... got the right value from mixed augment/override foo'); + +=pod + +Allow me to clarify this one now ... + +Since Baz::bar is an augment routine, it needs to find the +correct inner() to be called by. In this case it is Foo::bar. +However, Bar::bar is inbetween us, so it should actually be +called first. Bar::bar is an overriden sub, and calls super() +which in turn then calls our Foo::bar, which calls inner(), +which calls Baz::bar. + +Confusing I know, but it is correct :) + +=cut + +is($baz->bar, + 'Bar::bar -> Foo::bar(Baz::bar)', + '... got the right value from mixed augment/override bar'); diff --git a/t/015_override_and_foreign_classes.t b/t/015_override_and_foreign_classes.t new file mode 100644 index 0000000..3620c56 --- /dev/null +++ b/t/015_override_and_foreign_classes.t @@ -0,0 +1,79 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 16; + +BEGIN { + use_ok('Moose'); +} + +=pod + +This just tests the interaction of override/super +with non-Moose superclasses. It really should not +cause issues, the only thing it does is to create +a metaclass for Foo so that it can find the right +super method. + +This may end up being a sensitive issue for some +non-Moose classes, but in 99% of the cases it +should be just fine. + +=cut + +{ + package Foo; + use strict; + use warnings; + + sub new { bless {} => shift() } + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + package Bar; + use strict; + use warnings; + use Moose; + + extends 'Foo'; + + override bar => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use strict; + use warnings; + use Moose; + + extends 'Bar'; + + override bar => sub { 'Baz::bar -> ' . super() }; + override baz => sub { 'Baz::baz -> ' . super() }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +is($baz->foo(), 'Foo::foo', '... got the right value from &foo'); +is($baz->bar(), 'Baz::bar -> Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($baz->baz(), 'Baz::baz -> Foo::baz', '... got the right value from &baz'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo(), 'Foo::foo', '... got the right value from &foo'); +is($bar->bar(), 'Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($bar->baz(), 'Foo::baz', '... got the right value from &baz'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is($foo->foo(), 'Foo::foo', '... got the right value from &foo'); +is($foo->bar(), 'Foo::bar', '... got the right value from &bar'); +is($foo->baz(), 'Foo::baz', '... got the right value from &baz'); \ No newline at end of file diff --git a/t/056_util_more_type_coercion.t b/t/056_util_more_type_coercion.t index 9321766..f7afba5 100644 --- a/t/056_util_more_type_coercion.t +++ b/t/056_util_more_type_coercion.t @@ -15,6 +15,7 @@ BEGIN { use strict; use warnings; use Moose; + use Moose::Util::TypeConstraints; coerce 'HTTPHeader' => from ArrayRef diff --git a/t/lib/Bar.pm b/t/lib/Bar.pm index e598f1f..8683ba5 100644 --- a/t/lib/Bar.pm +++ b/t/lib/Bar.pm @@ -3,6 +3,7 @@ package Bar; use strict; use warnings; use Moose; +use Moose::Util::TypeConstraints; type Baz => where { 1 };