Commit | Line | Data |
38bf2a25 |
1 | |
2 | package Class::MOP::Method::Constructor; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Carp 'confess'; |
bdb2de61 |
8 | use Scalar::Util 'blessed', 'weaken', 'refaddr'; |
38bf2a25 |
9 | use Try::Tiny; |
10 | |
38bf2a25 |
11 | use base 'Class::MOP::Method::Inlined'; |
12 | |
13 | sub new { |
14 | my $class = shift; |
15 | my %options = @_; |
16 | |
17 | (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class')) |
18 | || confess "You must pass a metaclass instance if you want to inline" |
19 | if $options{is_inline}; |
20 | |
21 | ($options{package_name} && $options{name}) |
22 | || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"; |
23 | |
24 | my $self = $class->_new(\%options); |
25 | |
26 | # we don't want this creating |
27 | # a cycle in the code, if not |
28 | # needed |
29 | weaken($self->{'associated_metaclass'}); |
30 | |
31 | $self->_initialize_body; |
32 | |
33 | return $self; |
34 | } |
35 | |
36 | sub _new { |
37 | my $class = shift; |
38 | |
39 | return Class::MOP::Class->initialize($class)->new_object(@_) |
40 | if $class ne __PACKAGE__; |
41 | |
42 | my $params = @_ == 1 ? $_[0] : {@_}; |
43 | |
44 | return bless { |
45 | # inherited from Class::MOP::Method |
46 | body => $params->{body}, |
47 | # associated_metaclass => $params->{associated_metaclass}, # overriden |
48 | package_name => $params->{package_name}, |
49 | name => $params->{name}, |
50 | original_method => $params->{original_method}, |
51 | |
52 | # inherited from Class::MOP::Generated |
53 | is_inline => $params->{is_inline} || 0, |
54 | definition_context => $params->{definition_context}, |
55 | |
56 | # inherited from Class::MOP::Inlined |
57 | _expected_method_class => $params->{_expected_method_class}, |
58 | |
59 | # defined in this subclass |
60 | options => $params->{options} || {}, |
61 | associated_metaclass => $params->{metaclass}, |
62 | }, $class; |
63 | } |
64 | |
65 | ## accessors |
66 | |
67 | sub options { (shift)->{'options'} } |
68 | sub associated_metaclass { (shift)->{'associated_metaclass'} } |
69 | |
38bf2a25 |
70 | ## method |
71 | |
72 | sub _initialize_body { |
73 | my $self = shift; |
74 | my $method_name = '_generate_constructor_method'; |
75 | |
76 | $method_name .= '_inline' if $self->is_inline; |
77 | |
78 | $self->{'body'} = $self->$method_name; |
79 | } |
80 | |
81 | sub _eval_environment { |
82 | my $self = shift; |
96fec633 |
83 | return $self->associated_metaclass->_eval_environment; |
38bf2a25 |
84 | } |
85 | |
86 | sub _generate_constructor_method { |
87 | return sub { Class::MOP::Class->initialize(shift)->new_object(@_) } |
88 | } |
89 | |
90 | sub _generate_constructor_method_inline { |
91 | my $self = shift; |
92 | |
93 | my $meta = $self->associated_metaclass; |
94 | |
95 | my @source = ( |
96 | 'sub {', |
97 | $meta->_inline_new_object, |
98 | '}', |
99 | ); |
100 | |
101 | warn join("\n", @source) if $self->options->{debug}; |
102 | |
bdb2de61 |
103 | my $RuNNeR; |
104 | my $code; |
105 | return $code = bless sub { |
106 | if (!defined($RuNNeR)) { |
107 | $RuNNeR = try { |
108 | $self->_compile_code(\@source); |
109 | } |
110 | catch { |
111 | my $source = join("\n", @source); |
112 | confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$_"; |
113 | }; |
114 | # update the body member unless something else has stomped on it |
115 | my $body = $self->{'body'}; |
116 | if (refaddr($code) != refaddr($body)) { |
117 | # we seem to be outdated... paranoid future-proofing, I think.. |
118 | goto $RuNNeR = $body; |
119 | } |
120 | $self->{'body'} = $RuNNeR; |
121 | # update the symbol in the stash if it's currently immutable |
122 | # and it's still the original we set previously. |
123 | # my $assoc_class = $self->associated_metaclass; |
124 | # my $sigiled_name = '&'.$self->{'name'}; |
125 | # if ($assoc_class->is_immutable) { |
126 | # my $stash = $assoc_class->_package_stash; |
127 | # my $symbol_ref = $stash->get_symbol($sigiled_name); |
128 | # if (!defined($symbol_ref)) { |
129 | # confess "A metaobject is corrupted"; |
130 | # } |
131 | # if (refaddr($code) != refaddr($symbol_ref)) { |
132 | # goto $RuNNeR = $symbol_ref; |
133 | # } |
134 | # $stash->add_symbol($sigiled_name, $RuNNeR); |
135 | # } |
136 | }; |
137 | return unless defined($_[0]); |
138 | goto $RuNNeR; |
139 | },'RuNNeR'; |
38bf2a25 |
140 | } |
141 | |
142 | 1; |
143 | |
144 | # ABSTRACT: Method Meta Object for constructors |
145 | |
146 | __END__ |
147 | |
148 | =pod |
149 | |
150 | =head1 SYNOPSIS |
151 | |
152 | use Class::MOP::Method::Constructor; |
153 | |
154 | my $constructor = Class::MOP::Method::Constructor->new( |
155 | metaclass => $metaclass, |
156 | options => { |
157 | debug => 1, # this is all for now |
158 | }, |
159 | ); |
160 | |
161 | # calling the constructor ... |
162 | $constructor->body->execute($metaclass->name, %params); |
163 | |
164 | =head1 DESCRIPTION |
165 | |
166 | This is a subclass of C<Class::MOP::Method> which generates |
167 | constructor methods. |
168 | |
169 | =head1 METHODS |
170 | |
171 | =over 4 |
172 | |
173 | =item B<< Class::MOP::Method::Constructor->new(%options) >> |
174 | |
175 | This creates a new constructor object. It accepts a hash reference of |
176 | options. |
177 | |
178 | =over 8 |
179 | |
180 | =item * metaclass |
181 | |
182 | This should be a L<Class::MOP::Class> object. It is required. |
183 | |
184 | =item * name |
185 | |
186 | The method name (without a package name). This is required. |
187 | |
188 | =item * package_name |
189 | |
190 | The package name for the method. This is required. |
191 | |
192 | =item * is_inline |
193 | |
194 | This indicates whether or not the constructor should be inlined. This |
195 | defaults to false. |
196 | |
197 | =back |
198 | |
199 | =item B<< $metamethod->is_inline >> |
200 | |
201 | Returns a boolean indicating whether or not the constructor is |
202 | inlined. |
203 | |
204 | =item B<< $metamethod->associated_metaclass >> |
205 | |
206 | This returns the L<Class::MOP::Class> object for the method. |
207 | |
208 | =back |
209 | |
210 | =cut |
211 | |