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 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) = @_;
125 "my $var = " . $self->meta_instance->inline_create_instance($class_var)
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(
248 . $i . ']' . ');' . "\n}";
251 return join ";\n" => @trigger_calls;
254 sub _generate_slot_initializer {
258 my $attr = $self->attributes->[$index];
260 my @source = ('## ' . $attr->name);
262 my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
264 if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
265 push @source => ('(exists $params->{\'' . $attr->init_arg . '\'}) ' .
266 '|| ' . $self->_inline_throw_error('"Attribute (' . $attr->name . ') is required"') .';');
269 if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
271 if ( defined( my $init_arg = $attr->init_arg ) ) {
272 push @source => 'if (exists $params->{\'' . $init_arg . '\'}) {';
273 push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
274 push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
276 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
277 push @source => "} else {";
280 if ( $attr->has_default ) {
281 $default = $self->_generate_default_value($attr, $index);
284 my $builder = $attr->builder;
285 $default = '$instance->' . $builder;
288 push @source => '{'; # wrap this to avoid my $val overwrite warnings
289 push @source => ('my $val = ' . $default . ';');
290 push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
292 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
293 push @source => '}'; # close - wrap this to avoid my $val overrite warnings
295 push @source => "}" if defined $attr->init_arg;
297 elsif ( defined( my $init_arg = $attr->init_arg ) ) {
298 push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
300 push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
301 if ($is_moose && $attr->has_type_constraint) {
302 if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
303 push @source => $self->_generate_type_coercion(
305 '$type_constraints[' . $index . ']',
310 push @source => $self->_generate_type_constraint_check(
312 '$type_constraint_bodies[' . $index . ']',
313 '$type_constraints[' . $index . ']',
317 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
322 return join "\n" => @source;
325 sub _generate_slot_assignment {
326 my ($self, $attr, $value, $index) = @_;
330 if ($attr->has_initializer) {
332 '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
337 $self->meta_instance->inline_set_slot_value(
345 my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
347 if ($is_moose && $attr->is_weak_ref) {
350 $self->meta_instance->inline_weaken_slot_value(
354 ' if ref ' . $value . ';'
361 sub _generate_type_constraint_and_coercion {
362 my ($self, $attr, $index) = @_;
364 return unless $attr->has_type_constraint;
367 if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
368 push @source => $self->_generate_type_coercion(
370 '$type_constraints[' . $index . ']',
375 push @source => $self->_generate_type_constraint_check(
377 ('$type_constraint_bodies[' . $index . ']'),
378 ('$type_constraints[' . $index . ']'),
384 sub _generate_type_coercion {
385 my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
386 return ($return_value_name . ' = ' . $type_constraint_name . '->coerce(' . $value_name . ');');
389 sub _generate_type_constraint_check {
390 my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
392 $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
394 . ') does not pass the type constraint because: " . '
395 . $type_constraint_obj . '->get_message(' . $value_name . ')')
396 . "\n\t unless " . $type_constraint_cv . '->(' . $value_name . ');'
400 sub _generate_default_value {
401 my ($self, $attr, $index) = @_;
403 # default values can either be CODE refs
404 # in which case we need to call them. Or
405 # they can be scalars (strings/numbers)
406 # in which case we can just deal with them
407 # in the code we eval.
408 if ($attr->is_default_a_coderef) {
409 return '$attrs->[' . $index . ']->default($instance)';
412 return q{"} . quotemeta( $attr->default ) . q{"};
424 Moose::Meta::Method::Constructor - Method Meta Object for constructors
428 This class is a subclass of L<Class::MOP::Class::Constructor> that
429 provides additional Moose-specific functionality
431 To understand this class, you should read the the
432 L<Class::MOP::Class::Constructor> documentation as well.
438 =item B<< $metamethod->can_be_inlined >>
440 This returns true if the method can inlined.
442 First, it looks at all of the parents of the associated class. If any
443 of them have an inlined constructor, then the constructor can be
446 If none of them have been inlined, it checks to make sure that the
447 pre-inlining constructor for the class matches the constructor from
450 By default, it expects this constructor come from L<Moose::Object>,
451 but subclasses can change this expectation.
453 If the constructor cannot be inlined it warns that this is the case.
459 Stevan Little E<lt>stevan@iinteractive.comE<gt>
461 =head1 COPYRIGHT AND LICENSE
463 Copyright 2006-2009 by Infinity Interactive, Inc.
465 L<http://www.iinteractive.com>
467 This library is free software; you can redistribute it and/or modify
468 it under the same terms as Perl itself.