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_use_default(
  34     '$_[0]', $name, $spec,
  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_get_default {
  45   my $self = shift;
  46   local $self->{captures} = {};
  47   my $code = $self->_generate_get_default(@_);
  48   return ($code, $self->{captures});
  49 }
  50
  51 sub _generate_use_default {
  52   my ($self, $me, $name, $spec, $test) = @_;
  53   $self->_generate_simple_set(
  54     $me, $name, $self->_generate_get_default($me, $name, $spec)
  55   ).' unless '.$test;
  56 }
  57
  58 sub _generate_get_default {
  59   my ($self, $me, $name, $spec) = @_;
  60   $spec->{default}
  61     ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
  62     : "${me}->${\$spec->{builder}}"
  63 }
  64
  65 sub generate_simple_get {
  66   shift->_generate_simple_get(@_);
  67 }
  68
  69 sub _generate_simple_get {
  70   my ($self, $me, $name) = @_;
  71   my $name_str = perlstring $name;
  72   "${me}->{${name_str}}";
  73 }
  74
  75 sub _generate_set {
  76   my ($self, $name, $value, $spec) = @_;
  77   my $simple = $self->_generate_simple_set('$_[0]', $name, $value);
  78   my ($trigger, $isa_check) = @{$spec}{qw(trigger isa)};
  79   return $simple unless $trigger or $isa_check;
  80   my $code = 'do {';
  81   if ($isa_check) {
  82     $code .= ' '.$self->_generate_isa_check($name, '$_[1]', $isa_check).';';
  83   }
  84   if ($trigger) {
  85     my $fire = $self->_generate_trigger($name, '$_[0]', '$value', $trigger);
  86     $code .=
  87       ' my $value = '.$simple.'; '.$fire.'; '
  88       .'$value';
  89   } else {
  90     $code .= ' '.$simple;
  91   }
  92   $code .= ' }';
  93   return $code;
  94 }
  95
  96 sub generate_trigger {
  97   my $self = shift;
  98   local $self->{captures} = {};
  99   my $code = $self->_generate_trigger(@_);
 100   return ($code, $self->{captures});
 101 }
 102
 103 sub _generate_trigger {
 104   my ($self, $name, $obj, $value, $trigger) = @_;
 105   $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
 106 }
 107
 108 sub generate_isa_check {
 109   my $self = shift;
 110   local $self->{captures} = {};
 111   my $code = $self->_generate_isa_check(@_);
 112   return ($code, $self->{captures});
 113 }
 114
 115 sub _generate_isa_check {
 116   my ($self, $name, $value, $check) = @_;
 117   $self->_generate_call_code($name, 'isa_check', $value, $check);
 118 }
 119
 120 sub _generate_call_code {
 121   my ($self, $name, $type, $values, $sub) = @_;
 122   if (my $quoted = quoted_from_sub($sub)) {
 123     my $code = $quoted->[1];
 124     my $at_ = 'local @_ = ('.$values.');';
 125     if (my $captures = $quoted->[2]) {
 126       my $cap_name = qq{\$${type}_captures_for_${name}};
 127       $self->{captures}->{$cap_name} = \$captures;
 128       return "do {\n".'      '.$at_."\n"
 129         .Sub::Quote::capture_unroll($cap_name, $captures, 6)
 130         ."     ${code}\n    }";
 131     }
 132     return 'do { local @_ = ('.$values.'); '.$code.' }';
 133   }
 134   my $cap_name = qq{\$${type}_for_${name}};
 135   $self->{captures}->{$cap_name} = \$sub;
 136   return "${cap_name}->(${values})";
 137 }
 138
 139 sub generate_simple_set {
 140   my $self = shift;
 141   local $self->{captures} = {};
 142   my $code = $self->_generate_simple_set(@_);
 143   return ($code, $self->{captures});
 144 }
 145
 146 sub _generate_simple_set {
 147   my ($self, $me, $name, $value) = @_;
 148   my $name_str = perlstring $name;
 149   "${me}->{${name_str}} = ${value}";
 150 }
 151
 152 sub _generate_getset {
 153   my ($self, $name, $spec) = @_;
 154   q{(@_ > 1 ? }.$self->_generate_set($name, q{$_[1]}, $spec)
 155     .' : '.$self->_generate_get($name).')';
 156 }
 157
 158 1;