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