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

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