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';
  10 our $AUTHORITY = 'cpan:STEVAN';
  11
  12 use base 'Moose::Meta::Method',
  13          'Class::MOP::Method::Generated';
  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->get_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 # this was changed in 0.41, but broke MooseX::Singleton, so try to catch
 119 # any other code using the original broken spelling
 120 sub intialize_body { $_[0]->throw_error("Please correct the spelling of 'intialize_body' to 'initialize_body'") }
 121
 122 sub _generate_params {
 123   my ($self, $var, $class_var) = @_;
 124   "my $var = " . $self->_generate_BUILDARGS($class_var, '@_') . ";\n";
 125 }
 126
 127 sub _generate_instance {
 128   my ($self, $var, $class_var) = @_;
 129   "my $var = " . $self->meta_instance->inline_create_instance($class_var)
 130                . ";\n";
 131 }
 132
 133 sub _generate_slot_initializers {
 134     my ($self) = @_;
 135     return (join ";\n" => map {
 136         $self->_generate_slot_initializer($_)
 137     } 0 .. (@{$self->attributes} - 1)) . ";\n";
 138 }
 139
 140 sub initialize_body {
 141     my $self = shift;
 142     # TODO:
 143     # the %options should also include a both
 144     # a call 'initializer' and call 'SUPER::'
 145     # options, which should cover approx 90%
 146     # of the possible use cases (even if it
 147     # requires some adaption on the part of
 148     # the author, after all, nothing is free)
 149     my $source = 'sub {';
 150     $source .= "\n" . 'my $class = shift;';
 151
 152     $source .= "\n" . 'return $class->Moose::Object::new(@_)';
 153     $source .= "\n    if \$class ne '" . $self->associated_metaclass->name
 154             .  "';\n";
 155
 156     $source .= $self->_generate_params('$params', '$class');
 157     $source .= $self->_generate_instance('$instance', '$class');
 158     $source .= $self->_generate_slot_initializers;
 159
 160     $source .= $self->_generate_triggers();
 161     $source .= ";\n" . $self->_generate_BUILDALL();
 162
 163     $source .= ";\nreturn \$instance";
 164     $source .= ";\n" . '}';
 165     warn $source if $self->options->{debug};
 166
 167     # We need to check if the attribute ->can('type_constraint')
 168     # since we may be trying to immutabilize a Moose meta class,
 169     # which in turn has attributes which are Class::MOP::Attribute
 170     # objects, rather than Moose::Meta::Attribute. And
 171     # Class::MOP::Attribute attributes have no type constraints.
 172     # However we need to make sure we leave an undef value there
 173     # because the inlined code is using the index of the attributes
 174     # to determine where to find the type constraint
 175
 176     my $attrs = $self->attributes;
 177
 178     my @type_constraints = map {
 179         $_->can('type_constraint') ? $_->type_constraint : undef
 180     } @$attrs;
 181
 182     my @type_constraint_bodies = map {
 183         defined $_ ? $_->_compiled_type_constraint : undef;
 184     } @type_constraints;
 185
 186     my $code = $self->_compile_code(
 187         code => $source,
 188         environment => {
 189             '$meta'  => \$self,
 190             '$attrs' => \$attrs,
 191             '@type_constraints' => \@type_constraints,
 192             '@type_constraint_bodies' => \@type_constraint_bodies,
 193         },
 194     ) or $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source );
 195
 196     $self->{'body'} = $code;
 197 }
 198
 199 sub _generate_BUILDARGS {
 200     my ( $self, $class, $args ) = @_;
 201
 202     my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
 203
 204     if ( $args eq '@_' and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS ) ) {
 205         return join("\n",
 206             'do {',
 207             $self->_inline_throw_error('"Single parameters to new() must be a HASH ref"', 'data => $_[0]'),
 208             '    if scalar @_ == 1 && !( defined $_[0] && ref $_[0] eq q{HASH} );',
 209             '(scalar @_ == 1) ? {%{$_[0]}} : {@_};',
 210             '}',
 211         );
 212     } else {
 213         return $class . "->BUILDARGS($args)";
 214     }
 215 }
 216
 217 sub _generate_BUILDALL {
 218     my $self = shift;
 219     my @BUILD_calls;
 220     foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
 221         push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD($params)';
 222     }
 223     return join ";\n" => @BUILD_calls;
 224 }
 225
 226 sub _generate_triggers {
 227     my $self = shift;
 228     my @trigger_calls;
 229     foreach my $i ( 0 .. $#{ $self->attributes } ) {
 230         my $attr = $self->attributes->[$i];
 231
 232         next unless $attr->can('has_trigger') && $attr->has_trigger;
 233
 234         my $init_arg = $attr->init_arg;
 235
 236         next unless defined $init_arg;
 237
 238         push @trigger_calls => '(exists $params->{\''
 239             . $init_arg
 240             . '\'}) && do {'
 241             . "\n    "
 242             . '$attrs->['
 243             . $i
 244             . ']->trigger->('
 245             . '$instance, '
 246             . $self->meta_instance->inline_get_slot_value(
 247                   '$instance',
 248                   $attr->name,
 249               )
 250             . ', '
 251             . '$attrs->['
 252             . $i . ']' . ');' . "\n}";
 253     }
 254
 255     return join ";\n" => @trigger_calls;
 256 }
 257
 258 sub _generate_slot_initializer {
 259     my $self  = shift;
 260     my $index = shift;
 261
 262     my $attr = $self->attributes->[$index];
 263
 264     my @source = ('## ' . $attr->name);
 265
 266     my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
 267
 268     if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
 269         push @source => ('(exists $params->{\'' . $attr->init_arg . '\'}) ' .
 270                         '|| ' . $self->_inline_throw_error('"Attribute (' . $attr->name . ') is required"') .';');
 271     }
 272
 273     if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
 274
 275         if ( defined( my $init_arg = $attr->init_arg ) ) {
 276             push @source => 'if (exists $params->{\'' . $init_arg . '\'}) {';
 277             push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
 278             push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
 279                 if $is_moose;
 280             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 281             push @source => "} else {";
 282         }
 283             my $default;
 284             if ( $attr->has_default ) {
 285                 $default = $self->_generate_default_value($attr, $index);
 286             }
 287             else {
 288                my $builder = $attr->builder;
 289                $default = '$instance->' . $builder;
 290             }
 291
 292             push @source => '{'; # wrap this to avoid my $val overwrite warnings
 293             push @source => ('my $val = ' . $default . ';');
 294             push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
 295                 if $is_moose;
 296             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 297             push @source => '}'; # close - wrap this to avoid my $val overrite warnings
 298
 299         push @source => "}" if defined $attr->init_arg;
 300     }
 301     elsif ( defined( my $init_arg = $attr->init_arg ) ) {
 302         push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
 303
 304             push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
 305             if ($is_moose && $attr->has_type_constraint) {
 306                 if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
 307                     push @source => $self->_generate_type_coercion(
 308                         $attr,
 309                         '$type_constraints[' . $index . ']',
 310                         '$val',
 311                         '$val'
 312                     );
 313                 }
 314                 push @source => $self->_generate_type_constraint_check(
 315                     $attr,
 316                     '$type_constraint_bodies[' . $index . ']',
 317                     '$type_constraints[' . $index . ']',
 318                     '$val'
 319                 );
 320             }
 321             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 322
 323         push @source => "}";
 324     }
 325
 326     return join "\n" => @source;
 327 }
 328
 329 sub _generate_slot_assignment {
 330     my ($self, $attr, $value, $index) = @_;
 331
 332     my $source;
 333
 334     if ($attr->has_initializer) {
 335         $source = (
 336             '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
 337         );
 338     }
 339     else {
 340         $source = (
 341             $self->meta_instance->inline_set_slot_value(
 342                 '$instance',
 343                 $attr->name,
 344                 $value
 345             ) . ';'
 346         );
 347     }
 348
 349     my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
 350
 351     if ($is_moose && $attr->is_weak_ref) {
 352         $source .= (
 353             "\n" .
 354             $self->meta_instance->inline_weaken_slot_value(
 355                 '$instance',
 356                 $attr->name
 357             ) .
 358             ' if ref ' . $value . ';'
 359         );
 360     }
 361
 362     return $source;
 363 }
 364
 365 sub _generate_type_constraint_and_coercion {
 366     my ($self, $attr, $index) = @_;
 367
 368     return unless $attr->has_type_constraint;
 369
 370     my @source;
 371     if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
 372         push @source => $self->_generate_type_coercion(
 373             $attr,
 374             '$type_constraints[' . $index . ']',
 375             '$val',
 376             '$val'
 377         );
 378     }
 379     push @source => $self->_generate_type_constraint_check(
 380         $attr,
 381         ('$type_constraint_bodies[' . $index . ']'),
 382         ('$type_constraints[' . $index . ']'),
 383         '$val'
 384     );
 385     return @source;
 386 }
 387
 388 sub _generate_type_coercion {
 389     my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
 390     return ($return_value_name . ' = ' . $type_constraint_name .  '->coerce(' . $value_name . ');');
 391 }
 392
 393 sub _generate_type_constraint_check {
 394     my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
 395     return (
 396         $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
 397         . $attr->name
 398         . ') does not pass the type constraint because: " . '
 399         . $type_constraint_obj . '->get_message(' . $value_name . ')')
 400         . "\n\t unless " .  $type_constraint_cv . '->(' . $value_name . ');'
 401     );
 402 }
 403
 404 sub _generate_default_value {
 405     my ($self, $attr, $index) = @_;
 406     # NOTE:
 407     # default values can either be CODE refs
 408     # in which case we need to call them. Or
 409     # they can be scalars (strings/numbers)
 410     # in which case we can just deal with them
 411     # in the code we eval.
 412     if ($attr->is_default_a_coderef) {
 413         return '$attrs->[' . $index . ']->default($instance)';
 414     }
 415     else {
 416         return q{"} . quotemeta( $attr->default ) . q{"};
 417     }
 418 }
 419
 420 1;
 421
 422 __END__
 423
 424 =pod
 425
 426 =head1 NAME
 427
 428 Moose::Meta::Method::Constructor - Method Meta Object for constructors
 429
 430 =head1 DESCRIPTION
 431
 432 This class is a subclass of L<Class::MOP::Class::Constructor> that
 433 provides additional Moose-specific functionality
 434
 435 To understand this class, you should read the the
 436 L<Class::MOP::Class::Constructor> documentation as well.
 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