2 package Moose::Meta::Method::Constructor;
7 use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
10 our $AUTHORITY = 'cpan:STEVAN';
12 use base 'Moose::Meta::Method',
13 'Class::MOP::Method::Generated';
19 my $meta = $options{metaclass};
21 (ref $options{options} eq 'HASH')
22 || $class->throw_error("You must pass a hash of options", data => $options{options});
24 ($options{package_name} && $options{name})
25 || $class->throw_error("You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT");
30 'package_name' => $options{package_name},
31 'name' => $options{name},
32 # specific to this subclass
33 'options' => $options{options},
34 'meta_instance' => $meta->get_meta_instance,
35 'attributes' => [ $meta->compute_all_applicable_attributes ],
37 'associated_metaclass' => $meta,
40 # we don't want this creating
41 # a cycle in the code, if not
43 weaken($self->{'associated_metaclass'});
45 $self->initialize_body;
52 my $metaclass = $self->associated_metaclass;
54 my $expected_class = $self->_expected_constructor_class;
56 # If any of our parents have been made immutable, we are okay to
57 # inline our own new method. The assumption is that an inlined new
58 # method provided by a parent does not actually get used by
61 grep { $_->is_immutable }
62 map { ( ref $metaclass )->initialize($_) }
63 grep { $_ ne $expected_class }
64 $metaclass->linearized_isa
66 my $transformer = $meta->get_immutable_transformer;
68 # This is actually a false positive if we're in a subclass of
69 # this class, _and_ the expected class is not overridden (but
70 # should be), and the real expected class is actually
71 # immutable itself (see Fey::Object::Table for an example of
72 # how this can happen). I'm not sure how to actually handle
73 # that case, since it's effectively a bug in the subclass (for
74 # not overriding _expected_constructor_class).
75 return 1 if $transformer->inlined_constructor;
78 if ( my $constructor = $metaclass->find_method_by_name( $self->name ) ) {
79 my $class = $self->associated_metaclass->name;
81 if ( $constructor->body != $expected_class->can('new') ) {
83 = "Not inlining a constructor for $class since it is not"
84 . " inheriting the default $expected_class constructor\n"
85 . "If you are certain you don't need to inline your"
86 . " constructor, specify inline_constructor => 0 in your"
87 . " call to $class->meta->make_immutable\n";
89 $warning .= " (constructor has method modifiers which would be lost if it were inlined)\n"
90 if $constructor->isa('Class::MOP::Method::Wrapped');
101 # This would be a rather weird case where we have no constructor
102 # in the inheritance chain.
106 # This is here so can_be_inlined can be inherited by MooseX modules.
107 sub _expected_constructor_class {
108 return 'Moose::Object';
113 sub meta_instance { (shift)->{'meta_instance'} }
114 sub attributes { (shift)->{'attributes'} }
118 # this was changed in 0.41, but broke MooseX::Singleton, so try to catch
119 # any other code using the original broken spelling
120 sub intialize_body { $_[0]->throw_error("Please correct the spelling of 'intialize_body' to 'initialize_body'") }
122 sub _generate_params {
123 my ($self, $var, $class_var) = @_;
124 "my $var = " . $self->_generate_BUILDARGS($class_var, '@_') . ";\n";
127 sub _generate_instance {
128 my ($self, $var, $class_var) = @_;
129 "my $var = " . $self->meta_instance->inline_create_instance($class_var)
133 sub _generate_slot_initializers {
135 return (join ";\n" => map {
136 $self->_generate_slot_initializer($_)
137 } 0 .. (@{$self->attributes} - 1)) . ";\n";
140 sub initialize_body {
143 # the %options should also include a both
144 # a call 'initializer' and call 'SUPER::'
145 # options, which should cover approx 90%
146 # of the possible use cases (even if it
147 # requires some adaption on the part of
148 # the author, after all, nothing is free)
149 my $source = 'sub {';
150 $source .= "\n" . 'my $class = shift;';
152 $source .= "\n" . 'return $class->Moose::Object::new(@_)';
153 $source .= "\n if \$class ne '" . $self->associated_metaclass->name
156 $source .= $self->_generate_params('$params', '$class');
157 $source .= $self->_generate_instance('$instance', '$class');
158 $source .= $self->_generate_slot_initializers;
160 $source .= $self->_generate_triggers();
161 $source .= ";\n" . $self->_generate_BUILDALL();
163 $source .= ";\nreturn \$instance";
164 $source .= ";\n" . '}';
165 warn $source if $self->options->{debug};
167 # We need to check if the attribute ->can('type_constraint')
168 # since we may be trying to immutabilize a Moose meta class,
169 # which in turn has attributes which are Class::MOP::Attribute
170 # objects, rather than Moose::Meta::Attribute. And
171 # Class::MOP::Attribute attributes have no type constraints.
172 # However we need to make sure we leave an undef value there
173 # because the inlined code is using the index of the attributes
174 # to determine where to find the type constraint
176 my $attrs = $self->attributes;
178 my @type_constraints = map {
179 $_->can('type_constraint') ? $_->type_constraint : undef
182 my @type_constraint_bodies = map {
183 defined $_ ? $_->_compiled_type_constraint : undef;
186 my $code = $self->_compile_code(
191 '@type_constraints' => \@type_constraints,
192 '@type_constraint_bodies' => \@type_constraint_bodies,
194 ) or $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source );
196 $self->{'body'} = $code;
199 sub _generate_BUILDARGS {
200 my ( $self, $class, $args ) = @_;
202 my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
204 if ( $args eq '@_' and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS ) ) {
207 $self->_inline_throw_error('"Single parameters to new() must be a HASH ref"', 'data => $_[0]'),
208 ' if scalar @_ == 1 && !( defined $_[0] && ref $_[0] eq q{HASH} );',
209 '(scalar @_ == 1) ? {%{$_[0]}} : {@_};',
213 return $class . "->BUILDARGS($args)";
217 sub _generate_BUILDALL {
220 foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
221 push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD($params)';
223 return join ";\n" => @BUILD_calls;
226 sub _generate_triggers {
229 foreach my $i ( 0 .. $#{ $self->attributes } ) {
230 my $attr = $self->attributes->[$i];
232 next unless $attr->can('has_trigger') && $attr->has_trigger;
234 my $init_arg = $attr->init_arg;
236 next unless defined $init_arg;
238 push @trigger_calls => '(exists $params->{\''
246 . $self->meta_instance->inline_get_slot_value(
252 . $i . ']' . ');' . "\n}";
255 return join ";\n" => @trigger_calls;
258 sub _generate_slot_initializer {
262 my $attr = $self->attributes->[$index];
264 my @source = ('## ' . $attr->name);
266 my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
268 if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
269 push @source => ('(exists $params->{\'' . $attr->init_arg . '\'}) ' .
270 '|| ' . $self->_inline_throw_error('"Attribute (' . $attr->name . ') is required"') .';');
273 if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
275 if ( defined( my $init_arg = $attr->init_arg ) ) {
276 push @source => 'if (exists $params->{\'' . $init_arg . '\'}) {';
277 push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
278 push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
280 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
281 push @source => "} else {";
284 if ( $attr->has_default ) {
285 $default = $self->_generate_default_value($attr, $index);
288 my $builder = $attr->builder;
289 $default = '$instance->' . $builder;
292 push @source => '{'; # wrap this to avoid my $val overwrite warnings
293 push @source => ('my $val = ' . $default . ';');
294 push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
296 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
297 push @source => '}'; # close - wrap this to avoid my $val overrite warnings
299 push @source => "}" if defined $attr->init_arg;
301 elsif ( defined( my $init_arg = $attr->init_arg ) ) {
302 push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
304 push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
305 if ($is_moose && $attr->has_type_constraint) {
306 if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
307 push @source => $self->_generate_type_coercion(
309 '$type_constraints[' . $index . ']',
314 push @source => $self->_generate_type_constraint_check(
316 '$type_constraint_bodies[' . $index . ']',
317 '$type_constraints[' . $index . ']',
321 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
326 return join "\n" => @source;
329 sub _generate_slot_assignment {
330 my ($self, $attr, $value, $index) = @_;
334 if ($attr->has_initializer) {
336 '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
341 $self->meta_instance->inline_set_slot_value(
349 my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
351 if ($is_moose && $attr->is_weak_ref) {
354 $self->meta_instance->inline_weaken_slot_value(
358 ' if ref ' . $value . ';'
365 sub _generate_type_constraint_and_coercion {
366 my ($self, $attr, $index) = @_;
368 return unless $attr->has_type_constraint;
371 if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
372 push @source => $self->_generate_type_coercion(
374 '$type_constraints[' . $index . ']',
379 push @source => $self->_generate_type_constraint_check(
381 ('$type_constraint_bodies[' . $index . ']'),
382 ('$type_constraints[' . $index . ']'),
388 sub _generate_type_coercion {
389 my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
390 return ($return_value_name . ' = ' . $type_constraint_name . '->coerce(' . $value_name . ');');
393 sub _generate_type_constraint_check {
394 my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
396 $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
398 . ') does not pass the type constraint because: " . '
399 . $type_constraint_obj . '->get_message(' . $value_name . ')')
400 . "\n\t unless " . $type_constraint_cv . '->(' . $value_name . ');'
404 sub _generate_default_value {
405 my ($self, $attr, $index) = @_;
407 # default values can either be CODE refs
408 # in which case we need to call them. Or
409 # they can be scalars (strings/numbers)
410 # in which case we can just deal with them
411 # in the code we eval.
412 if ($attr->is_default_a_coderef) {
413 return '$attrs->[' . $index . ']->default($instance)';
416 return q{"} . quotemeta( $attr->default ) . q{"};
428 Moose::Meta::Method::Constructor - Method Meta Object for constructors
432 This class is a subclass of L<Class::MOP::Class::Constructor> that
433 provides additional Moose-specific functionality
435 To understand this class, you should read the the
436 L<Class::MOP::Class::Constructor> documentation as well.
442 =item B<< $metamethod->can_be_inlined >>
444 This returns true if the method can inlined.
446 First, it looks at all of the parents of the associated class. If any
447 of them have an inlined constructor, then the constructor can be
450 If none of them have been inlined, it checks to make sure that the
451 pre-inlining constructor for the class matches the constructor from
454 By default, it expects this constructor come from L<Moose::Object>,
455 but subclasses can change this expectation.
457 If the constructor cannot be inlined it warns that this is the case.
463 Stevan Little E<lt>stevan@iinteractive.comE<gt>
465 =head1 COPYRIGHT AND LICENSE
467 Copyright 2006-2009 by Infinity Interactive, Inc.
469 L<http://www.iinteractive.com>
471 This library is free software; you can redistribute it and/or modify
472 it under the same terms as Perl itself.