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', 'refaddr';
   8
   9 our $VERSION   = '0.77';
  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         '_expected_method_class' => $options{_expected_method_class} || 'Moose::Object',
  34     } => $class;
  35
  36     # we don't want this creating
  37     # a cycle in the code, if not
  38     # needed
  39     weaken($self->{'associated_metaclass'});
  40
  41     $self->_initialize_body;
  42
  43     return $self;
  44 }
  45
  46 # This is here so can_be_inlined can be inherited by MooseX modules.
  47 sub _expected_constructor_class {
  48     return 'Moose::Object';
  49 }
  50
  51 ## method
  52
  53 sub _initialize_body {
  54     my $self = shift;
  55     # TODO:
  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)
  62     my $source = 'sub {';
  63     $source .= "\n" . 'my $class = shift;';
  64
  65     $source .= "\n" . 'return $class->Moose::Object::new(@_)';
  66     $source .= "\n    if \$class ne '" . $self->associated_metaclass->name
  67             .  "';\n";
  68
  69     $source .= $self->_generate_params('$params', '$class');
  70     $source .= $self->_generate_instance('$instance', '$class');
  71     $source .= $self->_generate_slot_initializers;
  72
  73     $source .= $self->_generate_triggers();
  74     $source .= ";\n" . $self->_generate_BUILDALL();
  75
  76     $source .= ";\nreturn \$instance";
  77     $source .= ";\n" . '}';
  78     warn $source if $self->options->{debug};
  79
  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
  88
  89     my $attrs = $self->_attributes;
  90
  91     my @type_constraints = map {
  92         $_->can('type_constraint') ? $_->type_constraint : undef
  93     } @$attrs;
  94
  95     my @type_constraint_bodies = map {
  96         defined $_ ? $_->_compiled_type_constraint : undef;
  97     } @type_constraints;
  98
  99     my $code = $self->_compile_code(
 100         code => $source,
 101         environment => {
 102             '$meta'  => \$self,
 103             '$attrs' => \$attrs,
 104             '@type_constraints' => \@type_constraints,
 105             '@type_constraint_bodies' => \@type_constraint_bodies,
 106         },
 107     ) or $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source );
 108
 109     $self->{'body'} = $code;
 110 }
 111
 112 sub _generate_params {
 113     my ( $self, $var, $class_var ) = @_;
 114     "my $var = " . $self->_generate_BUILDARGS( $class_var, '@_' ) . ";\n";
 115 }
 116
 117 sub _generate_instance {
 118     my ( $self, $var, $class_var ) = @_;
 119     "my $var = "
 120         . $self->_meta_instance->inline_create_instance($class_var) . ";\n";
 121 }
 122
 123 sub _generate_slot_initializers {
 124     my ($self) = @_;
 125     return (join ";\n" => map {
 126         $self->_generate_slot_initializer($_)
 127     } 0 .. (@{$self->_attributes} - 1)) . ";\n";
 128 }
 129
 130 sub _generate_BUILDARGS {
 131     my ( $self, $class, $args ) = @_;
 132
 133     my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
 134
 135     if ( $args eq '@_' and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS ) ) {
 136         return join("\n",
 137             'do {',
 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]}} : {@_};',
 141             '}',
 142         );
 143     } else {
 144         return $class . "->BUILDARGS($args)";
 145     }
 146 }
 147
 148 sub _generate_BUILDALL {
 149     my $self = shift;
 150     my @BUILD_calls;
 151     foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
 152         push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD($params)';
 153     }
 154     return join ";\n" => @BUILD_calls;
 155 }
 156
 157 sub _generate_triggers {
 158     my $self = shift;
 159     my @trigger_calls;
 160     foreach my $i ( 0 .. $#{ $self->_attributes } ) {
 161         my $attr = $self->_attributes->[$i];
 162
 163         next unless $attr->can('has_trigger') && $attr->has_trigger;
 164
 165         my $init_arg = $attr->init_arg;
 166
 167         next unless defined $init_arg;
 168
 169         push @trigger_calls => '(exists $params->{\''
 170             . $init_arg
 171             . '\'}) && do {'
 172             . "\n    "
 173             . '$attrs->['
 174             . $i
 175             . ']->trigger->('
 176             . '$instance, '
 177             . $self->_meta_instance->inline_get_slot_value(
 178                   '$instance',
 179                   $attr->name,
 180               )
 181             . ', '
 182             . ');' . "\n}";
 183     }
 184
 185     return join ";\n" => @trigger_calls;
 186 }
 187
 188 sub _generate_slot_initializer {
 189     my $self  = shift;
 190     my $index = shift;
 191
 192     my $attr = $self->_attributes->[$index];
 193
 194     my @source = ('## ' . $attr->name);
 195
 196     my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
 197
 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"') .';');
 201     }
 202
 203     if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
 204
 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)
 209                 if $is_moose;
 210             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 211             push @source => "} else {";
 212         }
 213             my $default;
 214             if ( $attr->has_default ) {
 215                 $default = $self->_generate_default_value($attr, $index);
 216             }
 217             else {
 218                my $builder = $attr->builder;
 219                $default = '$instance->' . $builder;
 220             }
 221
 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)
 225                 if $is_moose;
 226             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 227             push @source => '}'; # close - wrap this to avoid my $val overrite warnings
 228
 229         push @source => "}" if defined $attr->init_arg;
 230     }
 231     elsif ( defined( my $init_arg = $attr->init_arg ) ) {
 232         push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
 233
 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(
 238                         $attr,
 239                         '$type_constraints[' . $index . ']',
 240                         '$val',
 241                         '$val'
 242                     );
 243                 }
 244                 push @source => $self->_generate_type_constraint_check(
 245                     $attr,
 246                     '$type_constraint_bodies[' . $index . ']',
 247                     '$type_constraints[' . $index . ']',
 248                     '$val'
 249                 );
 250             }
 251             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 252
 253         push @source => "}";
 254     }
 255
 256     return join "\n" => @source;
 257 }
 258
 259 sub _generate_slot_assignment {
 260     my ($self, $attr, $value, $index) = @_;
 261
 262     my $source;
 263
 264     if ($attr->has_initializer) {
 265         $source = (
 266             '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
 267         );
 268     }
 269     else {
 270         $source = (
 271             $self->_meta_instance->inline_set_slot_value(
 272                 '$instance',
 273                 $attr->name,
 274                 $value
 275             ) . ';'
 276         );
 277     }
 278
 279     my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
 280
 281     if ($is_moose && $attr->is_weak_ref) {
 282         $source .= (
 283             "\n" .
 284             $self->_meta_instance->inline_weaken_slot_value(
 285                 '$instance',
 286                 $attr->name
 287             ) .
 288             ' if ref ' . $value . ';'
 289         );
 290     }
 291
 292     return $source;
 293 }
 294
 295 sub _generate_type_constraint_and_coercion {
 296     my ($self, $attr, $index) = @_;
 297
 298     return unless $attr->has_type_constraint;
 299
 300     my @source;
 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     return @source;
 316 }
 317
 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 . ');');
 321 }
 322
 323 sub _generate_type_constraint_check {
 324     my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
 325     return (
 326         $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
 327         . $attr->name
 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 . ');'
 331     );
 332 }
 333
 334 sub _generate_default_value {
 335     my ($self, $attr, $index) = @_;
 336     # NOTE:
 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)';
 344     }
 345     else {
 346         return q{"} . quotemeta( $attr->default ) . q{"};
 347     }
 348 }
 349
 350 1;
 351
 352 __END__
 353
 354 =pod
 355
 356 =head1 NAME
 357
 358 Moose::Meta::Method::Constructor - Method Meta Object for constructors
 359
 360 =head1 DESCRIPTION
 361
 362 This class is a subclass of L<Class::MOP::Class::Constructor> that
 363 provides additional Moose-specific functionality
 364
 365 To understand this class, you should read the the
 366 L<Class::MOP::Class::Constructor> documentation as well.
 367
 368 =head1 INHERITANCE
 369
 370 C<Moose::Meta::Method::Constructor> is a subclass of
 371 L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>.
 372
 373 =head1 METHODS
 374
 375 =over 4
 376
 377 =item B<< $metamethod->can_be_inlined >>
 378
 379 This returns true if the method can inlined.
 380
 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
 383 inlined.
 384
 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
 387 the expected class.
 388
 389 By default, it expects this constructor come from L<Moose::Object>,
 390 but subclasses can change this expectation.
 391
 392 If the constructor cannot be inlined it warns that this is the case.
 393
 394 =back
 395
 396 =head1 AUTHORS
 397
 398 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 399
 400 =head1 COPYRIGHT AND LICENSE
 401
 402 Copyright 2006-2009 by Infinity Interactive, Inc.
 403
 404 L<http://www.iinteractive.com>
 405
 406 This library is free software; you can redistribute it and/or modify
 407 it under the same terms as Perl itself.
 408
 409 =cut
 410