ArrayBasedStorage - An example of an Array based instance storage

  package Foo;

  use metaclass (
    ':instance_metaclass'  => 'ArrayBasedStorage::Instance'
  );

  __PACKAGE__->meta->add_attribute('foo' => (
      reader => 'get_foo',
      writer => 'set_foo'
  ));    

  sub new  {
      my $class = shift;
      $class->meta->new_object(@_);
  } 

  # now you can just use the class as normal

  
package # hide the package from PAUSE
    ArrayBasedStorage::Instance;

use strict;
use warnings;
use Scalar::Util qw/refaddr/;

use Carp 'confess';

our $VERSION = '0.01';
my $unbound = \'empty-slot-value';

use base 'Class::MOP::Instance';

sub new {
    my ($class, $meta, @attrs) = @_;
    my $self = $class->SUPER::new($meta, @attrs);
    my $index = 0;
    $self->{'slot_index_map'} = { map { $_ => $index++ } $self->get_all_slots };
    return $self;
}

sub create_instance {
    my $self = shift;
    my $instance = bless [], $self->_class_name;
    $self->initialize_all_slots($instance);
    return $instance;
}

sub clone_instance {
    my ($self, $instance) = shift;
    $self->bless_instance_structure([ @$instance ]);
}

# operations on meta instance

sub get_slot_index_map { (shift)->{'slot_index_map'} }

sub initialize_slot {
    my ($self, $instance, $slot_name) = @_;
    $self->set_slot_value($instance, $slot_name, $unbound);
}

sub deinitialize_slot {
    my ( $self, $instance, $slot_name ) = @_;
    $self->set_slot_value($instance, $slot_name, $unbound);
}

sub get_all_slots {
    my $self = shift;
    return sort $self->SUPER::get_all_slots;
}

sub get_slot_value {
    my ($self, $instance, $slot_name) = @_;
    my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ];
    return $value unless ref $value;
    refaddr $value eq refaddr $unbound ? undef : $value;
}

sub set_slot_value {
    my ($self, $instance, $slot_name, $value) = @_;
    $instance->[ $self->{'slot_index_map'}->{$slot_name} ] = $value;
}

sub is_slot_initialized {
    my ($self, $instance, $slot_name) = @_;
    # NOTE: maybe use CLOS's *special-unbound-value* for this?
    my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ];
    return 1 unless ref $value;
    refaddr $value eq refaddr $unbound ? 0 : 1;
}

sub is_dependent_on_superclasses { 1 }

1;

__END__