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 sub is_inlinable{ 0 }
  37
  38 # operations on meta instance
  39
  40 sub get_slot_index_map { (shift)->{'slot_index_map'} }
  41
  42 sub initialize_slot {
  43     my ($self, $instance, $slot_name) = @_;
  44     $self->set_slot_value($instance, $slot_name, $unbound);
  45 }
  46
  47 sub deinitialize_slot {
  48     my ( $self, $instance, $slot_name ) = @_;
  49     $self->set_slot_value($instance, $slot_name, $unbound);
  50 }
  51
  52 sub get_all_slots {
  53     my $self = shift;
  54     return sort $self->SUPER::get_all_slots;
  55 }
  56
  57 sub get_slot_value {
  58     my ($self, $instance, $slot_name) = @_;
  59     my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ];
  60     return $value unless ref $value;
  61     refaddr $value eq refaddr $unbound ? undef : $value;
  62 }
  63
  64 sub set_slot_value {
  65     my ($self, $instance, $slot_name, $value) = @_;
  66     $instance->[ $self->{'slot_index_map'}->{$slot_name} ] = $value;
  67 }
  68
  69 sub is_slot_initialized {
  70     my ($self, $instance, $slot_name) = @_;
  71     # NOTE: maybe use CLOS's *special-unbound-value* for this?
  72     my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ];
  73     return 1 unless ref $value;
  74     refaddr $value eq refaddr $unbound ? 0 : 1;
  75 }
  76
  77 sub is_dependent_on_superclasses { 1 }
  78
  79 1;
  80
  81 __END__
  82
  83 =pod
  84
  85 =head1 NAME
  86
  87 ArrayBasedStorage - An example of an Array based instance storage
  88
  89 =head1 SYNOPSIS
  90
  91   package Foo;
  92
  93   use metaclass (
  94     ':instance_metaclass'  => 'ArrayBasedStorage::Instance'
  95   );
  96
  97   __PACKAGE__->meta->add_attribute('foo' => (
  98       reader => 'get_foo',
  99       writer => 'set_foo'
 100   ));
 101
 102   sub new  {
 103       my $class = shift;
 104       $class->meta->new_object(@_);
 105   }
 106
 107   # now you can just use the class as normal
 108
 109 =head1 DESCRIPTION
 110
 111 This is a proof of concept using the Instance sub-protocol
 112 which uses ARRAY refs to store the instance data.
 113
 114 This is very similar now to the InsideOutClass example, and
 115 in fact, they both share the exact same test suite, with
 116 the only difference being the Instance metaclass they use.
 117
 118 =head1 AUTHORS
 119
 120 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 121
 122 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 123
 124 =head1 SEE ALSO
 125
 126 =head1 COPYRIGHT AND LICENSE
 127
 128 Copyright 2006-2008 by Infinity Interactive, Inc.
 129
 130 L<http://www.iinteractive.com>
 131
 132 This library is free software; you can redistribute it and/or modify
 133 it under the same terms as Perl itself.
 134
 135 =cut