1 package MooseX::Singleton::Role::Meta::Method::Constructor;
5 $VERSION = eval $VERSION;
7 if ( $Moose::VERSION < 1.9900 ) {
8 override _initialize_body => sub {
12 # the %options should also include a both
13 # a call 'initializer' and call 'SUPER::'
14 # options, which should cover approx 90%
15 # of the possible use cases (even if it
16 # requires some adaption on the part of
17 # the author, after all, nothing is free)
19 $source .= "\n" . 'my $class = shift;';
22 . 'my $existing = do { no strict "refs"; no warnings "once"; \${"$class\::singleton"}; };';
23 $source .= "\n" . 'return ${$existing} if ${$existing};';
25 $source .= "\n" . 'return $class->Moose::Object::new(@_)';
29 . $self->associated_metaclass->name . '\';';
31 $source .= $self->_generate_params( '$params', '$class' );
32 $source .= $self->_generate_instance( '$instance', '$class' );
33 $source .= $self->_generate_slot_initializers;
35 $source .= ";\n" . $self->_generate_triggers();
36 $source .= ";\n" . $self->_generate_BUILDALL();
38 $source .= ";\n" . 'return ${$existing} = $instance';
39 $source .= ";\n" . '}';
40 warn $source if $self->options->{debug};
42 my $attrs = $self->_attributes;
45 = map { $_->can('type_constraint') ? $_->type_constraint : undef }
48 my @type_constraint_bodies
49 = map { defined $_ ? $_->_compiled_type_constraint : undef; }
52 my $defaults = [map { $_->default } @$attrs];
54 my ( $code, $e ) = $self->_compile_code(
59 '$defaults' => \$defaults,
60 '@type_constraints' => \@type_constraints,
61 '@type_constraint_bodies' => \@type_constraint_bodies,
66 "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e",
67 error => $e, data => $source )
70 $self->{'body'} = $code;
74 # Ideally we'd be setting this in the constructor, but the new() methods in
75 # what the parent classes are not well-factored.
77 # This is all a nasty hack, though. We need to fix Class::MOP::Inlined to
78 # allow constructor class roles to say "if the parent class has role X,
80 override _expected_method_class => sub {
83 my $super_value = super();
84 if ( $super_value eq 'Moose::Object' ) {
85 for my $parent ( map { Class::MOP::class_of($_) }
86 $self->associated_metaclass->superclasses ) {
88 if $parent->is_anon_class
89 && grep { $_->name eq 'Moose::Object' }
90 map { Class::MOP::class_of($_) } $parent->superclasses;
107 MooseX::Singleton::Role::Meta::Method::Constructor - Constructor method role for MooseX::Singleton
111 This role overrides the generated object C<new> method so that it returns the
112 singleton if it already exists.