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