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 is_simple_attribute {
  29   my ($self, $name, $spec) = @_;
  30   return !grep $spec->{$_}, qw(lazy default builder isa trigger);
  31 }
  32
  33 sub _generate_get {
  34   my ($self, $name, $spec) = @_;
  35   my $simple = $self->_generate_simple_get('$_[0]', $name);
  36   my ($lazy, $default, $builder) = @{$spec}{qw(lazy default builder)};
  37   return $simple unless $lazy and ($default or $builder);
  38   'do { '.$self->_generate_use_default(
  39     '$_[0]', $name, $spec,
  40     $self->_generate_simple_has('$_[0]', $name),
  41   ).'; '.$simple.' }';
  42 }
  43
  44 sub _generate_simple_has {
  45   my ($self, $me, $name) = @_;
  46   "exists ${me}->{${\perlstring $name}}";
  47 }
  48
  49 sub generate_get_default {
  50   my $self = shift;
  51   local $self->{captures} = {};
  52   my $code = $self->_generate_get_default(@_);
  53   return ($code, $self->{captures});
  54 }
  55
  56 sub _generate_use_default {
  57   my ($self, $me, $name, $spec, $test) = @_;
  58   $self->_generate_simple_set(
  59     $me, $name, $self->_generate_get_default($me, $name, $spec)
  60   ).' unless '.$test;
  61 }
  62
  63 sub _generate_get_default {
  64   my ($self, $me, $name, $spec) = @_;
  65   $spec->{default}
  66     ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
  67     : "${me}->${\$spec->{builder}}"
  68 }
  69
  70 sub generate_simple_get {
  71   shift->_generate_simple_get(@_);
  72 }
  73
  74 sub _generate_simple_get {
  75   my ($self, $me, $name) = @_;
  76   my $name_str = perlstring $name;
  77   "${me}->{${name_str}}";
  78 }
  79
  80 sub _generate_set {
  81   my ($self, $name, $value, $spec) = @_;
  82   my $simple = $self->_generate_simple_set('$_[0]', $name, $value);
  83   my ($trigger, $isa_check) = @{$spec}{qw(trigger isa)};
  84   return $simple unless $trigger or $isa_check;
  85   my $code = 'do {';
  86   if ($isa_check) {
  87     $code .= ' '.$self->_generate_isa_check($name, '$_[1]', $isa_check).';';
  88   }
  89   if ($trigger) {
  90     my $fire = $self->_generate_trigger($name, '$_[0]', '$value', $trigger);
  91     $code .=
  92       ' my $value = '.$simple.'; '.$fire.'; '
  93       .'$value';
  94   } else {
  95     $code .= ' '.$simple;
  96   }
  97   $code .= ' }';
  98   return $code;
  99 }
 100
 101 sub generate_trigger {
 102   my $self = shift;
 103   local $self->{captures} = {};
 104   my $code = $self->_generate_trigger(@_);
 105   return ($code, $self->{captures});
 106 }
 107
 108 sub _generate_trigger {
 109   my ($self, $name, $obj, $value, $trigger) = @_;
 110   $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
 111 }
 112
 113 sub generate_isa_check {
 114   my $self = shift;
 115   local $self->{captures} = {};
 116   my $code = $self->_generate_isa_check(@_);
 117   return ($code, $self->{captures});
 118 }
 119
 120 sub _generate_isa_check {
 121   my ($self, $name, $value, $check) = @_;
 122   $self->_generate_call_code($name, 'isa_check', $value, $check);
 123 }
 124
 125 sub _generate_call_code {
 126   my ($self, $name, $type, $values, $sub) = @_;
 127   if (my $quoted = quoted_from_sub($sub)) {
 128     my $code = $quoted->[1];
 129     my $at_ = 'local @_ = ('.$values.');';
 130     if (my $captures = $quoted->[2]) {
 131       my $cap_name = qq{\$${type}_captures_for_${name}};
 132       $self->{captures}->{$cap_name} = \$captures;
 133       return "do {\n".'      '.$at_."\n"
 134         .Sub::Quote::capture_unroll($cap_name, $captures, 6)
 135         ."     ${code}\n    }";
 136     }
 137     return 'do { local @_ = ('.$values.'); '.$code.' }';
 138   }
 139   my $cap_name = qq{\$${type}_for_${name}};
 140   $self->{captures}->{$cap_name} = \$sub;
 141   return "${cap_name}->(${values})";
 142 }
 143
 144 sub generate_populate_set {
 145   my $self = shift;
 146   local $self->{captures} = {};
 147   my $code = $self->_generate_populate_set(@_);
 148   return ($code, $self->{captures});
 149 }
 150
 151 sub _generate_populate_set {
 152   my ($self, $me, $name, $spec, $source, $test) = @_;
 153   if (!$spec->{lazy} and
 154         ($spec->{default} or $spec->{builder})) {
 155     my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
 156     my $get_value =
 157       "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
 158         .$self->_generate_get_default(
 159           '$new', $_, $spec
 160         )
 161         ."\n${get_indent})";
 162     ($spec->{isa}
 163       ? "    {\n      my \$value = ".$get_value.";\n      "
 164         .$self->_generate_isa_check(
 165           $name, '$value', $spec->{isa}
 166         ).";\n"
 167         .'      '.$self->_generate_simple_set($me, $name, '$value').";\n"
 168         ."    }\n"
 169       : '    '.$self->_generate_simple_set($me, $name, $get_value).";\n"
 170     )
 171     .($spec->{trigger}
 172       ? '    '
 173         .$self->_generate_trigger(
 174           $name, $me, $self->_generate_simple_get($me, $name),
 175           $spec->{trigger}
 176         )." if ${test};\n"
 177       : ''
 178     );
 179   } else {
 180     "    if (${test}) {\n"
 181       .($spec->{isa}
 182         ? "      "
 183           .$self->_generate_isa_check(
 184             $name, $source, $spec->{isa}
 185           ).";\n"
 186         : ""
 187       )
 188       ."      ".$self->_generate_simple_set($me, $name, $source).";\n"
 189       .($spec->{trigger}
 190         ? "      "
 191           .$self->_generate_trigger(
 192             $name, $me, $self->_generate_simple_get($me, $name),
 193             $spec->{trigger}
 194           ).";\n"
 195         : ""
 196       )
 197       ."    }\n";
 198   }
 199 }
 200
 201 sub generate_multi_set {
 202   my ($self, $me, $to_set, $from) = @_;
 203   "\@{${me}}{qw(${\join ' ', @$to_set})} = $from";
 204 }
 205
 206 sub generate_simple_set {
 207   my $self = shift;
 208   local $self->{captures} = {};
 209   my $code = $self->_generate_simple_set(@_);
 210   return ($code, $self->{captures});
 211 }
 212
 213 sub _generate_simple_set {
 214   my ($self, $me, $name, $value) = @_;
 215   my $name_str = perlstring $name;
 216   "${me}->{${name_str}} = ${value}";
 217 }
 218
 219 sub _generate_getset {
 220   my ($self, $name, $spec) = @_;
 221   q{(@_ > 1 ? }.$self->_generate_set($name, q{$_[1]}, $spec)
 222     .' : '.$self->_generate_get($name).')';
 223 }
 224
 225 1;