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");
29 'package_name' => $options{package_name},
30 'name' => $options{name},
31 'options' => $options{options},
32 'associated_metaclass' => $meta,
35 # we don't want this creating
36 # a cycle in the code, if not
38 weaken($self->{'associated_metaclass'});
40 $self->_initialize_body;
47 my $metaclass = $self->associated_metaclass;
49 my $expected_class = $self->_expected_constructor_class;
51 # If any of our parents have been made immutable, we are okay to
52 # inline our own new method. The assumption is that an inlined new
53 # method provided by a parent does not actually get used by
56 grep { $_->is_immutable }
57 map { ( ref $metaclass )->initialize($_) }
58 grep { $_ ne $expected_class }
59 $metaclass->linearized_isa
61 my $transformer = $meta->immutable_transformer;
63 # This is actually a false positive if we're in a subclass of
64 # this class, _and_ the expected class is not overridden (but
65 # should be), and the real expected class is actually
66 # immutable itself (see Fey::Object::Table for an example of
67 # how this can happen). I'm not sure how to actually handle
68 # that case, since it's effectively a bug in the subclass (for
69 # not overriding _expected_constructor_class).
70 return 1 if $transformer->inlined_constructor;
73 if ( my $constructor = $metaclass->find_method_by_name( $self->name ) ) {
74 my $class = $self->associated_metaclass->name;
76 if ( $constructor->body != $expected_class->can('new') ) {
78 = "Not inlining a constructor for $class since it is not"
79 . " inheriting the default $expected_class constructor\n"
80 . "If you are certain you don't need to inline your"
81 . " constructor, specify inline_constructor => 0 in your"
82 . " call to $class->meta->make_immutable\n";
84 $warning .= " (constructor has method modifiers which would be lost if it were inlined)\n"
85 if $constructor->isa('Class::MOP::Method::Wrapped');
96 # This would be a rather weird case where we have no constructor
97 # in the inheritance chain.
101 # This is here so can_be_inlined can be inherited by MooseX modules.
102 sub _expected_constructor_class {
103 return 'Moose::Object';
108 sub _initialize_body {
111 # the %options should also include a both
112 # a call 'initializer' and call 'SUPER::'
113 # options, which should cover approx 90%
114 # of the possible use cases (even if it
115 # requires some adaption on the part of
116 # the author, after all, nothing is free)
117 my $source = 'sub {';
118 $source .= "\n" . 'my $class = shift;';
120 $source .= "\n" . 'return $class->Moose::Object::new(@_)';
121 $source .= "\n if \$class ne '" . $self->associated_metaclass->name
124 $source .= $self->_generate_params('$params', '$class');
125 $source .= $self->_generate_instance('$instance', '$class');
126 $source .= $self->_generate_slot_initializers;
128 $source .= $self->_generate_triggers();
129 $source .= ";\n" . $self->_generate_BUILDALL();
131 $source .= ";\nreturn \$instance";
132 $source .= ";\n" . '}';
133 warn $source if $self->options->{debug};
135 # We need to check if the attribute ->can('type_constraint')
136 # since we may be trying to immutabilize a Moose meta class,
137 # which in turn has attributes which are Class::MOP::Attribute
138 # objects, rather than Moose::Meta::Attribute. And
139 # Class::MOP::Attribute attributes have no type constraints.
140 # However we need to make sure we leave an undef value there
141 # because the inlined code is using the index of the attributes
142 # to determine where to find the type constraint
144 my $attrs = $self->_attributes;
146 my @type_constraints = map {
147 $_->can('type_constraint') ? $_->type_constraint : undef
150 my @type_constraint_bodies = map {
151 defined $_ ? $_->_compiled_type_constraint : undef;
154 my $code = $self->_compile_code(
159 '@type_constraints' => \@type_constraints,
160 '@type_constraint_bodies' => \@type_constraint_bodies,
162 ) or $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source );
164 $self->{'body'} = $code;
167 sub _generate_params {
168 my ( $self, $var, $class_var ) = @_;
169 "my $var = " . $self->_generate_BUILDARGS( $class_var, '@_' ) . ";\n";
172 sub _generate_instance {
173 my ( $self, $var, $class_var ) = @_;
175 . $self->_meta_instance->inline_create_instance($class_var) . ";\n";
178 sub _generate_slot_initializers {
180 return (join ";\n" => map {
181 $self->_generate_slot_initializer($_)
182 } 0 .. (@{$self->_attributes} - 1)) . ";\n";
185 sub _generate_BUILDARGS {
186 my ( $self, $class, $args ) = @_;
188 my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
190 if ( $args eq '@_' and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS ) ) {
193 $self->_inline_throw_error('"Single parameters to new() must be a HASH ref"', 'data => $_[0]'),
194 ' if scalar @_ == 1 && !( defined $_[0] && ref $_[0] eq q{HASH} );',
195 '(scalar @_ == 1) ? {%{$_[0]}} : {@_};',
199 return $class . "->BUILDARGS($args)";
203 sub _generate_BUILDALL {
206 foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
207 push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD($params)';
209 return join ";\n" => @BUILD_calls;
212 sub _generate_triggers {
215 foreach my $i ( 0 .. $#{ $self->_attributes } ) {
216 my $attr = $self->_attributes->[$i];
218 next unless $attr->can('has_trigger') && $attr->has_trigger;
220 my $init_arg = $attr->init_arg;
222 next unless defined $init_arg;
224 push @trigger_calls => '(exists $params->{\''
232 . $self->_meta_instance->inline_get_slot_value(
240 return join ";\n" => @trigger_calls;
243 sub _generate_slot_initializer {
247 my $attr = $self->_attributes->[$index];
249 my @source = ('## ' . $attr->name);
251 my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
253 if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
254 push @source => ('(exists $params->{\'' . $attr->init_arg . '\'}) ' .
255 '|| ' . $self->_inline_throw_error('"Attribute (' . $attr->name . ') is required"') .';');
258 if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
260 if ( defined( my $init_arg = $attr->init_arg ) ) {
261 push @source => 'if (exists $params->{\'' . $init_arg . '\'}) {';
262 push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
263 push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
265 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
266 push @source => "} else {";
269 if ( $attr->has_default ) {
270 $default = $self->_generate_default_value($attr, $index);
273 my $builder = $attr->builder;
274 $default = '$instance->' . $builder;
277 push @source => '{'; # wrap this to avoid my $val overwrite warnings
278 push @source => ('my $val = ' . $default . ';');
279 push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
281 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
282 push @source => '}'; # close - wrap this to avoid my $val overrite warnings
284 push @source => "}" if defined $attr->init_arg;
286 elsif ( defined( my $init_arg = $attr->init_arg ) ) {
287 push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
289 push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
290 if ($is_moose && $attr->has_type_constraint) {
291 if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
292 push @source => $self->_generate_type_coercion(
294 '$type_constraints[' . $index . ']',
299 push @source => $self->_generate_type_constraint_check(
301 '$type_constraint_bodies[' . $index . ']',
302 '$type_constraints[' . $index . ']',
306 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
311 return join "\n" => @source;
314 sub _generate_slot_assignment {
315 my ($self, $attr, $value, $index) = @_;
319 if ($attr->has_initializer) {
321 '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
326 $self->_meta_instance->inline_set_slot_value(
334 my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
336 if ($is_moose && $attr->is_weak_ref) {
339 $self->_meta_instance->inline_weaken_slot_value(
343 ' if ref ' . $value . ';'
350 sub _generate_type_constraint_and_coercion {
351 my ($self, $attr, $index) = @_;
353 return unless $attr->has_type_constraint;
356 if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
357 push @source => $self->_generate_type_coercion(
359 '$type_constraints[' . $index . ']',
364 push @source => $self->_generate_type_constraint_check(
366 ('$type_constraint_bodies[' . $index . ']'),
367 ('$type_constraints[' . $index . ']'),
373 sub _generate_type_coercion {
374 my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
375 return ($return_value_name . ' = ' . $type_constraint_name . '->coerce(' . $value_name . ');');
378 sub _generate_type_constraint_check {
379 my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
381 $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
383 . ') does not pass the type constraint because: " . '
384 . $type_constraint_obj . '->get_message(' . $value_name . ')')
385 . "\n\t unless " . $type_constraint_cv . '->(' . $value_name . ');'
389 sub _generate_default_value {
390 my ($self, $attr, $index) = @_;
392 # default values can either be CODE refs
393 # in which case we need to call them. Or
394 # they can be scalars (strings/numbers)
395 # in which case we can just deal with them
396 # in the code we eval.
397 if ($attr->is_default_a_coderef) {
398 return '$attrs->[' . $index . ']->default($instance)';
401 return q{"} . quotemeta( $attr->default ) . q{"};
413 Moose::Meta::Method::Constructor - Method Meta Object for constructors
417 This class is a subclass of L<Class::MOP::Class::Constructor> that
418 provides additional Moose-specific functionality
420 To understand this class, you should read the the
421 L<Class::MOP::Class::Constructor> documentation as well.
425 C<Moose::Meta::Method::Constructor> is a subclass of
426 L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>.
432 =item B<< $metamethod->can_be_inlined >>
434 This returns true if the method can inlined.
436 First, it looks at all of the parents of the associated class. If any
437 of them have an inlined constructor, then the constructor can be
440 If none of them have been inlined, it checks to make sure that the
441 pre-inlining constructor for the class matches the constructor from
444 By default, it expects this constructor come from L<Moose::Object>,
445 but subclasses can change this expectation.
447 If the constructor cannot be inlined it warns that this is the case.
453 Stevan Little E<lt>stevan@iinteractive.comE<gt>
455 =head1 COPYRIGHT AND LICENSE
457 Copyright 2006-2009 by Infinity Interactive, Inc.
459 L<http://www.iinteractive.com>
461 This library is free software; you can redistribute it and/or modify
462 it under the same terms as Perl itself.