lib/Moose/Meta/Method/Constructor.pm

   1
   2 package Moose::Meta::Method::Constructor;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
   8
   9 our $VERSION   = '0.74';
  10 our $AUTHORITY = 'cpan:STEVAN';
  11
  12 use base 'Moose::Meta::Method',
  13          'Class::MOP::Method::Constructor';
  14
  15 sub new {
  16     my $class   = shift;
  17     my %options = @_;
  18
  19     my $meta = $options{metaclass};
  20
  21     (ref $options{options} eq 'HASH')
  22         || $class->throw_error("You must pass a hash of options", data => $options{options});
  23
  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");
  26
  27     my $self = bless {
  28         'body'          => undef,
  29         'package_name'  => $options{package_name},
  30         'name'          => $options{name},
  31         'options'       => $options{options},
  32         'associated_metaclass' => $meta,
  33     } => $class;
  34
  35     # we don't want this creating
  36     # a cycle in the code, if not
  37     # needed
  38     weaken($self->{'associated_metaclass'});
  39
  40     $self->_initialize_body;
  41
  42     return $self;
  43 }
  44
  45 sub can_be_inlined {
  46     my $self      = shift;
  47     my $metaclass = $self->associated_metaclass;
  48
  49     my $expected_class = $self->_expected_constructor_class;
  50
  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
  54     # children anyway.
  55     for my $meta (
  56         grep { $_->is_immutable }
  57         map  { ( ref $metaclass )->initialize($_) }
  58         grep { $_ ne $expected_class }
  59         $metaclass->linearized_isa
  60         ) {
  61         my $transformer = $meta->immutable_transformer;
  62
  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;
  71     }
  72
  73     if ( my $constructor = $metaclass->find_method_by_name( $self->name ) ) {
  74         my $class = $self->associated_metaclass->name;
  75
  76         if ( $constructor->body != $expected_class->can('new') ) {
  77             my $warning
  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";
  83
  84             $warning .= " (constructor has method modifiers which would be lost if it were inlined)\n"
  85                 if $constructor->isa('Class::MOP::Method::Wrapped');
  86
  87             warn $warning;
  88
  89             return 0;
  90         }
  91         else {
  92             return 1;
  93         }
  94     }
  95
  96     # This would be a rather weird case where we have no constructor
  97     # in the inheritance chain.
  98     return 1;
  99 }
 100
 101 # This is here so can_be_inlined can be inherited by MooseX modules.
 102 sub _expected_constructor_class {
 103     return 'Moose::Object';
 104 }
 105
 106 ## method
 107
 108 sub _initialize_body {
 109     my $self = shift;
 110     # TODO:
 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;';
 119
 120     $source .= "\n" . 'return $class->Moose::Object::new(@_)';
 121     $source .= "\n    if \$class ne '" . $self->associated_metaclass->name
 122             .  "';\n";
 123
 124     $source .= $self->_generate_params('$params', '$class');
 125     $source .= $self->_generate_instance('$instance', '$class');
 126     $source .= $self->_generate_slot_initializers;
 127
 128     $source .= $self->_generate_triggers();
 129     $source .= ";\n" . $self->_generate_BUILDALL();
 130
 131     $source .= ";\nreturn \$instance";
 132     $source .= ";\n" . '}';
 133     warn $source if $self->options->{debug};
 134
 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
 143
 144     my $attrs = $self->_attributes;
 145
 146     my @type_constraints = map {
 147         $_->can('type_constraint') ? $_->type_constraint : undef
 148     } @$attrs;
 149
 150     my @type_constraint_bodies = map {
 151         defined $_ ? $_->_compiled_type_constraint : undef;
 152     } @type_constraints;
 153
 154     my $code = $self->_compile_code(
 155         code => $source,
 156         environment => {
 157             '$meta'  => \$self,
 158             '$attrs' => \$attrs,
 159             '@type_constraints' => \@type_constraints,
 160             '@type_constraint_bodies' => \@type_constraint_bodies,
 161         },
 162     ) or $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source );
 163
 164     $self->{'body'} = $code;
 165 }
 166
 167 sub _generate_params {
 168     my ( $self, $var, $class_var ) = @_;
 169     "my $var = " . $self->_generate_BUILDARGS( $class_var, '@_' ) . ";\n";
 170 }
 171
 172 sub _generate_instance {
 173     my ( $self, $var, $class_var ) = @_;
 174     "my $var = "
 175         . $self->_meta_instance->inline_create_instance($class_var) . ";\n";
 176 }
 177
 178 sub _generate_slot_initializers {
 179     my ($self) = @_;
 180     return (join ";\n" => map {
 181         $self->_generate_slot_initializer($_)
 182     } 0 .. (@{$self->_attributes} - 1)) . ";\n";
 183 }
 184
 185 sub _generate_BUILDARGS {
 186     my ( $self, $class, $args ) = @_;
 187
 188     my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
 189
 190     if ( $args eq '@_' and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS ) ) {
 191         return join("\n",
 192             'do {',
 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]}} : {@_};',
 196             '}',
 197         );
 198     } else {
 199         return $class . "->BUILDARGS($args)";
 200     }
 201 }
 202
 203 sub _generate_BUILDALL {
 204     my $self = shift;
 205     my @BUILD_calls;
 206     foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
 207         push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD($params)';
 208     }
 209     return join ";\n" => @BUILD_calls;
 210 }
 211
 212 sub _generate_triggers {
 213     my $self = shift;
 214     my @trigger_calls;
 215     foreach my $i ( 0 .. $#{ $self->_attributes } ) {
 216         my $attr = $self->_attributes->[$i];
 217
 218         next unless $attr->can('has_trigger') && $attr->has_trigger;
 219
 220         my $init_arg = $attr->init_arg;
 221
 222         next unless defined $init_arg;
 223
 224         push @trigger_calls => '(exists $params->{\''
 225             . $init_arg
 226             . '\'}) && do {'
 227             . "\n    "
 228             . '$attrs->['
 229             . $i
 230             . ']->trigger->('
 231             . '$instance, '
 232             . $self->_meta_instance->inline_get_slot_value(
 233                   '$instance',
 234                   $attr->name,
 235               )
 236             . ', '
 237             . ');' . "\n}";
 238     }
 239
 240     return join ";\n" => @trigger_calls;
 241 }
 242
 243 sub _generate_slot_initializer {
 244     my $self  = shift;
 245     my $index = shift;
 246
 247     my $attr = $self->_attributes->[$index];
 248
 249     my @source = ('## ' . $attr->name);
 250
 251     my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
 252
 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"') .';');
 256     }
 257
 258     if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
 259
 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)
 264                 if $is_moose;
 265             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 266             push @source => "} else {";
 267         }
 268             my $default;
 269             if ( $attr->has_default ) {
 270                 $default = $self->_generate_default_value($attr, $index);
 271             }
 272             else {
 273                my $builder = $attr->builder;
 274                $default = '$instance->' . $builder;
 275             }
 276
 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)
 280                 if $is_moose;
 281             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 282             push @source => '}'; # close - wrap this to avoid my $val overrite warnings
 283
 284         push @source => "}" if defined $attr->init_arg;
 285     }
 286     elsif ( defined( my $init_arg = $attr->init_arg ) ) {
 287         push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
 288
 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(
 293                         $attr,
 294                         '$type_constraints[' . $index . ']',
 295                         '$val',
 296                         '$val'
 297                     );
 298                 }
 299                 push @source => $self->_generate_type_constraint_check(
 300                     $attr,
 301                     '$type_constraint_bodies[' . $index . ']',
 302                     '$type_constraints[' . $index . ']',
 303                     '$val'
 304                 );
 305             }
 306             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 307
 308         push @source => "}";
 309     }
 310
 311     return join "\n" => @source;
 312 }
 313
 314 sub _generate_slot_assignment {
 315     my ($self, $attr, $value, $index) = @_;
 316
 317     my $source;
 318
 319     if ($attr->has_initializer) {
 320         $source = (
 321             '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
 322         );
 323     }
 324     else {
 325         $source = (
 326             $self->_meta_instance->inline_set_slot_value(
 327                 '$instance',
 328                 $attr->name,
 329                 $value
 330             ) . ';'
 331         );
 332     }
 333
 334     my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
 335
 336     if ($is_moose && $attr->is_weak_ref) {
 337         $source .= (
 338             "\n" .
 339             $self->_meta_instance->inline_weaken_slot_value(
 340                 '$instance',
 341                 $attr->name
 342             ) .
 343             ' if ref ' . $value . ';'
 344         );
 345     }
 346
 347     return $source;
 348 }
 349
 350 sub _generate_type_constraint_and_coercion {
 351     my ($self, $attr, $index) = @_;
 352
 353     return unless $attr->has_type_constraint;
 354
 355     my @source;
 356     if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
 357         push @source => $self->_generate_type_coercion(
 358             $attr,
 359             '$type_constraints[' . $index . ']',
 360             '$val',
 361             '$val'
 362         );
 363     }
 364     push @source => $self->_generate_type_constraint_check(
 365         $attr,
 366         ('$type_constraint_bodies[' . $index . ']'),
 367         ('$type_constraints[' . $index . ']'),
 368         '$val'
 369     );
 370     return @source;
 371 }
 372
 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 . ');');
 376 }
 377
 378 sub _generate_type_constraint_check {
 379     my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
 380     return (
 381         $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
 382         . $attr->name
 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 . ');'
 386     );
 387 }
 388
 389 sub _generate_default_value {
 390     my ($self, $attr, $index) = @_;
 391     # NOTE:
 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)';
 399     }
 400     else {
 401         return q{"} . quotemeta( $attr->default ) . q{"};
 402     }
 403 }
 404
 405 1;
 406
 407 __END__
 408
 409 =pod
 410
 411 =head1 NAME
 412
 413 Moose::Meta::Method::Constructor - Method Meta Object for constructors
 414
 415 =head1 DESCRIPTION
 416
 417 This class is a subclass of L<Class::MOP::Class::Constructor> that
 418 provides additional Moose-specific functionality
 419
 420 To understand this class, you should read the the
 421 L<Class::MOP::Class::Constructor> documentation as well.
 422
 423 =head1 INHERITANCE
 424
 425 C<Moose::Meta::Method::Constructor> is a subclass of
 426 L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>.
 427
 428 =head1 METHODS
 429
 430 =over 4
 431
 432 =item B<< $metamethod->can_be_inlined >>
 433
 434 This returns true if the method can inlined.
 435
 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
 438 inlined.
 439
 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
 442 the expected class.
 443
 444 By default, it expects this constructor come from L<Moose::Object>,
 445 but subclasses can change this expectation.
 446
 447 If the constructor cannot be inlined it warns that this is the case.
 448
 449 =back
 450
 451 =head1 AUTHORS
 452
 453 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 454
 455 =head1 COPYRIGHT AND LICENSE
 456
 457 Copyright 2006-2009 by Infinity Interactive, Inc.
 458
 459 L<http://www.iinteractive.com>
 460
 461 This library is free software; you can redistribute it and/or modify
 462 it under the same terms as Perl itself.
 463
 464 =cut
 465