lib/MooseX/InsideOut/Meta/Instance.pm

   1 use strict;
   2 use warnings;
   3
   4 package MooseX::InsideOut::Meta::Instance;
   5
   6 use Moose;
   7 extends 'Moose::Meta::Instance';
   8
   9 use Hash::Util::FieldHash::Compat qw(fieldhash);
  10 use Scalar::Util qw(refaddr weaken);
  11
  12 # don't touch this or I beat you
  13 # this is only a package variable for inlinability
  14 fieldhash our %__attr;
  15
  16 sub create_instance {
  17   my ($self) = @_;
  18
  19   #my $instance = \(my $dummy);
  20   my $instance = $self->SUPER::create_instance;
  21
  22   $__attr{refaddr $instance} = {};
  23   return bless $instance => $self->associated_metaclass->name;
  24 }
  25
  26 sub get_slot_value {
  27   my ($self, $instance, $slot_name) = @_;
  28
  29   return $__attr{refaddr $instance}->{$slot_name};
  30 }
  31
  32 sub set_slot_value {
  33   my ($self, $instance, $slot_name, $value) = @_;
  34
  35   return $__attr{refaddr $instance}->{$slot_name} = $value;
  36 }
  37
  38 sub deinitialize_slot {
  39   my ($self, $instance, $slot_name) = @_;
  40
  41   return delete $__attr{refaddr $instance}->{$slot_name};
  42 }
  43
  44 sub is_slot_initialized {
  45   my ($self, $instance, $slot_name) = @_;
  46
  47   return exists $__attr{refaddr $instance}->{$slot_name};
  48 }
  49
  50 sub weaken_slot_value {
  51   my ($self, $instance, $slot_name) = @_;
  52
  53   weaken $__attr{refaddr $instance}->{$slot_name};
  54 }
  55
  56 sub inline_create_instance {
  57   my ($self, $class_variable) = @_;
  58   return join '',
  59     #'my $instance = \(my $dummy);',
  60     # hardcoding superclass -- can't think of a good way to avoid that
  61     'my $instance = Moose::Meta::Instance->create_instance;',
  62     sprintf(
  63       '$%s::__attr{%s} = {};',
  64       __PACKAGE__,
  65       'Scalar::Util::refaddr($instance)',
  66     ),
  67     sprintf(
  68       'bless $instance => %s;',
  69       $class_variable,
  70     ),
  71   ;
  72 }
  73
  74 sub inline_slot_access {
  75   my ($self, $instance, $slot_name) = @_;
  76   return sprintf '$%s::__attr{%s}->{%s}',
  77     __PACKAGE__,
  78     'Scalar::Util::refaddr ' . $instance,
  79     $slot_name,
  80   ;
  81 }
  82
  83 sub __dump {
  84   my ($class, $instance) = @_;
  85   require Data::Dumper;
  86   return Data::Dumper::Dumper($__attr{refaddr $instance});
  87 }
  88
  89 1;