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