lib/Method/Generate/Constructor.pm

   1 package Method::Generate::Constructor;
   2
   3 use strictures 1;
   4 use Sub::Quote;
   5 use base qw(Moo::Object);
   6 use Sub::Defer;
   7 use B 'perlstring';
   8 use Moo::_Utils qw(_getstash);
   9
  10 sub register_attribute_specs {
  11   my ($self, @new_specs) = @_;
  12   my $specs = $self->{attribute_specs}||={};
  13   while (my ($name, $new_spec) = splice @new_specs, 0, 2) {
  14     if ($name =~ s/^\+//) {
  15       die "has '+${name}' given but no ${name} attribute already exists"
  16         unless my $old_spec = $specs->{$name};
  17       foreach my $key (keys %$old_spec) {
  18         if (!exists $new_spec->{$key}) {
  19           $new_spec->{$key} = $old_spec->{$key}
  20             unless $key eq 'handles';
  21         }
  22         elsif ($key eq 'moosify') {
  23           $new_spec->{$key} = [
  24             map { ref $_ eq 'ARRAY' ? @$_ : $_ }
  25               ($old_spec->{$key}, $new_spec->{$key})
  26           ];
  27         }
  28       }
  29     }
  30     $new_spec->{index} = scalar keys %$specs
  31       unless defined $new_spec->{index};
  32     $specs->{$name} = $new_spec;
  33   }
  34   $self;
  35 }
  36
  37 sub all_attribute_specs {
  38   $_[0]->{attribute_specs}
  39 }
  40
  41 sub accessor_generator {
  42   $_[0]->{accessor_generator}
  43 }
  44
  45 sub construction_string {
  46   my ($self) = @_;
  47   $self->{construction_string}
  48     ||= $self->_build_construction_string;
  49 }
  50
  51 sub _build_construction_string {
  52   'bless('
  53     .$_[0]->accessor_generator->default_construction_string
  54     .', $class);'
  55 }
  56
  57 sub install_delayed {
  58   my ($self) = @_;
  59   my $package = $self->{package};
  60   defer_sub "${package}::new" => sub {
  61     unquote_sub $self->generate_method(
  62       $package, 'new', $self->{attribute_specs}, { no_install => 1 }
  63     )
  64   };
  65   $self;
  66 }
  67
  68 sub generate_method {
  69   my ($self, $into, $name, $spec, $quote_opts) = @_;
  70   foreach my $no_init (grep !exists($spec->{$_}{init_arg}), keys %$spec) {
  71     $spec->{$no_init}{init_arg} = $no_init;
  72   }
  73   local $self->{captures} = {};
  74   my $body = '    my $class = shift;'."\n"
  75             .'    $class = ref($class) if ref($class);'."\n";
  76   $body .= $self->_handle_subconstructor($into, $name);
  77   my $into_buildargs = $into->can('BUILDARGS');
  78   if ( $into_buildargs && $into_buildargs != \&Moo::Object::BUILDARGS ) {
  79       $body .= $self->_generate_args_via_buildargs;
  80   } else {
  81       $body .= $self->_generate_args;
  82   }
  83   $body .= $self->_check_required($spec);
  84   $body .= '    my $new = '.$self->construction_string.";\n";
  85   $body .= $self->_assign_new($spec);
  86   if ($into->can('BUILD')) {
  87     require Method::Generate::BuildAll;
  88     $body .= Method::Generate::BuildAll->new->buildall_body_for(
  89       $into, '$new', '$args'
  90     );
  91   }
  92   $body .= '    return $new;'."\n";
  93   if ($into->can('DEMOLISH')) {
  94     require Method::Generate::DemolishAll;
  95     Method::Generate::DemolishAll->new->generate_method($into);
  96   }
  97   quote_sub
  98     "${into}::${name}" => $body,
  99     $self->{captures}, $quote_opts||{}
 100   ;
 101 }
 102
 103 sub _handle_subconstructor {
 104   my ($self, $into, $name) = @_;
 105   if (my $gen = $self->{subconstructor_handler}) {
 106     '    if ($class ne '.perlstring($into).') {'."\n".
 107     $gen.
 108     '    }'."\n";
 109   } else {
 110     ''
 111   }
 112 }
 113
 114 sub _cap_call {
 115   my ($self, $code, $captures) = @_;
 116   @{$self->{captures}}{keys %$captures} = values %$captures if $captures;
 117   $code;
 118 }
 119
 120 sub _generate_args_via_buildargs {
 121   my ($self) = @_;
 122   q{    my $args = $class->BUILDARGS(@_);}."\n"
 123   .q{    die "BUILDARGS did not return a hashref" unless ref($args) eq 'HASH';}
 124   ."\n";
 125 }
 126
 127 # inlined from Moo::Object - update that first.
 128 sub _generate_args {
 129   my ($self) = @_;
 130   return <<'_EOA';
 131     my $args;
 132     if ( scalar @_ == 1 ) {
 133         unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
 134             die "Single parameters to new() must be a HASH ref"
 135                 ." data => ". $_[0] ."\n";
 136         }
 137         $args = { %{ $_[0] } };
 138     }
 139     elsif ( @_ % 2 ) {
 140         die "The new() method for $class expects a hash reference or a key/value list."
 141                 . " You passed an odd number of arguments\n";
 142     }
 143     else {
 144         $args = {@_};
 145     }
 146 _EOA
 147
 148 }
 149
 150 sub _assign_new {
 151   my ($self, $spec) = @_;
 152   my $ag = $self->accessor_generator;
 153   my %test;
 154   NAME: foreach my $name (sort keys %$spec) {
 155     my $attr_spec = $spec->{$name};
 156     next NAME unless defined($attr_spec->{init_arg})
 157                        or $ag->has_eager_default($name, $attr_spec);
 158     $test{$name} = $attr_spec->{init_arg};
 159   }
 160   join '', map {
 161     my $arg_key = perlstring($test{$_});
 162     my $test = "exists \$args->{$arg_key}";
 163     my $source = "\$args->{$arg_key}";
 164     my $attr_spec = $spec->{$_};
 165     $self->_cap_call($ag->generate_populate_set(
 166       '$new', $_, $attr_spec, $source, $test, $test{$_},
 167     ));
 168   } sort keys %test;
 169 }
 170
 171 sub _check_required {
 172   my ($self, $spec) = @_;
 173   my @required_init =
 174     map $spec->{$_}{init_arg},
 175       grep {
 176         my %s = %{$spec->{$_}}; # ignore required if default or builder set
 177         $s{required} and not($s{builder} or $s{default})
 178       } sort keys %$spec;
 179   return '' unless @required_init;
 180   '    if (my @missing = grep !exists $args->{$_}, qw('
 181     .join(' ',@required_init).')) {'."\n"
 182     .q{      die "Missing required arguments: ".join(', ', sort @missing);}."\n"
 183     ."    }\n";
 184 }
 185
 186 use Moo;
 187 Moo->_constructor_maker_for(__PACKAGE__)->register_attribute_specs(
 188   attribute_specs => {
 189     is => 'ro',
 190     reader => 'all_attribute_specs',
 191   },
 192   accessor_generator => { is => 'ro' },
 193   construction_string => { is => 'lazy' },
 194   subconstructor_handler => { is => 'ro' },
 195   package => { is => 'ro' },
 196 );
 197
 198 1;