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