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.73';
  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         # from our superclass
  29         'body'          => undef,
  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 ],
  36         # ...
  37         'associated_metaclass' => $meta,
  38     } => $class;
  39
  40     # we don't want this creating
  41     # a cycle in the code, if not
  42     # needed
  43     weaken($self->{'associated_metaclass'});
  44
  45     $self->initialize_body;
  46
  47     return $self;
  48 }
  49
  50 sub can_be_inlined {
  51     my $self      = shift;
  52     my $metaclass = $self->associated_metaclass;
  53
  54     my $expected_class = $self->_expected_constructor_class;
  55
  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
  59     # children anyway.
  60     for my $meta (
  61         grep { $_->is_immutable }
  62         map  { ( ref $metaclass )->initialize($_) }
  63         grep { $_ ne $expected_class }
  64         $metaclass->linearized_isa
  65         ) {
  66         my $transformer = $meta->immutable_transformer;
  67
  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;
  76     }
  77
  78     if ( my $constructor = $metaclass->find_method_by_name( $self->name ) ) {
  79         my $class = $self->associated_metaclass->name;
  80
  81         if ( $constructor->body != $expected_class->can('new') ) {
  82             my $warning
  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";
  88
  89             $warning .= " (constructor has method modifiers which would be lost if it were inlined)\n"
  90                 if $constructor->isa('Class::MOP::Method::Wrapped');
  91
  92             warn $warning;
  93
  94             return 0;
  95         }
  96         else {
  97             return 1;
  98         }
  99     }
 100
 101     # This would be a rather weird case where we have no constructor
 102     # in the inheritance chain.
 103     return 1;
 104 }
 105
 106 # This is here so can_be_inlined can be inherited by MooseX modules.
 107 sub _expected_constructor_class {
 108     return 'Moose::Object';
 109 }
 110
 111 ## accessors
 112
 113 sub meta_instance { (shift)->{'meta_instance'} }
 114 sub attributes    { (shift)->{'attributes'}    }
 115
 116 ## method
 117
 118 sub _generate_params {
 119   my ($self, $var, $class_var) = @_;
 120   "my $var = " . $self->_generate_BUILDARGS($class_var, '@_') . ";\n";
 121 }
 122
 123 sub _generate_instance {
 124   my ($self, $var, $class_var) = @_;
 125   "my $var = " . $self->meta_instance->inline_create_instance($class_var)
 126                . ";\n";
 127 }
 128
 129 sub _generate_slot_initializers {
 130     my ($self) = @_;
 131     return (join ";\n" => map {
 132         $self->_generate_slot_initializer($_)
 133     } 0 .. (@{$self->attributes} - 1)) . ";\n";
 134 }
 135
 136 sub initialize_body {
 137     my $self = shift;
 138     # TODO:
 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;';
 147
 148     $source .= "\n" . 'return $class->Moose::Object::new(@_)';
 149     $source .= "\n    if \$class ne '" . $self->associated_metaclass->name
 150             .  "';\n";
 151
 152     $source .= $self->_generate_params('$params', '$class');
 153     $source .= $self->_generate_instance('$instance', '$class');
 154     $source .= $self->_generate_slot_initializers;
 155
 156     $source .= $self->_generate_triggers();
 157     $source .= ";\n" . $self->_generate_BUILDALL();
 158
 159     $source .= ";\nreturn \$instance";
 160     $source .= ";\n" . '}';
 161     warn $source if $self->options->{debug};
 162
 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
 171
 172     my $attrs = $self->attributes;
 173
 174     my @type_constraints = map {
 175         $_->can('type_constraint') ? $_->type_constraint : undef
 176     } @$attrs;
 177
 178     my @type_constraint_bodies = map {
 179         defined $_ ? $_->_compiled_type_constraint : undef;
 180     } @type_constraints;
 181
 182     my $code = $self->_compile_code(
 183         code => $source,
 184         environment => {
 185             '$meta'  => \$self,
 186             '$attrs' => \$attrs,
 187             '@type_constraints' => \@type_constraints,
 188             '@type_constraint_bodies' => \@type_constraint_bodies,
 189         },
 190     ) or $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source );
 191
 192     $self->{'body'} = $code;
 193 }
 194
 195 sub _generate_BUILDARGS {
 196     my ( $self, $class, $args ) = @_;
 197
 198     my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
 199
 200     if ( $args eq '@_' and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS ) ) {
 201         return join("\n",
 202             'do {',
 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]}} : {@_};',
 206             '}',
 207         );
 208     } else {
 209         return $class . "->BUILDARGS($args)";
 210     }
 211 }
 212
 213 sub _generate_BUILDALL {
 214     my $self = shift;
 215     my @BUILD_calls;
 216     foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
 217         push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD($params)';
 218     }
 219     return join ";\n" => @BUILD_calls;
 220 }
 221
 222 sub _generate_triggers {
 223     my $self = shift;
 224     my @trigger_calls;
 225     foreach my $i ( 0 .. $#{ $self->attributes } ) {
 226         my $attr = $self->attributes->[$i];
 227
 228         next unless $attr->can('has_trigger') && $attr->has_trigger;
 229
 230         my $init_arg = $attr->init_arg;
 231
 232         next unless defined $init_arg;
 233
 234         push @trigger_calls => '(exists $params->{\''
 235             . $init_arg
 236             . '\'}) && do {'
 237             . "\n    "
 238             . '$attrs->['
 239             . $i
 240             . ']->trigger->('
 241             . '$instance, '
 242             . $self->meta_instance->inline_get_slot_value(
 243                   '$instance',
 244                   $attr->name,
 245               )
 246             . ', '
 247             . ');' . "\n}";
 248     }
 249
 250     return join ";\n" => @trigger_calls;
 251 }
 252
 253 sub _generate_slot_initializer {
 254     my $self  = shift;
 255     my $index = shift;
 256
 257     my $attr = $self->attributes->[$index];
 258
 259     my @source = ('## ' . $attr->name);
 260
 261     my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
 262
 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"') .';');
 266     }
 267
 268     if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
 269
 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)
 274                 if $is_moose;
 275             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 276             push @source => "} else {";
 277         }
 278             my $default;
 279             if ( $attr->has_default ) {
 280                 $default = $self->_generate_default_value($attr, $index);
 281             }
 282             else {
 283                my $builder = $attr->builder;
 284                $default = '$instance->' . $builder;
 285             }
 286
 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)
 290                 if $is_moose;
 291             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 292             push @source => '}'; # close - wrap this to avoid my $val overrite warnings
 293
 294         push @source => "}" if defined $attr->init_arg;
 295     }
 296     elsif ( defined( my $init_arg = $attr->init_arg ) ) {
 297         push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
 298
 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(
 303                         $attr,
 304                         '$type_constraints[' . $index . ']',
 305                         '$val',
 306                         '$val'
 307                     );
 308                 }
 309                 push @source => $self->_generate_type_constraint_check(
 310                     $attr,
 311                     '$type_constraint_bodies[' . $index . ']',
 312                     '$type_constraints[' . $index . ']',
 313                     '$val'
 314                 );
 315             }
 316             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 317
 318         push @source => "}";
 319     }
 320
 321     return join "\n" => @source;
 322 }
 323
 324 sub _generate_slot_assignment {
 325     my ($self, $attr, $value, $index) = @_;
 326
 327     my $source;
 328
 329     if ($attr->has_initializer) {
 330         $source = (
 331             '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
 332         );
 333     }
 334     else {
 335         $source = (
 336             $self->meta_instance->inline_set_slot_value(
 337                 '$instance',
 338                 $attr->name,
 339                 $value
 340             ) . ';'
 341         );
 342     }
 343
 344     my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
 345
 346     if ($is_moose && $attr->is_weak_ref) {
 347         $source .= (
 348             "\n" .
 349             $self->meta_instance->inline_weaken_slot_value(
 350                 '$instance',
 351                 $attr->name
 352             ) .
 353             ' if ref ' . $value . ';'
 354         );
 355     }
 356
 357     return $source;
 358 }
 359
 360 sub _generate_type_constraint_and_coercion {
 361     my ($self, $attr, $index) = @_;
 362
 363     return unless $attr->has_type_constraint;
 364
 365     my @source;
 366     if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
 367         push @source => $self->_generate_type_coercion(
 368             $attr,
 369             '$type_constraints[' . $index . ']',
 370             '$val',
 371             '$val'
 372         );
 373     }
 374     push @source => $self->_generate_type_constraint_check(
 375         $attr,
 376         ('$type_constraint_bodies[' . $index . ']'),
 377         ('$type_constraints[' . $index . ']'),
 378         '$val'
 379     );
 380     return @source;
 381 }
 382
 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 . ');');
 386 }
 387
 388 sub _generate_type_constraint_check {
 389     my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
 390     return (
 391         $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
 392         . $attr->name
 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 . ');'
 396     );
 397 }
 398
 399 sub _generate_default_value {
 400     my ($self, $attr, $index) = @_;
 401     # NOTE:
 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)';
 409     }
 410     else {
 411         return q{"} . quotemeta( $attr->default ) . q{"};
 412     }
 413 }
 414
 415 1;
 416
 417 __END__
 418
 419 =pod
 420
 421 =head1 NAME
 422
 423 Moose::Meta::Method::Constructor - Method Meta Object for constructors
 424
 425 =head1 DESCRIPTION
 426
 427 This class is a subclass of L<Class::MOP::Class::Constructor> that
 428 provides additional Moose-specific functionality
 429
 430 To understand this class, you should read the the
 431 L<Class::MOP::Class::Constructor> documentation as well.
 432
 433 =head1 INHERITANCE
 434
 435 C<Moose::Meta::Method::Constructor> is a subclass of
 436 L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>.
 437
 438 =head1 METHODS
 439
 440 =over 4
 441
 442 =item B<< $metamethod->can_be_inlined >>
 443
 444 This returns true if the method can inlined.
 445
 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
 448 inlined.
 449
 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
 452 the expected class.
 453
 454 By default, it expects this constructor come from L<Moose::Object>,
 455 but subclasses can change this expectation.
 456
 457 If the constructor cannot be inlined it warns that this is the case.
 458
 459 =back
 460
 461 =head1 AUTHORS
 462
 463 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 464
 465 =head1 COPYRIGHT AND LICENSE
 466
 467 Copyright 2006-2009 by Infinity Interactive, Inc.
 468
 469 L<http://www.iinteractive.com>
 470
 471 This library is free software; you can redistribute it and/or modify
 472 it under the same terms as Perl itself.
 473
 474 =cut
 475