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