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::Constructor';
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->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 sub _generate_params {
119 my ( $self, $var, $class_var ) = @_;
120 "my $var = " . $self->_generate_BUILDARGS( $class_var, '@_' ) . ";\n";
123 sub _generate_instance {
124 my ( $self, $var, $class_var ) = @_;
126 . $self->meta_instance->inline_create_instance($class_var) . ";\n";
129 sub _generate_slot_initializers {
131 return (join ";\n" => map {
132 $self->_generate_slot_initializer($_)
133 } 0 .. (@{$self->attributes} - 1)) . ";\n";
136 sub initialize_body {
139 # the %options should also include a both
140 # a call 'initializer' and call 'SUPER::'
141 # options, which should cover approx 90%
142 # of the possible use cases (even if it
143 # requires some adaption on the part of
144 # the author, after all, nothing is free)
145 my $source = 'sub {';
146 $source .= "\n" . 'my $class = shift;';
148 $source .= "\n" . 'return $class->Moose::Object::new(@_)';
149 $source .= "\n if \$class ne '" . $self->associated_metaclass->name
152 $source .= $self->_generate_params('$params', '$class');
153 $source .= $self->_generate_instance('$instance', '$class');
154 $source .= $self->_generate_slot_initializers;
156 $source .= $self->_generate_triggers();
157 $source .= ";\n" . $self->_generate_BUILDALL();
159 $source .= ";\nreturn \$instance";
160 $source .= ";\n" . '}';
161 warn $source if $self->options->{debug};
163 # We need to check if the attribute ->can('type_constraint')
164 # since we may be trying to immutabilize a Moose meta class,
165 # which in turn has attributes which are Class::MOP::Attribute
166 # objects, rather than Moose::Meta::Attribute. And
167 # Class::MOP::Attribute attributes have no type constraints.
168 # However we need to make sure we leave an undef value there
169 # because the inlined code is using the index of the attributes
170 # to determine where to find the type constraint
172 my $attrs = $self->attributes;
174 my @type_constraints = map {
175 $_->can('type_constraint') ? $_->type_constraint : undef
178 my @type_constraint_bodies = map {
179 defined $_ ? $_->_compiled_type_constraint : undef;
182 my $code = $self->_compile_code(
187 '@type_constraints' => \@type_constraints,
188 '@type_constraint_bodies' => \@type_constraint_bodies,
190 ) or $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source );
192 $self->{'body'} = $code;
195 sub _generate_BUILDARGS {
196 my ( $self, $class, $args ) = @_;
198 my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
200 if ( $args eq '@_' and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS ) ) {
203 $self->_inline_throw_error('"Single parameters to new() must be a HASH ref"', 'data => $_[0]'),
204 ' if scalar @_ == 1 && !( defined $_[0] && ref $_[0] eq q{HASH} );',
205 '(scalar @_ == 1) ? {%{$_[0]}} : {@_};',
209 return $class . "->BUILDARGS($args)";
213 sub _generate_BUILDALL {
216 foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
217 push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD($params)';
219 return join ";\n" => @BUILD_calls;
222 sub _generate_triggers {
225 foreach my $i ( 0 .. $#{ $self->attributes } ) {
226 my $attr = $self->attributes->[$i];
228 next unless $attr->can('has_trigger') && $attr->has_trigger;
230 my $init_arg = $attr->init_arg;
232 next unless defined $init_arg;
234 push @trigger_calls => '(exists $params->{\''
242 . $self->meta_instance->inline_get_slot_value(
250 return join ";\n" => @trigger_calls;
253 sub _generate_slot_initializer {
257 my $attr = $self->attributes->[$index];
259 my @source = ('## ' . $attr->name);
261 my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
263 if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
264 push @source => ('(exists $params->{\'' . $attr->init_arg . '\'}) ' .
265 '|| ' . $self->_inline_throw_error('"Attribute (' . $attr->name . ') is required"') .';');
268 if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
270 if ( defined( my $init_arg = $attr->init_arg ) ) {
271 push @source => 'if (exists $params->{\'' . $init_arg . '\'}) {';
272 push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
273 push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
275 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
276 push @source => "} else {";
279 if ( $attr->has_default ) {
280 $default = $self->_generate_default_value($attr, $index);
283 my $builder = $attr->builder;
284 $default = '$instance->' . $builder;
287 push @source => '{'; # wrap this to avoid my $val overwrite warnings
288 push @source => ('my $val = ' . $default . ';');
289 push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
291 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
292 push @source => '}'; # close - wrap this to avoid my $val overrite warnings
294 push @source => "}" if defined $attr->init_arg;
296 elsif ( defined( my $init_arg = $attr->init_arg ) ) {
297 push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
299 push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
300 if ($is_moose && $attr->has_type_constraint) {
301 if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
302 push @source => $self->_generate_type_coercion(
304 '$type_constraints[' . $index . ']',
309 push @source => $self->_generate_type_constraint_check(
311 '$type_constraint_bodies[' . $index . ']',
312 '$type_constraints[' . $index . ']',
316 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
321 return join "\n" => @source;
324 sub _generate_slot_assignment {
325 my ($self, $attr, $value, $index) = @_;
329 if ($attr->has_initializer) {
331 '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
336 $self->meta_instance->inline_set_slot_value(
344 my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
346 if ($is_moose && $attr->is_weak_ref) {
349 $self->meta_instance->inline_weaken_slot_value(
353 ' if ref ' . $value . ';'
360 sub _generate_type_constraint_and_coercion {
361 my ($self, $attr, $index) = @_;
363 return unless $attr->has_type_constraint;
366 if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
367 push @source => $self->_generate_type_coercion(
369 '$type_constraints[' . $index . ']',
374 push @source => $self->_generate_type_constraint_check(
376 ('$type_constraint_bodies[' . $index . ']'),
377 ('$type_constraints[' . $index . ']'),
383 sub _generate_type_coercion {
384 my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
385 return ($return_value_name . ' = ' . $type_constraint_name . '->coerce(' . $value_name . ');');
388 sub _generate_type_constraint_check {
389 my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
391 $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
393 . ') does not pass the type constraint because: " . '
394 . $type_constraint_obj . '->get_message(' . $value_name . ')')
395 . "\n\t unless " . $type_constraint_cv . '->(' . $value_name . ');'
399 sub _generate_default_value {
400 my ($self, $attr, $index) = @_;
402 # default values can either be CODE refs
403 # in which case we need to call them. Or
404 # they can be scalars (strings/numbers)
405 # in which case we can just deal with them
406 # in the code we eval.
407 if ($attr->is_default_a_coderef) {
408 return '$attrs->[' . $index . ']->default($instance)';
411 return q{"} . quotemeta( $attr->default ) . q{"};
423 Moose::Meta::Method::Constructor - Method Meta Object for constructors
427 This class is a subclass of L<Class::MOP::Class::Constructor> that
428 provides additional Moose-specific functionality
430 To understand this class, you should read the the
431 L<Class::MOP::Class::Constructor> documentation as well.
435 C<Moose::Meta::Method::Constructor> is a subclass of
436 L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>.
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.