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 | |
0a14785c |
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 | |
d871257e |
25 | $source .= "\n" . 'my $params = ' . $self->_generate_BUILDARGS('$class', '@_'); |
2b4ce4bd |
26 | |
d871257e |
27 | $source .= ";\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class'); |
2b4ce4bd |
28 | |
29 | $source .= ";\n" . (join ";\n" => map { |
30 | $self->_generate_slot_initializer($_) |
31 | } 0 .. (@{$self->attributes} - 1)); |
32 | |
a06ef25a |
33 | $source .= ";\n" . $self->_generate_triggers(); |
2b4ce4bd |
34 | $source .= ";\n" . $self->_generate_BUILDALL(); |
35 | |
36 | $source .= ";\n" . 'return ${$existing} = $instance'; |
37 | $source .= ";\n" . '}'; |
38 | warn $source if $self->options->{debug}; |
39 | |
40 | my $code; |
41 | { |
0272982a |
42 | my $meta = $self; |
43 | |
2b4ce4bd |
44 | # NOTE: |
45 | # create the nessecary lexicals |
46 | # to be picked up in the eval |
47 | my $attrs = $self->attributes; |
48 | |
49 | # We need to check if the attribute ->can('type_constraint') |
50 | # since we may be trying to immutabilize a Moose meta class, |
51 | # which in turn has attributes which are Class::MOP::Attribute |
52 | # objects, rather than Moose::Meta::Attribute. And |
53 | # Class::MOP::Attribute attributes have no type constraints. |
54 | # However we need to make sure we leave an undef value there |
55 | # because the inlined code is using the index of the attributes |
56 | # to determine where to find the type constraint |
57 | |
58 | my @type_constraints = map { |
59 | $_->can('type_constraint') ? $_->type_constraint : undef |
60 | } @$attrs; |
61 | |
62 | my @type_constraint_bodies = map { |
63 | defined $_ ? $_->_compiled_type_constraint : undef; |
64 | } @type_constraints; |
65 | |
66 | $code = eval $source; |
8a137905 |
67 | $self->throw_error( |
68 | "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", |
69 | error => $@, data => $source ) |
70 | if $@; |
2b4ce4bd |
71 | } |
ede8dce0 |
72 | $self->{'body'} = $code; |
2b4ce4bd |
73 | } |
74 | |
c87dffa8 |
75 | sub _expected_constructor_class { |
76 | return 'MooseX::Singleton::Object'; |
77 | } |
78 | |
2b4ce4bd |
79 | no Moose; |
80 | |
81 | 1; |