examples/ArrayBasedStorage.pod

   1
   2 package # hide the package from PAUSE
   3     ArrayBasedStorage::Instance;
   4
   5 use strict;
   6 use warnings;
   7
   8 use Carp 'confess';
   9
  10 our $VERSION = '0.01';
  11
  12 use base 'Class::MOP::Instance';
  13
  14 sub new {
  15     my ($class, $meta, @attrs) = @_;
  16     my $self = $class->SUPER::new($meta, @attrs);
  17     my $index = 0;
  18     $self->{slot_index_map} = { map { $_ => $index++ } $self->get_all_slots };
  19     return $self;
  20 }
  21
  22 sub create_instance {
  23     my $self = shift;
  24     $self->bless_instance_structure([]);
  25 }
  26
  27 sub clone_instance {
  28     my ($self, $instance) = shift;
  29     $self->bless_instance_structure([ @$instance ]);
  30 }
  31
  32 # operations on meta instance
  33
  34 sub get_slot_index_map { (shift)->{slot_index_map} }
  35
  36 sub get_all_slots {
  37     my $self = shift;
  38     return sort $self->SUPER::get_all_slots;
  39 }
  40
  41 sub get_slot_value {
  42     my ($self, $instance, $slot_name) = @_;
  43     return $instance->[ $self->{slot_index_map}->{$slot_name} ];
  44 }
  45
  46 sub set_slot_value {
  47     my ($self, $instance, $slot_name, $value) = @_;
  48     $instance->[ $self->{slot_index_map}->{$slot_name} ] = $value;
  49 }
  50
  51 sub initialize_slot {
  52     my ($self, $instance, $slot_name) = @_;
  53     $instance->[ $self->{slot_index_map}->{$slot_name} ] = undef;
  54 }
  55
  56 sub is_slot_initialized {
  57     # NOTE:
  58     # maybe use CLOS's *special-unbound-value*
  59     # for this ?
  60     confess "Cannot really tell this for sure";
  61 }
  62
  63 1;
  64
  65 __END__
  66
  67 =pod
  68
  69 =head1 NAME
  70
  71 ArrayBasedStorage - An example of an Array based instance storage
  72
  73 =head1 SYNOPSIS
  74
  75   package Foo;
  76
  77   use metaclass (
  78     ':instance_metaclass'  => 'ArrayBasedStorage::Instance'
  79   );
  80
  81   __PACKAGE__->meta->add_attribute('foo' => (
  82       reader => 'get_foo',
  83       writer => 'set_foo'
  84   ));
  85
  86   sub new  {
  87       my $class = shift;
  88       $class->meta->new_object(@_);
  89   }
  90
  91   # now you can just use the class as normal
  92
  93 =head1 DESCRIPTION
  94
  95 This is a proof of concept using the Instance sub-protocol
  96 which uses ARRAY refs to store the instance data.
  97
  98 This is very similar now to the InsideOutClass example, and
  99 in fact, they both share the exact same test suite, with
 100 the only difference being the Instance metaclass they use.
 101
 102 =head1 AUTHOR
 103
 104 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 105
 106 =head1 SEE ALSO
 107
 108 =head1 COPYRIGHT AND LICENSE
 109
 110 Copyright 2006 by Infinity Interactive, Inc.
 111
 112 L<http://www.iinteractive.com>
 113
 114 This library is free software; you can redistribute it and/or modify
 115 it under the same terms as Perl itself.
 116
 117 =cut