Commit | Line | Data |
d6fbcd05 |
1 | |
2 | package # hide the package from PAUSE |
3 | ClassEncapsulatedAttributes; |
4 | |
5 | use strict; |
6 | use warnings; |
7 | |
2bab2be6 |
8 | our $VERSION = '0.06'; |
d6fbcd05 |
9 | |
10 | use base 'Class::MOP::Class'; |
11 | |
351bd7d4 |
12 | sub initialize { |
13 | (shift)->SUPER::initialize(@_, |
14 | # use the custom attribute metaclass here |
15 | ':attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute' |
16 | ); |
17 | } |
18 | |
d6fbcd05 |
19 | sub construct_instance { |
20 | my ($class, %params) = @_; |
839ea973 |
21 | my $meta_instance = Class::MOP::Instance->new($class); |
d6fbcd05 |
22 | foreach my $current_class ($class->class_precedence_list()) { |
839ea973 |
23 | $meta_instance->add_slot($current_class => {}) |
24 | unless $meta_instance->has_slot($current_class); |
aa448b16 |
25 | my $meta = $current_class->meta; |
d6fbcd05 |
26 | foreach my $attr_name ($meta->get_attribute_list()) { |
27 | my $attr = $meta->get_attribute($attr_name); |
839ea973 |
28 | $attr->initialize_instance_slot($meta, $meta_instance, \%params); |
d6fbcd05 |
29 | } |
30 | } |
839ea973 |
31 | return $meta_instance->get_instance; |
d6fbcd05 |
32 | } |
33 | |
34 | package # hide the package from PAUSE |
35 | ClassEncapsulatedAttributes::Attribute; |
36 | |
37 | use strict; |
38 | use warnings; |
39 | |
2bab2be6 |
40 | our $VERSION = '0.04'; |
d6fbcd05 |
41 | |
42 | use base 'Class::MOP::Attribute'; |
43 | |
fed4cee7 |
44 | sub initialize_instance_slot { |
839ea973 |
45 | my ($self, $class, $meta_instance, $params) = @_; |
fed4cee7 |
46 | # if the attr has an init_arg, use that, otherwise, |
47 | # use the attributes name itself as the init_arg |
48 | my $init_arg = $self->init_arg(); |
49 | # try to fetch the init arg from the %params ... |
50 | my $val; |
51 | $val = $params->{$class->name}->{$init_arg} |
52 | if exists $params->{$class->name} && |
53 | exists ${$params->{$class->name}}{$init_arg}; |
54 | # if nothing was in the %params, we can use the |
55 | # attribute's default value (if it has one) |
56 | if (!defined $val && $self->has_default) { |
839ea973 |
57 | $val = $self->default($meta_instance->get_instance); |
fed4cee7 |
58 | } |
59 | # now add this to the instance structure |
2bab2be6 |
60 | $meta_instance->get_slot_value( |
61 | $meta_instance->get_instance, |
62 | $class->name |
63 | )->{$self->name} = $val; |
fed4cee7 |
64 | } |
65 | |
d6fbcd05 |
66 | sub generate_accessor_method { |
67 | my ($self, $attr_name) = @_; |
68 | my $class_name = $self->associated_class->name; |
69 | eval qq{sub { |
70 | \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1] if scalar(\@_) == 2; |
71 | \$_[0]->{'$class_name'}->{'$attr_name'}; |
72 | }}; |
73 | } |
74 | |
75 | sub generate_reader_method { |
76 | my ($self, $attr_name) = @_; |
77 | my $class_name = $self->associated_class->name; |
78 | eval qq{sub { |
b9dfbf78 |
79 | Carp::confess "Cannot assign a value to a read-only accessor" if \@_ > 1; |
d6fbcd05 |
80 | \$_[0]->{'$class_name'}->{'$attr_name'}; |
81 | }}; |
82 | } |
83 | |
84 | sub generate_writer_method { |
85 | my ($self, $attr_name) = @_; |
86 | my $class_name = $self->associated_class->name; |
87 | eval qq{sub { |
88 | \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1]; |
89 | }}; |
90 | } |
91 | |
92 | sub generate_predicate_method { |
93 | my ($self, $attr_name) = @_; |
94 | my $class_name = $self->associated_class->name; |
95 | eval qq{sub { |
96 | defined \$_[0]->{'$class_name'}->{'$attr_name'} ? 1 : 0; |
97 | }}; |
98 | } |
99 | |
100 | ## &remove_attribute is left as an exercise for the reader :) |
101 | |
102 | 1; |
103 | |
104 | __END__ |
105 | |
106 | =pod |
107 | |
108 | =head1 NAME |
109 | |
110 | ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes |
111 | |
112 | =head1 SYNOPSIS |
113 | |
114 | package Foo; |
115 | |
677eb158 |
116 | use metaclass 'ClassEncapsulatedAttributes'; |
d6fbcd05 |
117 | |
2e41896e |
118 | Foo->meta->add_attribute('foo' => ( |
119 | accessor => 'Foo_foo', |
120 | default => 'init in FOO' |
121 | )); |
d6fbcd05 |
122 | |
123 | sub new { |
124 | my $class = shift; |
5659d76e |
125 | $class->meta->new_object(@_); |
d6fbcd05 |
126 | } |
127 | |
128 | package Bar; |
129 | our @ISA = ('Foo'); |
130 | |
131 | # duplicate the attribute name here |
2e41896e |
132 | Bar->meta->add_attribute('foo' => ( |
133 | accessor => 'Bar_foo', |
134 | default => 'init in BAR' |
135 | )); |
d6fbcd05 |
136 | |
137 | # ... later in other code ... |
138 | |
139 | my $bar = Bar->new(); |
140 | prints $bar->Bar_foo(); # init in BAR |
141 | prints $bar->Foo_foo(); # init in FOO |
142 | |
143 | # and ... |
144 | |
145 | my $bar = Bar->new( |
146 | 'Foo' => { 'foo' => 'Foo::foo' }, |
147 | 'Bar' => { 'foo' => 'Bar::foo' } |
148 | ); |
149 | |
150 | prints $bar->Bar_foo(); # Foo::foo |
151 | prints $bar->Foo_foo(); # Bar::foo |
152 | |
153 | =head1 DESCRIPTION |
154 | |
d7c2cbe3 |
155 | This is an example metaclass which encapsulates a class's |
156 | attributes on a per-class basis. This means that there is no |
157 | possibility of name clashes with inherited attributes. This |
158 | is similar to how C++ handles its data members. |
159 | |
160 | =head1 ACKNOWLEDGEMENTS |
161 | |
162 | Thanks to Yuval "nothingmuch" Kogman for the idea for this example. |
163 | |
d6fbcd05 |
164 | =head1 AUTHOR |
165 | |
166 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
167 | |
168 | =head1 COPYRIGHT AND LICENSE |
169 | |
170 | Copyright 2006 by Infinity Interactive, Inc. |
171 | |
172 | L<http://www.iinteractive.com> |
173 | |
174 | This library is free software; you can redistribute it and/or modify |
175 | it under the same terms as Perl itself. |
176 | |
177 | =cut |