examples/ArrayBasedStorage.pod

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