making the init_arg even more silly
[gitmo/Class-MOP.git] / examples / InsideOutClass.pod
CommitLineData
9ec169fe 1
9ec169fe 2package # hide the package from PAUSE
43715282 3 InsideOutClass::Attribute;
4
5use strict;
6use warnings;
7
8our $VERSION = '0.01';
9
10use Carp 'confess';
11use Scalar::Util 'refaddr';
12
13use base 'Class::MOP::Attribute';
14
15sub initialize_instance_slot {
16 my ($self, $meta_instance, $instance, $params) = @_;
17 my $init_arg = $self->{init_arg};
18 # try to fetch the init arg from the %params ...
19 my $val;
20 $val = $params->{$init_arg} if exists $params->{$init_arg};
21 # if nothing was in the %params, we can use the
22 # attribute's default value (if it has one)
23 if (!defined $val && defined $self->{default}) {
24 $val = $self->default($instance);
25 }
6d5355c3 26 my $_meta_instance = $self->associated_class->get_meta_instance;
27 $_meta_instance->initialize_slot($instance, $self->name);
28 $_meta_instance->set_slot_value($instance, $self->name, $val);
43715282 29}
30
31## Method generation helpers
32
33sub generate_accessor_method {
34 my $self = shift;
35 my $meta_class = $self->associated_class;
36 my $attr_name = $self->name;
37 return sub {
38 my $meta_instance = $meta_class->get_meta_instance;
39 $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2;
40 $meta_instance->get_slot_value($_[0], $attr_name);
41 };
42}
43
44sub generate_reader_method {
45 my $self = shift;
46 my $meta_class = $self->associated_class;
47 my $attr_name = $self->name;
48 return sub {
49 confess "Cannot assign a value to a read-only accessor" if @_ > 1;
50 $meta_class->get_meta_instance
51 ->get_slot_value($_[0], $attr_name);
52 };
53}
54
55sub generate_writer_method {
56 my $self = shift;
57 my $meta_class = $self->associated_class;
58 my $attr_name = $self->name;
59 return sub {
60 $meta_class->get_meta_instance
61 ->set_slot_value($_[0], $attr_name, $_[1]);
62 };
63}
64
65sub generate_predicate_method {
66 my $self = shift;
67 my $meta_class = $self->associated_class;
68 my $attr_name = $self->name;
69 return sub {
70 defined $meta_class->get_meta_instance
71 ->get_slot_value($_[0], $attr_name) ? 1 : 0;
72 };
73}
74
75package # hide the package from PAUSE
2d711cc8 76 InsideOutClass::Instance;
9ec169fe 77
78use strict;
79use warnings;
80
b880e0de 81our $VERSION = '0.01';
9ec169fe 82
b9dfbf78 83use Carp 'confess';
9ec169fe 84use Scalar::Util 'refaddr';
85
2d711cc8 86use base 'Class::MOP::Instance';
87
88sub create_instance {
49c93440 89 my ($self, $class) = @_;
90 $self->bless_instance_structure(\(my $instance));
9ec169fe 91}
92
2d711cc8 93sub get_slot_value {
49c93440 94 my ($self, $instance, $slot_name) = @_;
58d75218 95 $self->{meta}->get_package_symbol('%' . $slot_name)->{refaddr $instance};
9ec169fe 96}
97
2d711cc8 98sub set_slot_value {
49c93440 99 my ($self, $instance, $slot_name, $value) = @_;
58d75218 100 $self->{meta}->get_package_symbol('%' . $slot_name)->{refaddr $instance} = $value;
9ec169fe 101}
102
49c93440 103sub initialize_slot {
104 my ($self, $instance, $slot_name) = @_;
58d75218 105 $self->{meta}->add_package_symbol(('%' . $slot_name) => {})
106 unless $self->{meta}->has_package_symbol('%' . $slot_name);
107 $self->{meta}->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef;
49c93440 108}
2d711cc8 109
49c93440 110sub is_slot_initialized {
111 my ($self, $instance, $slot_name) = @_;
58d75218 112 return 0 unless $self->{meta}->has_package_symbol('%' . $slot_name);
113 return exists $self->{meta}->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0;
9ec169fe 114}
115
9ec169fe 1161;
117
118__END__
119
120=pod
121
122=head1 NAME
123
124InsideOutClass - A set of example metaclasses which implement the Inside-Out technique
125
126=head1 SYNOPSIS
127
128 package Foo;
129
1becdfcc 130 use metaclass (
43715282 131 ':attribute_metaclass' => 'InsideOutClass::Attribute',
132 ':instance_metaclass' => 'InsideOutClass::Instance'
677eb158 133 );
9ec169fe 134
2e41896e 135 __PACKAGE__->meta->add_attribute('foo' => (
136 reader => 'get_foo',
137 writer => 'set_foo'
138 ));
9ec169fe 139
140 sub new {
141 my $class = shift;
5659d76e 142 $class->meta->new_object(@_);
143 }
9ec169fe 144
145 # now you can just use the class as normal
146
147=head1 DESCRIPTION
148
149This is a set of example metaclasses which implement the Inside-Out
150class technique. What follows is a brief explaination of the code
151found in this module.
152
2d711cc8 153We must create a subclass of B<Class::MOP::Instance> and override
154the slot operations. This requires
155overloading C<get_slot_value>, C<set_slot_value>, C<slot_initialized>, and
156C<initialize_slot>, as well as their inline counterparts. Additionally we
157overload C<add_slot> in order to initialize the global hash containing the
158actual slot values.
9ec169fe 159
160And that is pretty much all. Of course I am ignoring need for
161inside-out objects to be C<DESTROY>-ed, and some other details as
2d711cc8 162well (threading, etc), but this is an example. A real implementation is left as
163an exercise to the reader.
9ec169fe 164
1a09d9cc 165=head1 AUTHORS
9ec169fe 166
167Stevan Little E<lt>stevan@iinteractive.comE<gt>
168
005adf8f 169Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
2d711cc8 170
9ec169fe 171=head1 COPYRIGHT AND LICENSE
172
173Copyright 2006 by Infinity Interactive, Inc.
174
175L<http://www.iinteractive.com>
176
177This library is free software; you can redistribute it and/or modify
178it under the same terms as Perl itself.
179
180=cut