2 package MooseX::Singleton::Role::Meta::Method::Constructor;
5 override _initialize_body => sub {
8 # the %options should also include a both
9 # a call 'initializer' and call 'SUPER::'
10 # options, which should cover approx 90%
11 # of the possible use cases (even if it
12 # requires some adaption on the part of
13 # the author, after all, nothing is free)
15 $source .= "\n" . 'my $class = shift;';
17 $source .= "\n" . 'my $existing = do { no strict "refs"; no warnings "once"; \${"$class\::singleton"}; };';
18 $source .= "\n" . 'return ${$existing} if ${$existing};';
20 $source .= "\n" . 'return $class->Moose::Object::new(@_)';
21 $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
23 $source .= $self->_generate_params('$params', '$class');
24 $source .= $self->_generate_instance('$instance', '$class');
25 $source .= $self->_generate_slot_initializers;
27 $source .= ";\n" . $self->_generate_triggers();
28 $source .= ";\n" . $self->_generate_BUILDALL();
30 $source .= ";\n" . 'return ${$existing} = $instance';
31 $source .= ";\n" . '}';
32 warn $source if $self->options->{debug};
34 my $attrs = $self->_attributes;
36 my @type_constraints = map {
37 $_->can('type_constraint') ? $_->type_constraint : undef
40 my @type_constraint_bodies = map {
41 defined $_ ? $_->_compiled_type_constraint : undef;
44 my ( $code, $e ) = $self->_compile_code(
49 '@type_constraints' => \@type_constraints,
50 '@type_constraint_bodies' => \@type_constraint_bodies,
54 $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e", error => $e, data => $source )
57 $self->{'body'} = $code;
60 # Ideally we'd be setting this in the constructor, but the new() methods in
61 # what the parent classes are not well-factored.
63 # This is all a nasty hack, though. We need to fix Class::MOP::Inlined to
64 # allow constructor class roles to say "if the parent class has role X,
66 override _expected_method_class => sub {
69 my $super_value = super();
70 if ( $super_value eq 'Moose::Object' ) {
71 for my $parent ( map { Class::MOP::class_of($_) }
72 $self->associated_metaclass->superclasses ) {
74 if $parent->is_anon_class
75 && grep { $_->name eq 'Moose::Object' }
76 map { Class::MOP::class_of($_) } $parent->superclasses;