Commit | Line | Data |
38bf2a25 |
1 | |
2 | package # hide the package from PAUSE |
3 | ClassEncapsulatedAttributes; |
4 | |
5 | use strict; |
6 | use warnings; |
7 | |
8 | our $VERSION = '0.06'; |
9 | |
10 | use base 'Class::MOP::Class'; |
11 | |
12 | sub initialize { |
13 | (shift)->SUPER::initialize(@_, |
14 | # use the custom attribute metaclass here |
15 | 'attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute', |
16 | ); |
17 | } |
18 | |
19 | sub construct_instance { |
20 | my ($class, %params) = @_; |
21 | |
22 | my $meta_instance = $class->get_meta_instance; |
23 | my $instance = $meta_instance->create_instance(); |
24 | |
25 | # initialize *ALL* attributes, including masked ones (as opposed to applicable) |
26 | foreach my $current_class ($class->class_precedence_list()) { |
27 | my $meta = $current_class->meta; |
28 | foreach my $attr_name ($meta->get_attribute_list()) { |
29 | my $attr = $meta->get_attribute($attr_name); |
30 | $attr->initialize_instance_slot($meta_instance, $instance, \%params); |
31 | } |
32 | } |
33 | |
34 | return $instance; |
35 | } |
36 | |
37 | package # hide the package from PAUSE |
38 | ClassEncapsulatedAttributes::Attribute; |
39 | |
40 | use strict; |
41 | use warnings; |
42 | |
43 | our $VERSION = '0.04'; |
44 | |
45 | use base 'Class::MOP::Attribute'; |
46 | |
47 | # alter the way parameters are specified |
48 | sub initialize_instance_slot { |
49 | my ($self, $meta_instance, $instance, $params) = @_; |
50 | # if the attr has an init_arg, use that, otherwise, |
51 | # use the attributes name itself as the init_arg |
52 | my $init_arg = $self->init_arg(); |
53 | # try to fetch the init arg from the %params ... |
54 | my $class = $self->associated_class; |
55 | my $val; |
56 | $val = $params->{$class->name}->{$init_arg} |
57 | if exists $params->{$class->name} && |
58 | exists ${$params->{$class->name}}{$init_arg}; |
59 | # if nothing was in the %params, we can use the |
60 | # attribute's default value (if it has one) |
61 | if (!defined $val && $self->has_default) { |
62 | $val = $self->default($instance); |
63 | } |
64 | |
65 | # now add this to the instance structure |
66 | $meta_instance->set_slot_value($instance, $self->name, $val); |
67 | } |
68 | |
69 | sub name { |
70 | my $self = shift; |
71 | return ($self->associated_class->name . '::' . $self->SUPER::name) |
72 | } |
73 | |
74 | 1; |
75 | |
76 | __END__ |
77 | |
78 | =pod |
79 | |
80 | =head1 NAME |
81 | |
82 | ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes |
83 | |
84 | =head1 SYNOPSIS |
85 | |
86 | package Foo; |
87 | |
88 | use metaclass 'ClassEncapsulatedAttributes'; |
89 | |
90 | Foo->meta->add_attribute('foo' => ( |
91 | accessor => 'Foo_foo', |
92 | default => 'init in FOO' |
93 | )); |
94 | |
95 | sub new { |
96 | my $class = shift; |
97 | $class->meta->new_object(@_); |
98 | } |
99 | |
100 | package Bar; |
101 | our @ISA = ('Foo'); |
102 | |
103 | # duplicate the attribute name here |
104 | Bar->meta->add_attribute('foo' => ( |
105 | accessor => 'Bar_foo', |
106 | default => 'init in BAR' |
107 | )); |
108 | |
109 | # ... later in other code ... |
110 | |
111 | my $bar = Bar->new(); |
112 | prints $bar->Bar_foo(); # init in BAR |
113 | prints $bar->Foo_foo(); # init in FOO |
114 | |
115 | # and ... |
116 | |
117 | my $bar = Bar->new( |
118 | 'Foo' => { 'foo' => 'Foo::foo' }, |
119 | 'Bar' => { 'foo' => 'Bar::foo' } |
120 | ); |
121 | |
122 | prints $bar->Bar_foo(); # Foo::foo |
123 | prints $bar->Foo_foo(); # Bar::foo |
124 | |
125 | =head1 DESCRIPTION |
126 | |
127 | This is an example metaclass which encapsulates a class's |
128 | attributes on a per-class basis. This means that there is no |
129 | possibility of name clashes with inherited attributes. This |
130 | is similar to how C++ handles its data members. |
131 | |
132 | =head1 ACKNOWLEDGEMENTS |
133 | |
134 | Thanks to Yuval "nothingmuch" Kogman for the idea for this example. |
135 | |
136 | =head1 AUTHORS |
137 | |
138 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
139 | |
140 | Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> |
141 | |
142 | =head1 COPYRIGHT AND LICENSE |
143 | |
144 | Copyright 2006-2008 by Infinity Interactive, Inc. |
145 | |
146 | L<http://www.iinteractive.com> |
147 | |
148 | This library is free software; you can redistribute it and/or modify |
149 | it under the same terms as Perl itself. |
150 | |
151 | =cut |