allow this to work with arbitrarily named constructors

4 files changed, 168 insertions, 21 deletions

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<new>.
-
-=back
-
 =head1 BUGS/CAVEATS
 
 =over 4
@@ -106,10 +98,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
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'"
+        );
     }
 }