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