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) |
16 | my $source = 'sub {'; |
17 | $source .= "\n" . 'my $class = shift;'; |
18 | |
19 | $source .= "\n" . 'my $existing = do { no strict "refs"; \${"$class\::singleton"}; };'; |
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 | { |
42 | # NOTE: |
43 | # create the nessecary lexicals |
44 | # to be picked up in the eval |
45 | my $attrs = $self->attributes; |
46 | |
47 | # We need to check if the attribute ->can('type_constraint') |
48 | # since we may be trying to immutabilize a Moose meta class, |
49 | # which in turn has attributes which are Class::MOP::Attribute |
50 | # objects, rather than Moose::Meta::Attribute. And |
51 | # Class::MOP::Attribute attributes have no type constraints. |
52 | # However we need to make sure we leave an undef value there |
53 | # because the inlined code is using the index of the attributes |
54 | # to determine where to find the type constraint |
55 | |
56 | my @type_constraints = map { |
57 | $_->can('type_constraint') ? $_->type_constraint : undef |
58 | } @$attrs; |
59 | |
60 | my @type_constraint_bodies = map { |
61 | defined $_ ? $_->_compiled_type_constraint : undef; |
62 | } @type_constraints; |
63 | |
64 | $code = eval $source; |
65 | confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@; |
66 | } |
67 | $self->{'&!body'} = $code; |
68 | } |
69 | |
70 | no Moose; |
71 | |
72 | 1; |