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

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