throw an error on non-string builder (RT#78479)

[gitmo/Moo.git] / lib / Method / Generate / Accessor.pm

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index d315818..c644919 100644 (file)
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -5,6 +5,8 @@ use Moo::_Utils;
 use base qw(Moo::Object);
 use Sub::Quote;
 use B 'perlstring';
+use Scalar::Util 'blessed';
+use overload ();
 BEGIN {
   our $CAN_HAZ_XS =
     !$ENV{MOO_XS_DISABLE}
@@ -17,6 +19,7 @@ BEGIN {
 
 sub generate_method {
   my ($self, $into, $name, $spec, $quote_opts) = @_;
+  $name =~ s/^\+//;
   die "Must have an is" unless my $is = $spec->{is};
   if ($is eq 'ro') {
     $spec->{reader} = $name unless exists $spec->{reader};
@@ -33,6 +36,8 @@ sub generate_method {
     die "Unknown is ${is}";
   }
   $spec->{builder} = '_build_'.$name if ($spec->{builder}||0) eq 1;
+  die "Invalid builder for $into->$name - not a string"
+    if exists $spec->{builder} and ref $spec->{builder};
   if (($spec->{predicate}||0) eq 1) {
     $spec->{predicate} = $name =~ /^_/ ? "_has${name}" : "has_${name}";
   }
@@ -42,6 +47,18 @@ sub generate_method {
   if (($spec->{trigger}||0) eq 1) {
     $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)');
   }
+
+  for my $setting (qw( default coerce )) {
+    next if !exists $spec->{$setting};
+    my $value = $spec->{$setting};
+    my $invalid = "Invalid $setting '" . overload::StrVal($value)
+      . "' for $into->$name - not a coderef";
+    die "$invalid or code-convertible object"
+      unless ref $value and (ref $value eq 'CODE' or blessed($value));
+    die "$invalid and could not be converted to a coderef: $@"
+      if !eval { \&$value };
+  }
+
   my %methods;
   if (my $reader = $spec->{reader}) {
     if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
@@ -172,7 +189,12 @@ sub _generate_get {
     'do { '.$self->_generate_use_default(
       '$_[0]', $name, $spec,
       $self->_generate_simple_has('$_[0]', $name, $spec),
-    ).'; '.$simple.' }';
+    ).'; '
+    .($spec->{isa}
+      ?($self->_generate_isa_check($name, $simple, $spec->{isa}).'; ')
+      :''
+    )
+    .$simple.' }';
   }
 }
 
@@ -264,7 +286,10 @@ sub generate_coerce {
 
 sub _generate_coerce {
   my ($self, $name, $value, $coerce) = @_;
-  $self->_generate_call_code($name, 'coerce', "${value}", $coerce);
+  $self->_generate_die_prefix(
+    "coercion for ${\perlstring($name)} failed: ",
+    $self->_generate_call_code($name, 'coerce', "${value}", $coerce)
+  );
 }
  
 sub generate_trigger {
@@ -286,24 +311,37 @@ sub generate_isa_check {
   ($code, delete $self->{captures});
 }
 
+sub _generate_die_prefix {
+  my ($self, $prefix, $inside) = @_;
+  "do {\n"
+  .'  my $sig_die = $SIG{__DIE__} || sub { die $_[0] };'."\n"
+  .'  local $SIG{__DIE__} = sub {'."\n"
+  .'    $sig_die->(ref($_[0]) ? $_[0] : '.perlstring($prefix).'.$_[0]);'."\n"
+  .'  };'."\n"
+  .$inside
+  ."}\n"
+}
+
 sub _generate_isa_check {
   my ($self, $name, $value, $check) = @_;
-  $self->_generate_call_code($name, 'isa_check', $value, $check);
+  $self->_generate_die_prefix(
+    "isa check for ${\perlstring($name)} failed: ",
+    $self->_generate_call_code($name, 'isa_check', $value, $check)
+  );
 }
 
 sub _generate_call_code {
   my ($self, $name, $type, $values, $sub) = @_;
   if (my $quoted = quoted_from_sub($sub)) {
     my $code = $quoted->[1];
-    my $at_ = '@_ = ('.$values.');';
     if (my $captures = $quoted->[2]) {
       my $cap_name = qq{\$${type}_captures_for_${name}};
       $self->{captures}->{$cap_name} = \$captures;
       Sub::Quote::inlinify(
-        $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6)
+        $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6), 1
       );
     } else {
-      Sub::Quote::inlinify($code, $values);
+      Sub::Quote::inlinify($code, $values, undef, 1);
     }
   } else {
     my $cap_name = qq{\$${type}_for_${name}};
@@ -385,11 +423,6 @@ sub _generate_populate_set {
   }
 }
 
-sub generate_multi_set {
-  my ($self, $me, $to_set, $from) = @_;
-  "\@{${me}}{qw(${\join ' ', @$to_set})} = $from";
-}
-
 sub _generate_core_set {
   my ($self, $me, $name, $spec, $value) = @_;
   my $name_str = perlstring $name;
@@ -399,9 +432,10 @@ sub _generate_core_set {
 sub _generate_simple_set {
   my ($self, $me, $name, $spec, $value) = @_;
   my $name_str = perlstring $name;
-  my $simple = $self->_generate_core_set($self, $me, $name, $spec, $value);
 
   if ($spec->{weak_ref}) {
+    $value = '$preserve = '.$value;
+    my $simple = $self->_generate_core_set($me, $name, $spec, $value);
     require Scalar::Util;
 
     # Perl < 5.8.3 can't weaken refs to readonly vars
@@ -413,8 +447,10 @@ sub _generate_simple_set {
     #
     # but requires XS and is just too damn crazy
     # so simply throw a better exception
-    Moo::_Utils::lt_5_8_3() ? <<"EOC" : "Scalar::Util::weaken(${simple})";
+    my $weak_simple = "my \$preserve; Scalar::Util::weaken(${simple})";
+    Moo::_Utils::lt_5_8_3() ? <<"EOC" : $weak_simple;
 
+      my \$preserve;
       eval { Scalar::Util::weaken($simple); 1 } or do {
         if( \$@ =~ /Modification of a read-only value attempted/) {
           require Carp;
@@ -428,7 +464,7 @@ sub _generate_simple_set {
       };
 EOC
   } else {
-    $simple;
+    $self->_generate_core_set($me, $name, $spec, $value);
   }
 }
 
@@ -457,7 +493,8 @@ sub _generate_xs {
   my ($self, $type, $into, $name, $slot) = @_;
   Class::XSAccessor->import(
     class => $into,
-    $type => { $name => $slot }
+    $type => { $name => $slot },
+    replace => 1,
   );
   $into->can($name);
 }