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