Commit | Line | Data |
2b4ce4bd |
1 | #!/usr/bin/env perl |
2 | package MooseX::Singleton::Meta::Method::Constructor; |
3 | use Moose; |
4 | |
5 | extends 'Moose::Meta::Method::Constructor'; |
6 | |
0cd38a85 |
7 | sub _initialize_body { |
2b4ce4bd |
8 | my $self = shift; |
9 | # TODO: |
10 | # the %options should also include a both |
11 | # a call 'initializer' and call 'SUPER::' |
12 | # options, which should cover approx 90% |
13 | # of the possible use cases (even if it |
14 | # requires some adaption on the part of |
15 | # the author, after all, nothing is free) |
0272982a |
16 | my $source = 'sub {'; |
2b4ce4bd |
17 | $source .= "\n" . 'my $class = shift;'; |
32bf84e9 |
18 | |
19 | $source .= "\n" . 'my $existing = do { no strict "refs"; no warnings "once"; \${"$class\::singleton"}; };'; |
2b4ce4bd |
20 | $source .= "\n" . 'return ${$existing} if ${$existing};'; |
21 | |
22 | $source .= "\n" . 'return $class->Moose::Object::new(@_)'; |
23 | $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';'; |
24 | |
0cd38a85 |
25 | $source .= $self->_generate_params('$params', '$class'); |
26 | $source .= $self->_generate_instance('$instance', '$class'); |
27 | $source .= $self->_generate_slot_initializers; |
2b4ce4bd |
28 | |
a06ef25a |
29 | $source .= ";\n" . $self->_generate_triggers(); |
2b4ce4bd |
30 | $source .= ";\n" . $self->_generate_BUILDALL(); |
31 | |
32 | $source .= ";\n" . 'return ${$existing} = $instance'; |
33 | $source .= ";\n" . '}'; |
34 | warn $source if $self->options->{debug}; |
35 | |
0cd38a85 |
36 | my $attrs = $self->_attributes; |
37 | |
38 | my @type_constraints = map { |
39 | $_->can('type_constraint') ? $_->type_constraint : undef |
40 | } @$attrs; |
0272982a |
41 | |
0cd38a85 |
42 | my @type_constraint_bodies = map { |
43 | defined $_ ? $_->_compiled_type_constraint : undef; |
44 | } @type_constraints; |
2b4ce4bd |
45 | |
ade9ece0 |
46 | my ( $code, $e ) = $self->_compile_code( |
0cd38a85 |
47 | code => $source, |
48 | environment => { |
49 | '$meta' => \$self, |
50 | '$attrs' => \$attrs, |
51 | '@type_constraints' => \@type_constraints, |
52 | '@type_constraint_bodies' => \@type_constraint_bodies, |
53 | }, |
ade9ece0 |
54 | ); |
55 | |
56 | $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e", error => $e, data => $source ) |
57 | if $e; |
2b4ce4bd |
58 | |
ede8dce0 |
59 | $self->{'body'} = $code; |
2b4ce4bd |
60 | } |
61 | |
dbeedf9e |
62 | # For CMOP 0.82_01+ |
63 | sub _expected_method_class { |
64 | return 'MooseX::Singleton::Object'; |
65 | } |
66 | |
67 | # For older versions of Moose/CMOP |
c87dffa8 |
68 | sub _expected_constructor_class { |
69 | return 'MooseX::Singleton::Object'; |
70 | } |
71 | |
2b4ce4bd |
72 | no Moose; |
73 | |
74 | 1; |