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

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