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     !$ENV{MOO_XS_DISABLE}
  11       &&
  12     _maybe_load_module('Class::XSAccessor')
  13       &&
  14     (eval { Class::XSAccessor->VERSION('1.07') })
  15   ;
  16 }
  17
  18 sub generate_method {
  19   my ($self, $into, $name, $spec, $quote_opts) = @_;
  20   die "Must have an is" unless my $is = $spec->{is};
  21   if ($is eq 'ro') {
  22     $spec->{reader} = $name unless exists $spec->{reader};
  23   } elsif ($is eq 'rw') {
  24     $spec->{accessor} = $name unless exists $spec->{accessor};
  25   } elsif ($is eq 'lazy') {
  26     $spec->{init_arg} = undef unless exists $spec->{init_arg};
  27     $spec->{reader} = $name unless exists $spec->{reader};
  28     $spec->{lazy} = 1;
  29     $spec->{builder} ||= '_build_'.$name unless $spec->{default};
  30   } elsif ($is ne 'bare') {
  31     die "Unknown is ${is}";
  32   }
  33   my %methods;
  34   if (my $reader = $spec->{reader}) {
  35     if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
  36       $methods{$reader} = $self->_generate_xs(
  37         getters => $into, $reader, $name
  38       );
  39     } else {
  40       $self->{captures} = {};
  41       $methods{$reader} =
  42         quote_sub "${into}::${reader}"
  43           => '    die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n"
  44              .$self->_generate_get($name, $spec)
  45           => delete $self->{captures}
  46         ;
  47     }
  48   }
  49   if (my $accessor = $spec->{accessor}) {
  50     if (
  51       our $CAN_HAZ_XS
  52       && $self->is_simple_get($name, $spec)
  53       && $self->is_simple_set($name, $spec)
  54     ) {
  55       $methods{$accessor} = $self->_generate_xs(
  56         accessors => $into, $accessor, $name
  57       );
  58     } else {
  59       $self->{captures} = {};
  60       $methods{$accessor} =
  61         quote_sub "${into}::${accessor}"
  62           => $self->_generate_getset($name, $spec)
  63           => delete $self->{captures}
  64         ;
  65     }
  66   }
  67   if (my $writer = $spec->{writer}) {
  68     if (
  69       our $CAN_HAZ_XS
  70       && $self->is_simple_set($name, $spec)
  71     ) {
  72       $methods{$writer} = $self->_generate_xs(
  73         setters => $into, $writer, $name
  74       );
  75     } else {
  76       $self->{captures} = {};
  77       $methods{$writer} =
  78         quote_sub "${into}::${writer}"
  79           => $self->_generate_set($name, $spec)
  80           => delete $self->{captures}
  81         ;
  82     }
  83   }
  84   if (my $pred = $spec->{predicate}) {
  85     $methods{$pred} =
  86       quote_sub "${into}::${pred}" =>
  87         '    '.$self->_generate_simple_has('$_[0]', $name)."\n"
  88       ;
  89   }
  90   if (my $cl = $spec->{clearer}) {
  91     $methods{$cl} =
  92       quote_sub "${into}::${cl}" =>
  93         "    delete \$_[0]->{${\perlstring $name}}\n"
  94       ;
  95   }
  96   if (my $hspec = $spec->{handles}) {
  97     my $asserter = $spec->{asserter} ||= '_assert_'.$name;
  98     my @specs = do {
  99       if (ref($hspec) eq 'ARRAY') {
 100         map [ $_ => $_ ], @$hspec;
 101       } elsif (ref($hspec) eq 'HASH') {
 102         map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ],
 103           keys %$hspec;
 104       } elsif (!ref($hspec)) {
 105         map [ $_ => $_ ], Role::Tiny->methods_provided_by($hspec);
 106       } else {
 107         die "You gave me a handles of ${hspec} and I have no idea why";
 108       }
 109     };
 110     foreach my $spec (@specs) {
 111       my ($proxy, $target, @args) = @$spec;
 112       $self->{captures} = {};
 113       $methods{$proxy} =
 114         quote_sub "${into}::${proxy}" =>
 115           $self->_generate_delegation($asserter, $target, \@args),
 116           delete $self->{captures}
 117         ;
 118     }
 119   }
 120   if (my $asserter = $spec->{asserter}) {
 121     $self->{captures} = {};
 122     $methods{$asserter} =
 123       quote_sub "${into}::${asserter}" =>
 124         'do { '.$self->_generate_get($name, $spec).qq! }||die "Attempted to access '${name}' but it is not set"!,
 125         delete $self->{captures}
 126       ;
 127   }
 128   \%methods;
 129 }
 130
 131 sub is_simple_attribute {
 132   my ($self, $name, $spec) = @_;
 133   # clearer doesn't have to be listed because it doesn't
 134   # affect whether defined/exists makes a difference
 135   !grep $spec->{$_},
 136     qw(lazy default builder coerce isa trigger predicate weak_ref);
 137 }
 138
 139 sub is_simple_get {
 140   my ($self, $name, $spec) = @_;
 141   !($spec->{lazy} and ($spec->{default} or $spec->{builder}));
 142 }
 143
 144 sub is_simple_set {
 145   my ($self, $name, $spec) = @_;
 146   !grep $spec->{$_}, qw(coerce isa trigger weak_ref);
 147 }
 148
 149 sub has_eager_default {
 150   my ($self, $name, $spec) = @_;
 151   (!$spec->{lazy} and ($spec->{default} or $spec->{builder}));
 152 }
 153
 154 sub _generate_get {
 155   my ($self, $name, $spec) = @_;
 156   my $simple = $self->_generate_simple_get('$_[0]', $name);
 157   if ($self->is_simple_get($name, $spec)) {
 158     $simple;
 159   } else {
 160     'do { '.$self->_generate_use_default(
 161       '$_[0]', $name, $spec,
 162       $self->_generate_simple_has('$_[0]', $name),
 163     ).'; '.$simple.' }';
 164   }
 165 }
 166
 167 sub _generate_simple_has {
 168   my ($self, $me, $name) = @_;
 169   "exists ${me}->{${\perlstring $name}}";
 170 }
 171
 172 sub generate_get_default {
 173   my $self = shift;
 174   $self->{captures} = {};
 175   my $code = $self->_generate_get_default(@_);
 176   ($code, delete $self->{captures});
 177 }
 178
 179 sub _generate_use_default {
 180   my ($self, $me, $name, $spec, $test) = @_;
 181   $self->_generate_simple_set(
 182     $me, $name, $spec, $self->_generate_get_default($me, $name, $spec)
 183   ).' unless '.$test;
 184 }
 185
 186 sub _generate_get_default {
 187   my ($self, $me, $name, $spec) = @_;
 188   $spec->{default}
 189     ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
 190     : "${me}->${\$spec->{builder}}"
 191 }
 192
 193 sub generate_simple_get {
 194   my ($self, @args) = @_;
 195   $self->_generate_simple_get(@args);
 196 }
 197
 198 sub _generate_simple_get {
 199   my ($self, $me, $name) = @_;
 200   my $name_str = perlstring $name;
 201   "${me}->{${name_str}}";
 202 }
 203
 204 sub _generate_set {
 205   my ($self, $name, $spec) = @_;
 206   if ($self->is_simple_set($name, $spec)) {
 207     $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]');
 208   } else {
 209     my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
 210     my $simple = $self->_generate_simple_set('$self', $name, $spec, '$value');
 211     my $code = "do { my (\$self, \$value) = \@_;\n";
 212     if ($coerce) {
 213       $code .=
 214         "        \$value = "
 215         .$self->_generate_coerce($name, '$self', '$value', $coerce).";\n";
 216     }
 217     if ($isa_check) {
 218       $code .=
 219         "        ".$self->_generate_isa_check($name, '$value', $isa_check).";\n";
 220     }
 221     if ($trigger) {
 222       my $fire = $self->_generate_trigger($name, '$self', '$value', $trigger);
 223       $code .=
 224         "        ".$simple.";\n        ".$fire.";\n"
 225         ."        \$value;\n";
 226     } else {
 227       $code .= "        ".$simple.";\n";
 228     }
 229     $code .= "      }";
 230     $code;
 231   }
 232 }
 233
 234 sub generate_coerce {
 235   my $self = shift;
 236   $self->{captures} = {};
 237   my $code = $self->_generate_coerce(@_);
 238   ($code, delete $self->{captures});
 239 }
 240
 241 sub _generate_coerce {
 242   my ($self, $name, $obj, $value, $coerce) = @_;
 243   $self->_generate_call_code($name, 'coerce', "${value}", $coerce);
 244 }
 245
 246 sub generate_trigger {
 247   my $self = shift;
 248   $self->{captures} = {};
 249   my $code = $self->_generate_trigger(@_);
 250   ($code, delete $self->{captures});
 251 }
 252
 253 sub _generate_trigger {
 254   my ($self, $name, $obj, $value, $trigger) = @_;
 255   $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
 256 }
 257
 258 sub generate_isa_check {
 259   my ($self, @args) = @_;
 260   $self->{captures} = {};
 261   my $code = $self->_generate_isa_check(@args);
 262   ($code, delete $self->{captures});
 263 }
 264
 265 sub _generate_isa_check {
 266   my ($self, $name, $value, $check) = @_;
 267   $self->_generate_call_code($name, 'isa_check', $value, $check);
 268 }
 269
 270 sub _generate_call_code {
 271   my ($self, $name, $type, $values, $sub) = @_;
 272   if (my $quoted = quoted_from_sub($sub)) {
 273     my $code = $quoted->[1];
 274     my $at_ = '@_ = ('.$values.');';
 275     if (my $captures = $quoted->[2]) {
 276       my $cap_name = qq{\$${type}_captures_for_${name}};
 277       $self->{captures}->{$cap_name} = \$captures;
 278       Sub::Quote::inlinify(
 279         $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6)
 280       );
 281     } else {
 282       Sub::Quote::inlinify($code, $values);
 283     }
 284   } else {
 285     my $cap_name = qq{\$${type}_for_${name}};
 286     $self->{captures}->{$cap_name} = \$sub;
 287     "${cap_name}->(${values})";
 288   }
 289 }
 290
 291 sub generate_populate_set {
 292   my $self = shift;
 293   $self->{captures} = {};
 294   my $code = $self->_generate_populate_set(@_);
 295   ($code, delete $self->{captures});
 296 }
 297
 298 sub _generate_populate_set {
 299   my ($self, $me, $name, $spec, $source, $test) = @_;
 300   if ($self->has_eager_default($name, $spec)) {
 301     my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
 302     my $get_default = $self->_generate_get_default(
 303                         '$new', $_, $spec
 304                       );
 305     my $get_value =
 306       defined($spec->{init_arg})
 307         ? "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
 308             .$get_default
 309             ."\n${get_indent})"
 310         : $get_default;
 311     if ( $spec->{coerce} ) {
 312         $get_value = $self->_generate_coerce(
 313             $name, $me, $get_value,
 314             $spec->{coerce}
 315           )
 316     }
 317     ($spec->{isa}
 318       ? "    {\n      my \$value = ".$get_value.";\n      "
 319         .$self->_generate_isa_check(
 320           $name, '$value', $spec->{isa}
 321         ).";\n"
 322         .'      '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n"
 323         ."    }\n"
 324       : '    '.$self->_generate_simple_set($me, $name, $spec, $get_value).";\n"
 325     )
 326     .($spec->{trigger}
 327       ? '    '
 328         .$self->_generate_trigger(
 329           $name, $me, $self->_generate_simple_get($me, $name),
 330           $spec->{trigger}
 331         )." if ${test};\n"
 332       : ''
 333     );
 334   } else {
 335     "    if (${test}) {\n"
 336       .($spec->{coerce}
 337         ? "      $source = "
 338           .$self->_generate_coerce(
 339             $name, $me, $source,
 340             $spec->{coerce}
 341           ).";\n"
 342         : ""
 343       )
 344       .($spec->{isa}
 345         ? "      "
 346           .$self->_generate_isa_check(
 347             $name, $source, $spec->{isa}
 348           ).";\n"
 349         : ""
 350       )
 351       ."      ".$self->_generate_simple_set($me, $name, $spec, $source).";\n"
 352       .($spec->{trigger}
 353         ? "      "
 354           .$self->_generate_trigger(
 355             $name, $me, $self->_generate_simple_get($me, $name),
 356             $spec->{trigger}
 357           ).";\n"
 358         : ""
 359       )
 360       ."    }\n";
 361   }
 362 }
 363
 364 sub generate_multi_set {
 365   my ($self, $me, $to_set, $from) = @_;
 366   "\@{${me}}{qw(${\join ' ', @$to_set})} = $from";
 367 }
 368
 369 sub _generate_simple_set {
 370   my ($self, $me, $name, $spec, $value) = @_;
 371   my $name_str = perlstring $name;
 372   my $simple = "${me}->{${name_str}} = ${value}";
 373
 374   if ($spec->{weak_ref}) {
 375     require Scalar::Util;
 376
 377     # Perl < 5.8.3 can't weaken refs to readonly vars
 378     # (e.g. string constants). This *can* be solved by:
 379     #
 380     #Internals::SetReadWrite($foo);
 381     #Scalar::Util::weaken ($foo);
 382     #Internals::SetReadOnly($foo);
 383     #
 384     # but requires XS and is just too damn crazy
 385     # so simply throw a better exception
 386     Moo::_Utils::lt_5_8_3() ? <<"EOC" : "Scalar::Util::weaken(${simple})";
 387
 388       eval { Scalar::Util::weaken($simple); 1 } or do {
 389         if( \$@ =~ /Modification of a read-only value attempted/) {
 390           require Carp;
 391           Carp::croak( sprintf (
 392             'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
 393             $name_str,
 394           ) );
 395         } else {
 396           die \$@;
 397         }
 398       };
 399 EOC
 400   } else {
 401     $simple;
 402   }
 403 }
 404
 405 sub _generate_getset {
 406   my ($self, $name, $spec) = @_;
 407   q{(@_ > 1}."\n      ? ".$self->_generate_set($name, $spec)
 408     ."\n      : ".$self->_generate_get($name, $spec)."\n    )";
 409 }
 410
 411 sub _generate_delegation {
 412   my ($self, $asserter, $target, $args) = @_;
 413   my $arg_string = do {
 414     if (@$args) {
 415       # I could, I reckon, linearise out non-refs here using perlstring
 416       # plus something to check for numbers but I'm unsure if it's worth it
 417       $self->{captures}{'@curries'} = $args;
 418       '@curries, @_';
 419     } else {
 420       '@_';
 421     }
 422   };
 423   "shift->${asserter}->${target}(${arg_string});";
 424 }
 425
 426 sub _generate_xs {
 427   my ($self, $type, $into, $name, $slot) = @_;
 428   Class::XSAccessor->import(
 429     class => $into,
 430     $type => { $name => $slot }
 431   );
 432   $into->can($name);
 433 }
 434
 435 1;