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