Commit | Line | Data |
8eec3c69 |
1 | package MooseX::Singleton::Role::Meta::Method::Constructor; |
2 | use Moose::Role; |
2b4ce4bd |
3 | |
8eec3c69 |
4 | override _initialize_body => sub { |
2b4ce4bd |
5 | my $self = shift; |
4c256923 |
6 | |
2b4ce4bd |
7 | # TODO: |
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) |
0272982a |
14 | my $source = 'sub {'; |
2b4ce4bd |
15 | $source .= "\n" . 'my $class = shift;'; |
8eec3c69 |
16 | |
4c256923 |
17 | $source .= "\n" |
18 | . 'my $existing = do { no strict "refs"; no warnings "once"; \${"$class\::singleton"}; };'; |
2b4ce4bd |
19 | $source .= "\n" . 'return ${$existing} if ${$existing};'; |
20 | |
21 | $source .= "\n" . 'return $class->Moose::Object::new(@_)'; |
4c256923 |
22 | $source |
23 | .= "\n" |
24 | . ' if $class ne \'' |
25 | . $self->associated_metaclass->name . '\';'; |
2b4ce4bd |
26 | |
4c256923 |
27 | $source .= $self->_generate_params( '$params', '$class' ); |
28 | $source .= $self->_generate_instance( '$instance', '$class' ); |
0cd38a85 |
29 | $source .= $self->_generate_slot_initializers; |
2b4ce4bd |
30 | |
a06ef25a |
31 | $source .= ";\n" . $self->_generate_triggers(); |
2b4ce4bd |
32 | $source .= ";\n" . $self->_generate_BUILDALL(); |
33 | |
34 | $source .= ";\n" . 'return ${$existing} = $instance'; |
35 | $source .= ";\n" . '}'; |
36 | warn $source if $self->options->{debug}; |
37 | |
0cd38a85 |
38 | my $attrs = $self->_attributes; |
39 | |
4c256923 |
40 | my @type_constraints |
41 | = map { $_->can('type_constraint') ? $_->type_constraint : undef } |
42 | @$attrs; |
0272982a |
43 | |
4c256923 |
44 | my @type_constraint_bodies |
45 | = map { defined $_ ? $_->_compiled_type_constraint : undef; } |
46 | @type_constraints; |
2b4ce4bd |
47 | |
ade9ece0 |
48 | my ( $code, $e ) = $self->_compile_code( |
4c256923 |
49 | code => $source, |
0cd38a85 |
50 | environment => { |
4c256923 |
51 | '$meta' => \$self, |
52 | '$attrs' => \$attrs, |
53 | '@type_constraints' => \@type_constraints, |
0cd38a85 |
54 | '@type_constraint_bodies' => \@type_constraint_bodies, |
55 | }, |
ade9ece0 |
56 | ); |
57 | |
4c256923 |
58 | $self->throw_error( |
59 | "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e", |
60 | error => $e, data => $source ) |
ade9ece0 |
61 | if $e; |
2b4ce4bd |
62 | |
ede8dce0 |
63 | $self->{'body'} = $code; |
8eec3c69 |
64 | }; |
65 | |
66 | # Ideally we'd be setting this in the constructor, but the new() methods in |
67 | # what the parent classes are not well-factored. |
68 | # |
69 | # This is all a nasty hack, though. We need to fix Class::MOP::Inlined to |
70 | # allow constructor class roles to say "if the parent class has role X, |
71 | # inline". |
72 | override _expected_method_class => sub { |
73 | my $self = shift; |
dbeedf9e |
74 | |
8eec3c69 |
75 | my $super_value = super(); |
76 | if ( $super_value eq 'Moose::Object' ) { |
77 | for my $parent ( map { Class::MOP::class_of($_) } |
78 | $self->associated_metaclass->superclasses ) { |
79 | return $parent->name |
80 | if $parent->is_anon_class |
81 | && grep { $_->name eq 'Moose::Object' } |
82 | map { Class::MOP::class_of($_) } $parent->superclasses; |
83 | } |
84 | } |
85 | |
86 | return $super_value; |
87 | }; |
c87dffa8 |
88 | |
2cb90d53 |
89 | no Moose::Role; |
2b4ce4bd |
90 | |
91 | 1; |
387bf3e0 |
92 | |
93 | __END__ |
94 | |
95 | =pod |
96 | |
97 | =head1 NAME |
98 | |
99 | MooseX::Singleton::Role::Meta::Method::Constructor - Constructor method role for MooseX::Singleton |
100 | |
101 | =head1 DESCRIPTION |
102 | |
103 | This role overrides the generated object C<new> method so that it returns the |
104 | singleton if it already exists. |
105 | |
106 | =cut |
107 | |