lib/Mouse/Meta/Method/Constructor.pm

   1 package Mouse::Meta::Method::Constructor;
   2 use strict;
   3 use warnings;
   4
   5 sub generate_constructor_method_inline {
   6     my ($class, $meta) = @_;
   7
   8     my $buildall = $class->_generate_BUILDALL($meta);
   9     my $buildargs = $class->_generate_BUILDARGS();
  10     my $processattrs = $class->_generate_processattrs($meta);
  11
  12     my $code = <<"...";
  13     sub {
  14         my \$class = shift;
  15         my \$args = $buildargs;
  16         my \$instance = bless {}, \$class;
  17         $processattrs;
  18         $buildall;
  19         return \$instance;
  20     }
  21 ...
  22
  23     warn $code if $ENV{DEBUG};
  24
  25     local $@;
  26     my $res = eval $code;
  27     die $@ if $@;
  28     $res;
  29 }
  30
  31 sub _generate_processattrs {
  32     my ($class, $meta, ) = @_;
  33     my @attrs = $meta->compute_all_applicable_attributes;
  34     my @res;
  35     for my $attr (@attrs) {
  36         my $from = $attr->init_arg;
  37         my $key  = $attr->name;
  38         my $part1 = do {
  39             my @code;
  40             if ($attr->should_coerce) {
  41                 push @code, "\$args->{\$from} = \$attr->coerce_constraint( \$args->{\$from} );";
  42             }
  43             if ($attr->has_type_constraint) {
  44                 push @code, "\$attr->verify_type_constraint( \$args->{\$from} );";
  45             }
  46             push @code, "\$instance->{\$key} = \$args->{\$from};";
  47             if ($attr->is_weak_ref) {
  48                 push @code, "weaken( \$instance->{\$key} ) if ref( \$instance->{\$key} );";
  49             }
  50             if ( $attr->has_trigger ) {
  51                 push @code, "\$attr->trigger->( \$instance, \$args->{\$from}, \$attr );";
  52             }
  53             join "\n", @code;
  54         };
  55         my $part2 = do {
  56             my @code;
  57             if ( $attr->has_default || $attr->has_builder ) {
  58                 unless ( $attr->is_lazy ) {
  59                     my $default = $attr->default;
  60                     my $builder = $attr->builder;
  61                     if ($attr->has_builder) {
  62                         push @code, "my \$value = \$instance->$builder;";
  63                     } elsif (ref($default) eq 'CODE') {
  64                         push @code, "my \$value = \$attr->default()->();";
  65                     } else {
  66                         push @code, "my \$value = \$attr->default();";
  67                     }
  68                     if ($attr->should_coerce) {
  69                         push @code, "\$value = \$attr->coerce_constraint(\$value);";
  70                     }
  71                     if ($attr->has_type_constraint) {
  72                         push @code, "\$attr->verify_type_constraint(\$value);";
  73                     }
  74                     push @code, "\$instance->{\$key} = \$value;";
  75                     if ($attr->is_weak_ref) {
  76                         push @code, "weaken( \$instance->{\$key} ) if ref( \$instance->{\$key} );";
  77                     }
  78                 }
  79                 join "\n", @code;
  80             }
  81             else {
  82                 if ( $attr->is_required ) {
  83                     q{Carp::confess("Attribute (} . $attr->name . q{) is required");};
  84                 } else {
  85                     ""
  86                 }
  87             }
  88         };
  89         my $code = <<"...";
  90             {
  91                 my \$attr = \$meta->get_attribute('$key');
  92                 my \$from = '$from';
  93                 my \$key  = '$key';
  94                 if (defined(\$from) && exists(\$args->{\$from})) {
  95                     $part1;
  96                 } else {
  97                     $part2;
  98                 }
  99             }
 100 ...
 101         push @res, $code;
 102     }
 103     return join "\n", @res;
 104 }
 105
 106 sub _generate_BUILDARGS {
 107     <<'...';
 108     do {
 109         if ( scalar @_ == 1 ) {
 110             if ( defined $_[0] ) {
 111                 ( ref( $_[0] ) eq 'HASH' )
 112                 || Carp::confess "Single parameters to new() must be a HASH ref";
 113                 +{ %{ $_[0] } };
 114             }
 115             else {
 116                 +{};
 117             }
 118         }
 119         else {
 120             +{@_};
 121         }
 122     };
 123 ...
 124 }
 125
 126 sub _generate_BUILDALL {
 127     my ($class, $meta) = @_;
 128     return '' unless $meta->name->can('BUILD');
 129
 130     my @code = ();
 131     push @code, q{no strict 'refs';};
 132     push @code, q{no warnings 'once';};
 133     no strict 'refs';
 134     for my $class ($meta->linearized_isa) {
 135         if (*{ $class . '::BUILD' }{CODE}) {
 136             push  @code, qq{${class}::BUILD->(\$instance, \$args);};
 137         }
 138     }
 139     return join "\n", @code;
 140 }
 141
 142 1;