lib/MooseX/Singleton/Role/Meta/Instance.pm

   1 package MooseX::Singleton::Role::Meta::Instance;
   2 use Moose::Role;
   3 use Scalar::Util 'weaken';
   4
   5 sub get_singleton_instance {
   6     my ( $self, $instance ) = @_;
   7
   8     return $instance if blessed $instance;
   9
  10     # optimization: it's really slow to go through new_object for every access
  11     # so return the singleton if we see it already exists, which it will every
  12     # single except the first.
  13     no strict 'refs';
  14     return ${"$instance\::singleton"} if defined ${"$instance\::singleton"};
  15
  16     # We need to go through ->new in order to make sure BUILD and
  17     # BUILDARGS get called.
  18     return $instance->meta->name->new;
  19 }
  20
  21 override clone_instance => sub {
  22     my ( $self, $instance ) = @_;
  23     $self->get_singleton_instance($instance);
  24 };
  25
  26 override get_slot_value => sub {
  27     my ( $self, $instance, $slot_name ) = @_;
  28     $self->is_slot_initialized( $instance, $slot_name )
  29         ? $self->get_singleton_instance($instance)->{$slot_name}
  30         : undef;
  31 };
  32
  33 override set_slot_value => sub {
  34     my ( $self, $instance, $slot_name, $value ) = @_;
  35     $self->get_singleton_instance($instance)->{$slot_name} = $value;
  36 };
  37
  38 override deinitialize_slot => sub {
  39     my ( $self, $instance, $slot_name ) = @_;
  40     delete $self->get_singleton_instance($instance)->{$slot_name};
  41 };
  42
  43 override is_slot_initialized => sub {
  44     my ( $self, $instance, $slot_name, $value ) = @_;
  45     exists $self->get_singleton_instance($instance)->{$slot_name} ? 1 : 0;
  46 };
  47
  48 override weaken_slot_value => sub {
  49     my ( $self, $instance, $slot_name ) = @_;
  50     weaken $self->get_singleton_instance($instance)->{$slot_name};
  51 };
  52
  53 override inline_slot_access => sub {
  54     my ( $self, $instance, $slot_name ) = @_;
  55     sprintf "%s->meta->instance_metaclass->get_singleton_instance(%s)->{%s}",
  56         $instance, $instance, $slot_name;
  57 };
  58
  59 no Moose::Role;
  60
  61 1;
  62
  63 __END__
  64
  65 =pod
  66
  67 =head1 NAME
  68
  69 MooseX::Singleton::Role::Meta::Instance - Instance metaclass role for MooseX::Singleton
  70
  71 =head1 DESCRIPTION
  72
  73 This role overrides all object access so that it gets the appropriate
  74 singleton instance for the class.
  75
  76 =cut
  77