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 initialize_body {
121 # the %options should also include a both
122 # a call 'initializer' and call 'SUPER::'
123 # options, which should cover approx 90%
124 # of the possible use cases (even if it
125 # requires some adaption on the part of
126 # the author, after all, nothing is free)
127 my $source = 'sub {';
128 $source .= "\n" . 'my $class = shift;';
130 $source .= "\n" . 'return $class->Moose::Object::new(@_)';
131 $source .= "\n if \$class ne '" . $self->associated_metaclass->name
134 $source .= $self->_generate_params('$params', '$class');
135 $source .= $self->_generate_instance('$instance', '$class');
136 $source .= $self->_generate_slot_initializers;
138 $source .= $self->_generate_triggers();
139 $source .= ";\n" . $self->_generate_BUILDALL();
141 $source .= ";\nreturn \$instance";
142 $source .= ";\n" . '}';
143 warn $source if $self->options->{debug};
145 # We need to check if the attribute ->can('type_constraint')
146 # since we may be trying to immutabilize a Moose meta class,
147 # which in turn has attributes which are Class::MOP::Attribute
148 # objects, rather than Moose::Meta::Attribute. And
149 # Class::MOP::Attribute attributes have no type constraints.
150 # However we need to make sure we leave an undef value there
151 # because the inlined code is using the index of the attributes
152 # to determine where to find the type constraint
154 my $attrs = $self->attributes;
156 my @type_constraints = map {
157 $_->can('type_constraint') ? $_->type_constraint : undef
160 my @type_constraint_bodies = map {
161 defined $_ ? $_->_compiled_type_constraint : undef;
164 my $code = $self->_compile_code(
169 '@type_constraints' => \@type_constraints,
170 '@type_constraint_bodies' => \@type_constraint_bodies,
172 ) or $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source );
174 $self->{'body'} = $code;
177 sub _generate_params {
178 my ( $self, $var, $class_var ) = @_;
179 "my $var = " . $self->_generate_BUILDARGS( $class_var, '@_' ) . ";\n";
182 sub _generate_instance {
183 my ( $self, $var, $class_var ) = @_;
185 . $self->meta_instance->inline_create_instance($class_var) . ";\n";
188 sub _generate_slot_initializers {
190 return (join ";\n" => map {
191 $self->_generate_slot_initializer($_)
192 } 0 .. (@{$self->attributes} - 1)) . ";\n";
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.