lib/Method/Generate/Accessor.pm

   1 package Method::Generate::Accessor;
   2
   3 use strictures 1;
   4 use Class::Tiny::_Utils;
   5 use base qw(Class::Tiny::Object);
   6 use Sub::Quote;
   7 use B 'perlstring';
   8
   9 sub generate_method {
  10   my ($self, $into, $name, $spec, $quote_opts) = @_;
  11   die "Must have an is" unless my $is = $spec->{is};
  12   local $self->{captures} = {};
  13   my $body = do {
  14     if ($is eq 'ro') {
  15       $self->_generate_get($name, $spec)
  16     } elsif ($is eq 'rw') {
  17       $self->_generate_getset($name, $spec)
  18     } else {
  19       die "Unknown is ${is}";
  20     }
  21   };
  22   quote_sub
  23     "${into}::${name}" => '    '.$body."\n",
  24     $self->{captures}, $quote_opts||{}
  25   ;
  26 }
  27
  28 sub _generate_get {
  29   my ($self, $name, $spec) = @_;
  30   my $simple = $self->_generate_simple_get('$_[0]', $name);
  31   my ($lazy, $default, $builder) = @{$spec}{qw(lazy default builder)};
  32   return $simple unless $lazy and ($default or $builder);
  33   'do { '.$self->_generate_default(
  34     '$_[0]', $name, $default, $builder,
  35     $self->_generate_simple_has('$_[0]', $name),
  36   ).'; '.$simple.' }';
  37 }
  38
  39 sub _generate_simple_has {
  40   my ($self, $me, $name) = @_;
  41   "exists ${me}->{${\perlstring $name}}";
  42 }
  43
  44 sub _generate_default {
  45   my ($self, $me, $name, $default, $builder, $test) = @_;
  46   $self->_generate_simple_set(
  47     $me, $name, (
  48       $default
  49         ? $self->_generate_call_code($name, 'default', $me, $default)
  50         : "${me}->${builder}"
  51     )
  52   ).' unless '.$test;
  53 }
  54
  55 sub generate_simple_get {
  56   shift->_generate_simple_get(@_);
  57 }
  58
  59 sub _generate_simple_get {
  60   my ($self, $me, $name) = @_;
  61   my $name_str = perlstring $name;
  62   "${me}->{${name_str}}";
  63 }
  64
  65 sub _generate_set {
  66   my ($self, $name, $value, $spec) = @_;
  67   my $simple = $self->_generate_simple_set('$_[0]', $name, $value);
  68   my ($trigger, $isa_check) = @{$spec}{qw(trigger isa)};
  69   return $simple unless $trigger or $isa_check;
  70   my $code = 'do {';
  71   if ($isa_check) {
  72     $code .= ' '.$self->_generate_isa_check($name, '$_[1]', $isa_check).';';
  73   }
  74   if ($trigger) {
  75     my $fire = $self->_generate_trigger($name, '$_[0]', '$value', $trigger);
  76     $code .=
  77       ' my $value = '.$simple.'; '.$fire.'; '
  78       .'$value';
  79   } else {
  80     $code .= ' '.$simple;
  81   }
  82   $code .= ' }';
  83   return $code;
  84 }
  85
  86 sub generate_trigger {
  87   my $self = shift;
  88   local $self->{captures} = {};
  89   my $code = $self->_generate_trigger(@_);
  90   return ($code, $self->{captures});
  91 }
  92
  93 sub _generate_trigger {
  94   my ($self, $name, $obj, $value, $trigger) = @_;
  95   $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
  96 }
  97
  98 sub generate_isa_check {
  99   my $self = shift;
 100   local $self->{captures} = {};
 101   my $code = $self->_generate_isa_check(@_);
 102   return ($code, $self->{captures});
 103 }
 104
 105 sub _generate_isa_check {
 106   my ($self, $name, $value, $check) = @_;
 107   $self->_generate_call_code($name, 'isa_check', $value, $check);
 108 }
 109
 110 sub _generate_call_code {
 111   my ($self, $name, $type, $values, $sub) = @_;
 112   if (my $quoted = quoted_from_sub($sub)) {
 113     my $code = $quoted->[1];
 114     my $at_ = 'local @_ = ('.$values.');';
 115     if (my $captures = $quoted->[2]) {
 116       my $cap_name = qq{\$${type}_captures_for_${name}};
 117       $self->{captures}->{$cap_name} = \$captures;
 118       return "do {\n".'      '.$at_."\n"
 119         .Sub::Quote::capture_unroll($cap_name, $captures, 6)
 120         ."     ${code}\n    }";
 121     }
 122     return 'do { local @_ = ('.$values.'); '.$code.' }';
 123   }
 124   my $cap_name = qq{\$${type}_for_${name}};
 125   $self->{captures}->{$cap_name} = \$sub;
 126   return "${cap_name}->(${values})";
 127 }
 128
 129 sub _generate_simple_set {
 130   my ($self, $me, $name, $value) = @_;
 131   my $name_str = perlstring $name;
 132   "${me}->{${name_str}} = ${value}";
 133 }
 134
 135 sub _generate_getset {
 136   my ($self, $name, $spec) = @_;
 137   q{(@_ > 1 ? }.$self->_generate_set($name, q{$_[1]}, $spec)
 138     .' : '.$self->_generate_get($name).')';
 139 }
 140
 141 1;