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

   1 package MooseX::Singleton::Role::Meta::Method::Constructor;
   2 use Moose::Role;
   3
   4 override _initialize_body => sub {
   5     my $self = shift;
   6
   7     # TODO:
   8     # the %options should also include a both
   9     # a call 'initializer' and call 'SUPER::'
  10     # options, which should cover approx 90%
  11     # of the possible use cases (even if it
  12     # requires some adaption on the part of
  13     # the author, after all, nothing is free)
  14     my $source = 'sub {';
  15     $source .= "\n" . 'my $class = shift;';
  16
  17     $source .= "\n"
  18         . 'my $existing = do { no strict "refs"; no warnings "once"; \${"$class\::singleton"}; };';
  19     $source .= "\n" . 'return ${$existing} if ${$existing};';
  20
  21     $source .= "\n" . 'return $class->Moose::Object::new(@_)';
  22     $source
  23         .= "\n"
  24         . '    if $class ne \''
  25         . $self->associated_metaclass->name . '\';';
  26
  27     $source .= $self->_generate_params( '$params', '$class' );
  28     $source .= $self->_generate_instance( '$instance', '$class' );
  29     $source .= $self->_generate_slot_initializers;
  30
  31     $source .= ";\n" . $self->_generate_triggers();
  32     $source .= ";\n" . $self->_generate_BUILDALL();
  33
  34     $source .= ";\n" . 'return ${$existing} = $instance';
  35     $source .= ";\n" . '}';
  36     warn $source if $self->options->{debug};
  37
  38     my $attrs = $self->_attributes;
  39
  40     my @type_constraints
  41         = map { $_->can('type_constraint') ? $_->type_constraint : undef }
  42         @$attrs;
  43
  44     my @type_constraint_bodies
  45         = map { defined $_ ? $_->_compiled_type_constraint : undef; }
  46         @type_constraints;
  47
  48     my ( $code, $e ) = $self->_compile_code(
  49         code        => $source,
  50         environment => {
  51             '$meta'                   => \$self,
  52             '$attrs'                  => \$attrs,
  53             '@type_constraints'       => \@type_constraints,
  54             '@type_constraint_bodies' => \@type_constraint_bodies,
  55         },
  56     );
  57
  58     $self->throw_error(
  59         "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e",
  60         error => $e, data => $source )
  61         if $e;
  62
  63     $self->{'body'} = $code;
  64 };
  65
  66 # Ideally we'd be setting this in the constructor, but the new() methods in
  67 # what the parent classes are not well-factored.
  68 #
  69 # This is all a nasty hack, though. We need to fix Class::MOP::Inlined to
  70 # allow constructor class roles to say "if the parent class has role X,
  71 # inline".
  72 override _expected_method_class => sub {
  73     my $self = shift;
  74
  75     my $super_value = super();
  76     if ( $super_value eq 'Moose::Object' ) {
  77         for my $parent ( map { Class::MOP::class_of($_) }
  78             $self->associated_metaclass->superclasses ) {
  79             return $parent->name
  80                 if $parent->is_anon_class
  81                     && grep { $_->name eq 'Moose::Object' }
  82                     map { Class::MOP::class_of($_) } $parent->superclasses;
  83         }
  84     }
  85
  86     return $super_value;
  87 };
  88
  89 no Moose::Role;
  90
  91 1;
  92
  93 __END__
  94
  95 =pod
  96
  97 =head1 NAME
  98
  99 MooseX::Singleton::Role::Meta::Method::Constructor - Constructor method role for MooseX::Singleton
 100
 101 =head1 DESCRIPTION
 102
 103 This role overrides the generated object C<new> method so that it returns the
 104 singleton if it already exists.
 105
 106 =cut
 107