Moose-t-failing/040_type_constraints/001_util_type_constraints.t

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