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 BEGIN {
   9   our $CAN_HAZ_XS = ($^O ne 'Win32')
  10     && _maybe_load_module('Class::XSAccessor')
  11     && (Class::XSAccessor->VERSION > 1.06);
  12 }
  13
  14 sub generate_method {
  15   my ($self, $into, $name, $spec, $quote_opts) = @_;
  16   die "Must have an is" unless my $is = $spec->{is};
  17   local $self->{captures} = {};
  18   my $body = do {
  19     if ($is eq 'ro') {
  20       if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
  21         $self->_generate_xs_get($into, $name);
  22       } else {
  23         $self->_generate_get($name, $spec)
  24       }
  25     } elsif ($is eq 'rw') {
  26       if (
  27         our $CAN_HAZ_XS
  28         && $self->is_simple_get($name, $spec)
  29         && $self->is_simple_set($name, $spec)
  30       ) {
  31         $self->_generate_xs_getset($into, $name);
  32       } else {
  33         $self->_generate_getset($name, $spec)
  34       }
  35     } else {
  36       die "Unknown is ${is}";
  37     }
  38   };
  39   if (my $pred = $spec->{predicate}) {
  40     quote_sub "${into}::${pred}" =>
  41     '    '.$self->_generate_simple_has('$_[0]', $name)."\n"
  42     ;
  43   }
  44   if (my $cl = $spec->{clearer}) {
  45     quote_sub "${into}::${cl}" =>
  46       "    delete \$_[0]->{${\perlstring $name}}\n"
  47     ;
  48   }
  49   return $body if ref($body); # optimiferised
  50   quote_sub
  51     "${into}::${name}" => '    '.$body."\n",
  52     $self->{captures}, $quote_opts||{}
  53   ;
  54 }
  55
  56 sub is_simple_attribute {
  57   my ($self, $name, $spec) = @_;
  58   # clearer doesn't have to be listed because it doesn't
  59   # affect whether defined/exists makes a difference
  60   return !grep $spec->{$_},
  61     qw(lazy default builder isa trigger predicate);
  62 }
  63
  64 sub is_simple_get {
  65   my ($self, $name, $spec) = @_;
  66   return !($spec->{lazy} and ($spec->{default} or $spec->{builder}));
  67 }
  68
  69 sub is_simple_set {
  70   my ($self, $name, $spec) = @_;
  71   return !grep $spec->{$_}, qw(isa trigger);
  72 }
  73
  74 sub _generate_get {
  75   my ($self, $name, $spec) = @_;
  76   my $simple = $self->_generate_simple_get('$_[0]', $name);
  77   my ($lazy, $default, $builder) = @{$spec}{qw(lazy default builder)};
  78   return $simple unless $lazy and ($default or $builder);
  79   'do { '.$self->_generate_use_default(
  80     '$_[0]', $name, $spec,
  81     $self->_generate_simple_has('$_[0]', $name),
  82   ).'; '.$simple.' }';
  83 }
  84
  85 sub _generate_simple_has {
  86   my ($self, $me, $name) = @_;
  87   "exists ${me}->{${\perlstring $name}}";
  88 }
  89
  90 sub generate_get_default {
  91   my $self = shift;
  92   local $self->{captures} = {};
  93   my $code = $self->_generate_get_default(@_);
  94   return ($code, $self->{captures});
  95 }
  96
  97 sub _generate_use_default {
  98   my ($self, $me, $name, $spec, $test) = @_;
  99   $self->_generate_simple_set(
 100     $me, $name, $self->_generate_get_default($me, $name, $spec)
 101   ).' unless '.$test;
 102 }
 103
 104 sub _generate_get_default {
 105   my ($self, $me, $name, $spec) = @_;
 106   $spec->{default}
 107     ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
 108     : "${me}->${\$spec->{builder}}"
 109 }
 110
 111 sub generate_simple_get {
 112   shift->_generate_simple_get(@_);
 113 }
 114
 115 sub _generate_simple_get {
 116   my ($self, $me, $name) = @_;
 117   my $name_str = perlstring $name;
 118   "${me}->{${name_str}}";
 119 }
 120
 121 sub _generate_set {
 122   my ($self, $name, $value, $spec) = @_;
 123   my $simple = $self->_generate_simple_set('$_[0]', $name, $value);
 124   my ($trigger, $isa_check) = @{$spec}{qw(trigger isa)};
 125   return $simple unless $trigger or $isa_check;
 126   my $code = "do {\n";
 127   if ($isa_check) {
 128     $code .=
 129       "        ".$self->_generate_isa_check($name, '$_[1]', $isa_check).";\n";
 130   }
 131   if ($trigger) {
 132     my $fire = $self->_generate_trigger($name, '$_[0]', '$value', $trigger);
 133     $code .=
 134       "        my \$value = ".$simple.";\n        ".$fire.";\n"
 135       ."        \$value;\n";
 136   } else {
 137     $code .= "        ".$simple.";\n";
 138   }
 139   $code .= "      }";
 140   return $code;
 141 }
 142
 143 sub generate_trigger {
 144   my $self = shift;
 145   local $self->{captures} = {};
 146   my $code = $self->_generate_trigger(@_);
 147   return ($code, $self->{captures});
 148 }
 149
 150 sub _generate_trigger {
 151   my ($self, $name, $obj, $value, $trigger) = @_;
 152   $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
 153 }
 154
 155 sub generate_isa_check {
 156   my $self = shift;
 157   local $self->{captures} = {};
 158   my $code = $self->_generate_isa_check(@_);
 159   return ($code, $self->{captures});
 160 }
 161
 162 sub _generate_isa_check {
 163   my ($self, $name, $value, $check) = @_;
 164   $self->_generate_call_code($name, 'isa_check', $value, $check);
 165 }
 166
 167 sub _generate_call_code {
 168   my ($self, $name, $type, $values, $sub) = @_;
 169   if (my $quoted = quoted_from_sub($sub)) {
 170     my $code = $quoted->[1];
 171     my $at_ = 'local @_ = ('.$values.');';
 172     if (my $captures = $quoted->[2]) {
 173       my $cap_name = qq{\$${type}_captures_for_${name}};
 174       $self->{captures}->{$cap_name} = \$captures;
 175       return "do {\n".'      '.$at_."\n"
 176         .Sub::Quote::capture_unroll($cap_name, $captures, 6)
 177         ."     ${code}\n    }";
 178     }
 179     return 'do { local @_ = ('.$values.'); '.$code.' }';
 180   }
 181   my $cap_name = qq{\$${type}_for_${name}};
 182   $self->{captures}->{$cap_name} = \$sub;
 183   return "${cap_name}->(${values})";
 184 }
 185
 186 sub generate_populate_set {
 187   my $self = shift;
 188   local $self->{captures} = {};
 189   my $code = $self->_generate_populate_set(@_);
 190   return ($code, $self->{captures});
 191 }
 192
 193 sub _generate_populate_set {
 194   my ($self, $me, $name, $spec, $source, $test) = @_;
 195   if (!$spec->{lazy} and
 196         ($spec->{default} or $spec->{builder})) {
 197     my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
 198     my $get_value =
 199       "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
 200         .$self->_generate_get_default(
 201           '$new', $_, $spec
 202         )
 203         ."\n${get_indent})";
 204     ($spec->{isa}
 205       ? "    {\n      my \$value = ".$get_value.";\n      "
 206         .$self->_generate_isa_check(
 207           $name, '$value', $spec->{isa}
 208         ).";\n"
 209         .'      '.$self->_generate_simple_set($me, $name, '$value').";\n"
 210         ."    }\n"
 211       : '    '.$self->_generate_simple_set($me, $name, $get_value).";\n"
 212     )
 213     .($spec->{trigger}
 214       ? '    '
 215         .$self->_generate_trigger(
 216           $name, $me, $self->_generate_simple_get($me, $name),
 217           $spec->{trigger}
 218         )." if ${test};\n"
 219       : ''
 220     );
 221   } else {
 222     "    if (${test}) {\n"
 223       .($spec->{isa}
 224         ? "      "
 225           .$self->_generate_isa_check(
 226             $name, $source, $spec->{isa}
 227           ).";\n"
 228         : ""
 229       )
 230       ."      ".$self->_generate_simple_set($me, $name, $source).";\n"
 231       .($spec->{trigger}
 232         ? "      "
 233           .$self->_generate_trigger(
 234             $name, $me, $self->_generate_simple_get($me, $name),
 235             $spec->{trigger}
 236           ).";\n"
 237         : ""
 238       )
 239       ."    }\n";
 240   }
 241 }
 242
 243 sub generate_multi_set {
 244   my ($self, $me, $to_set, $from) = @_;
 245   "\@{${me}}{qw(${\join ' ', @$to_set})} = $from";
 246 }
 247
 248 sub generate_simple_set {
 249   my $self = shift;
 250   local $self->{captures} = {};
 251   my $code = $self->_generate_simple_set(@_);
 252   return ($code, $self->{captures});
 253 }
 254
 255 sub _generate_simple_set {
 256   my ($self, $me, $name, $value) = @_;
 257   my $name_str = perlstring $name;
 258   "${me}->{${name_str}} = ${value}";
 259 }
 260
 261 sub _generate_getset {
 262   my ($self, $name, $spec) = @_;
 263   q{(@_ > 1}."\n      ? ".$self->_generate_set($name, q{$_[1]}, $spec)
 264     ."\n      : ".$self->_generate_get($name)."\n    )";
 265 }
 266
 267 sub _generate_xs_get {
 268   shift->_generate_xs('getters', @_);
 269 }
 270
 271 sub _generate_xs_getset {
 272   shift->_generate_xs('accessors', @_);
 273 }
 274
 275 sub _generate_xs {
 276   my ($self, $type, $into, $name) = @_;
 277   no strict 'refs';
 278   Class::XSAccessor->import(
 279     class => $into,
 280     $type => { $name => $name }
 281   );
 282   return $into->can($name);
 283 }
 284
 285 1;