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; |
6 | # TODO: |
7 | # the %options should also include a both |
8 | # a call 'initializer' and call 'SUPER::' |
9 | # options, which should cover approx 90% |
10 | # of the possible use cases (even if it |
11 | # requires some adaption on the part of |
12 | # the author, after all, nothing is free) |
0272982a |
13 | my $source = 'sub {'; |
2b4ce4bd |
14 | $source .= "\n" . 'my $class = shift;'; |
8eec3c69 |
15 | |
32bf84e9 |
16 | $source .= "\n" . 'my $existing = do { no strict "refs"; no warnings "once"; \${"$class\::singleton"}; };'; |
2b4ce4bd |
17 | $source .= "\n" . 'return ${$existing} if ${$existing};'; |
18 | |
19 | $source .= "\n" . 'return $class->Moose::Object::new(@_)'; |
20 | $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';'; |
21 | |
0cd38a85 |
22 | $source .= $self->_generate_params('$params', '$class'); |
23 | $source .= $self->_generate_instance('$instance', '$class'); |
24 | $source .= $self->_generate_slot_initializers; |
2b4ce4bd |
25 | |
a06ef25a |
26 | $source .= ";\n" . $self->_generate_triggers(); |
2b4ce4bd |
27 | $source .= ";\n" . $self->_generate_BUILDALL(); |
28 | |
29 | $source .= ";\n" . 'return ${$existing} = $instance'; |
30 | $source .= ";\n" . '}'; |
31 | warn $source if $self->options->{debug}; |
32 | |
0cd38a85 |
33 | my $attrs = $self->_attributes; |
34 | |
35 | my @type_constraints = map { |
36 | $_->can('type_constraint') ? $_->type_constraint : undef |
37 | } @$attrs; |
0272982a |
38 | |
0cd38a85 |
39 | my @type_constraint_bodies = map { |
40 | defined $_ ? $_->_compiled_type_constraint : undef; |
41 | } @type_constraints; |
2b4ce4bd |
42 | |
ade9ece0 |
43 | my ( $code, $e ) = $self->_compile_code( |
0cd38a85 |
44 | code => $source, |
45 | environment => { |
46 | '$meta' => \$self, |
47 | '$attrs' => \$attrs, |
48 | '@type_constraints' => \@type_constraints, |
49 | '@type_constraint_bodies' => \@type_constraint_bodies, |
50 | }, |
ade9ece0 |
51 | ); |
52 | |
53 | $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e", error => $e, data => $source ) |
54 | if $e; |
2b4ce4bd |
55 | |
ede8dce0 |
56 | $self->{'body'} = $code; |
8eec3c69 |
57 | }; |
58 | |
59 | # Ideally we'd be setting this in the constructor, but the new() methods in |
60 | # what the parent classes are not well-factored. |
61 | # |
62 | # This is all a nasty hack, though. We need to fix Class::MOP::Inlined to |
63 | # allow constructor class roles to say "if the parent class has role X, |
64 | # inline". |
65 | override _expected_method_class => sub { |
66 | my $self = shift; |
dbeedf9e |
67 | |
8eec3c69 |
68 | my $super_value = super(); |
69 | if ( $super_value eq 'Moose::Object' ) { |
70 | for my $parent ( map { Class::MOP::class_of($_) } |
71 | $self->associated_metaclass->superclasses ) { |
72 | return $parent->name |
73 | if $parent->is_anon_class |
74 | && grep { $_->name eq 'Moose::Object' } |
75 | map { Class::MOP::class_of($_) } $parent->superclasses; |
76 | } |
77 | } |
78 | |
79 | return $super_value; |
80 | }; |
c87dffa8 |
81 | |
2b4ce4bd |
82 | no Moose; |
83 | |
84 | 1; |