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.72_01';
  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             . '$attrs->['
 248             . $i . ']' . ');' . "\n}";
 249     }
 250
 251     return join ";\n" => @trigger_calls;
 252 }
 253
 254 sub _generate_slot_initializer {
 255     my $self  = shift;
 256     my $index = shift;
 257
 258     my $attr = $self->attributes->[$index];
 259
 260     my @source = ('## ' . $attr->name);
 261
 262     my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
 263
 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"') .';');
 267     }
 268
 269     if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
 270
 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)
 275                 if $is_moose;
 276             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 277             push @source => "} else {";
 278         }
 279             my $default;
 280             if ( $attr->has_default ) {
 281                 $default = $self->_generate_default_value($attr, $index);
 282             }
 283             else {
 284                my $builder = $attr->builder;
 285                $default = '$instance->' . $builder;
 286             }
 287
 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)
 291                 if $is_moose;
 292             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 293             push @source => '}'; # close - wrap this to avoid my $val overrite warnings
 294
 295         push @source => "}" if defined $attr->init_arg;
 296     }
 297     elsif ( defined( my $init_arg = $attr->init_arg ) ) {
 298         push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
 299
 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(
 304                         $attr,
 305                         '$type_constraints[' . $index . ']',
 306                         '$val',
 307                         '$val'
 308                     );
 309                 }
 310                 push @source => $self->_generate_type_constraint_check(
 311                     $attr,
 312                     '$type_constraint_bodies[' . $index . ']',
 313                     '$type_constraints[' . $index . ']',
 314                     '$val'
 315                 );
 316             }
 317             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 318
 319         push @source => "}";
 320     }
 321
 322     return join "\n" => @source;
 323 }
 324
 325 sub _generate_slot_assignment {
 326     my ($self, $attr, $value, $index) = @_;
 327
 328     my $source;
 329
 330     if ($attr->has_initializer) {
 331         $source = (
 332             '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
 333         );
 334     }
 335     else {
 336         $source = (
 337             $self->meta_instance->inline_set_slot_value(
 338                 '$instance',
 339                 $attr->name,
 340                 $value
 341             ) . ';'
 342         );
 343     }
 344
 345     my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
 346
 347     if ($is_moose && $attr->is_weak_ref) {
 348         $source .= (
 349             "\n" .
 350             $self->meta_instance->inline_weaken_slot_value(
 351                 '$instance',
 352                 $attr->name
 353             ) .
 354             ' if ref ' . $value . ';'
 355         );
 356     }
 357
 358     return $source;
 359 }
 360
 361 sub _generate_type_constraint_and_coercion {
 362     my ($self, $attr, $index) = @_;
 363
 364     return unless $attr->has_type_constraint;
 365
 366     my @source;
 367     if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
 368         push @source => $self->_generate_type_coercion(
 369             $attr,
 370             '$type_constraints[' . $index . ']',
 371             '$val',
 372             '$val'
 373         );
 374     }
 375     push @source => $self->_generate_type_constraint_check(
 376         $attr,
 377         ('$type_constraint_bodies[' . $index . ']'),
 378         ('$type_constraints[' . $index . ']'),
 379         '$val'
 380     );
 381     return @source;
 382 }
 383
 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 . ');');
 387 }
 388
 389 sub _generate_type_constraint_check {
 390     my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
 391     return (
 392         $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
 393         . $attr->name
 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 . ');'
 397     );
 398 }
 399
 400 sub _generate_default_value {
 401     my ($self, $attr, $index) = @_;
 402     # NOTE:
 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)';
 410     }
 411     else {
 412         return q{"} . quotemeta( $attr->default ) . q{"};
 413     }
 414 }
 415
 416 1;
 417
 418 __END__
 419
 420 =pod
 421
 422 =head1 NAME
 423
 424 Moose::Meta::Method::Constructor - Method Meta Object for constructors
 425
 426 =head1 DESCRIPTION
 427
 428 This class is a subclass of L<Class::MOP::Class::Constructor> that
 429 provides additional Moose-specific functionality
 430
 431 To understand this class, you should read the the
 432 L<Class::MOP::Class::Constructor> documentation as well.
 433
 434 =head1 INHERITANCE
 435
 436 C<Moose::Meta::Method::Constructor> is a subclass of
 437 L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>.
 438
 439 =head1 METHODS
 440
 441 =over 4
 442
 443 =item B<< $metamethod->can_be_inlined >>
 444
 445 This returns true if the method can inlined.
 446
 447 First, it looks at all of the parents of the associated class. If any
 448 of them have an inlined constructor, then the constructor can be
 449 inlined.
 450
 451 If none of them have been inlined, it checks to make sure that the
 452 pre-inlining constructor for the class matches the constructor from
 453 the expected class.
 454
 455 By default, it expects this constructor come from L<Moose::Object>,
 456 but subclasses can change this expectation.
 457
 458 If the constructor cannot be inlined it warns that this is the case.
 459
 460 =back
 461
 462 =head1 AUTHORS
 463
 464 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 465
 466 =head1 COPYRIGHT AND LICENSE
 467
 468 Copyright 2006-2009 by Infinity Interactive, Inc.
 469
 470 L<http://www.iinteractive.com>
 471
 472 This library is free software; you can redistribute it and/or modify
 473 it under the same terms as Perl itself.
 474
 475 =cut
 476