Have is_class_loaded use the old code from Moose's ClassName type check
[gitmo/Class-MOP.git] / examples / ArrayBasedStorage.pod
CommitLineData
43715282 1
62189f84 2package # hide the package from PAUSE
f892c0f0 3 ArrayBasedStorage::Instance;
0e76a376 4
5use strict;
6use warnings;
8d2d4c67 7use Scalar::Util qw/refaddr/;
0e76a376 8
9use Carp 'confess';
10
11our $VERSION = '0.01';
8d2d4c67 12my $unbound = \'empty-slot-value';
0e76a376 13
14use base 'Class::MOP::Instance';
15
16sub new {
17 my ($class, $meta, @attrs) = @_;
18 my $self = $class->SUPER::new($meta, @attrs);
19 my $index = 0;
c23184fc 20 $self->{'%!slot_index_map'} = { map { $_ => $index++ } $self->get_all_slots };
0e76a376 21 return $self;
22}
23
24sub create_instance {
25 my $self = shift;
8d2d4c67 26 my $instance = $self->bless_instance_structure([]);
27 $self->initialize_all_slots($instance);
28 return $instance;
0e76a376 29}
30
f7259199 31sub clone_instance {
32 my ($self, $instance) = shift;
33 $self->bless_instance_structure([ @$instance ]);
34}
35
0e76a376 36# operations on meta instance
37
c23184fc 38sub get_slot_index_map { (shift)->{'%!slot_index_map'} }
62189f84 39
8d2d4c67 40sub initialize_slot {
41 my ($self, $instance, $slot_name) = @_;
42 $self->set_slot_value($instance, $slot_name, $unbound);
43}
44
45sub deinitialize_slot {
46 my ( $self, $instance, $slot_name ) = @_;
47 $self->set_slot_value($instance, $slot_name, $unbound);
48}
49
0e76a376 50sub get_all_slots {
51 my $self = shift;
f7259199 52 return sort $self->SUPER::get_all_slots;
0e76a376 53}
54
55sub get_slot_value {
56 my ($self, $instance, $slot_name) = @_;
8d2d4c67 57 my $value = $instance->[ $self->{'%!slot_index_map'}->{$slot_name} ];
58 return $value unless ref $value;
59 refaddr $value eq refaddr $unbound ? undef : $value;
0e76a376 60}
61
62sub set_slot_value {
63 my ($self, $instance, $slot_name, $value) = @_;
c23184fc 64 $instance->[ $self->{'%!slot_index_map'}->{$slot_name} ] = $value;
0e76a376 65}
66
0e76a376 67sub is_slot_initialized {
8d2d4c67 68 my ($self, $instance, $slot_name) = @_;
69 # NOTE: maybe use CLOS's *special-unbound-value* for this?
70 my $value = $instance->[ $self->{'%!slot_index_map'}->{$slot_name} ];
71 return 1 unless ref $value;
72 refaddr $value eq refaddr $unbound ? 0 : 1;
0e76a376 73}
74
751;
76
77__END__
78
79=pod
80
81=head1 NAME
82
f892c0f0 83ArrayBasedStorage - An example of an Array based instance storage
0e76a376 84
85=head1 SYNOPSIS
86
f892c0f0 87 package Foo;
88
1becdfcc 89 use metaclass (
f892c0f0 90 ':instance_metaclass' => 'ArrayBasedStorage::Instance'
91 );
92
93 __PACKAGE__->meta->add_attribute('foo' => (
94 reader => 'get_foo',
95 writer => 'set_foo'
96 ));
97
98 sub new {
99 my $class = shift;
100 $class->meta->new_object(@_);
101 }
102
103 # now you can just use the class as normal
104
0e76a376 105=head1 DESCRIPTION
106
f892c0f0 107This is a proof of concept using the Instance sub-protocol
108which uses ARRAY refs to store the instance data.
109
1becdfcc 110This is very similar now to the InsideOutClass example, and
111in fact, they both share the exact same test suite, with
112the only difference being the Instance metaclass they use.
113
1a09d9cc 114=head1 AUTHORS
0e76a376 115
116Stevan Little E<lt>stevan@iinteractive.comE<gt>
117
1a09d9cc 118Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
119
0e76a376 120=head1 SEE ALSO
121
122=head1 COPYRIGHT AND LICENSE
123
69e3ab0a 124Copyright 2006-2008 by Infinity Interactive, Inc.
0e76a376 125
126L<http://www.iinteractive.com>
127
128This library is free software; you can redistribute it and/or modify
129it under the same terms as Perl itself.
130
131=cut