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