diff options
| -rw-r--r-- | Changes | 22 | ||||
| -rw-r--r-- | lib/MooseX/NonMoose.pm | 23 | ||||
| -rw-r--r-- | lib/MooseX/NonMoose/Meta/Role/Class.pm | 89 | ||||
| -rw-r--r-- | t/11-constructor-name.t | 108 | ||||
| -rw-r--r-- | t/12-reinitialize.t | 32 | ||||
| -rw-r--r-- | t/26-no-new-constructor-error.t | 21 |
6 files changed, 269 insertions, 26 deletions
@@ -2,6 +2,28 @@ Revision history for MooseX-NonMoose {{$NEXT}} +0.22 2011-05-09 + - Fix issues where the metaclass gets reinitialized after the call to + 'extends' but before 'make_immutable'. This could happen if a role + used an extension which provided an application_to_class metarole, + since the role application would then apply a metarole to the class, + and metarole application currently causes metaclass reinitialization + in Moose. (ugh.) + +0.21 2011-04-29 + - Allow this module to work with constructors with names other than + 'new'. If you're extending a class with a constructor named something + other than 'new', you should declare this when calling extends, as in: + + extends 'Foo' => { -constructor_name => 'create' }; + + This will ensure that calling 'create' will also call Moose's + constructor. + +0.20 2011-03-22 + - fix warning when passing inline_constructor => 0 with no superclass new + method (rafl). + 0.19 2011-03-02 - don't die if superclass doesn't have a 'new' method diff --git a/lib/MooseX/NonMoose.pm b/lib/MooseX/NonMoose.pm index 0fd9282..5a989e0 100644 --- a/lib/MooseX/NonMoose.pm +++ b/lib/MooseX/NonMoose.pm @@ -62,6 +62,15 @@ return a list of arguments to pass to the superclass constructor. This allows C<MooseX::NonMoose> to support superclasses whose constructors would get confused by the extra arguments that Moose requires (for attributes, etc.) +Not all non-Moose classes use C<new> as the name of their constructor. This +module allows you to extend these classes by explicitly stating which method is +the constructor, during the call to C<extends>. The syntax looks like this: + + extends 'Foo' => { -constructor_name => 'create' }; + +similar to how you can already pass C<-version> in the C<extends> call in a +similar way. + =cut my ($import, $unimport, $init_meta) = Moose::Exporter->build_import_methods( @@ -81,14 +90,6 @@ sub init_meta { $package->$init_meta(@_); } -=head1 TODO - -=over 4 - -=item * Allow for constructors with names other than C<new>. - -=back - =head1 BUGS/CAVEATS =over 4 @@ -111,10 +112,6 @@ C<MooseX::NonMoose> (i.e. using C<sub new { ... }>) currently doesn't work, although using method modifiers on the constructor should work identically to normal Moose classes. -=item * C<MooseX::NonMoose> currently assumes in several places that the -superclass constructor will be called C<new>. This may be made configurable -in the future. - =back Please report any bugs through RT: email @@ -125,7 +122,7 @@ L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=MooseX-NonMoose>. =over 4 -=item * L<Moose::Cookbook::FAQ/How do I make non-Moose constructors work with Moose?> +=item * L<Moose::Manual::FAQ/How do I make non-Moose constructors work with Moose?> =item * L<MooseX::Alien> diff --git a/lib/MooseX/NonMoose/Meta/Role/Class.pm b/lib/MooseX/NonMoose/Meta/Role/Class.pm index 6c09b22..e873877 100644 --- a/lib/MooseX/NonMoose/Meta/Role/Class.pm +++ b/lib/MooseX/NonMoose/Meta/Role/Class.pm @@ -46,6 +46,33 @@ has has_nonmoose_destructor => ( default => 0, ); +# overrides the constructor_name attr that already exists +has constructor_name => ( + is => 'rw', + isa => 'Str', + lazy => 1, + default => sub { shift->throw_error("No constructor name has been set") }, +); + +# XXX ugh, really need to fix this in moose +around reinitialize => sub { + my $orig = shift; + my $class = shift; + my ($pkg) = @_; + + my $meta = blessed($pkg) ? $pkg : Class::MOP::class_of($pkg); + + $class->$orig( + @_, + (map { $_->init_arg => $_->get_value($meta) } + grep { $_->has_value($meta) } + map { $meta->meta->find_attribute_by_name($_) } + qw(has_nonmoose_constructor + has_nonmoose_destructor + constructor_name)), + ); +}; + sub _determine_constructor_options { my $self = shift; my @options = @_; @@ -57,12 +84,17 @@ sub _determine_constructor_options { unless $cc_meta->can('does_role') && $cc_meta->does_role('MooseX::NonMoose::Meta::Role::Constructor'); - # XXX: get constructor name from the constructor metaclass? - my $local_constructor = $self->get_method('new'); + # do nothing if we explicitly ask for the constructor to not be inlined + my %options = @options; + return @options if !$options{inline_constructor}; + + my $constructor_name = $self->constructor_name; + + my $local_constructor = $self->get_method($constructor_name); if (!defined($local_constructor)) { warn "Not inlining a constructor for " . $self->name . " since " . "its parent " . ($self->superclasses)[0] . " doesn't contain a " - . "'new' method. " + . "constructor named '$constructor_name'. " . "If you are certain you don't need to inline your" . " constructor, specify inline_constructor => 0 in your" . " call to " . $self->name . "->meta->make_immutable\n"; @@ -77,10 +109,6 @@ sub _determine_constructor_options { return @options if $local_constructor->isa('Class::MOP::Method::Wrapped'); - # do nothing if we explicitly ask for the constructor to not be inlined - my %options = @options; - return @options if !$options{inline_constructor}; - # otherwise, explicitly ask for the constructor to be replaced (to suppress # the warning message), since this is the expected usage, and shouldn't # cause a warning @@ -115,13 +143,12 @@ sub _check_superclass_constructor { # if the current class defined a custom new method (since subs happen at # BEGIN time), don't try to override it - return if $self->has_method('new'); + return if $self->has_method($self->constructor_name); # we need to get the non-moose constructor from the superclass # of the class where this method actually exists, regardless of what class # we're calling it on - # XXX: get constructor name from the constructor metaclass? - my $super_new = $self->find_next_method_by_name('new'); + my $super_new = $self->find_next_method_by_name($self->constructor_name); # if we're trying to extend a (non-immutable) moose class, just do nothing return if $super_new->package_name eq 'Moose::Object'; @@ -142,7 +169,7 @@ sub _check_superclass_constructor { $super_new->associated_metaclass->_inlined_methods; } - $self->add_method(new => sub { + $self->add_method($self->constructor_name => sub { my $class = shift; my $params = $class->BUILDARGS(@_); @@ -228,6 +255,46 @@ around superclasses => sub { return $self->$orig unless @_; + # XXX lots of duplication between here and MMC::superclasses + my ($constructor_name, $constructor_class); + for my $super (@{ Data::OptList::mkopt(\@_) }) { + my ($name, $opts) = @{ $super }; + + my $cur_constructor_name = delete $opts->{'-constructor_name'}; + + if (defined($constructor_name) && defined($cur_constructor_name)) { + $self->throw_error( + "You have already specified " + . "${constructor_class}::${constructor_name} as the parent " + . "constructor; ${name}::${cur_constructor_name} cannot also be " + . "the constructor" + ); + } + + Class::MOP::load_class($name, $opts); + + if (defined($cur_constructor_name)) { + my $meta = Class::MOP::class_of($name); + $self->throw_error( + "You specified '$cur_constructor_name' as the constructor for " + . "$name, but $name has no method by that name" + ) unless $meta + ? $meta->find_method_by_name($cur_constructor_name) + : $name->can($cur_constructor_name); + } + + if (!defined($constructor_name)) { + $constructor_name = $cur_constructor_name; + $constructor_class = $name; + } + + delete $opts->{'-constructor_name'}; + } + + $self->constructor_name( + defined($constructor_name) ? $constructor_name : 'new' + ); + my @superclasses = @_; push @superclasses, 'Moose::Object' unless grep { !ref($_) && $_->isa('Moose::Object') } @superclasses; diff --git a/t/11-constructor-name.t b/t/11-constructor-name.t new file mode 100644 index 0000000..4d790eb --- /dev/null +++ b/t/11-constructor-name.t @@ -0,0 +1,108 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + package Foo; + + sub create { + my $class = shift; + my %params = @_; + bless { foo => ($params{foo} || 'FOO') }, $class; + } + + sub foo { shift->{foo} } +} + +{ + package Foo::Sub; + use Moose; + use MooseX::NonMoose; + + extends 'Foo' => { -constructor_name => 'create' }; + + has bar => ( + is => 'ro', + isa => 'Str', + default => 'BAR', + ); +} + +with_immutable { + my $foo = Foo::Sub->create; + is($foo->foo, 'FOO', "nonmoose constructor called"); + is($foo->bar, 'BAR', "moose constructor called"); +} 'Foo::Sub'; + +{ + package Foo::BadSub; + use Moose; + use MooseX::NonMoose; + + ::like( + ::exception { + extends 'Foo' => { -constructor_name => 'something_else' }; + }, + qr/You specified 'something_else' as the constructor for Foo, but Foo has no method by that name/, + "specifying an incorrect constructor name dies" + ); +} + +{ + package Foo::Mixin; + + sub thing { + return shift->foo . 'BAZ'; + } +} + +{ + package Foo::Sub2; + use Moose; + use MooseX::NonMoose; + + extends 'Foo::Mixin', 'Foo' => { -constructor_name => 'create' }; + + has bar => ( + is => 'ro', + isa => 'Str', + default => 'BAR', + ); +} + +with_immutable { + my $foo = Foo::Sub2->create; + is($foo->foo, 'FOO', "nonmoose constructor called"); + is($foo->bar, 'BAR', "moose constructor called"); + is($foo->thing, 'FOOBAZ', "mixin still works"); +} 'Foo::Sub2'; + +{ + package Bar; + + sub make { + my $class = shift; + my %params = @_; + bless { baz => ($params{baz} || 'BAZ') }, $class; + } +} + +{ + package Foo::Bar::Sub; + use Moose; + use MooseX::NonMoose; + + ::like( + ::exception { + extends 'Bar' => { -constructor_name => 'make' }, + 'Foo' => { -constructor_name => 'create' }; + }, + qr/You have already specified Bar::make as the parent constructor; Foo::create cannot also be the constructor/, + "can't specify two parent constructors" + ); +} + +done_testing; diff --git a/t/12-reinitialize.t b/t/12-reinitialize.t new file mode 100644 index 0000000..5e4aa11 --- /dev/null +++ b/t/12-reinitialize.t @@ -0,0 +1,32 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo; + sub new { bless {}, shift } +} + +{ + package Foo::Meta::Role; + use Moose::Role; +} + +{ + package Foo::Sub; + use Moose; + use MooseX::NonMoose; + extends 'Foo'; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + class => ['Foo::Meta::Role'], + }, + ); + ::is(::exception { __PACKAGE__->meta->make_immutable }, undef, + "can make_immutable after reinitialization"); +} + +done_testing; diff --git a/t/26-no-new-constructor-error.t b/t/26-no-new-constructor-error.t index e70442e..2becbce 100644 --- a/t/26-no-new-constructor-error.t +++ b/t/26-no-new-constructor-error.t @@ -18,8 +18,25 @@ use Test::More; my $warning; local $SIG{__WARN__} = sub { $warning = $_[0] }; __PACKAGE__->meta->make_immutable; - ::like($warning, qr/Not inlining.*doesn't contain a 'new' method/, - "warning when trying to make_immutable without a superclass 'new'"); + ::like( + $warning, + qr/Not inlining.*doesn't contain a constructor named 'new'/, + "warning when trying to make_immutable without a superclass 'new'" + ); + } +} + +{ + package ChildTwo; + use Moose; + use MooseX::NonMoose; + extends 'NonMoose'; + { + my $warning; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + __PACKAGE__->meta->make_immutable(inline_constructor => 0); + ::is($warning, undef, + "no warning when trying to make_immutable(inline_constructor => 0) without a superclass 'new'"); } } |