From ffa87f12e2999ab231c79bd1c87276cd22cf3385 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Fri, 29 Apr 2011 18:05:42 -0500 Subject: allow this to work with arbitrarily named constructors --- lib/MooseX/NonMoose.pm | 12 ---- lib/MooseX/NonMoose/Meta/Role/Class.pm | 62 ++++++++++++++++--- t/11-constructor-name.t | 108 +++++++++++++++++++++++++++++++++ t/26-no-new-constructor-error.t | 7 ++- 4 files changed, 168 insertions(+), 21 deletions(-) create mode 100644 t/11-constructor-name.t diff --git a/lib/MooseX/NonMoose.pm b/lib/MooseX/NonMoose.pm index eba9ea9..1bd29ee 100644 --- a/lib/MooseX/NonMoose.pm +++ b/lib/MooseX/NonMoose.pm @@ -81,14 +81,6 @@ sub init_meta { $package->$init_meta(@_); } -=head1 TODO - -=over 4 - -=item * Allow for constructors with names other than C. - -=back - =head1 BUGS/CAVEATS =over 4 @@ -106,10 +98,6 @@ C (i.e. using C) currently doesn't work, although using method modifiers on the constructor should work identically to normal Moose classes. -=item * C currently assumes in several places that the -superclass constructor will be called C. This may be made configurable -in the future. - =back Please report any bugs through RT: email diff --git a/lib/MooseX/NonMoose/Meta/Role/Class.pm b/lib/MooseX/NonMoose/Meta/Role/Class.pm index b9f9dbb..579e618 100644 --- a/lib/MooseX/NonMoose/Meta/Role/Class.pm +++ b/lib/MooseX/NonMoose/Meta/Role/Class.pm @@ -46,6 +46,14 @@ 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") }, +); + sub _determine_constructor_options { my $self = shift; my @options = @_; @@ -61,12 +69,13 @@ sub _determine_constructor_options { my %options = @options; return @options if !$options{inline_constructor}; - # XXX: get constructor name from the constructor metaclass? - my $local_constructor = $self->get_method('new'); + 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"; @@ -115,13 +124,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 +150,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 +236,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/26-no-new-constructor-error.t b/t/26-no-new-constructor-error.t index 4dbc944..2becbce 100644 --- a/t/26-no-new-constructor-error.t +++ b/t/26-no-new-constructor-error.t @@ -18,8 +18,11 @@ 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'" + ); } } -- cgit v1.2.3-54-g00ecf