Commit | Line | Data |
38bf2a25 |
1 | |
2 | package # hide the package from PAUSE |
3 | LazyClass::Attribute; |
4 | |
5 | use strict; |
6 | use warnings; |
7 | |
8 | use Carp 'confess'; |
9 | |
10 | our $VERSION = '0.05'; |
11 | |
12 | use base 'Class::MOP::Attribute'; |
13 | |
14 | sub initialize_instance_slot { |
15 | my ($self, $meta_instance, $instance, $params) = @_; |
16 | |
17 | # if the attr has an init_arg, use that, otherwise, |
18 | # use the attributes name itself as the init_arg |
19 | my $init_arg = $self->init_arg(); |
20 | |
21 | if ( exists $params->{$init_arg} ) { |
22 | my $val = $params->{$init_arg}; |
23 | $meta_instance->set_slot_value($instance, $self->name, $val); |
24 | } |
25 | } |
26 | |
27 | sub accessor_metaclass { 'LazyClass::Method::Accessor' } |
28 | |
29 | package # hide the package from PAUSE |
30 | LazyClass::Method::Accessor; |
31 | |
32 | use strict; |
33 | use warnings; |
34 | |
35 | use Carp 'confess'; |
36 | |
37 | our $VERSION = '0.01'; |
38 | |
39 | use base 'Class::MOP::Method::Accessor'; |
40 | |
41 | sub _generate_accessor_method { |
42 | my $attr = (shift)->associated_attribute; |
43 | |
44 | my $attr_name = $attr->name; |
45 | my $meta_instance = $attr->associated_class->get_meta_instance; |
46 | |
47 | sub { |
48 | if (scalar(@_) == 2) { |
49 | $meta_instance->set_slot_value($_[0], $attr_name, $_[1]); |
50 | } |
51 | else { |
52 | unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { |
53 | my $value = $attr->has_default ? $attr->default($_[0]) : undef; |
54 | $meta_instance->set_slot_value($_[0], $attr_name, $value); |
55 | } |
56 | |
57 | $meta_instance->get_slot_value($_[0], $attr_name); |
58 | } |
59 | }; |
60 | } |
61 | |
62 | sub _generate_reader_method { |
63 | my $attr = (shift)->associated_attribute; |
64 | |
65 | my $attr_name = $attr->name; |
66 | my $meta_instance = $attr->associated_class->get_meta_instance; |
67 | |
68 | sub { |
69 | confess "Cannot assign a value to a read-only accessor" if @_ > 1; |
70 | |
71 | unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { |
72 | my $value = $attr->has_default ? $attr->default($_[0]) : undef; |
73 | $meta_instance->set_slot_value($_[0], $attr_name, $value); |
74 | } |
75 | |
76 | $meta_instance->get_slot_value($_[0], $attr_name); |
77 | }; |
78 | } |
79 | |
80 | package # hide the package from PAUSE |
81 | LazyClass::Instance; |
82 | |
83 | use strict; |
84 | use warnings; |
85 | |
86 | our $VERSION = '0.01'; |
87 | |
88 | use base 'Class::MOP::Instance'; |
89 | |
90 | sub initialize_all_slots {} |
91 | |
92 | 1; |
93 | |
94 | __END__ |
95 | |
96 | =pod |
97 | |
98 | =head1 NAME |
99 | |
100 | LazyClass - An example metaclass with lazy initialization |
101 | |
102 | =head1 SYNOPSIS |
103 | |
104 | package BinaryTree; |
105 | |
106 | use metaclass ( |
107 | ':attribute_metaclass' => 'LazyClass::Attribute', |
108 | ':instance_metaclass' => 'LazyClass::Instance', |
109 | ); |
110 | |
111 | BinaryTree->meta->add_attribute('node' => ( |
112 | accessor => 'node', |
113 | init_arg => ':node' |
114 | )); |
115 | |
116 | BinaryTree->meta->add_attribute('left' => ( |
117 | reader => 'left', |
118 | default => sub { BinaryTree->new() } |
119 | )); |
120 | |
121 | BinaryTree->meta->add_attribute('right' => ( |
122 | reader => 'right', |
123 | default => sub { BinaryTree->new() } |
124 | )); |
125 | |
126 | sub new { |
127 | my $class = shift; |
128 | $class->meta->new_object(@_); |
129 | } |
130 | |
131 | # ... later in code |
132 | |
133 | my $btree = BinaryTree->new(); |
134 | # ... $btree is an empty hash, no keys are initialized yet |
135 | |
136 | =head1 DESCRIPTION |
137 | |
138 | This is an example metclass in which all attributes are created |
139 | lazily. This means that no entries are made in the instance HASH |
140 | until the last possible moment. |
141 | |
142 | The example above of a binary tree is a good use for such a |
143 | metaclass because it allows the class to be space efficient |
144 | without complicating the programing of it. This would also be |
145 | ideal for a class which has a large amount of attributes, |
146 | several of which are optional. |
147 | |
148 | =head1 AUTHORS |
149 | |
150 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
151 | |
152 | Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> |
153 | |
154 | =head1 COPYRIGHT AND LICENSE |
155 | |
156 | Copyright 2006-2008 by Infinity Interactive, Inc. |
157 | |
158 | L<http://www.iinteractive.com> |
159 | |
160 | This library is free software; you can redistribute it and/or modify |
161 | it under the same terms as Perl itself. |
162 | |
163 | =cut |