lib/Mouse/Meta/Method/Constructor.pm

   1 package Mouse::Meta::Method::Constructor;
   2 use Mouse::Util qw(:meta); # enables strict and warnings
   3
   4 sub _inline_slot{
   5     my(undef, $self_var, $attr_name) = @_;
   6     return sprintf '%s->{q{%s}}', $self_var, $attr_name;
   7 }
   8
   9 sub _generate_constructor {
  10     my ($class, $metaclass, $args) = @_;
  11
  12     my $associated_metaclass_name = $metaclass->name;
  13
  14     my $buildall      = $class->_generate_BUILDALL($metaclass);
  15     my $buildargs     = $class->_generate_BUILDARGS($metaclass);
  16     my $initializer   = $metaclass->{_initialize_object} ||= do {
  17        $class->_generate_initialize_object($metaclass);
  18     };
  19     my $source = sprintf(<<'EOT', __LINE__, __FILE__, $metaclass->name, $buildargs, $buildall);
  20 #line %d %s
  21         package %s;
  22         sub {
  23             my $class = shift;
  24             return $class->Mouse::Object::new(@_)
  25                 if $class ne __PACKAGE__;
  26             # BUILDARGS
  27             %s;
  28             my $instance = bless {}, $class;
  29             $metaclass->$initializer($instance, $args, 0);
  30             # BUILDALL
  31             %s;
  32             return $instance;
  33         }
  34 EOT
  35     #warn $source;
  36     my $body;
  37     my $e = do{
  38         local $@;
  39         $body = eval $source;
  40         $@;
  41     };
  42     die $e if $e;
  43     return $body;
  44 }
  45
  46 sub _generate_initialize_object {
  47     my ($method_class, $metaclass) = @_;
  48     my @attrs  = $metaclass->get_all_attributes;
  49
  50     my @checks = map { $_ && $_->_compiled_type_constraint }
  51                  map { $_->type_constraint } @attrs;
  52
  53     my @res;
  54
  55     my $has_triggers;
  56     my $strict = $metaclass->strict_constructor;
  57
  58     if($strict){
  59         push @res, 'my $used = 0;';
  60     }
  61
  62     for my $index (0 .. @attrs - 1) {
  63         my $code = '';
  64
  65         my $attr = $attrs[$index];
  66         my $key  = $attr->name;
  67
  68         my $init_arg        = $attr->init_arg;
  69         my $type_constraint = $attr->type_constraint;
  70         my $is_weak_ref     = $attr->is_weak_ref;
  71         my $need_coercion;
  72
  73         my $instance_slot  = $method_class->_inline_slot('$instance', $key);
  74         my $attr_var       = "\$attrs[$index]";
  75         my $constraint_var;
  76
  77         if(defined $type_constraint){
  78              $constraint_var = "$attr_var\->{type_constraint}";
  79              $need_coercion  = ($attr->should_coerce && $type_constraint->has_coercion);
  80         }
  81
  82         $code .= "# initialize $key\n";
  83
  84         my $post_process = '';
  85         if(defined $type_constraint){
  86             $post_process .= "\$checks[$index]->($instance_slot)\n";
  87             $post_process .= "  or $attr_var->_throw_type_constraint_error($instance_slot, $constraint_var);\n";
  88         }
  89         if($is_weak_ref){
  90             $post_process  = "Scalar::Util::weaken($instance_slot) "
  91                              . "if ref $instance_slot;\n";
  92         }
  93
  94         # build cde for an attribute
  95         if (defined $init_arg) {
  96             my $value = "\$args->{q{$init_arg}}";
  97
  98             $code .= "if (exists $value) {\n";
  99
 100             if($need_coercion){
 101                 $value = "$constraint_var->coerce($value)";
 102             }
 103
 104             $code .= "$instance_slot = $value;\n";
 105             $code .= $post_process;
 106
 107             if ($attr->has_trigger) {
 108                 $has_triggers++;
 109                 $code .= "push \@triggers, [$attr_var\->{trigger}, $instance_slot];\n";
 110             }
 111
 112             if ($strict){
 113                 $code .= '++$used;' . "\n";
 114             }
 115
 116             $code .= "\n} else {\n"; # $value exists
 117         }
 118
 119         if ($attr->has_default || $attr->has_builder) {
 120             unless ($attr->is_lazy) {
 121                 my $default = $attr->default;
 122                 my $builder = $attr->builder;
 123
 124                 my $value;
 125                 if (defined($builder)) {
 126                     $value = "\$instance->$builder()";
 127                 }
 128                 elsif (ref($default) eq 'CODE') {
 129                     $value = "$attr_var\->{default}->(\$instance)";
 130                 }
 131                 elsif (defined($default)) {
 132                     $value = "$attr_var\->{default}";
 133                 }
 134                 else {
 135                     $value = 'undef';
 136                 }
 137
 138                 if($need_coercion){
 139                     $value = "$constraint_var->coerce($value)";
 140                 }
 141
 142                 $code .= "$instance_slot = $value;\n";
 143                 $code .= $post_process;
 144             }
 145         }
 146         elsif ($attr->is_required) {
 147             $code .= "\$meta->throw_error('Attribute ($key) is required')";
 148             $code .= "    unless \$is_cloning;\n";
 149         }
 150
 151         $code .= "}\n" if defined $init_arg;
 152
 153         push @res, $code;
 154     }
 155
 156     if($strict){
 157         push @res, q{if($used < keys %{$args})}
 158             . q{{ $meta->_report_unknown_args(\@attrs, $args) }};
 159     }
 160
 161     if($metaclass->is_anon_class){
 162         push @res, q{$instance->{__METACLASS__} = $meta;};
 163     }
 164
 165     if($has_triggers){
 166         unshift @res, q{my @triggers;};
 167         push    @res, q{$_->[0]->($instance, $_->[1]) for @triggers;};
 168     }
 169
 170     my $source = sprintf <<'EOT', __LINE__, __FILE__, $metaclass->name, join "\n", @res;
 171 #line %d %s
 172     package %s;
 173     sub {
 174         my($meta, $instance, $args, $is_cloning) = @_;
 175         %s;
 176         return $instance;
 177     }
 178 EOT
 179     warn $source if $ENV{MOUSE_DEBUG};
 180     my $body;
 181     my $e = do {
 182         local $@;
 183         $body = eval $source;
 184         $@;
 185     };
 186     die $e if $e;
 187     return $body;
 188 }
 189
 190 sub _generate_BUILDARGS {
 191     my(undef, $metaclass) = @_;
 192
 193     my $class = $metaclass->name;
 194     if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Mouse::Object::BUILDARGS ) {
 195         return 'my $args = $class->BUILDARGS(@_)';
 196     }
 197
 198     return <<'...';
 199         my $args;
 200         if ( scalar @_ == 1 ) {
 201             ( ref( $_[0] ) eq 'HASH' )
 202                 || Carp::confess "Single parameters to new() must be a HASH ref";
 203             $args = +{ %{ $_[0] } };
 204         }
 205         else {
 206             $args = +{@_};
 207         }
 208 ...
 209 }
 210
 211 sub _generate_BUILDALL {
 212     my (undef, $metaclass) = @_;
 213
 214     return '' unless $metaclass->name->can('BUILD');
 215
 216     my @code;
 217     for my $class ($metaclass->linearized_isa) {
 218         if (Mouse::Util::get_code_ref($class, 'BUILD')) {
 219             unshift  @code, qq{${class}::BUILD(\$instance, \$args);};
 220         }
 221     }
 222     return join "\n", @code;
 223 }
 224
 225 1;
 226 __END__
 227
 228 =head1 NAME
 229
 230 Mouse::Meta::Method::Constructor - A Mouse method generator for constructors
 231
 232 =head1 VERSION
 233
 234 This document describes Mouse version 0.73
 235
 236 =head1 SEE ALSO
 237
 238 L<Moose::Meta::Method::Constructor>
 239
 240 =cut