lib/MooseX/Singleton/Meta/Method/Constructor.pm

   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 _initialize_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"; no warnings "once"; \${"$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 .= $self->_generate_params('$params', '$class');
  26     $source .= $self->_generate_instance('$instance', '$class');
  27     $source .= $self->_generate_slot_initializers;
  28
  29     $source .= ";\n" . $self->_generate_triggers();
  30     $source .= ";\n" . $self->_generate_BUILDALL();
  31
  32     $source .= ";\n" . 'return ${$existing} = $instance';
  33     $source .= ";\n" . '}';
  34     warn $source if $self->options->{debug};
  35
  36     my $attrs = $self->_attributes;
  37
  38     my @type_constraints = map {
  39         $_->can('type_constraint') ? $_->type_constraint : undef
  40     } @$attrs;
  41
  42     my @type_constraint_bodies = map {
  43         defined $_ ? $_->_compiled_type_constraint : undef;
  44     } @type_constraints;
  45
  46     my $code = $self->_compile_code(
  47         code => $source,
  48         environment => {
  49             '$meta'  => \$self,
  50             '$attrs' => \$attrs,
  51             '@type_constraints' => \@type_constraints,
  52             '@type_constraint_bodies' => \@type_constraint_bodies,
  53         },
  54     ) or $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source );
  55
  56     $self->{'body'} = $code;
  57 }
  58
  59 sub _expected_constructor_class {
  60     return 'MooseX::Singleton::Object';
  61 }
  62
  63 no Moose;
  64
  65 1;