2 package Moose::Meta::Method::Constructor;
7 use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr';
9 our $VERSION = '0.75_01';
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,
33 '_expected_method_class' => $options{_expected_method_class} || 'Moose::Object',
36 # we don't want this creating
37 # a cycle in the code, if not
39 weaken($self->{'associated_metaclass'});
41 $self->_initialize_body;
46 # This is here so can_be_inlined can be inherited by MooseX modules.
47 sub _expected_constructor_class {
48 return 'Moose::Object';
53 sub _initialize_body {
56 # the %options should also include a both
57 # a call 'initializer' and call 'SUPER::'
58 # options, which should cover approx 90%
59 # of the possible use cases (even if it
60 # requires some adaption on the part of
61 # the author, after all, nothing is free)
63 $source .= "\n" . 'my $class = shift;';
65 $source .= "\n" . 'return $class->Moose::Object::new(@_)';
66 $source .= "\n if \$class ne '" . $self->associated_metaclass->name
69 $source .= $self->_generate_params('$params', '$class');
70 $source .= $self->_generate_instance('$instance', '$class');
71 $source .= $self->_generate_slot_initializers;
73 $source .= $self->_generate_triggers();
74 $source .= ";\n" . $self->_generate_BUILDALL();
76 $source .= ";\nreturn \$instance";
77 $source .= ";\n" . '}';
78 warn $source if $self->options->{debug};
80 # We need to check if the attribute ->can('type_constraint')
81 # since we may be trying to immutabilize a Moose meta class,
82 # which in turn has attributes which are Class::MOP::Attribute
83 # objects, rather than Moose::Meta::Attribute. And
84 # Class::MOP::Attribute attributes have no type constraints.
85 # However we need to make sure we leave an undef value there
86 # because the inlined code is using the index of the attributes
87 # to determine where to find the type constraint
89 my $attrs = $self->_attributes;
91 my @type_constraints = map {
92 $_->can('type_constraint') ? $_->type_constraint : undef
95 my @type_constraint_bodies = map {
96 defined $_ ? $_->_compiled_type_constraint : undef;
99 my $code = $self->_compile_code(
104 '@type_constraints' => \@type_constraints,
105 '@type_constraint_bodies' => \@type_constraint_bodies,
107 ) or $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source );
109 $self->{'body'} = $code;
112 sub _generate_params {
113 my ( $self, $var, $class_var ) = @_;
114 "my $var = " . $self->_generate_BUILDARGS( $class_var, '@_' ) . ";\n";
117 sub _generate_instance {
118 my ( $self, $var, $class_var ) = @_;
120 . $self->_meta_instance->inline_create_instance($class_var) . ";\n";
123 sub _generate_slot_initializers {
125 return (join ";\n" => map {
126 $self->_generate_slot_initializer($_)
127 } 0 .. (@{$self->_attributes} - 1)) . ";\n";
130 sub _generate_BUILDARGS {
131 my ( $self, $class, $args ) = @_;
133 my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
135 if ( $args eq '@_' and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS ) ) {
138 $self->_inline_throw_error('"Single parameters to new() must be a HASH ref"', 'data => $_[0]'),
139 ' if scalar @_ == 1 && !( defined $_[0] && ref $_[0] eq q{HASH} );',
140 '(scalar @_ == 1) ? {%{$_[0]}} : {@_};',
144 return $class . "->BUILDARGS($args)";
148 sub _generate_BUILDALL {
151 foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
152 push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD($params)';
154 return join ";\n" => @BUILD_calls;
157 sub _generate_triggers {
160 foreach my $i ( 0 .. $#{ $self->_attributes } ) {
161 my $attr = $self->_attributes->[$i];
163 next unless $attr->can('has_trigger') && $attr->has_trigger;
165 my $init_arg = $attr->init_arg;
167 next unless defined $init_arg;
169 push @trigger_calls => '(exists $params->{\''
177 . $self->_meta_instance->inline_get_slot_value(
185 return join ";\n" => @trigger_calls;
188 sub _generate_slot_initializer {
192 my $attr = $self->_attributes->[$index];
194 my @source = ('## ' . $attr->name);
196 my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
198 if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
199 push @source => ('(exists $params->{\'' . $attr->init_arg . '\'}) ' .
200 '|| ' . $self->_inline_throw_error('"Attribute (' . $attr->name . ') is required"') .';');
203 if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
205 if ( defined( my $init_arg = $attr->init_arg ) ) {
206 push @source => 'if (exists $params->{\'' . $init_arg . '\'}) {';
207 push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
208 push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
210 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
211 push @source => "} else {";
214 if ( $attr->has_default ) {
215 $default = $self->_generate_default_value($attr, $index);
218 my $builder = $attr->builder;
219 $default = '$instance->' . $builder;
222 push @source => '{'; # wrap this to avoid my $val overwrite warnings
223 push @source => ('my $val = ' . $default . ';');
224 push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
226 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
227 push @source => '}'; # close - wrap this to avoid my $val overrite warnings
229 push @source => "}" if defined $attr->init_arg;
231 elsif ( defined( my $init_arg = $attr->init_arg ) ) {
232 push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
234 push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
235 if ($is_moose && $attr->has_type_constraint) {
236 if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
237 push @source => $self->_generate_type_coercion(
239 '$type_constraints[' . $index . ']',
244 push @source => $self->_generate_type_constraint_check(
246 '$type_constraint_bodies[' . $index . ']',
247 '$type_constraints[' . $index . ']',
251 push @source => $self->_generate_slot_assignment($attr, '$val', $index);
256 return join "\n" => @source;
259 sub _generate_slot_assignment {
260 my ($self, $attr, $value, $index) = @_;
264 if ($attr->has_initializer) {
266 '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
271 $self->_meta_instance->inline_set_slot_value(
279 my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
281 if ($is_moose && $attr->is_weak_ref) {
284 $self->_meta_instance->inline_weaken_slot_value(
288 ' if ref ' . $value . ';'
295 sub _generate_type_constraint_and_coercion {
296 my ($self, $attr, $index) = @_;
298 return unless $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 . ']'),
318 sub _generate_type_coercion {
319 my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
320 return ($return_value_name . ' = ' . $type_constraint_name . '->coerce(' . $value_name . ');');
323 sub _generate_type_constraint_check {
324 my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
326 $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
328 . ') does not pass the type constraint because: " . '
329 . $type_constraint_obj . '->get_message(' . $value_name . ')')
330 . "\n\t unless " . $type_constraint_cv . '->(' . $value_name . ');'
334 sub _generate_default_value {
335 my ($self, $attr, $index) = @_;
337 # default values can either be CODE refs
338 # in which case we need to call them. Or
339 # they can be scalars (strings/numbers)
340 # in which case we can just deal with them
341 # in the code we eval.
342 if ($attr->is_default_a_coderef) {
343 return '$attrs->[' . $index . ']->default($instance)';
346 return q{"} . quotemeta( $attr->default ) . q{"};
358 Moose::Meta::Method::Constructor - Method Meta Object for constructors
362 This class is a subclass of L<Class::MOP::Class::Constructor> that
363 provides additional Moose-specific functionality
365 To understand this class, you should read the the
366 L<Class::MOP::Class::Constructor> documentation as well.
370 C<Moose::Meta::Method::Constructor> is a subclass of
371 L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>.
377 =item B<< $metamethod->can_be_inlined >>
379 This returns true if the method can inlined.
381 First, it looks at all of the parents of the associated class. If any
382 of them have an inlined constructor, then the constructor can be
385 If none of them have been inlined, it checks to make sure that the
386 pre-inlining constructor for the class matches the constructor from
389 By default, it expects this constructor come from L<Moose::Object>,
390 but subclasses can change this expectation.
392 If the constructor cannot be inlined it warns that this is the case.
398 Stevan Little E<lt>stevan@iinteractive.comE<gt>
400 =head1 COPYRIGHT AND LICENSE
402 Copyright 2006-2009 by Infinity Interactive, Inc.
404 L<http://www.iinteractive.com>
406 This library is free software; you can redistribute it and/or modify
407 it under the same terms as Perl itself.