t/040_type_constraints/failing/001_util_type_constraints.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 85;
   7 use Test::Exception;
   8
   9 use Scalar::Util ();
  10
  11 use lib 't/lib';
  12 use Test::Mouse;
  13 use Mouse::Util::TypeConstraints;
  14
  15
  16 type Number => where { Scalar::Util::looks_like_number($_) };
  17 type String
  18     => where { !ref($_) && !Number($_) }
  19     => message { "This is not a string ($_)" };
  20
  21 subtype Natural
  22         => as Number
  23         => where { $_ > 0 };
  24
  25 subtype NaturalLessThanTen
  26         => as Natural
  27         => where { $_ < 10 }
  28         => message { "The number '$_' is not less than 10" };
  29
  30 Mouse::Util::TypeConstraints->export_type_constraints_as_functions();
  31
  32 ok(Number(5), '... this is a Num');
  33 ok(!defined(Number('Foo')), '... this is not a Num');
  34 {
  35     my $number_tc = Mouse::Util::TypeConstraints::find_type_constraint('Number');
  36     is("$number_tc", 'Number', '... type constraint stringifies to name');
  37 }
  38
  39 ok(String('Foo'), '... this is a Str');
  40 ok(!defined(String(5)), '... this is not a Str');
  41
  42 ok(Natural(5), '... this is a Natural');
  43 is(Natural(-5), undef, '... this is not a Natural');
  44 is(Natural('Foo'), undef, '... this is not a Natural');
  45
  46 ok(NaturalLessThanTen(5), '... this is a NaturalLessThanTen');
  47 is(NaturalLessThanTen(12), undef, '... this is not a NaturalLessThanTen');
  48 is(NaturalLessThanTen(-5), undef, '... this is not a NaturalLessThanTen');
  49 is(NaturalLessThanTen('Foo'), undef, '... this is not a NaturalLessThanTen');
  50
  51 # anon sub-typing
  52
  53 my $negative = subtype Number => where  { $_ < 0 };
  54 ok(defined $negative, '... got a value back from negative');
  55 isa_ok($negative, 'Mouse::Meta::TypeConstraint');
  56
  57 ok($negative->check(-5), '... this is a negative number');
  58 ok(!defined($negative->check(5)), '... this is not a negative number');
  59 is($negative->check('Foo'), undef, '... this is not a negative number');
  60
  61 ok($negative->is_subtype_of('Number'), '... $negative is a subtype of Number');
  62 ok(!$negative->is_subtype_of('String'), '... $negative is not a subtype of String');
  63
  64 my $negative2 = subtype Number => where { $_ < 0 } => message {"$_ is not a negative number"};
  65
  66 ok(defined $negative2, '... got a value back from negative');
  67 isa_ok($negative2, 'Mouse::Meta::TypeConstraint');
  68
  69 ok($negative2->check(-5), '... this is a negative number');
  70 ok(!defined($negative2->check(5)), '... this is not a negative number');
  71 is($negative2->check('Foo'), undef, '... this is not a negative number');
  72
  73 ok($negative2->is_subtype_of('Number'), '... $negative2 is a subtype of Number');
  74 ok(!$negative2->is_subtype_of('String'), '... $negative is not a subtype of String');
  75
  76 ok($negative2->has_message, '... it has a message');
  77 is($negative2->validate(2),
  78    '2 is not a negative number',
  79    '... validated unsuccessfully (got error)');
  80
  81 # check some meta-details
  82
  83 my $natural_less_than_ten = find_type_constraint('NaturalLessThanTen');
  84 isa_ok($natural_less_than_ten, 'Mouse::Meta::TypeConstraint');
  85
  86 ok($natural_less_than_ten->is_subtype_of('Natural'), '... NaturalLessThanTen is subtype of Natural');
  87 ok($natural_less_than_ten->is_subtype_of('Number'), '... NaturalLessThanTen is subtype of Number');
  88 ok(!$natural_less_than_ten->is_subtype_of('String'), '... NaturalLessThanTen is not subtype of String');
  89
  90 ok($natural_less_than_ten->has_message, '... it has a message');
  91
  92 ok(!defined($natural_less_than_ten->validate(5)), '... validated successfully (no error)');
  93
  94 is($natural_less_than_ten->validate(15),
  95    "The number '15' is not less than 10",
  96    '... validated unsuccessfully (got error)');
  97
  98 my $natural = find_type_constraint('Natural');
  99 isa_ok($natural, 'Mouse::Meta::TypeConstraint');
 100
 101 ok($natural->is_subtype_of('Number'), '... Natural is a subtype of Number');
 102 ok(!$natural->is_subtype_of('String'), '... Natural is not a subtype of String');
 103
 104 ok(!$natural->has_message, '... it does not have a message');
 105
 106 ok(!defined($natural->validate(5)), '... validated successfully (no error)');
 107
 108 is($natural->validate(-5),
 109   "Validation failed for 'Natural' failed with value -5",
 110   '... validated unsuccessfully (got error)');
 111
 112 my $string = find_type_constraint('String');
 113 isa_ok($string, 'Mouse::Meta::TypeConstraint');
 114
 115 ok($string->has_message, '... it does have a message');
 116
 117 ok(!defined($string->validate("Five")), '... validated successfully (no error)');
 118
 119 is($string->validate(5),
 120 "This is not a string (5)",
 121 '... validated unsuccessfully (got error)');
 122
 123 lives_ok { Mouse::Meta::Attribute->new('bob', isa => 'Spong') }
 124   'meta-attr construction ok even when type constraint utils loaded first';
 125
 126 # Test type constraint predicate return values.
 127
 128 foreach my $predicate (qw/equals is_subtype_of is_a_type_of/) {
 129     ok( !defined $string->$predicate('DoesNotExist'), "$predicate predicate returns undef for non existant constraint");
 130 }
 131
 132 # Test adding things which don't look like types to the registry throws an exception
 133
 134 my $r = Mouse::Util::TypeConstraints->get_type_constraint_registry;
 135 throws_ok {$r->add_type_constraint()} qr/not a valid type constraint/, '->add_type_constraint(undef) throws';
 136 throws_ok {$r->add_type_constraint('foo')} qr/not a valid type constraint/, '->add_type_constraint("foo") throws';
 137 throws_ok {$r->add_type_constraint(bless {}, 'SomeClass')} qr/not a valid type constraint/, '->add_type_constraint(SomeClass->new) throws';
 138
 139 # Test some specific things that in the past did not work,
 140 # specifically weird variations on anon subtypes.
 141
 142 {
 143     my $subtype = subtype as 'Str';
 144     isa_ok( $subtype, 'Mouse::Meta::TypeConstraint', 'got an anon subtype' );
 145     is( $subtype->parent->name, 'Str', 'parent is Str' );
 146     # This test sucks but is the best we can do
 147     is( $subtype->constraint->(), 1,
 148         'subtype has the null constraint' );
 149     ok( ! $subtype->has_message, 'subtype has no message' );
 150 }
 151
 152 {
 153     my $subtype = subtype as 'ArrayRef[Num|Str]';
 154     isa_ok( $subtype, 'Mouse::Meta::TypeConstraint', 'got an anon subtype' );
 155     is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' );
 156     ok( ! $subtype->has_message, 'subtype has no message' );
 157 }
 158
 159 {
 160     my $subtype = subtype 'ArrayRef[Num|Str]' => message { 'foo' };
 161     isa_ok( $subtype, 'Mouse::Meta::TypeConstraint', 'got an anon subtype' );
 162     is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' );
 163     ok( $subtype->has_message, 'subtype does have a message' );
 164 }
 165
 166 # alternative sugar-less calling style which is documented as legit:
 167 {
 168     my $subtype = subtype( 'MyStr', { as => 'Str' } );
 169     isa_ok( $subtype, 'Mouse::Meta::TypeConstraint', 'got a subtype' );
 170     is( $subtype->name, 'MyStr', 'name is MyStr' );
 171     is( $subtype->parent->name, 'Str', 'parent is Str' );
 172 }
 173
 174 {
 175     my $subtype = subtype( { as => 'Str' } );
 176     isa_ok( $subtype, 'Mouse::Meta::TypeConstraint', 'got a subtype' );
 177     is( $subtype->name, '__ANON__', 'name is __ANON__' );
 178     is( $subtype->parent->name, 'Str', 'parent is Str' );
 179 }
 180
 181 {
 182     my $subtype = subtype( { as => 'Str', where => sub { /X/ } } );
 183     isa_ok( $subtype, 'Mouse::Meta::TypeConstraint', 'got a subtype' );
 184     is( $subtype->name, '__ANON__', 'name is __ANON__' );
 185     is( $subtype->parent->name, 'Str', 'parent is Str' );
 186     ok( $subtype->check('FooX'), 'constraint accepts FooX' );
 187     ok( ! $subtype->check('Foo'), 'constraint reject Foo' );
 188 }
 189
 190 {
 191     throws_ok { subtype 'Foo' } qr/cannot consist solely of a name/,
 192         'Cannot call subtype with a single string argument';
 193 }
 194
 195 # Back-compat for being called without sugar. Previously, calling with
 196 # sugar was indistinguishable from calling directly.
 197
 198 {
 199     my $type = type( 'Number2', sub { Scalar::Util::looks_like_number($_) } );
 200
 201     ok( $type->check(5), '... this is a Num' );
 202     ok( ! $type->check('Foo'), '... this is not a Num' );
 203 }
 204
 205 {
 206     # anon subtype
 207     my $subtype = subtype( 'Number2', sub { $_ > 0 } );
 208
 209     ok( $subtype->check(5), '... this is a Natural');
 210     ok( ! $subtype->check(-5), '... this is not a Natural');
 211     ok( ! $subtype->check('Foo'), '... this is not a Natural');
 212 }
 213
 214 {
 215     my $subtype = subtype( 'Natural2', 'Number2', sub { $_ > 0 } );
 216
 217     ok( $subtype->check(5), '... this is a Natural');
 218     ok( ! $subtype->check(-5), '... this is not a Natural');
 219     ok( ! $subtype->check('Foo'), '... this is not a Natural');
 220 }
 221
 222 {
 223     my $subtype = subtype( 'Natural3', 'Number2' );
 224
 225     ok( $subtype->check(5), '... this is a Natural');
 226     ok( $subtype->check(-5), '... this is a Natural');
 227     ok( ! $subtype->check('Foo'), '... this is not a Natural');
 228 }
 229