lib/Mouse/Meta/Method/Constructor.pm

   1 package Mouse::Meta::Method::Constructor;
   2 use Mouse::Util; # enables strict and warnings
   3
   4 sub _generate_constructor_method {
   5     my ($class, $metaclass, $args) = @_;
   6
   7     my $associated_metaclass_name = $metaclass->name;
   8
   9     my @attrs         = $metaclass->get_all_attributes;
  10
  11     my $buildall      = $class->_generate_BUILDALL($metaclass);
  12     my $buildargs     = $class->_generate_BUILDARGS($metaclass);
  13     my $processattrs  = $class->_generate_processattrs($metaclass, \@attrs);
  14
  15     my @checks = map { $_ && $_->_compiled_type_constraint }
  16                  map { $_->type_constraint } @attrs;
  17
  18     my $source = sprintf("#line %d %s\n", __LINE__, __FILE__).<<"...";
  19         sub \{
  20             my \$class = shift;
  21             return \$class->Mouse::Object::new(\@_)
  22                 if \$class ne q{$associated_metaclass_name};
  23             # BUILDARGS
  24             $buildargs;
  25             my \$instance = bless {}, \$class;
  26             # process attributes
  27             $processattrs;
  28             # BUILDALL
  29             $buildall;
  30             return \$instance;
  31         }
  32 ...
  33     #warn $source;
  34     my $code;
  35     my $e = do{
  36         local $@;
  37         $code = eval $source;
  38         $@;
  39     };
  40     die $e if $e;
  41
  42     $metaclass->add_method($args->{constructor_name} => $code);
  43     return;
  44 }
  45
  46 sub _generate_processattrs {
  47     my ($class, $metaclass, $attrs) = @_;
  48     my @res;
  49
  50     my $has_triggers;
  51
  52     for my $index (0 .. @$attrs - 1) {
  53         my $code = '';
  54
  55         my $attr = $attrs->[$index];
  56         my $key  = $attr->name;
  57
  58         my $init_arg        = $attr->init_arg;
  59         my $type_constraint = $attr->type_constraint;
  60         my $need_coercion;
  61
  62         my $instance_slot  = "\$instance->{q{$key}}";
  63         my $attr_var       = "\$attrs[$index]";
  64         my $constraint_var;
  65
  66         if(defined $type_constraint){
  67              $constraint_var = "$attr_var\->{type_constraint}";
  68              $need_coercion  = ($attr->should_coerce && $type_constraint->has_coercion);
  69         }
  70
  71         $code .= "# initialize $key\n";
  72
  73         my $post_process = '';
  74         if(defined $type_constraint){
  75             $post_process .= "\$checks[$index]->($instance_slot)";
  76             $post_process .= "  or $attr_var->verify_type_constraint_error(q{$key}, $instance_slot, $constraint_var);\n";
  77         }
  78         if($attr->is_weak_ref){
  79             $post_process .= "Scalar::Util::weaken($instance_slot) if ref $instance_slot;\n";
  80         }
  81
  82         if (defined $init_arg) {
  83             my $value = "\$args->{q{$init_arg}}";
  84
  85             $code .= "if (exists $value) {\n";
  86
  87             if($need_coercion){
  88                 $value = "$instance_slot = $constraint_var->coerce($value);\n";
  89             }
  90
  91             $code .= "$instance_slot = $value;\n";
  92             $code .= $post_process;
  93
  94             if ($attr->has_trigger) {
  95                 $has_triggers++;
  96                 $code .= "push \@triggers, [$attr_var\->{trigger}, $value];\n";
  97             }
  98
  99             $code .= "\n} else {\n";
 100         }
 101
 102         if ($attr->has_default || $attr->has_builder) {
 103             unless ($attr->is_lazy) {
 104                 my $default = $attr->default;
 105                 my $builder = $attr->builder;
 106
 107                 my $value;
 108                 if (defined($builder)) {
 109                     $value = "\$instance->$builder()";
 110                 }
 111                 elsif (ref($default) eq 'CODE') {
 112                     $value = "$attr_var\->{default}->(\$instance)";
 113                 }
 114                 elsif (defined($default)) {
 115                     $value = "$attr_var\->{default}";
 116                 }
 117                 else {
 118                     $value = 'undef';
 119                 }
 120
 121                 if($need_coercion){
 122                     $value = "$constraint_var->coerce($value)";
 123                 }
 124
 125                 $code .= "$instance_slot = $value;\n";
 126             }
 127         }
 128         elsif ($attr->is_required) {
 129             $code .= "Carp::confess('Attribute ($key) is required');";
 130         }
 131
 132         $code .= "}\n" if defined $init_arg;
 133
 134         push @res, $code;
 135     }
 136
 137     if($metaclass->is_anon_class){
 138         push @res, q{$instnace->{__METACLASS__} = $metaclass;};
 139     }
 140
 141     if($has_triggers){
 142         unshift @res, q{my @triggers;};
 143         push    @res,  q{$_->[0]->($instance, $_->[1]) for @triggers;};
 144     }
 145
 146     return join "\n", @res;
 147 }
 148
 149 sub _generate_BUILDARGS {
 150     my(undef, $metaclass) = @_;
 151
 152     my $class = $metaclass->name;
 153     if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Mouse::Object::BUILDARGS ) {
 154         return 'my $args = $class->BUILDARGS(@_)';
 155     }
 156
 157     return <<'...';
 158         my $args;
 159         if ( scalar @_ == 1 ) {
 160             ( ref( $_[0] ) eq 'HASH' )
 161                 || Carp::confess "Single parameters to new() must be a HASH ref";
 162             $args = +{ %{ $_[0] } };
 163         }
 164         else {
 165             $args = +{@_};
 166         }
 167 ...
 168 }
 169
 170 sub _generate_BUILDALL {
 171     my (undef, $metaclass) = @_;
 172
 173     return '' unless $metaclass->name->can('BUILD');
 174
 175     my @code;
 176     for my $class ($metaclass->linearized_isa) {
 177         no strict 'refs';
 178         no warnings 'once';
 179
 180         if (*{ $class . '::BUILD' }{CODE}) {
 181             unshift  @code, qq{${class}::BUILD(\$instance, \$args);};
 182         }
 183     }
 184     return join "\n", @code;
 185 }
 186
 187 1;