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