examples/ArrayBasedInstance.pod

   1
   2 package # hide the package from PAUSE
   3     ArrayBasedInstance::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 = $self->associated_class->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         my $meta_instance = $self->associated_class->get_meta_instance;
  30         $meta_instance->get_slot_value($_[0], $attr_name);
  31     };
  32 }
  33
  34 sub generate_writer_method {
  35     my $self = shift;
  36     my $attr_name = $self->name;
  37     return sub {
  38         my $meta_instance = $self->associated_class->get_meta_instance;
  39         $meta_instance->set_slot_value($_[0], $attr_name, $_[1]);
  40     };
  41 }
  42
  43 sub generate_predicate_method {
  44     my $self = shift;
  45     my $attr_name = $self->name;
  46     return sub {
  47         my $meta_instance = $self->associated_class->get_meta_instance;
  48         defined $meta_instance->get_slot_value($_[0], $attr_name) ? 1 : 0;
  49     };
  50 }
  51
  52 package # hide the package from PAUSE
  53     ArrayBasedInstance::Instance;
  54
  55 use strict;
  56 use warnings;
  57
  58 use Carp 'confess';
  59
  60 our $VERSION = '0.01';
  61
  62 use base 'Class::MOP::Instance';
  63
  64 sub new {
  65     my ($class, $meta, @attrs) = @_;
  66     my $self = $class->SUPER::new($meta, @attrs);
  67     my $index = 0;
  68     $self->{slot_index_map} = { map { $_ => $index++ } $self->get_all_slots };
  69     return $self;
  70 }
  71
  72 sub create_instance {
  73     my $self = shift;
  74     $self->bless_instance_structure([]);
  75 }
  76
  77 # operations on meta instance
  78
  79 sub get_all_slots {
  80     my $self = shift;
  81     return sort @{$self->{slots}};
  82 }
  83
  84 sub get_slot_value {
  85     my ($self, $instance, $slot_name) = @_;
  86     return $instance->[ $self->{slot_index_map}->{$slot_name} ];
  87 }
  88
  89 sub set_slot_value {
  90     my ($self, $instance, $slot_name, $value) = @_;
  91     $instance->[ $self->{slot_index_map}->{$slot_name} ] = $value;
  92 }
  93
  94 sub initialize_slot {
  95     my ($self, $instance, $slot_name) = @_;
  96     $instance->[ $self->{slot_index_map}->{$slot_name} ] = undef;
  97 }
  98
  99 sub is_slot_initialized {
 100     # NOTE:
 101     # maybe use CLOS's *special-unbound-value*
 102     # for this ?
 103     confess "Cannot really tell this for sure";
 104 }
 105
 106 1;
 107
 108 __END__
 109
 110 =pod
 111
 112 =head1 NAME
 113
 114 ArrayBasedInstance - An example of an Array based instance
 115
 116 =head1 SYNOPSIS
 117
 118 =head1 DESCRIPTION
 119
 120 =head1 AUTHOR
 121
 122 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 123
 124 =head1 SEE ALSO
 125
 126 =head1 COPYRIGHT AND LICENSE
 127
 128 Copyright 2006 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