refactoring-n-tests

[gitmo/Class-MOP.git] / examples / ArrayBasedStorage.pod

package # hide the package from PAUSE
    ArrayBasedStorage::Attribute;

use strict;
use warnings;

use Carp 'confess';

our $VERSION = '0.01';

use base 'Class::MOP::Attribute';    

sub generate_accessor_method {
    my $self = shift;
    my $attr_name = $self->name;
    return sub {
        my $meta_instance = $_[0]->meta->get_meta_instance;            
        $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2;
        $meta_instance->get_slot_value($_[0], $attr_name);
    };
}

sub generate_reader_method {
    my $self = shift;
    my $attr_name = $self->name;
    return sub { 
        confess "Cannot assign a value to a read-only accessor" if @_ > 1;
        $_[0]->meta
             ->get_meta_instance
             ->get_slot_value($_[0], $attr_name); 
    };   
}

sub generate_writer_method {
    my $self = shift;
    my $attr_name = $self->name;
    return sub { 
        $_[0]->meta
             ->get_meta_instance
             ->set_slot_value($_[0], $attr_name, $_[1]);
    };
}

sub generate_predicate_method {
    my $self = shift;
    my $attr_name = $self->name;
    return sub {        
        defined $_[0]->meta
                     ->get_meta_instance
                     ->get_slot_value($_[0], $attr_name) ? 1 : 0;
    };
}    

package # hide the package from PAUSE
    ArrayBasedStorage::Instance;

use strict;
use warnings;

use Carp 'confess';

our $VERSION = '0.01';

use base 'Class::MOP::Instance';

sub new {
    my ($class, $meta, @attrs) = @_;
    my $self = $class->SUPER::new($meta, @attrs);
    my $index = 0;
    $self->{slot_index_map} = { map { $_ => $index++ } $self->get_all_slots };
    return $self;
}

sub create_instance {
    my $self = shift;
    $self->bless_instance_structure([]);
}

# operations on meta instance

sub get_all_slots {
    my $self = shift;
    return sort @{$self->{slots}};
}

sub get_slot_value {
    my ($self, $instance, $slot_name) = @_;
    return $instance->[ $self->{slot_index_map}->{$slot_name} ];
}

sub set_slot_value {
    my ($self, $instance, $slot_name, $value) = @_;
    $instance->[ $self->{slot_index_map}->{$slot_name} ] = $value;
}

sub initialize_slot {
    my ($self, $instance, $slot_name) = @_;
    $instance->[ $self->{slot_index_map}->{$slot_name} ] = undef;
}

sub is_slot_initialized {
    # NOTE:
    # maybe use CLOS's *special-unbound-value*
    # for this ?
    confess "Cannot really tell this for sure";
}

1;

__END__

=pod

=head1 NAME

ArrayBasedStorage - An example of an Array based instance storage 

=head1 SYNOPSIS

  package Foo;
  
  use metaclass 'Class::MOP::Class' => (
    ':attribute_metaclass' => 'ArrayBasedStorage::Attribute'
    ':instance_metaclass'  => 'ArrayBasedStorage::Instance'
  );
  
  __PACKAGE__->meta->add_attribute('foo' => (
      reader => 'get_foo',
      writer => 'set_foo'
  ));    
  
  sub new  {
      my $class = shift;
      $class->meta->new_object(@_);
  } 
  
  # now you can just use the class as normal

=head1 DESCRIPTION

This is a proof of concept using the Instance sub-protocol 
which uses ARRAY refs to store the instance data. 

=head1 AUTHOR

Stevan Little E<lt>stevan@iinteractive.comE<gt>

=head1 SEE ALSO

=head1 COPYRIGHT AND LICENSE

Copyright 2006 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut