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