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       die "Invalid builder for $into->$name - not a method name, coderef or"
  60         . " code-convertible object"
  61         unless ref $spec->{builder} eq 'CODE'
  62         or (blessed($spec->{builder}) and eval { \&{$spec->{builder}} });
  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, $me, $name) = @_;
 253   "exists ${me}->{${\perlstring $name}}";
 254 }
 255
 256 sub _generate_simple_clear {
 257   my ($self, $me, $name) = @_;
 258   "    delete ${me}->{${\perlstring $name}}\n"
 259 }
 260
 261 sub generate_get_default {
 262   my $self = shift;
 263   $self->{captures} = {};
 264   my $code = $self->_generate_get_default(@_);
 265   ($code, delete $self->{captures});
 266 }
 267
 268 sub _generate_use_default {
 269   my ($self, $me, $name, $spec, $test) = @_;
 270   my $get_value = $self->_generate_get_default($me, $name, $spec);
 271   if ($spec->{coerce}) {
 272     $get_value = $self->_generate_coerce(
 273       $name, $get_value,
 274       $spec->{coerce}
 275     )
 276   }
 277   $test." ? \n"
 278   .$self->_generate_simple_get($me, $name, $spec)."\n:"
 279   .($spec->{isa}
 280     ? "    do {\n      my \$value = ".$get_value.";\n"
 281       ."      ".$self->_generate_isa_check($name, '$value', $spec->{isa}).";\n"
 282       ."      ".$self->_generate_simple_set($me, $name, $spec, '$value')."\n"
 283       ."    }\n"
 284     : '    ('.$self->_generate_simple_set($me, $name, $spec, $get_value).")\n");
 285 }
 286
 287 sub _generate_get_default {
 288   my ($self, $me, $name, $spec) = @_;
 289   if (exists $spec->{default}) {
 290     ref $spec->{default}
 291       ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
 292       : perlstring $spec->{default};
 293   }
 294   else {
 295     "${me}->${\$spec->{builder}}"
 296   }
 297 }
 298
 299 sub generate_simple_get {
 300   my ($self, @args) = @_;
 301   $self->_generate_simple_get(@args);
 302 }
 303
 304 sub _generate_simple_get {
 305   my ($self, $me, $name) = @_;
 306   my $name_str = perlstring $name;
 307   "${me}->{${name_str}}";
 308 }
 309
 310 sub _generate_set {
 311   my ($self, $name, $spec) = @_;
 312   if ($self->is_simple_set($name, $spec)) {
 313     $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]');
 314   } else {
 315     my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
 316     my $value_store = '$_[0]';
 317     my $code;
 318     if ($coerce) {
 319       $value_store = '$value';
 320       $code = "do { my (\$self, \$value) = \@_;\n"
 321         ."        \$value = "
 322         .$self->_generate_coerce($name, $value_store, $coerce).";\n";
 323     }
 324     else {
 325       $code = "do { my \$self = shift;\n";
 326     }
 327     if ($isa_check) {
 328       $code .=
 329         "        ".$self->_generate_isa_check($name, $value_store, $isa_check).";\n";
 330     }
 331     my $simple = $self->_generate_simple_set('$self', $name, $spec, $value_store);
 332     if ($trigger) {
 333       my $fire = $self->_generate_trigger($name, '$self', $value_store, $trigger);
 334       $code .=
 335         "        ".$simple.";\n        ".$fire.";\n"
 336         ."        $value_store;\n";
 337     } else {
 338       $code .= "        ".$simple.";\n";
 339     }
 340     $code .= "      }";
 341     $code;
 342   }
 343 }
 344
 345 sub generate_coerce {
 346   my $self = shift;
 347   $self->{captures} = {};
 348   my $code = $self->_generate_coerce(@_);
 349   ($code, delete $self->{captures});
 350 }
 351
 352 sub _attr_desc {
 353   my ($name, $init_arg) = @_;
 354   return perlstring($name) if !defined($init_arg) or $init_arg eq $name;
 355   return perlstring($name).' (constructor argument: '.perlstring($init_arg).')';
 356 }
 357
 358 sub _generate_coerce {
 359   my ($self, $name, $value, $coerce, $init_arg) = @_;
 360   $self->_generate_die_prefix(
 361     $name,
 362     "coercion",
 363     $init_arg,
 364     $self->_generate_call_code($name, 'coerce', "${value}", $coerce)
 365   );
 366 }
 367
 368 sub generate_trigger {
 369   my $self = shift;
 370   $self->{captures} = {};
 371   my $code = $self->_generate_trigger(@_);
 372   ($code, delete $self->{captures});
 373 }
 374
 375 sub _generate_trigger {
 376   my ($self, $name, $obj, $value, $trigger) = @_;
 377   $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
 378 }
 379
 380 sub generate_isa_check {
 381   my ($self, @args) = @_;
 382   $self->{captures} = {};
 383   my $code = $self->_generate_isa_check(@args);
 384   ($code, delete $self->{captures});
 385 }
 386
 387 sub _generate_die_prefix {
 388   my ($self, $name, $prefix, $arg, $inside) = @_;
 389   "do {\n"
 390   .'  local $Method::Generate::Accessor::CurrentAttribute = {'
 391   .'    init_arg => '.(defined $arg ? B::perlstring($arg) : 'undef') . ",\n"
 392   .'    name     => '.B::perlstring($name).",\n"
 393   .'    step     => '.B::perlstring($prefix).",\n"
 394   ."  };\n"
 395   .'  local $Method::Generate::Accessor::OrigSigDie = $SIG{__DIE__};'."\n"
 396   .'  local $SIG{__DIE__} = \&Method::Generate::Accessor::_SIGDIE;'."\n"
 397   .$inside
 398   ."}\n"
 399 }
 400
 401 sub _generate_isa_check {
 402   my ($self, $name, $value, $check, $init_arg) = @_;
 403   $self->_generate_die_prefix(
 404     $name,
 405     "isa check",
 406     $init_arg,
 407     $self->_generate_call_code($name, 'isa_check', $value, $check)
 408   );
 409 }
 410
 411 sub _generate_call_code {
 412   my ($self, $name, $type, $values, $sub) = @_;
 413   $sub = \&{$sub} if blessed($sub);  # coderef if blessed
 414   if (my $quoted = quoted_from_sub($sub)) {
 415     my $local = 1;
 416     if ($values eq '@_' || $values eq '$_[0]') {
 417       $local = 0;
 418       $values = '@_';
 419     }
 420     my $code = $quoted->[1];
 421     if (my $captures = $quoted->[2]) {
 422       my $cap_name = qq{\$${type}_captures_for_${name}};
 423       $self->{captures}->{$cap_name} = \$captures;
 424       Sub::Quote::inlinify(
 425         $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6), $local
 426       );
 427     } else {
 428       Sub::Quote::inlinify($code, $values, undef, $local);
 429     }
 430   } else {
 431     my $cap_name = qq{\$${type}_for_${name}};
 432     $self->{captures}->{$cap_name} = \$sub;
 433     "${cap_name}->(${values})";
 434   }
 435 }
 436
 437 sub generate_populate_set {
 438   my $self = shift;
 439   $self->{captures} = {};
 440   my $code = $self->_generate_populate_set(@_);
 441   ($code, delete $self->{captures});
 442 }
 443
 444 sub _generate_populate_set {
 445   my ($self, $me, $name, $spec, $source, $test, $init_arg) = @_;
 446   if ($self->has_eager_default($name, $spec)) {
 447     my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
 448     my $get_default = $self->_generate_get_default(
 449                         '$new', $_, $spec
 450                       );
 451     my $get_value =
 452       defined($spec->{init_arg})
 453         ? "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
 454             .$get_default
 455             ."\n${get_indent})"
 456         : $get_default;
 457     if ($spec->{coerce}) {
 458       $get_value = $self->_generate_coerce(
 459         $name, $get_value,
 460         $spec->{coerce}, $init_arg
 461       )
 462     }
 463     ($spec->{isa}
 464       ? "    {\n      my \$value = ".$get_value.";\n      "
 465         .$self->_generate_isa_check(
 466           $name, '$value', $spec->{isa}, $init_arg
 467         ).";\n"
 468         .'      '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n"
 469         ."    }\n"
 470       : '    '.$self->_generate_simple_set($me, $name, $spec, $get_value).";\n"
 471     )
 472     .($spec->{trigger}
 473       ? '    '
 474         .$self->_generate_trigger(
 475           $name, $me, $self->_generate_simple_get($me, $name, $spec),
 476           $spec->{trigger}
 477         )." if ${test};\n"
 478       : ''
 479     );
 480   } else {
 481     "    if (${test}) {\n"
 482       .($spec->{coerce}
 483         ? "      $source = "
 484           .$self->_generate_coerce(
 485             $name, $source,
 486             $spec->{coerce}, $init_arg
 487           ).";\n"
 488         : ""
 489       )
 490       .($spec->{isa}
 491         ? "      "
 492           .$self->_generate_isa_check(
 493             $name, $source, $spec->{isa}, $init_arg
 494           ).";\n"
 495         : ""
 496       )
 497       ."      ".$self->_generate_simple_set($me, $name, $spec, $source).";\n"
 498       .($spec->{trigger}
 499         ? "      "
 500           .$self->_generate_trigger(
 501             $name, $me, $self->_generate_simple_get($me, $name, $spec),
 502             $spec->{trigger}
 503           ).";\n"
 504         : ""
 505       )
 506       ."    }\n";
 507   }
 508 }
 509
 510 sub _generate_core_set {
 511   my ($self, $me, $name, $spec, $value) = @_;
 512   my $name_str = perlstring $name;
 513   "${me}->{${name_str}} = ${value}";
 514 }
 515
 516 sub _generate_simple_set {
 517   my ($self, $me, $name, $spec, $value) = @_;
 518   my $name_str = perlstring $name;
 519   my $simple = $self->_generate_core_set($me, $name, $spec, $value);
 520
 521   if ($spec->{weak_ref}) {
 522     require Scalar::Util;
 523     my $get = $self->_generate_simple_get($me, $name, $spec);
 524
 525     # Perl < 5.8.3 can't weaken refs to readonly vars
 526     # (e.g. string constants). This *can* be solved by:
 527     #
 528     #Internals::SetReadWrite($foo);
 529     #Scalar::Util::weaken ($foo);
 530     #Internals::SetReadOnly($foo);
 531     #
 532     # but requires XS and is just too damn crazy
 533     # so simply throw a better exception
 534     my $weak_simple = "do { Scalar::Util::weaken(${simple}); no warnings 'void'; $get }";
 535     Moo::_Utils::lt_5_8_3() ? <<"EOC" : $weak_simple;
 536       eval { Scalar::Util::weaken($simple); 1 }
 537         ? do { no warnings 'void'; $get }
 538         : do {
 539           if( \$@ =~ /Modification of a read-only value attempted/) {
 540             require Carp;
 541             Carp::croak( sprintf (
 542               'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
 543               $name_str,
 544             ) );
 545           } else {
 546             die \$@;
 547           }
 548         }
 549 EOC
 550   } else {
 551     $simple;
 552   }
 553 }
 554
 555 sub _generate_getset {
 556   my ($self, $name, $spec) = @_;
 557   q{(@_ > 1}."\n      ? ".$self->_generate_set($name, $spec)
 558     ."\n      : ".$self->_generate_get($name, $spec)."\n    )";
 559 }
 560
 561 sub _generate_asserter {
 562   my ($self, $name, $spec) = @_;
 563
 564   "do {\n"
 565    ."  my \$val = ".$self->_generate_get($name, $spec).";\n"
 566    ."  unless (".$self->_generate_simple_has('$_[0]', $name, $spec).") {\n"
 567    .qq!    die "Attempted to access '${name}' but it is not set";\n!
 568    ."  }\n"
 569    ."  \$val;\n"
 570    ."}\n";
 571 }
 572 sub _generate_delegation {
 573   my ($self, $asserter, $target, $args) = @_;
 574   my $arg_string = do {
 575     if (@$args) {
 576       # I could, I reckon, linearise out non-refs here using perlstring
 577       # plus something to check for numbers but I'm unsure if it's worth it
 578       $self->{captures}{'@curries'} = $args;
 579       '@curries, @_';
 580     } else {
 581       '@_';
 582     }
 583   };
 584   "shift->${asserter}->${target}(${arg_string});";
 585 }
 586
 587 sub _generate_xs {
 588   my ($self, $type, $into, $name, $slot) = @_;
 589   Class::XSAccessor->import(
 590     class => $into,
 591     $type => { $name => $slot },
 592     replace => 1,
 593   );
 594   $into->can($name);
 595 }
 596
 597 sub default_construction_string { '{}' }
 598
 599 sub _validate_codulatable {
 600   my ($self, $setting, $value, $into, $appended) = @_;
 601   my $invalid = "Invalid $setting '" . overload::StrVal($value)
 602     . "' for $into not a coderef";
 603   $invalid .= " $appended" if $appended;
 604
 605   unless (ref $value and (ref $value eq 'CODE' or blessed($value))) {
 606     die "$invalid or code-convertible object";
 607   }
 608
 609   unless (eval { \&$value }) {
 610     die "$invalid and could not be converted to a coderef: $@";
 611   }
 612
 613   1;
 614 }
 615
 616 1;