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