lib/Moose/Meta/Method/Constructor.pm

   1
   2 package Moose::Meta::Method::Constructor;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp ();
   8 use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr';
   9 use Try::Tiny;
  10
  11 our $VERSION   = '1.19';
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use base 'Moose::Meta::Method',
  15          'Class::MOP::Method::Constructor';
  16
  17 sub new {
  18     my $class   = shift;
  19     my %options = @_;
  20
  21     my $meta = $options{metaclass};
  22
  23     (ref $options{options} eq 'HASH')
  24         || $class->throw_error("You must pass a hash of options", data => $options{options});
  25
  26     ($options{package_name} && $options{name})
  27         || $class->throw_error("You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT");
  28
  29     my $self = bless {
  30         'body'          => undef,
  31         'package_name'  => $options{package_name},
  32         'name'          => $options{name},
  33         'options'       => $options{options},
  34         'associated_metaclass' => $meta,
  35         '_expected_method_class' => $options{_expected_method_class} || 'Moose::Object',
  36     } => $class;
  37
  38     # we don't want this creating
  39     # a cycle in the code, if not
  40     # needed
  41     weaken($self->{'associated_metaclass'});
  42
  43     $self->_initialize_body;
  44
  45     return $self;
  46 }
  47
  48 ## method
  49
  50 sub _initialize_body {
  51     my $self = shift;
  52     $self->{'body'} = $self->_generate_constructor_method_inline;
  53 }
  54
  55 sub _eval_environment {
  56     my $self = shift;
  57
  58     my $attrs = $self->_attributes;
  59
  60     my $defaults = [map { $_->default } @$attrs];
  61
  62     # We need to check if the attribute ->can('type_constraint')
  63     # since we may be trying to immutabilize a Moose meta class,
  64     # which in turn has attributes which are Class::MOP::Attribute
  65     # objects, rather than Moose::Meta::Attribute. And
  66     # Class::MOP::Attribute attributes have no type constraints.
  67     # However we need to make sure we leave an undef value there
  68     # because the inlined code is using the index of the attributes
  69     # to determine where to find the type constraint
  70
  71     my @type_constraints = map {
  72         $_->can('type_constraint') ? $_->type_constraint : undef
  73     } @$attrs;
  74
  75     my @type_constraint_bodies = map {
  76         defined $_ ? $_->_compiled_type_constraint : undef;
  77     } @type_constraints;
  78
  79     return {
  80         '$meta'  => \$self,
  81         '$attrs' => \$attrs,
  82         '$defaults' => \$defaults,
  83         '@type_constraints' => \@type_constraints,
  84         '@type_constraint_bodies' => \@type_constraint_bodies,
  85     };
  86 }
  87
  88 sub _generate_constructor_method_inline {
  89     my $self = shift;
  90     # TODO:
  91     # the %options should also include a both
  92     # a call 'initializer' and call 'SUPER::'
  93     # options, which should cover approx 90%
  94     # of the possible use cases (even if it
  95     # requires some adaption on the part of
  96     # the author, after all, nothing is free)
  97
  98     my @source = (
  99         'sub {',
 100             'my $_instance = shift;',
 101             'my $class = Scalar::Util::blessed($_instance) || $_instance;',
 102             'if ($class ne \'' . $self->associated_metaclass->name . '\') {',
 103                 'return ' . $self->_generate_fallback_constructor('$class') . ';',
 104             '}',
 105             $self->_generate_params('$params', '$class'),
 106             $self->_generate_instance('$instance', '$class'),
 107             $self->_generate_slot_initializers,
 108             $self->_generate_triggers,
 109             $self->_generate_BUILDALL,
 110             'return $instance;',
 111         '}'
 112     );
 113     warn join("\n", @source) if $self->options->{debug};
 114
 115     return try {
 116         $self->_compile_code(\@source);
 117     }
 118     catch {
 119         my $source = join("\n", @source);
 120         $self->throw_error(
 121             "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$_",
 122             error => $_,
 123             data  => $source,
 124         );
 125     };
 126 }
 127
 128 sub _generate_fallback_constructor {
 129     my $self = shift;
 130     my ($class_var) = @_;
 131     return $class_var . '->Moose::Object::new(@_)'
 132 }
 133
 134 sub _generate_params {
 135     my $self = shift;
 136     my ($var, $class_var) = @_;
 137     return (
 138         'my ' . $var . ' = ',
 139         $self->_generate_BUILDARGS($class_var, '@_'),
 140         ';',
 141     );
 142 }
 143
 144 sub _generate_instance {
 145     my $self = shift;
 146     my ($var, $class_var) = @_;
 147     my $meta = $self->associated_metaclass;
 148
 149     return (
 150         'my ' . $var . ' = ',
 151         $meta->inline_create_instance($class_var) . ';',
 152     );
 153 }
 154
 155 sub _generate_slot_initializers {
 156     my $self = shift;
 157     return map { $self->_generate_slot_initializer($_) }
 158                0 .. (@{$self->_attributes} - 1);
 159 }
 160
 161 sub _generate_BUILDARGS {
 162     my $self = shift;
 163     my ($class, $args) = @_;
 164
 165     my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
 166
 167     if ($args eq '@_'
 168      && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) {
 169
 170         return (
 171             'do {',
 172                 'my $params;',
 173                 'if (scalar @_ == 1) {',
 174                     'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {',
 175                         $self->_inline_throw_error(
 176                             '"Single parameters to new() must be a HASH ref"',
 177                             'data => $_[0]',
 178                         ) . ';',
 179                     '}',
 180                     '$params = { %{ $_[0] } };',
 181                 '}',
 182                 'elsif (@_ % 2) {',
 183                     'Carp::carp(',
 184                         '"The new() method for ' . $class . ' expects a '
 185                       . 'hash reference or a key/value list. You passed an '
 186                       . 'odd number of arguments"',
 187                     ');',
 188                     '$params = {@_, undef};',
 189                 '}',
 190                 'else {',
 191                     '$params = {@_};',
 192                 '}',
 193                 '$params;',
 194             '}',
 195         );
 196     }
 197     else {
 198         return $class . '->BUILDARGS(' . $args . ')';
 199     }
 200 }
 201
 202 sub _generate_BUILDALL {
 203     my $self = shift;
 204
 205     my @methods = reverse $self->associated_metaclass->find_all_methods_by_name('BUILD');
 206     my @BUILD_calls;
 207
 208     foreach my $method (@methods) {
 209         push @BUILD_calls,
 210             '$instance->' . $method->{class} . '::BUILD($params);';
 211     }
 212
 213     return @BUILD_calls;
 214 }
 215
 216 sub _generate_triggers {
 217     my $self = shift;
 218     my @trigger_calls;
 219
 220     for my $i (0 .. $#{ $self->_attributes }) {
 221         my $attr = $self->_attributes->[$i];
 222
 223         next unless $attr->can('has_trigger') && $attr->has_trigger;
 224
 225         my $init_arg = $attr->init_arg;
 226         next unless defined $init_arg;
 227
 228         push @trigger_calls,
 229             'if (exists $params->{\'' . $init_arg . '\'}) {',
 230                 '$attrs->[' . $i . ']->trigger->(',
 231                     '$instance,',
 232                     $attr->_inline_instance_get('$instance') . ',',
 233                 ');',
 234             '}';
 235     }
 236
 237     return @trigger_calls;
 238 }
 239
 240 sub _generate_slot_initializer {
 241     my $self  = shift;
 242     my ($index) = @_;
 243
 244     my $attr = $self->_attributes->[$index];
 245
 246     my @source = ('## ' . $attr->name);
 247
 248     push @source, $self->_check_required_attr($attr);
 249
 250     if (defined $attr->init_arg) {
 251         push @source,
 252             'if (exists $params->{\'' . $attr->init_arg . '\'}) {',
 253                 $self->_init_attr_from_constructor($attr, $index),
 254             '}';
 255         if (my @default = $self->_init_attr_from_default($attr, $index)) {
 256             push @source,
 257                 'else {',
 258                     @default,
 259                 '}';
 260         }
 261     }
 262     else {
 263         if (my @default = $self->_init_attr_from_default($attr, $index)) {
 264             push @source,
 265                 '{', # _init_attr_from_default creates variables
 266                     @default,
 267                 '}';
 268         }
 269     }
 270
 271     return @source;
 272 }
 273
 274 sub _check_required_attr {
 275     my $self = shift;
 276     my ($attr) = @_;
 277
 278     return unless defined $attr->init_arg;
 279     return unless $attr->can('is_required') && $attr->is_required;
 280     return if $attr->has_default || $attr->has_builder;
 281
 282     return (
 283         'if (!exists $params->{\'' . $attr->init_arg . '\'}) {',
 284             $self->_inline_throw_error(
 285                 '"Attribute (' . quotemeta($attr->name) . ') is required"'
 286             ) . ';',
 287         '}',
 288     );
 289 }
 290
 291 sub _init_attr_from_constructor {
 292     my $self = shift;
 293     my ($attr, $index) = @_;
 294
 295     return (
 296         'my $val = $params->{\'' . $attr->init_arg . '\'};',
 297         $self->_generate_slot_assignment($attr, $index, '$val'),
 298     );
 299 }
 300
 301 sub _init_attr_from_default {
 302     my $self = shift;
 303     my ($attr, $index) = @_;
 304
 305     my $default = $self->_generate_default_value($attr, $index);
 306     return unless $default;
 307
 308     return (
 309         'my $val = ' . $default . ';',
 310         $self->_generate_slot_assignment($attr, $index, '$val'),
 311     );
 312 }
 313
 314 sub _generate_slot_assignment {
 315     my $self = shift;
 316     my ($attr, $index, $value) = @_;
 317
 318     my @source;
 319
 320     if ($self->can('_generate_type_constraint_and_coercion')) {
 321         push @source, $self->_generate_type_constraint_and_coercion(
 322             $attr, $index, $value,
 323         );
 324     }
 325
 326     if ($attr->has_initializer) {
 327         push @source, (
 328             '$attrs->[' . $index . ']->set_initial_value(',
 329                 '$instance' . ',',
 330                 $value . ',',
 331             ');'
 332         );
 333     }
 334     else {
 335         push @source, (
 336             $attr->_inline_instance_set('$instance', $value) . ';',
 337         );
 338     }
 339
 340     return @source;
 341 }
 342
 343 sub _generate_type_constraint_and_coercion {
 344     my $self = shift;
 345     my ($attr, $index, $value) = @_;
 346
 347     return unless $attr->can('has_type_constraint')
 348                && $attr->has_type_constraint;
 349
 350     my @source;
 351
 352     if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
 353         push @source => $self->_generate_type_coercion(
 354             '$type_constraints[' . $index . ']',
 355             $value,
 356             $value,
 357         );
 358     }
 359
 360     push @source => $self->_generate_type_constraint_check(
 361         $attr,
 362         '$type_constraint_bodies[' . $index . ']',
 363         '$type_constraints[' . $index . ']',
 364         $value,
 365     );
 366
 367     return @source;
 368 }
 369
 370 sub _generate_type_coercion {
 371     my $self = shift;
 372     my ($tc_obj, $value, $return_value) = @_;
 373     return $return_value . ' = ' . $tc_obj . '->coerce(' . $value . ');';
 374 }
 375
 376 sub _generate_type_constraint_check {
 377     my $self = shift;
 378     my ($attr, $tc_body, $tc_obj, $value) = @_;
 379     return (
 380         $self->_inline_throw_error(
 381             '"Attribute (' . quotemeta($attr->name) . ') '
 382           . 'does not pass the type constraint because: " . '
 383           . $tc_obj . '->get_message(' . $value . ')'
 384         ),
 385         'unless ' .  $tc_body . '->(' . $value . ');'
 386     );
 387 }
 388
 389 1;
 390
 391 __END__
 392
 393 =pod
 394
 395 =head1 NAME
 396
 397 Moose::Meta::Method::Constructor - Method Meta Object for constructors
 398
 399 =head1 DESCRIPTION
 400
 401 This class is a subclass of L<Class::MOP::Method::Constructor> that
 402 provides additional Moose-specific functionality
 403
 404 To understand this class, you should read the the
 405 L<Class::MOP::Method::Constructor> documentation as well.
 406
 407 =head1 INHERITANCE
 408
 409 C<Moose::Meta::Method::Constructor> is a subclass of
 410 L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>.
 411
 412 =head1 BUGS
 413
 414 See L<Moose/BUGS> for details on reporting bugs.
 415
 416 =head1 AUTHORS
 417
 418 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 419
 420 =head1 COPYRIGHT AND LICENSE
 421
 422 Copyright 2006-2010 by Infinity Interactive, Inc.
 423
 424 L<http://www.iinteractive.com>
 425
 426 This library is free software; you can redistribute it and/or modify
 427 it under the same terms as Perl itself.
 428
 429 =cut
 430