/usr/share/doc/libmoose-perl/examples/ArrayBasedStorage.pod is in libmoose-perl 2.0401-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 |
package # hide the package from PAUSE
ArrayBasedStorage::Instance;
use strict;
use warnings;
use Scalar::Util qw/refaddr/;
use Carp 'confess';
our $VERSION = '0.01';
my $unbound = \'empty-slot-value';
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;
my $instance = bless [], $self->_class_name;
$self->initialize_all_slots($instance);
return $instance;
}
sub clone_instance {
my ($self, $instance) = shift;
$self->bless_instance_structure([ @$instance ]);
}
# operations on meta instance
sub get_slot_index_map { (shift)->{'slot_index_map'} }
sub initialize_slot {
my ($self, $instance, $slot_name) = @_;
$self->set_slot_value($instance, $slot_name, $unbound);
}
sub deinitialize_slot {
my ( $self, $instance, $slot_name ) = @_;
$self->set_slot_value($instance, $slot_name, $unbound);
}
sub get_all_slots {
my $self = shift;
return sort $self->SUPER::get_all_slots;
}
sub get_slot_value {
my ($self, $instance, $slot_name) = @_;
my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ];
return $value unless ref $value;
refaddr $value eq refaddr $unbound ? undef : $value;
}
sub set_slot_value {
my ($self, $instance, $slot_name, $value) = @_;
$instance->[ $self->{'slot_index_map'}->{$slot_name} ] = $value;
}
sub is_slot_initialized {
my ($self, $instance, $slot_name) = @_;
# NOTE: maybe use CLOS's *special-unbound-value* for this?
my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ];
return 1 unless ref $value;
refaddr $value eq refaddr $unbound ? 0 : 1;
}
sub is_dependent_on_superclasses { 1 }
1;
__END__
=pod
=head1 NAME
ArrayBasedStorage - An example of an Array based instance storage
=head1 SYNOPSIS
package Foo;
use metaclass (
':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.
This is very similar now to the InsideOutClass example, and
in fact, they both share the exact same test suite, with
the only difference being the Instance metaclass they use.
=head1 AUTHORS
Stevan Little E<lt>stevan@iinteractive.comE<gt>
Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
=head1 SEE ALSO
=head1 COPYRIGHT AND LICENSE
Copyright 2006-2008 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
|