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