Commit | Line | Data |
d90b42a6 |
1 | |
2 | package Class::MOP::Method::Constructor; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Carp 'confess'; |
8 | use Scalar::Util 'blessed', 'weaken', 'looks_like_number'; |
9 | |
565f0cbb |
10 | our $VERSION = '0.02'; |
d90b42a6 |
11 | our $AUTHORITY = 'cpan:STEVAN'; |
12 | |
565f0cbb |
13 | use base 'Class::MOP::Method::Generated'; |
d90b42a6 |
14 | |
15 | sub new { |
16 | my $class = shift; |
17 | my %options = @_; |
18 | |
19 | (exists $options{options} && ref $options{options} eq 'HASH') |
20 | || confess "You must pass a hash of options"; |
d90b42a6 |
21 | |
22 | my $self = bless { |
23 | # from our superclass |
c23184fc |
24 | '&!body' => undef, |
d90b42a6 |
25 | # specific to this subclass |
565f0cbb |
26 | '%!options' => $options{options}, |
c23184fc |
27 | '$!associated_metaclass' => $options{metaclass}, |
565f0cbb |
28 | '$!is_inline' => ($options{is_inline} || 0), |
d90b42a6 |
29 | } => $class; |
30 | |
31 | # we don't want this creating |
32 | # a cycle in the code, if not |
33 | # needed |
c23184fc |
34 | weaken($self->{'$!associated_metaclass'}); |
d90b42a6 |
35 | |
565f0cbb |
36 | $self->initialize_body; |
d90b42a6 |
37 | |
38 | return $self; |
39 | } |
40 | |
565f0cbb |
41 | ## accessors |
c23184fc |
42 | |
565f0cbb |
43 | sub options { (shift)->{'%!options'} } |
44 | sub associated_metaclass { (shift)->{'$!associated_metaclass'} } |
c23184fc |
45 | |
565f0cbb |
46 | ## cached values ... |
d90b42a6 |
47 | |
565f0cbb |
48 | sub meta_instance { |
49 | my $self = shift; |
50 | $self->{'$!meta_instance'} ||= $self->associated_metaclass->get_meta_instance; |
51 | } |
c23184fc |
52 | |
565f0cbb |
53 | sub attributes { |
54 | my $self = shift; |
55 | $self->{'@!attributes'} ||= [ $self->associated_metaclass->compute_all_applicable_attributes ] |
56 | } |
d90b42a6 |
57 | |
58 | ## method |
59 | |
565f0cbb |
60 | sub initialize_body { |
61 | my $self = shift; |
62 | my $method_name = 'generate_constructor_method'; |
63 | |
64 | $method_name .= '_inline' if $self->is_inline; |
65 | |
66 | $self->{'&!body'} = $self->$method_name; |
67 | } |
68 | |
69 | sub generate_constructor_method { |
70 | return sub { (shift)->meta->new_object(@_) } |
71 | } |
72 | |
73 | sub generate_constructor_method_inline { |
d90b42a6 |
74 | my $self = shift; |
565f0cbb |
75 | |
d90b42a6 |
76 | my $source = 'sub {'; |
77 | $source .= "\n" . 'my ($class, %params) = @_;'; |
565f0cbb |
78 | |
79 | $source .= "\n" . 'return $class->meta->new_object(%params)'; |
80 | $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';'; |
81 | |
d90b42a6 |
82 | $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class'); |
83 | $source .= ";\n" . (join ";\n" => map { |
84 | $self->_generate_slot_initializer($_) |
85 | } 0 .. (@{$self->attributes} - 1)); |
86 | $source .= ";\n" . 'return $instance'; |
87 | $source .= ";\n" . '}'; |
88 | warn $source if $self->options->{debug}; |
89 | |
90 | my $code; |
91 | { |
92 | # NOTE: |
93 | # create the nessecary lexicals |
94 | # to be picked up in the eval |
95 | my $attrs = $self->attributes; |
96 | |
97 | $code = eval $source; |
98 | confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@; |
99 | } |
565f0cbb |
100 | return $code; |
d90b42a6 |
101 | } |
102 | |
103 | sub _generate_slot_initializer { |
104 | my $self = shift; |
105 | my $index = shift; |
106 | |
107 | my $attr = $self->attributes->[$index]; |
108 | |
109 | my $default; |
110 | if ($attr->has_default) { |
111 | # NOTE: |
112 | # default values can either be CODE refs |
113 | # in which case we need to call them. Or |
114 | # they can be scalars (strings/numbers) |
115 | # in which case we can just deal with them |
116 | # in the code we eval. |
117 | if ($attr->is_default_a_coderef) { |
118 | $default = '$attrs->[' . $index . ']->default($instance)'; |
119 | } |
120 | else { |
121 | $default = $attr->default; |
122 | # make sure to quote strings ... |
123 | unless (looks_like_number($default)) { |
124 | $default = "'$default'"; |
125 | } |
126 | } |
127 | } |
128 | $self->meta_instance->inline_set_slot_value( |
129 | '$instance', |
130 | ("'" . $attr->name . "'"), |
131 | ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : '')) |
132 | ); |
133 | } |
134 | |
135 | 1; |
136 | |
137 | 1; |
138 | |
139 | __END__ |
140 | |
141 | =pod |
142 | |
143 | =head1 NAME |
144 | |
145 | Class::MOP::Method::Constructor - Method Meta Object for constructors |
146 | |
147 | =head1 SYNOPSIS |
148 | |
96e38ba6 |
149 | use Class::MOP::Method::Constructor; |
150 | |
151 | my $constructor = Class::MOP::Method::Constructor->new( |
152 | metaclass => $metaclass, |
153 | options => { |
154 | debug => 1, # this is all for now |
155 | }, |
156 | ); |
157 | |
158 | # calling the constructor ... |
159 | $constructor->body->($metaclass->name, %params); |
160 | |
d90b42a6 |
161 | =head1 DESCRIPTION |
162 | |
96e38ba6 |
163 | This is a subclass of C<Class::MOP::Method> which deals with |
164 | class constructors. |
165 | |
d90b42a6 |
166 | =head1 METHODS |
167 | |
168 | =over 4 |
169 | |
96e38ba6 |
170 | =item B<new (metaclass => $meta, options => \%options)> |
d90b42a6 |
171 | |
96e38ba6 |
172 | =item B<options> |
173 | |
174 | This returns the options HASH which is passed into C<new>. |
175 | |
176 | =item B<associated_metaclass> |
177 | |
178 | This returns the metaclass which is passed into C<new>. |
c23184fc |
179 | |
d90b42a6 |
180 | =item B<attributes> |
181 | |
96e38ba6 |
182 | This returns the list of attributes which are associated with the |
183 | metaclass which is passed into C<new>. |
184 | |
d90b42a6 |
185 | =item B<meta_instance> |
186 | |
96e38ba6 |
187 | This returns the meta instance which is associated with the |
188 | metaclass which is passed into C<new>. |
c23184fc |
189 | |
96e38ba6 |
190 | =item B<is_inline> |
191 | |
192 | This returns a boolean, but since constructors are very rarely |
193 | not inlined, this always returns true for now. |
d90b42a6 |
194 | |
565f0cbb |
195 | =item B<initialize_body> |
d90b42a6 |
196 | |
96e38ba6 |
197 | This creates the code reference for the constructor itself. |
198 | |
d90b42a6 |
199 | =back |
200 | |
565f0cbb |
201 | =head2 Method Generators |
202 | |
203 | =over 4 |
204 | |
205 | =item B<generate_constructor_method> |
206 | |
207 | =item B<generate_constructor_method_inline> |
208 | |
209 | =back |
210 | |
d90b42a6 |
211 | =head1 AUTHORS |
212 | |
213 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
214 | |
215 | =head1 COPYRIGHT AND LICENSE |
216 | |
2367814a |
217 | Copyright 2006, 2007 by Infinity Interactive, Inc. |
d90b42a6 |
218 | |
219 | L<http://www.iinteractive.com> |
220 | |
221 | This library is free software; you can redistribute it and/or modify |
222 | it under the same terms as Perl itself. |
223 | |
224 | =cut |
225 | |