The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
Changes 08
MANIFEST 02
META.json 23
META.yml 23
Makefile.PL 23
README 710
lib/Method/Generate/Accessor.pm 2439
lib/Moo/Role.pm 11
lib/Moo.pm 710
lib/Sub/Defer.pm 11
lib/Sub/Quote.pm 11
t/accessor-default.t 015
t/accessor-isa.t 139
t/coerce-1.t 092
xt/type-tiny-coerce.t 022
15 files changed (This is a version diff) 48249
@@ -1,5 +1,13 @@
 Revision history for Moo
 
+1.006000 - 2014-08-16
+  - support coerce => 1 in attributes, taking the coercion from the isa option
+    if it is an object that supports the coerce or coercion method.
+  - add attribute information to type check errors by trapping with an eval
+    rather than overriding the global __DIE__ handler
+  - bump Module::Runtime prerequisite to fix error messages when there is a
+    missing module used by a role loaded using 'with' or similar (rt#97669)
+
 1.005000 - 2014-06-10
   - add qsub to Sub::Quote as a prototyped alternative to quote_sub, accepting
     only the sub body
@@ -38,6 +38,7 @@ t/buildall-subconstructor.t
 t/buildall.t
 t/buildargs-error.t
 t/buildargs.t
+t/coerce-1.t
 t/compose-non-role.t
 t/compose-roles.t
 t/demolish-basics.t
@@ -133,6 +134,7 @@ xt/type-inflate-coercion.t
 xt/type-inflate-threads.t
 xt/type-inflate-type-tiny.t
 xt/type-inflate.t
+xt/type-tiny-coerce.t
 xt/withautoclean.t
 META.yml                                 Module YAML meta-data (added by MakeMaker)
 META.json                                Module JSON meta-data (added by MakeMaker)
@@ -50,9 +50,10 @@
             "Class::Method::Modifiers" : "1.1",
             "Devel::GlobalDestruction" : "0.11",
             "Import::Into" : "1.002",
-            "Module::Runtime" : "0.012",
+            "Module::Runtime" : "0.014",
             "Role::Tiny" : "1.003003",
             "Scalar::Util" : "0",
+            "perl" : "5.006",
             "strictures" : "1.004003"
          }
       },
@@ -82,7 +83,7 @@
       },
       "x_IRC" : "irc://irc.perl.org/#moose"
    },
-   "version" : "1.005000",
+   "version" : "1.006000",
    "x_authority" : "cpan:MSTROUT",
    "x_breaks" : {
       "HTML::Restrict" : "== 2.1.5"
@@ -25,16 +25,17 @@ requires:
   Class::Method::Modifiers: '1.1'
   Devel::GlobalDestruction: '0.11'
   Import::Into: '1.002'
-  Module::Runtime: '0.012'
+  Module::Runtime: '0.014'
   Role::Tiny: '1.003003'
   Scalar::Util: '0'
+  perl: '5.006'
   strictures: '1.004003'
 resources:
   IRC: irc://irc.perl.org/#moose
   bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Moo
   license: http://dev.perl.org/licenses/
   repository: https://github.com/moose/Moo.git
-version: '1.005000'
+version: '1.006000'
 x_authority: cpan:MSTROUT
 x_breaks:
   HTML::Restrict: '== 2.1.5'
@@ -24,11 +24,12 @@ my %META = (
       requires => {
         'Class::Method::Modifiers'  => 1.10,  # for RT#80194
         'strictures'                => 1.004003,
-        'Module::Runtime'           => 0.012, # for RT#74789
+        'Module::Runtime'           => 0.014, # for RT#86394
         'Role::Tiny'                => 1.003003,
         'Devel::GlobalDestruction'  => 0.11,  # for RT#78617
         'Import::Into'              => 1.002,
         'Scalar::Util'              => 0,
+        'perl'                      => 5.006,
       },
       recommends => {
         'Class::XSAccessor'         => 1.18,
@@ -95,7 +96,7 @@ $MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META }
 for (qw(configure build test runtime)) {
   my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES';
   my $r = $MM_ARGS{$key} = {
-    %{$META{prereqs}{$_}{requires}},
+    %{$META{prereqs}{$_}{requires} || {}},
     %{delete $MM_ARGS{$key} || {}},
   };
   defined $r->{$_} or delete $r->{$_} for keys %$r;
@@ -89,9 +89,9 @@ MOO AND MOOSE
     to use them in Moose code without anybody ever noticing you aren't using
     Moose everywhere.
 
-    Moo will also create Moose type constraints for classes and roles, so
-    that "isa => 'MyClass'" and "isa => 'MyRole'" work the same as for Moose
-    classes and roles.
+    Moo will also create Moose type constraints for Moo classes and roles,
+    so that in Moose classes "isa => 'MyMooClass'" and "isa => 'MyMooRole'"
+    work the same as for Moose classes and roles.
 
     Extending a Moose class or consuming a Moose::Role will also work.
 
@@ -251,7 +251,7 @@ IMPORTED SUBROUTINES
 
     The options for "has" are as follows:
 
-    * is
+    * "is"
 
       required, may be "ro", "lazy", "rwp" or "rw".
 
@@ -276,7 +276,7 @@ IMPORTED SUBROUTINES
       "rw" generates a normal getter/setter by defaulting "accessor" to the
       name of the attribute.
 
-    * isa
+    * "isa"
 
       Takes a coderef which is meant to validate the attribute. Unlike
       Moose, Moo does not include a basic type system, so instead of doing
@@ -313,7 +313,7 @@ IMPORTED SUBROUTINES
       Moose::Meta::TypeConstraint object or something similar enough to it
       to make Moose happy is fine.
 
-    * coerce
+    * "coerce"
 
       Takes a coderef which is meant to coerce the attribute. The basic idea
       is to do something like the following:
@@ -330,7 +330,10 @@ IMPORTED SUBROUTINES
 
       Sub::Quote aware
 
-    * handles
+      If the "isa" option is a blessed object providing a "coerce" or
+      "coercion" method, then the "coerce" option may be set to just 1.
+
+    * "handles"
 
       Takes a string
 
@@ -23,19 +23,6 @@ BEGIN {
 
 my $module_name_only = qr/\A$Module::Runtime::module_name_rx\z/;
 
-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) = @_;
@@ -82,6 +69,16 @@ sub generate_method {
   if (($spec->{trigger}||0) eq 1) {
     $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)');
   }
+  if (($spec->{coerce}||0) eq 1) {
+    my $isa = $spec->{isa};
+    if (blessed $isa and $isa->can('coercion')) {
+      $spec->{coerce} = $isa->coercion;
+    } elsif (blessed $isa and $isa->can('coerce')) {
+      $spec->{coerce} = sub { $isa->coerce(@_) };
+    } else {
+      die "Invalid coercion for $into->$name - no appropriate type constraint";
+    }
+  }
 
   for my $setting (qw( isa coerce )) {
     next if !exists $spec->{$setting};
@@ -387,11 +384,12 @@ sub _attr_desc {
 
 sub _generate_coerce {
   my ($self, $name, $value, $coerce, $init_arg) = @_;
-  $self->_generate_die_prefix(
+  $self->_wrap_attr_exception(
     $name,
     "coercion",
     $init_arg,
-    $self->_generate_call_code($name, 'coerce', "${value}", $coerce)
+    $self->_generate_call_code($name, 'coerce', "${value}", $coerce),
+    1,
   );
 }
 
@@ -414,23 +412,40 @@ sub generate_isa_check {
   ($code, delete $self->{captures});
 }
 
-sub _generate_die_prefix {
-  my ($self, $name, $prefix, $arg, $inside) = @_;
+sub _wrap_attr_exception {
+  my ($self, $name, $step, $arg, $code, $want_return) = @_;
+  my $prefix = quotify("${step} for "._attr_desc($name, $arg).' failed: ');
   "do {\n"
-  .'  local $Method::Generate::Accessor::CurrentAttribute = {'
-  .'    init_arg => '.(defined $arg ? quotify($arg) : 'undef') . ",\n"
+  .'  local $Method::Generate::Accessor::CurrentAttribute = {'."\n"
+  .'    init_arg => '.quotify($arg).",\n"
   .'    name     => '.quotify($name).",\n"
-  .'    step     => '.quotify($prefix).",\n"
+  .'    step     => '.quotify($step).",\n"
   ."  };\n"
-  .'  local $Method::Generate::Accessor::OrigSigDie = $SIG{__DIE__};'."\n"
-  .'  local $SIG{__DIE__} = \&Method::Generate::Accessor::_SIGDIE;'."\n"
-  .$inside
+  .($want_return ? '  my $_return;'."\n" : '')
+  .'  my $_error;'."\n"
+  ."  {\n"
+  .'    my $_old_error = $@;'."\n"
+  ."    if (!eval {\n"
+  .'      $@ = $_old_error;'."\n"
+  .($want_return ? '      $_return ='."\n" : '')
+  .'      '.$code.";\n"
+  ."      1;\n"
+  ."    }) {\n"
+  .'      $_error = $@;'."\n"
+  .'      if (!ref $_error) {'."\n"
+  .'        $_error = '.$prefix.'.$_error;'."\n"
+  ."      }\n"
+  ."    }\n"
+  .'    $@ = $_old_error;'."\n"
+  ."  }\n"
+  .'  die $_error if $_error;'."\n"
+  .($want_return ? '  $_return;'."\n" : '')
   ."}\n"
 }
 
 sub _generate_isa_check {
   my ($self, $name, $value, $check, $init_arg) = @_;
-  $self->_generate_die_prefix(
+  $self->_wrap_attr_exception(
     $name,
     "isa check",
     $init_arg,
@@ -6,7 +6,7 @@ use Role::Tiny ();
 use base qw(Role::Tiny);
 use Import::Into;
 
-our $VERSION = '1.005000';
+our $VERSION = '1.006000';
 $VERSION = eval $VERSION;
 
 require Moo::sification;
@@ -4,7 +4,7 @@ use strictures 1;
 use Moo::_Utils;
 use Import::Into;
 
-our $VERSION = '1.005000';
+our $VERSION = '1.006000';
 $VERSION = eval $VERSION;
 
 require Moo::sification;
@@ -320,8 +320,8 @@ to use them in L<Moose> code without anybody ever noticing you aren't using
 L<Moose> everywhere.
 
 L<Moo> will also create L<Moose type constraints|Moose::Manual::Types> for
-classes and roles, so that C<< isa => 'MyClass' >> and C<< isa => 'MyRole' >>
-work the same as for L<Moose> classes and roles.
+L<Moo> classes and roles, so that in Moose classes C<< isa => 'MyMooClass' >>
+and C<< isa => 'MyMooRole' >> work the same as for L<Moose> classes and roles.
 
 Extending a L<Moose> class or consuming a L<Moose::Role> will also work.
 
@@ -495,7 +495,7 @@ The options for C<has> are as follows:
 
 =over 2
 
-=item * is
+=item * C<is>
 
 B<required>, may be C<ro>, C<lazy>, C<rwp> or C<rw>.
 
@@ -518,7 +518,7 @@ This feature comes from L<MooseX::AttributeShortcuts>.
 C<rw> generates a normal getter/setter by defaulting C<accessor> to the
 name of the attribute.
 
-=item * isa
+=item * C<isa>
 
 Takes a coderef which is meant to validate the attribute.  Unlike L<Moose>, Moo
 does not include a basic type system, so instead of doing C<< isa => 'Num' >>,
@@ -555,7 +555,7 @@ Note that this example is purely illustrative; anything that returns a
 L<Moose::Meta::TypeConstraint> object or something similar enough to it to
 make L<Moose> happy is fine.
 
-=item * coerce
+=item * C<coerce>
 
 Takes a coderef which is meant to coerce the attribute.  The basic idea is to
 do something like the following:
@@ -571,7 +571,10 @@ check after the coercion has run to ensure that it returned a valid value.
 
 L<Sub::Quote aware|/SUB QUOTE AWARE>
 
-=item * handles
+If the C<isa> option is a blessed object providing a C<coerce> or
+C<coercion> method, then the C<coerce> option may be set to just C<1>.
+
+=item * C<handles>
 
 Takes a string
 
@@ -5,7 +5,7 @@ use base qw(Exporter);
 use Moo::_Utils;
 use Scalar::Util qw(weaken);
 
-our $VERSION = '1.005000';
+our $VERSION = '1.006000';
 $VERSION = eval $VERSION;
 
 our @EXPORT = qw(defer_sub undefer_sub undefer_all);
@@ -12,7 +12,7 @@ BEGIN {
   *_HAVE_PERLSTRING = defined &B::perlstring ? sub(){1} : sub(){0};
 }
 
-our $VERSION = '1.005000';
+our $VERSION = '1.006000';
 $VERSION = eval $VERSION;
 
 our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub qsub);
@@ -29,6 +29,18 @@ my $c_ran;
   has fourteen => (is => 'ro', required => 1, builder => '_build_fourteen');
   sub _build_fourteen { {} }
   has fifteen => (is => 'lazy', default => undef);
+
+  # DIE handler was leaking into defaults when coercion is on.
+  has default_with_coerce => (
+      is        => 'rw',
+      coerce    => sub { return $_[0] },
+      default   => sub { eval { die "blah\n" }; return $@; }
+  );
+
+  has default_no_coerce => (
+      is        => 'rw',
+      default   => sub { eval { die "blah\n" }; return $@; }
+  );
 }
 
 sub check {
@@ -71,4 +83,7 @@ my $foo = Foo->new;
 is($foo->fifteen, undef, 'undef default');
 ok(exists $foo->{fifteen}, 'undef default is stored');
 
+is( Foo->new->default_with_coerce, "blah\n" );
+is( Foo->new->default_no_coerce,   "blah\n" );
+
 done_testing;
@@ -154,7 +154,7 @@ is($e->[2], 'isa check', 'step available in isa check');
   my $called;
   local $SIG{__DIE__} = sub { $called++; die $_[0] };
   my $e = exception { Fizz->new(attr_1 => 5) };
-  is($called, 1, '__DIE__ handler called if set')
+  ok($called, '__DIE__ handler called if set')
 }
 
 {
@@ -173,4 +173,42 @@ like exception { ClassUsingDeadlyIsa->new(bar => 1) },
 
 ComplexWriter->test_with("isa");
 
+{
+  package ClassWithEvilDestroy;
+  sub new { bless {}, $_[0] }
+  sub DESTROY {
+    eval {
+      # nop
+    };
+  }
+
+  package ClassWithEvilException;
+  use Moo;
+  has foo => (is => 'rw', isa => sub {
+    local $@;
+    die "welp";
+  });
+  has bar => (is => 'rw', isa => sub {
+    my $o = ClassWithEvilDestroy->new;
+    die "welp";
+  });
+  my $error;
+  has baz => (is => 'rw', isa => sub {
+    ::is $@, $error, '$@ unchanged inside isa';
+    1;
+  });
+
+  my $o = ClassWithEvilException->new;
+
+  ::like ::exception { $o->foo(1) }, qr/isa check for "foo" failed:/,
+    'got proper exception with localized $@';
+  ::like ::exception { $o->bar(1) }, qr/isa check for "bar" failed:/,
+    'got proper exception with eval in DESTROY';
+
+  eval { die "blah\n" };
+  $error = $@;
+  $o->baz(1);
+  ::is $@, $error, '$@ unchanged after successful isa';
+}
+
 done_testing;
@@ -0,0 +1,92 @@
+use strictures 1;
+use Test::More;
+use Test::Fatal;
+
+{
+  package IntConstraint;
+  use Moo;
+  use overload '&{}' => sub { shift->constraint }, fallback => 1;
+  has constraint => (
+    is       => 'ro',
+    default  => sub {
+      sub { $_[0] eq int $_[0] or die }
+    },
+  );
+  sub check {
+    my $self = shift;
+    !!eval { $self->constraint->(@_); 1 }
+  }
+}
+
+# First supported interface for coerce=>1.
+# The type constraint provides an $isa->coerce($value) method.
+{
+  package IntConstraint::WithCoerceMethod;
+  use Moo;
+  extends qw(IntConstraint);
+  sub coerce {
+    my $self = shift;
+    int($_[0]);
+  }
+}
+
+# First supported interface for coerce=>1.
+# The type constraint provides an $isa->coercion method
+# providing a coderef such that $coderef->($value) coerces.
+{
+  package IntConstraint::WithCoercionMethod;
+  use Moo;
+  extends qw(IntConstraint);
+  has coercion => (
+    is       => 'ro',
+    default  => sub {
+      sub { int($_[0]) }
+    },
+  );
+}
+
+{
+  package Goo;
+  use Moo;
+
+  ::like(::exception {
+    has foo => (
+      is      => 'ro',
+      isa     => sub { $_[0] eq int $_[0] },
+      coerce  => 1,
+    );
+  }, qr/Invalid coercion/,
+    'coerce => 1 not allowed when isa has no coercion');
+
+  ::like(::exception {
+    has foo => (
+      is      => 'ro',
+      isa     => IntConstraint->new,
+      coerce  => 1,
+    );
+  }, qr/Invalid coercion/,
+    'coerce => 1 not allowed when isa has no coercion');
+
+  has bar => (
+    is      => 'ro',
+    isa     => IntConstraint::WithCoercionMethod->new,
+    coerce  => 1,
+  );
+
+  has baz => (
+    is      => 'ro',
+    isa     => IntConstraint::WithCoerceMethod->new,
+    coerce  => 1,
+  );
+
+}
+
+my $obj = Goo->new(
+  bar => 3.14159,
+  baz => 3.14159,
+);
+
+is($obj->bar, '3', '$isa->coercion');
+is($obj->baz, '3', '$isa->coerce');
+
+done_testing;
@@ -0,0 +1,22 @@
+use strictures 1;
+use Test::More;
+
+{
+  package Goo;
+  use Moo;
+  use Types::Standard qw(Int Num);
+
+  has foo => (
+    is      => 'ro',
+    isa     => Int->plus_coercions(Num, q{ int($_) }),
+    coerce  => 1,
+  );
+}
+
+my $obj = Goo->new(
+  foo => 3.14159,
+);
+
+is($obj->foo, '3', 'Type::Tiny coercion applied with coerce => 1');
+
+done_testing;