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