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.86';
  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, $e ) = $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     );
 108
 109     $self->throw_error(
 110         "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e",
 111         error => $e, data => $source )
 112         if $e;
 113
 114     $self->{'body'} = $code;
 115 }
 116
 117 sub _generate_params {
 118     my ( $self, $var, $class_var ) = @_;
 119     "my $var = " . $self->_generate_BUILDARGS( $class_var, '@_' ) . ";\n";
 120 }
 121
 122 sub _generate_instance {
 123     my ( $self, $var, $class_var ) = @_;
 124     "my $var = "
 125         . $self->_meta_instance->inline_create_instance($class_var) . ";\n";
 126 }
 127
 128 sub _generate_slot_initializers {
 129     my ($self) = @_;
 130     return (join ";\n" => map {
 131         $self->_generate_slot_initializer($_)
 132     } 0 .. (@{$self->_attributes} - 1)) . ";\n";
 133 }
 134
 135 sub _generate_BUILDARGS {
 136     my ( $self, $class, $args ) = @_;
 137
 138     my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
 139
 140     if ( $args eq '@_' and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS ) ) {
 141         return join("\n",
 142             'do {',
 143             $self->_inline_throw_error('"Single parameters to new() must be a HASH ref"', 'data => $_[0]'),
 144             '    if scalar @_ == 1 && !( defined $_[0] && ref $_[0] eq q{HASH} );',
 145             '(scalar @_ == 1) ? {%{$_[0]}} : {@_};',
 146             '}',
 147         );
 148     } else {
 149         return $class . "->BUILDARGS($args)";
 150     }
 151 }
 152
 153 sub _generate_BUILDALL {
 154     my $self = shift;
 155     my @BUILD_calls;
 156     foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
 157         push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD($params)';
 158     }
 159     return join ";\n" => @BUILD_calls;
 160 }
 161
 162 sub _generate_triggers {
 163     my $self = shift;
 164     my @trigger_calls;
 165     foreach my $i ( 0 .. $#{ $self->_attributes } ) {
 166         my $attr = $self->_attributes->[$i];
 167
 168         next unless $attr->can('has_trigger') && $attr->has_trigger;
 169
 170         my $init_arg = $attr->init_arg;
 171
 172         next unless defined $init_arg;
 173
 174         push @trigger_calls => '(exists $params->{\''
 175             . $init_arg
 176             . '\'}) && do {'
 177             . "\n    "
 178             . '$attrs->['
 179             . $i
 180             . ']->trigger->('
 181             . '$instance, '
 182             . $self->_meta_instance->inline_get_slot_value(
 183                   '$instance',
 184                   $attr->name,
 185               )
 186             . ', '
 187             . ');' . "\n}";
 188     }
 189
 190     return join ";\n" => @trigger_calls;
 191 }
 192
 193 sub _generate_slot_initializer {
 194     my $self  = shift;
 195     my $index = shift;
 196
 197     my $attr = $self->_attributes->[$index];
 198
 199     my @source = ('## ' . $attr->name);
 200
 201     my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
 202
 203     if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
 204         push @source => ('(exists $params->{\'' . $attr->init_arg . '\'}) ' .
 205                         '|| ' . $self->_inline_throw_error('"Attribute (' . $attr->name . ') is required"') .';');
 206     }
 207
 208     if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
 209
 210         if ( defined( my $init_arg = $attr->init_arg ) ) {
 211             push @source => 'if (exists $params->{\'' . $init_arg . '\'}) {';
 212             push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
 213             push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
 214                 if $is_moose;
 215             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 216             push @source => "} else {";
 217         }
 218             my $default;
 219             if ( $attr->has_default ) {
 220                 $default = $self->_generate_default_value($attr, $index);
 221             }
 222             else {
 223                my $builder = $attr->builder;
 224                $default = '$instance->' . $builder;
 225             }
 226
 227             push @source => '{'; # wrap this to avoid my $val overwrite warnings
 228             push @source => ('my $val = ' . $default . ';');
 229             push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
 230                 if $is_moose;
 231             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 232             push @source => '}'; # close - wrap this to avoid my $val overrite warnings
 233
 234         push @source => "}" if defined $attr->init_arg;
 235     }
 236     elsif ( defined( my $init_arg = $attr->init_arg ) ) {
 237         push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
 238
 239             push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
 240             if ($is_moose && $attr->has_type_constraint) {
 241                 if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
 242                     push @source => $self->_generate_type_coercion(
 243                         $attr,
 244                         '$type_constraints[' . $index . ']',
 245                         '$val',
 246                         '$val'
 247                     );
 248                 }
 249                 push @source => $self->_generate_type_constraint_check(
 250                     $attr,
 251                     '$type_constraint_bodies[' . $index . ']',
 252                     '$type_constraints[' . $index . ']',
 253                     '$val'
 254                 );
 255             }
 256             push @source => $self->_generate_slot_assignment($attr, '$val', $index);
 257
 258         push @source => "}";
 259     }
 260
 261     return join "\n" => @source;
 262 }
 263
 264 sub _generate_slot_assignment {
 265     my ($self, $attr, $value, $index) = @_;
 266
 267     my $source;
 268
 269     if ($attr->has_initializer) {
 270         $source = (
 271             '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
 272         );
 273     }
 274     else {
 275         $source = (
 276             $self->_meta_instance->inline_set_slot_value(
 277                 '$instance',
 278                 $attr->name,
 279                 $value
 280             ) . ';'
 281         );
 282     }
 283
 284     my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
 285
 286     if ($is_moose && $attr->is_weak_ref) {
 287         $source .= (
 288             "\n" .
 289             $self->_meta_instance->inline_weaken_slot_value(
 290                 '$instance',
 291                 $attr->name
 292             ) .
 293             ' if ref ' . $value . ';'
 294         );
 295     }
 296
 297     return $source;
 298 }
 299
 300 sub _generate_type_constraint_and_coercion {
 301     my ($self, $attr, $index) = @_;
 302
 303     return unless $attr->has_type_constraint;
 304
 305     my @source;
 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     return @source;
 321 }
 322
 323 sub _generate_type_coercion {
 324     my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
 325     return ($return_value_name . ' = ' . $type_constraint_name .  '->coerce(' . $value_name . ');');
 326 }
 327
 328 sub _generate_type_constraint_check {
 329     my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
 330     return (
 331         $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
 332         . $attr->name
 333         . ') does not pass the type constraint because: " . '
 334         . $type_constraint_obj . '->get_message(' . $value_name . ')')
 335         . "\n\t unless " .  $type_constraint_cv . '->(' . $value_name . ');'
 336     );
 337 }
 338
 339 sub _generate_default_value {
 340     my ($self, $attr, $index) = @_;
 341     # NOTE:
 342     # default values can either be CODE refs
 343     # in which case we need to call them. Or
 344     # they can be scalars (strings/numbers)
 345     # in which case we can just deal with them
 346     # in the code we eval.
 347     if ($attr->is_default_a_coderef) {
 348         return '$attrs->[' . $index . ']->default($instance)';
 349     }
 350     else {
 351         return q{"} . quotemeta( $attr->default ) . q{"};
 352     }
 353 }
 354
 355 1;
 356
 357 __END__
 358
 359 =pod
 360
 361 =head1 NAME
 362
 363 Moose::Meta::Method::Constructor - Method Meta Object for constructors
 364
 365 =head1 DESCRIPTION
 366
 367 This class is a subclass of L<Class::MOP::Class::Constructor> that
 368 provides additional Moose-specific functionality
 369
 370 To understand this class, you should read the the
 371 L<Class::MOP::Class::Constructor> documentation as well.
 372
 373 =head1 INHERITANCE
 374
 375 C<Moose::Meta::Method::Constructor> is a subclass of
 376 L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>.
 377
 378 =head1 METHODS
 379
 380 =over 4
 381
 382 =item B<< $metamethod->can_be_inlined >>
 383
 384 This returns true if the method can inlined.
 385
 386 First, it looks at all of the parents of the associated class. If any
 387 of them have an inlined constructor, then the constructor can be
 388 inlined.
 389
 390 If none of them have been inlined, it checks to make sure that the
 391 pre-inlining constructor for the class matches the constructor from
 392 the expected class.
 393
 394 By default, it expects this constructor come from L<Moose::Object>,
 395 but subclasses can change this expectation.
 396
 397 If the constructor cannot be inlined it warns that this is the case.
 398
 399 =back
 400
 401 =head1 AUTHORS
 402
 403 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 404
 405 =head1 COPYRIGHT AND LICENSE
 406
 407 Copyright 2006-2009 by Infinity Interactive, Inc.
 408
 409 L<http://www.iinteractive.com>
 410
 411 This library is free software; you can redistribute it and/or modify
 412 it under the same terms as Perl itself.
 413
 414 =cut
 415