examples/ArrayBasedStorage.pod

   1
   2 package # hide the package from PAUSE
   3     ArrayBasedStorage::Attribute;
   4
   5 use strict;
   6 use warnings;
   7
   8 use Carp 'confess';
   9
  10 our $VERSION = '0.01';
  11
  12 use base 'Class::MOP::Attribute';
  13
  14 sub initialize_instance_slot {
  15     my ($self, $meta_instance, $instance, $params) = @_;
  16     my $init_arg = $self->{init_arg};
  17     # try to fetch the init arg from the %params ...
  18     my $val;
  19     $val = $params->{$init_arg} if exists $params->{$init_arg};
  20     # if nothing was in the %params, we can use the
  21     # attribute's default value (if it has one)
  22     if (!defined $val && defined $self->{default}) {
  23         $val = $self->default($instance);
  24     }
  25     $meta_instance->set_slot_value($instance, $self->name, $val);
  26 }
  27
  28 sub generate_accessor_method {
  29     my $self = shift;
  30     my $meta_class = $self->associated_class;
  31     my $attr_name  = $self->name;
  32     return sub {
  33         my $meta_instance = $meta_class->initialize(Scalar::Util::blessed($_[0]))->get_meta_instance;
  34         $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2;
  35         $meta_instance->get_slot_value($_[0], $attr_name);
  36     };
  37 }
  38
  39 sub generate_reader_method {
  40     my $self = shift;
  41     my $meta_class = $self->associated_class;
  42     my $attr_name  = $self->name;
  43     return sub {
  44         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
  45         $meta_class->initialize(Scalar::Util::blessed($_[0]))
  46                    ->get_meta_instance
  47                    ->get_slot_value($_[0], $attr_name);
  48     };
  49 }
  50
  51 sub generate_writer_method {
  52     my $self = shift;
  53     my $meta_class = $self->associated_class;
  54     my $attr_name  = $self->name;
  55     return sub {
  56         $meta_class->initialize(Scalar::Util::blessed($_[0]))
  57                    ->get_meta_instance
  58                    ->set_slot_value($_[0], $attr_name, $_[1]);
  59     };
  60 }
  61
  62 sub generate_predicate_method {
  63     my $self = shift;
  64     my $meta_class = $self->associated_class;
  65     my $attr_name  = $self->name;
  66     return sub {
  67         defined $meta_class->initialize(Scalar::Util::blessed($_[0]))
  68                            ->get_meta_instance
  69                            ->get_slot_value($_[0], $attr_name) ? 1 : 0;
  70     };
  71 }
  72
  73 package # hide the package from PAUSE
  74     ArrayBasedStorage::Instance;
  75
  76 use strict;
  77 use warnings;
  78
  79 use Carp 'confess';
  80
  81 our $VERSION = '0.01';
  82
  83 use base 'Class::MOP::Instance';
  84
  85 sub new {
  86     my ($class, $meta, @attrs) = @_;
  87     my $self = $class->SUPER::new($meta, @attrs);
  88     my $index = 0;
  89     $self->{slot_index_map} = { map { $_ => $index++ } $self->get_all_slots };
  90     return $self;
  91 }
  92
  93 sub create_instance {
  94     my $self = shift;
  95     $self->bless_instance_structure([]);
  96 }
  97
  98 # operations on meta instance
  99
 100 sub get_slot_index_map { (shift)->{slot_index_map} }
 101
 102 sub get_all_slots {
 103     my $self = shift;
 104     return sort @{$self->{slots}};
 105 }
 106
 107 sub get_slot_value {
 108     my ($self, $instance, $slot_name) = @_;
 109     return $instance->[ $self->{slot_index_map}->{$slot_name} ];
 110 }
 111
 112 sub set_slot_value {
 113     my ($self, $instance, $slot_name, $value) = @_;
 114     $instance->[ $self->{slot_index_map}->{$slot_name} ] = $value;
 115 }
 116
 117 sub initialize_slot {
 118     my ($self, $instance, $slot_name) = @_;
 119     $instance->[ $self->{slot_index_map}->{$slot_name} ] = undef;
 120 }
 121
 122 sub is_slot_initialized {
 123     # NOTE:
 124     # maybe use CLOS's *special-unbound-value*
 125     # for this ?
 126     confess "Cannot really tell this for sure";
 127 }
 128
 129 1;
 130
 131 __END__
 132
 133 =pod
 134
 135 =head1 NAME
 136
 137 ArrayBasedStorage - An example of an Array based instance storage
 138
 139 =head1 SYNOPSIS
 140
 141   package Foo;
 142
 143   use metaclass (
 144     ':instance_metaclass'  => 'ArrayBasedStorage::Instance'
 145   );
 146
 147   __PACKAGE__->meta->add_attribute('foo' => (
 148       reader => 'get_foo',
 149       writer => 'set_foo'
 150   ));
 151
 152   sub new  {
 153       my $class = shift;
 154       $class->meta->new_object(@_);
 155   }
 156
 157   # now you can just use the class as normal
 158
 159 =head1 DESCRIPTION
 160
 161 This is a proof of concept using the Instance sub-protocol
 162 which uses ARRAY refs to store the instance data.
 163
 164 This is very similar now to the InsideOutClass example, and
 165 in fact, they both share the exact same test suite, with
 166 the only difference being the Instance metaclass they use.
 167
 168 =head1 AUTHOR
 169
 170 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 171
 172 =head1 SEE ALSO
 173
 174 =head1 COPYRIGHT AND LICENSE
 175
 176 Copyright 2006 by Infinity Interactive, Inc.
 177
 178 L<http://www.iinteractive.com>
 179
 180 This library is free software; you can redistribute it and/or modify
 181 it under the same terms as Perl itself.
 182
 183 =cut