lib/Method/Generate/Accessor.pm

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