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