xt/type-inflate.t

   1 use strictures 1;
   2 use Test::More;
   3
   4 {
   5   package TypeOMatic;
   6
   7   use Moo::Role;
   8   use Sub::Quote;
   9   use Moo::HandleMoose ();
  10
  11   sub Str {
  12     my $type = sub {
  13       die unless defined $_[0] && !ref $_[0];
  14     };
  15     $Moo::HandleMoose::TYPE_MAP{$type} = sub {
  16       require Moose::Util::TypeConstraints;
  17       Moose::Util::TypeConstraints::find_type_constraint("Str");
  18     };
  19     return ($type, @_);
  20   }
  21   sub PositiveInt {
  22     my $type = sub {
  23       die unless defined $_[0] && !ref $_[0] && $_[0] =~ /^-?\d+/;
  24     };
  25     $Moo::HandleMoose::TYPE_MAP{$type} = sub {
  26       require Moose::Util::TypeConstraints;
  27       require MooseX::Types::Common::Numeric;
  28       Moose::Util::TypeConstraints::find_type_constraint(
  29         "MooseX::Types::Common::Numeric::PositiveInt");
  30     };
  31     return ($type, @_);
  32   }
  33
  34   has named_type => (
  35     is => 'ro',
  36     isa => Str,
  37   );
  38
  39   has named_external_type => (
  40     is => 'ro',
  41     isa => PositiveInt,
  42   );
  43
  44   package TypeOMatic::Consumer;
  45
  46   # do this as late as possible to simulate "real" behaviour
  47   use Moo::HandleMoose;
  48   use Moose;
  49   with 'TypeOMatic';
  50 }
  51
  52 my $meta = Class::MOP::class_of('TypeOMatic::Consumer');
  53
  54 my ($str, $positive_int)
  55   = map $meta->get_attribute($_)->type_constraint->name,
  56       qw(named_type named_external_type);
  57
  58 is($str, 'Str', 'Built-in Moose type ok');
  59 is(
  60   $positive_int, 'MooseX::Types::Common::Numeric::PositiveInt',
  61   'External (MooseX::Types type) ok'
  62 );
  63
  64 local $@;
  65 eval q {
  66   package Fooble;
  67   use Moo;
  68   my $isa = sub { 1 };
  69   $Moo::HandleMoose::TYPE_MAP{$isa} = sub { $isa };
  70   has barble => (is => "ro", isa => $isa);
  71   __PACKAGE__->meta->get_attribute("barble");
  72 };
  73
  74 like(
  75   $@,
  76   qr/^error inflating attribute 'barble' for package 'Fooble': \$TYPE_MAP\{CODE\(\w+?\)\} did not return a valid type constraint/,
  77   'error message for incorrect type constraint inflation',
  78 );
  79
  80 done_testing;