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       $methods{$proxy} =
 170         quote_sub "${into}::${proxy}" =>
 171           $self->_generate_delegation($asserter, $target, \@args),
 172           delete $self->{captures}
 173         ;
 174     }
 175   }
 176   if (my $asserter = $spec->{asserter}) {
 177     $self->{captures} = {};
 178
 179     my $code = "do {\n"
 180                ."  my \$val = ".$self->_generate_get($name, $spec).";\n"
 181                ."  unless (".$self->_generate_simple_has('$_[0]', $name).") {\n"
 182                .qq!    die "Attempted to access '${name}' but it is not set";\n!
 183                ."  }\n"
 184                ."  \$val;\n"
 185                ."}\n";
 186
 187     $methods{$asserter} =
 188       quote_sub "${into}::${asserter}" => $code,
 189         delete $self->{captures}
 190       ;
 191   }
 192   \%methods;
 193 }
 194
 195 sub is_simple_attribute {
 196   my ($self, $name, $spec) = @_;
 197   # clearer doesn't have to be listed because it doesn't
 198   # affect whether defined/exists makes a difference
 199   !grep $spec->{$_},
 200     qw(lazy default builder coerce isa trigger predicate weak_ref);
 201 }
 202
 203 sub is_simple_get {
 204   my ($self, $name, $spec) = @_;
 205   !($spec->{lazy} and ($spec->{default} or $spec->{builder}));
 206 }
 207
 208 sub is_simple_set {
 209   my ($self, $name, $spec) = @_;
 210   !grep $spec->{$_}, qw(coerce isa trigger weak_ref);
 211 }
 212
 213 sub has_eager_default {
 214   my ($self, $name, $spec) = @_;
 215   (!$spec->{lazy} and ($spec->{default} or $spec->{builder}));
 216 }
 217
 218 sub _generate_get {
 219   my ($self, $name, $spec) = @_;
 220   my $simple = $self->_generate_simple_get('$_[0]', $name, $spec);
 221   if ($self->is_simple_get($name, $spec)) {
 222     $simple;
 223   } else {
 224     'do { '.$self->_generate_use_default(
 225       '$_[0]', $name, $spec,
 226       $self->_generate_simple_has('$_[0]', $name, $spec),
 227     ).'; '
 228     .($spec->{isa}
 229       ?($self->_generate_isa_check($name, $simple, $spec->{isa}).'; ')
 230       :''
 231     )
 232     .$simple.' }';
 233   }
 234 }
 235
 236 sub _generate_simple_has {
 237   my ($self, $me, $name) = @_;
 238   "exists ${me}->{${\perlstring $name}}";
 239 }
 240
 241 sub _generate_simple_clear {
 242   my ($self, $me, $name) = @_;
 243   "    delete ${me}->{${\perlstring $name}}\n"
 244 }
 245
 246 sub generate_get_default {
 247   my $self = shift;
 248   $self->{captures} = {};
 249   my $code = $self->_generate_get_default(@_);
 250   ($code, delete $self->{captures});
 251 }
 252
 253 sub _generate_use_default {
 254   my ($self, $me, $name, $spec, $test) = @_;
 255   my $get_value = $self->_generate_get_default($me, $name, $spec);
 256   if ($spec->{coerce}) {
 257     $get_value = $self->_generate_coerce(
 258       $name, $get_value,
 259       $spec->{coerce}
 260     )
 261   }
 262   $self->_generate_simple_set(
 263     $me, $name, $spec, $get_value
 264   ).' unless '.$test;
 265 }
 266
 267 sub _generate_get_default {
 268   my ($self, $me, $name, $spec) = @_;
 269   if (exists $spec->{default}) {
 270     ref $spec->{default}
 271       ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
 272       : perlstring $spec->{default};
 273   }
 274   else {
 275     "${me}->${\$spec->{builder}}"
 276   }
 277 }
 278
 279 sub generate_simple_get {
 280   my ($self, @args) = @_;
 281   $self->_generate_simple_get(@args);
 282 }
 283
 284 sub _generate_simple_get {
 285   my ($self, $me, $name) = @_;
 286   my $name_str = perlstring $name;
 287   "${me}->{${name_str}}";
 288 }
 289
 290 sub _generate_set {
 291   my ($self, $name, $spec) = @_;
 292   if ($self->is_simple_set($name, $spec)) {
 293     $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]');
 294   } else {
 295     my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
 296     my $simple = $self->_generate_simple_set('$self', $name, $spec, '$value');
 297     my $code = "do { my (\$self, \$value) = \@_;\n";
 298     if ($coerce) {
 299       $code .=
 300         "        \$value = "
 301         .$self->_generate_coerce($name, '$value', $coerce).";\n";
 302     }
 303     if ($isa_check) {
 304       $code .=
 305         "        ".$self->_generate_isa_check($name, '$value', $isa_check).";\n";
 306     }
 307     if ($trigger) {
 308       my $fire = $self->_generate_trigger($name, '$self', '$value', $trigger);
 309       $code .=
 310         "        ".$simple.";\n        ".$fire.";\n"
 311         ."        \$value;\n";
 312     } else {
 313       $code .= "        ".$simple.";\n";
 314     }
 315     $code .= "      }";
 316     $code;
 317   }
 318 }
 319
 320 sub generate_coerce {
 321   my $self = shift;
 322   $self->{captures} = {};
 323   my $code = $self->_generate_coerce(@_);
 324   ($code, delete $self->{captures});
 325 }
 326
 327 sub _attr_desc {
 328   my ($name, $init_arg) = @_;
 329   return perlstring($name) if !defined($init_arg) or $init_arg eq $name;
 330   return perlstring($name).' (constructor argument: '.perlstring($init_arg).')';
 331 }
 332
 333 sub _generate_coerce {
 334   my ($self, $name, $value, $coerce, $init_arg) = @_;
 335   $self->_generate_die_prefix(
 336     "coercion for ${\_attr_desc($name, $init_arg)} failed: ",
 337     $self->_generate_call_code($name, 'coerce', "${value}", $coerce)
 338   );
 339 }
 340
 341 sub generate_trigger {
 342   my $self = shift;
 343   $self->{captures} = {};
 344   my $code = $self->_generate_trigger(@_);
 345   ($code, delete $self->{captures});
 346 }
 347
 348 sub _generate_trigger {
 349   my ($self, $name, $obj, $value, $trigger) = @_;
 350   $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
 351 }
 352
 353 sub generate_isa_check {
 354   my ($self, @args) = @_;
 355   $self->{captures} = {};
 356   my $code = $self->_generate_isa_check(@args);
 357   ($code, delete $self->{captures});
 358 }
 359
 360 sub _generate_die_prefix {
 361   my ($self, $prefix, $inside) = @_;
 362   "do {\n"
 363   .'  my $sig_die = $SIG{__DIE__} || sub { die $_[0] };'."\n"
 364   .'  local $SIG{__DIE__} = sub {'."\n"
 365   .'    $sig_die->(ref($_[0]) ? $_[0] : '.perlstring($prefix).'.$_[0]);'."\n"
 366   .'  };'."\n"
 367   .$inside
 368   ."}\n"
 369 }
 370
 371 sub _generate_isa_check {
 372   my ($self, $name, $value, $check, $init_arg) = @_;
 373   $self->_generate_die_prefix(
 374     "isa check for ${\_attr_desc($name, $init_arg)} failed: ",
 375     $self->_generate_call_code($name, 'isa_check', $value, $check)
 376   );
 377 }
 378
 379 sub _generate_call_code {
 380   my ($self, $name, $type, $values, $sub) = @_;
 381   if (my $quoted = quoted_from_sub($sub)) {
 382     my $code = $quoted->[1];
 383     if (my $captures = $quoted->[2]) {
 384       my $cap_name = qq{\$${type}_captures_for_${name}};
 385       $self->{captures}->{$cap_name} = \$captures;
 386       Sub::Quote::inlinify(
 387         $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6), 1
 388       );
 389     } else {
 390       Sub::Quote::inlinify($code, $values, undef, 1);
 391     }
 392   } else {
 393     my $cap_name = qq{\$${type}_for_${name}};
 394     $self->{captures}->{$cap_name} = \$sub;
 395     "${cap_name}->(${values})";
 396   }
 397 }
 398
 399 sub generate_populate_set {
 400   my $self = shift;
 401   $self->{captures} = {};
 402   my $code = $self->_generate_populate_set(@_);
 403   ($code, delete $self->{captures});
 404 }
 405
 406 sub _generate_populate_set {
 407   my ($self, $me, $name, $spec, $source, $test, $init_arg) = @_;
 408   if ($self->has_eager_default($name, $spec)) {
 409     my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
 410     my $get_default = $self->_generate_get_default(
 411                         '$new', $_, $spec
 412                       );
 413     my $get_value =
 414       defined($spec->{init_arg})
 415         ? "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
 416             .$get_default
 417             ."\n${get_indent})"
 418         : $get_default;
 419     if ($spec->{coerce}) {
 420       $get_value = $self->_generate_coerce(
 421         $name, $get_value,
 422         $spec->{coerce}, $init_arg
 423       )
 424     }
 425     ($spec->{isa}
 426       ? "    {\n      my \$value = ".$get_value.";\n      "
 427         .$self->_generate_isa_check(
 428           $name, '$value', $spec->{isa}, $init_arg
 429         ).";\n"
 430         .'      '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n"
 431         ."    }\n"
 432       : '    '.$self->_generate_simple_set($me, $name, $spec, $get_value).";\n"
 433     )
 434     .($spec->{trigger}
 435       ? '    '
 436         .$self->_generate_trigger(
 437           $name, $me, $self->_generate_simple_get($me, $name, $spec),
 438           $spec->{trigger}
 439         )." if ${test};\n"
 440       : ''
 441     );
 442   } else {
 443     "    if (${test}) {\n"
 444       .($spec->{coerce}
 445         ? "      $source = "
 446           .$self->_generate_coerce(
 447             $name, $source,
 448             $spec->{coerce}, $init_arg
 449           ).";\n"
 450         : ""
 451       )
 452       .($spec->{isa}
 453         ? "      "
 454           .$self->_generate_isa_check(
 455             $name, $source, $spec->{isa}, $init_arg
 456           ).";\n"
 457         : ""
 458       )
 459       ."      ".$self->_generate_simple_set($me, $name, $spec, $source).";\n"
 460       .($spec->{trigger}
 461         ? "      "
 462           .$self->_generate_trigger(
 463             $name, $me, $self->_generate_simple_get($me, $name, $spec),
 464             $spec->{trigger}
 465           ).";\n"
 466         : ""
 467       )
 468       ."    }\n";
 469   }
 470 }
 471
 472 sub _generate_core_set {
 473   my ($self, $me, $name, $spec, $value) = @_;
 474   my $name_str = perlstring $name;
 475   "${me}->{${name_str}} = ${value}";
 476 }
 477
 478 sub _generate_simple_set {
 479   my ($self, $me, $name, $spec, $value) = @_;
 480   my $name_str = perlstring $name;
 481
 482   if ($spec->{weak_ref}) {
 483     $value = '$preserve = '.$value;
 484     my $simple = $self->_generate_core_set($me, $name, $spec, $value);
 485     require Scalar::Util;
 486
 487     # Perl < 5.8.3 can't weaken refs to readonly vars
 488     # (e.g. string constants). This *can* be solved by:
 489     #
 490     #Internals::SetReadWrite($foo);
 491     #Scalar::Util::weaken ($foo);
 492     #Internals::SetReadOnly($foo);
 493     #
 494     # but requires XS and is just too damn crazy
 495     # so simply throw a better exception
 496     my $weak_simple = "my \$preserve; Scalar::Util::weaken(${simple}); no warnings 'void'; \$preserve";
 497     Moo::_Utils::lt_5_8_3() ? <<"EOC" : $weak_simple;
 498
 499       my \$preserve;
 500       eval { Scalar::Util::weaken($simple); 1 }
 501         ? do { no warnings 'void'; \$preserve; }
 502         : do {
 503           if( \$@ =~ /Modification of a read-only value attempted/) {
 504             require Carp;
 505             Carp::croak( sprintf (
 506               'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
 507               $name_str,
 508             ) );
 509           } else {
 510             die \$@;
 511           }
 512         }
 513 EOC
 514   } else {
 515     $self->_generate_core_set($me, $name, $spec, $value);
 516   }
 517 }
 518
 519 sub _generate_getset {
 520   my ($self, $name, $spec) = @_;
 521   q{(@_ > 1}."\n      ? ".$self->_generate_set($name, $spec)
 522     ."\n      : ".$self->_generate_get($name, $spec)."\n    )";
 523 }
 524
 525 sub _generate_delegation {
 526   my ($self, $asserter, $target, $args) = @_;
 527   my $arg_string = do {
 528     if (@$args) {
 529       # I could, I reckon, linearise out non-refs here using perlstring
 530       # plus something to check for numbers but I'm unsure if it's worth it
 531       $self->{captures}{'@curries'} = $args;
 532       '@curries, @_';
 533     } else {
 534       '@_';
 535     }
 536   };
 537   "shift->${asserter}->${target}(${arg_string});";
 538 }
 539
 540 sub _generate_xs {
 541   my ($self, $type, $into, $name, $slot) = @_;
 542   Class::XSAccessor->import(
 543     class => $into,
 544     $type => { $name => $slot },
 545     replace => 1,
 546   );
 547   $into->can($name);
 548 }
 549
 550 sub default_construction_string { '{}' }
 551
 552 1;