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