2 package MooseX::Singleton::Meta::Method::Constructor;
5 extends 'Moose::Meta::Method::Constructor';
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)
17 $source .= "\n" . 'my $class = shift;';
19 $source .= "\n" . 'my $existing = do { no strict "refs"; no warnings "once"; \${"$class\::singleton"}; };';
20 $source .= "\n" . 'return ${$existing} if ${$existing};';
22 $source .= "\n" . 'return $class->Moose::Object::new(@_)';
23 $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
25 $source .= $self->_generate_params('$params', '$class');
26 $source .= $self->_generate_instance('$instance', '$class');
27 $source .= $self->_generate_slot_initializers;
29 $source .= ";\n" . $self->_generate_triggers();
30 $source .= ";\n" . $self->_generate_BUILDALL();
32 $source .= ";\n" . 'return ${$existing} = $instance';
33 $source .= ";\n" . '}';
34 warn $source if $self->options->{debug};
36 my $attrs = $self->_attributes;
38 my @type_constraints = map {
39 $_->can('type_constraint') ? $_->type_constraint : undef
42 my @type_constraint_bodies = map {
43 defined $_ ? $_->_compiled_type_constraint : undef;
46 my $code = $self->_compile_code(
51 '@type_constraints' => \@type_constraints,
52 '@type_constraint_bodies' => \@type_constraint_bodies,
54 ) or $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source );
56 $self->{'body'} = $code;
59 sub _expected_constructor_class {
60 return 'MooseX::Singleton::Object';