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