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

   1 #!/usr/bin/env perl
   2 package MooseX::Singleton::Role::Meta::Method::Constructor;
   3 use Moose::Role;
   4
   5 override _initialize_body => sub {
   6     my $self = shift;
   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" . 'my $existing = do { no strict "refs"; no warnings "once"; \${"$class\::singleton"}; };';
  18     $source .= "\n" . 'return ${$existing} if ${$existing};';
  19
  20     $source .= "\n" . 'return $class->Moose::Object::new(@_)';
  21     $source .= "\n" . '    if $class ne \'' . $self->associated_metaclass->name . '\';';
  22
  23     $source .= $self->_generate_params('$params', '$class');
  24     $source .= $self->_generate_instance('$instance', '$class');
  25     $source .= $self->_generate_slot_initializers;
  26
  27     $source .= ";\n" . $self->_generate_triggers();
  28     $source .= ";\n" . $self->_generate_BUILDALL();
  29
  30     $source .= ";\n" . 'return ${$existing} = $instance';
  31     $source .= ";\n" . '}';
  32     warn $source if $self->options->{debug};
  33
  34     my $attrs = $self->_attributes;
  35
  36     my @type_constraints = map {
  37         $_->can('type_constraint') ? $_->type_constraint : undef
  38     } @$attrs;
  39
  40     my @type_constraint_bodies = map {
  41         defined $_ ? $_->_compiled_type_constraint : undef;
  42     } @type_constraints;
  43
  44     my ( $code, $e ) = $self->_compile_code(
  45         code => $source,
  46         environment => {
  47             '$meta'  => \$self,
  48             '$attrs' => \$attrs,
  49             '@type_constraints' => \@type_constraints,
  50             '@type_constraint_bodies' => \@type_constraint_bodies,
  51         },
  52     );
  53
  54     $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e", error => $e, data => $source )
  55         if $e;
  56
  57     $self->{'body'} = $code;
  58 };
  59
  60 # Ideally we'd be setting this in the constructor, but the new() methods in
  61 # what the parent classes are not well-factored.
  62 #
  63 # This is all a nasty hack, though. We need to fix Class::MOP::Inlined to
  64 # allow constructor class roles to say "if the parent class has role X,
  65 # inline".
  66 override _expected_method_class => sub {
  67     my $self = shift;
  68
  69     my $super_value = super();
  70     if ( $super_value eq 'Moose::Object' ) {
  71         for my $parent ( map { Class::MOP::class_of($_) }
  72             $self->associated_metaclass->superclasses ) {
  73             return $parent->name
  74                 if $parent->is_anon_class
  75                     && grep { $_->name eq 'Moose::Object' }
  76                     map { Class::MOP::class_of($_) } $parent->superclasses;
  77         }
  78     }
  79
  80     return $super_value;
  81 };
  82
  83 no Moose;
  84
  85 1;