X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMethod%2FGenerate%2FAccessor.pm;h=d0ab97061a2654ea7cb7aa931bc0d2d3df78e169;hb=42865691a20eb4d33df037c9677b9766126c98ec;hp=2f2e334b9544ddd05cd0d98e6aebfa3ee6dbd762;hpb=cada430ead20a84999bc1b95c934f9d9c6c9045b;p=gitmo%2FMoo.git

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index 2f2e334..d0ab970 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -18,6 +18,19 @@ BEGIN {
   ;
 }
 
+sub _SIGDIE
+{
+  our ($CurrentAttribute, $OrigSigDie);
+  my $sigdie = $OrigSigDie && $OrigSigDie != \&_SIGDIE
+    ? $OrigSigDie
+    : sub { die $_[0] };
+
+  return $sigdie->(@_) if ref($_[0]);
+
+  my $attr_desc = _attr_desc(@$CurrentAttribute{qw(name init_arg)});
+  $sigdie->("$CurrentAttribute->{step} for $attr_desc failed: $_[0]");
+}
+
 sub _die_overwrite
 {
   my ($pkg, $method, $type) = @_;
@@ -45,10 +58,8 @@ sub generate_method {
   }
   if (exists $spec->{builder}) {
     if(ref $spec->{builder}) {
-      die "Invalid builder for $into->$name - not a method name, coderef or"
-        . " code-convertible object"
-        unless ref $spec->{builder} eq 'CODE'
-        or (blessed($spec->{builder}) and eval { \&{$spec->{builder}} });
+      $self->_validate_codulatable('builder', $spec->{builder},
+        "$into->$name", 'or a method name');
       $spec->{builder_sub} = $spec->{builder};
       $spec->{builder} = 1;
     }
@@ -66,28 +77,26 @@ sub generate_method {
     $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)');
   }
 
-  if (exists $spec->{coerce}) {
-    my $value = $spec->{coerce};
-    my $invalid = "Invalid coerce '" . 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 };
+  for my $setting (qw( isa coerce )) {
+    next if !exists $spec->{$setting};
+    $self->_validate_codulatable($setting, $spec->{$setting}, "$into->$name");
   }
 
   if (exists $spec->{default}) {
-    my $value = $spec->{default};
-    if (!defined $value || ref $value) {
-      my $invalid = "Invalid default '" . overload::StrVal($value)
-        . "' for $into->$name - not a coderef or non-ref";
-      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 };
+    if (!defined $spec->{default} || ref $spec->{default}) {
+      $self->_validate_codulatable('default', $spec->{default}, "$into->$name", 'or a non-ref');
     }
   }
 
+  if (exists $spec->{moosify}) {
+    if (ref $spec->{moosify} ne 'ARRAY') {
+      $spec->{moosify} = [$spec->{moosify}];
+    }
+
+    for my $spec (@{$spec->{moosify}}) {
+      $self->_validate_codulatable('moosify', $spec, "$into->$name");
+    }
+  }
 
   my %methods;
   if (my $reader = $spec->{reader}) {
@@ -161,7 +170,7 @@ sub generate_method {
     _die_overwrite($into, $cl, 'a clearer')
       if !$spec->{allow_overwrite} && *{_getglob("${into}::${cl}")}{CODE};
     $methods{$cl} =
-      quote_sub "${into}::${cl}" => 
+      quote_sub "${into}::${cl}" =>
         $self->_generate_simple_clear('$_[0]', $name, $spec)."\n"
       ;
   }
@@ -223,7 +232,7 @@ sub is_simple_set {
 
 sub has_eager_default {
   my ($self, $name, $spec) = @_;
-  (!$spec->{lazy} and ($spec->{default} or $spec->{builder}));
+  (!$spec->{lazy} and (exists $spec->{default} or $spec->{builder}));
 }
 
 sub _generate_get {
@@ -239,6 +248,13 @@ sub _generate_get {
   }
 }
 
+sub generate_simple_has {
+  my $self = shift;
+  $self->{captures} = {};
+  my $code = $self->_generate_simple_has(@_);
+  ($code, delete $self->{captures});
+}
+
 sub _generate_simple_has {
   my ($self, $me, $name) = @_;
   "exists ${me}->{${\perlstring $name}}";
@@ -256,6 +272,13 @@ sub generate_get_default {
   ($code, delete $self->{captures});
 }
 
+sub generate_use_default {
+  my $self = shift;
+  $self->{captures} = {};
+  my $code = $self->_generate_use_default(@_);
+  ($code, delete $self->{captures});
+}
+
 sub _generate_use_default {
   my ($self, $me, $name, $spec, $test) = @_;
   my $get_value = $self->_generate_get_default($me, $name, $spec);
@@ -272,7 +295,7 @@ sub _generate_use_default {
       ."      ".$self->_generate_isa_check($name, '$value', $spec->{isa}).";\n"
       ."      ".$self->_generate_simple_set($me, $name, $spec, '$value')."\n"
       ."    }\n"
-    : '    '.$self->_generate_simple_set($me, $name, $spec, $get_value)."\n");
+    : '    ('.$self->_generate_simple_set($me, $name, $spec, $get_value).")\n");
 }
 
 sub _generate_get_default {
@@ -304,22 +327,27 @@ sub _generate_set {
     $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]');
   } else {
     my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
-    my $simple = $self->_generate_simple_set('$self', $name, $spec, '$value');
-    my $code = "do { my (\$self, \$value) = \@_;\n";
+    my $value_store = '$_[0]';
+    my $code;
     if ($coerce) {
-      $code .=
-        "        \$value = "
-        .$self->_generate_coerce($name, '$value', $coerce).";\n";
+      $value_store = '$value';
+      $code = "do { my (\$self, \$value) = \@_;\n"
+        ."        \$value = "
+        .$self->_generate_coerce($name, $value_store, $coerce).";\n";
+    }
+    else {
+      $code = "do { my \$self = shift;\n";
     }
     if ($isa_check) {
-      $code .= 
-        "        ".$self->_generate_isa_check($name, '$value', $isa_check).";\n";
+      $code .=
+        "        ".$self->_generate_isa_check($name, $value_store, $isa_check).";\n";
     }
+    my $simple = $self->_generate_simple_set('$self', $name, $spec, $value_store);
     if ($trigger) {
-      my $fire = $self->_generate_trigger($name, '$self', '$value', $trigger);
+      my $fire = $self->_generate_trigger($name, '$self', $value_store, $trigger);
       $code .=
         "        ".$simple.";\n        ".$fire.";\n"
-        ."        \$value;\n";
+        ."        $value_store;\n";
     } else {
       $code .= "        ".$simple.";\n";
     }
@@ -344,11 +372,13 @@ sub _attr_desc {
 sub _generate_coerce {
   my ($self, $name, $value, $coerce, $init_arg) = @_;
   $self->_generate_die_prefix(
-    "coercion for ${\_attr_desc($name, $init_arg)} failed: ",
+    $name,
+    "coercion",
+    $init_arg,
     $self->_generate_call_code($name, 'coerce', "${value}", $coerce)
   );
 }
- 
+
 sub generate_trigger {
   my $self = shift;
   $self->{captures} = {};
@@ -369,12 +399,15 @@ sub generate_isa_check {
 }
 
 sub _generate_die_prefix {
-  my ($self, $prefix, $inside) = @_;
+  my ($self, $name, $prefix, $arg, $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"
+  .'  local $Method::Generate::Accessor::CurrentAttribute = {'
+  .'    init_arg => '.(defined $arg ? B::perlstring($arg) : 'undef') . ",\n"
+  .'    name     => '.B::perlstring($name).",\n"
+  .'    step     => '.B::perlstring($prefix).",\n"
+  ."  };\n"
+  .'  local $Method::Generate::Accessor::OrigSigDie = $SIG{__DIE__};'."\n"
+  .'  local $SIG{__DIE__} = \&Method::Generate::Accessor::_SIGDIE;'."\n"
   .$inside
   ."}\n"
 }
@@ -382,7 +415,9 @@ sub _generate_die_prefix {
 sub _generate_isa_check {
   my ($self, $name, $value, $check, $init_arg) = @_;
   $self->_generate_die_prefix(
-    "isa check for ${\_attr_desc($name, $init_arg)} failed: ",
+    $name,
+    "isa check",
+    $init_arg,
     $self->_generate_call_code($name, 'isa_check', $value, $check)
   );
 }
@@ -391,15 +426,20 @@ sub _generate_call_code {
   my ($self, $name, $type, $values, $sub) = @_;
   $sub = \&{$sub} if blessed($sub);  # coderef if blessed
   if (my $quoted = quoted_from_sub($sub)) {
+    my $local = 1;
+    if ($values eq '@_' || $values eq '$_[0]') {
+      $local = 0;
+      $values = '@_';
+    }
     my $code = $quoted->[1];
     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), 1
+        $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6), $local
       );
     } else {
-      Sub::Quote::inlinify($code, $values, undef, 1);
+      Sub::Quote::inlinify($code, $values, undef, $local);
     }
   } else {
     my $cap_name = qq{\$${type}_for_${name}};
@@ -420,9 +460,9 @@ sub _generate_populate_set {
   if ($self->has_eager_default($name, $spec)) {
     my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
     my $get_default = $self->_generate_get_default(
-                        '$new', $_, $spec
+                        '$new', $name, $spec
                       );
-    my $get_value = 
+    my $get_value =
       defined($spec->{init_arg})
         ? "(\n${get_indent}  ${test}\n${get_indent}   ? ${source}\n${get_indent}   : "
             .$get_default
@@ -570,4 +610,21 @@ sub _generate_xs {
 
 sub default_construction_string { '{}' }
 
+sub _validate_codulatable {
+  my ($self, $setting, $value, $into, $appended) = @_;
+  my $invalid = "Invalid $setting '" . overload::StrVal($value)
+    . "' for $into not a coderef";
+  $invalid .= " $appended" if $appended;
+
+  unless (ref $value and (ref $value eq 'CODE' or blessed($value))) {
+    die "$invalid or code-convertible object";
+  }
+
+  unless (eval { \&$value }) {
+    die "$invalid and could not be converted to a coderef: $@";
+  }
+
+  1;
+}
+
 1;