t/foreign/Method-Signatures/type_check.t

   1 #!perl
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5
   6 use Test::More
   7     eval { require Moose }
   8     ? ()
   9     : (skip_all => "Moose required for testing types")
  10 ;
  11 use Test::More;
  12 use Test::Fatal;
  13
  14 use Function::Parameters qw(:strict);
  15
  16
  17 { package Foo::Bar; sub new { bless {}, __PACKAGE__; } }
  18 { package Foo::Baz; sub new { bless {}, __PACKAGE__; } }
  19
  20 our $foobar = Foo::Bar->new;
  21 our $foobaz = Foo::Baz->new;
  22
  23
  24 # types to check below
  25 # the test name needs to be interpolated into a method name, so it must be a valid identifier
  26 # either good value or bad value can be an array reference:
  27 #   *   if it is, it is taken to be multiple values to try
  28 #   *   if you want to pass an array reference, you have to put it inside another array reference
  29 #   *   so, [ 42, undef ] makes two calls: one with 42, and one with undef
  30 #   *   but [[ 42, undef ]] makes one call, passing [ 42, undef ]
  31 our @TYPES =
  32 (
  33 ##  Test Name       =>  Type                =>  Good Value                      =>  Bad Value
  34     int             =>  'Int'               =>  42                              =>  'foo'                               ,
  35     bool            =>  'Bool'              =>  0                               =>  'fool'                              ,
  36     aref            =>  'ArrayRef',         =>  [[ 42, undef ]]                 =>  42                                  ,
  37     class           =>  'Foo::Bar'          =>  $foobar                         =>  $foobaz                             ,
  38     maybe_int       =>  'Maybe[Int]'        =>  [ 42, undef ]                   =>  'foo'                               ,
  39     paramized_aref  =>  'ArrayRef[Num]'     =>  [[ 6.5, 42, 1e23 ]]             =>  [[ 6.5, 42, 'thing' ]]              ,
  40     paramized_href  =>  'HashRef[Num]'      =>  { a => 6.5, b => 2, c => 1e23 } =>  { a => 6.5, b => 42, c => 'thing' } ,
  41     paramized_nested=>  'HashRef[ArrayRef[Int]]'
  42                                             =>  { foo=>[1..3], bar=>[1] }       =>  { foo=>['a'] }                               ,
  43 ##  ScalarRef[X] not implemented in Mouse, so this test is moved to typeload_moose.t
  44 ##  if Mouse starts supporting it, the test could be restored here
  45     paramized_sref  =>  'ScalarRef[Num]'    =>  \42                             =>  \'thing'                            ,
  46     int_or_aref     =>  'Int|ArrayRef[Int]' =>  [ 42 , [42 ] ]                  =>  'foo'                               ,
  47     int_or_aref_or_undef
  48                     =>  'Int|ArrayRef[Int]|Undef'
  49                                             =>  [ 42 , [42 ], undef ]           =>  'foo'                               ,
  50 );
  51
  52
  53 our $tester;
  54 {
  55     package TypeCheck::Class;
  56
  57     use strict;
  58     use warnings;
  59
  60     use Test::More;
  61     use Test::Fatal;
  62
  63     use Function::Parameters qw(:strict);
  64
  65     method new ($class:) { bless {}, $class; }
  66
  67     sub _list { return ref $_[0] eq 'ARRAY' ? @{$_[0]} : ( $_[0] ); }
  68
  69
  70     $tester = __PACKAGE__->new;
  71     while (@TYPES)
  72     {
  73         my ($name, $type, $goodval, $badval) = splice @TYPES, 0, 4;
  74         note "name/type/goodval/badval $name/$type/$goodval/$badval";
  75         my $method = "check_$name";
  76         no strict 'refs';
  77
  78         # make sure the declaration of the method doesn't throw a warning
  79         is eval qq{ method $method ($type \$bar) {} 42 }, 42;
  80         is $@, '';
  81
  82         # positive test--can we call it with a good value?
  83         my @vals = _list($goodval);
  84         my $count = 1;
  85         foreach (@vals)
  86         {
  87             my $tag = @vals ? ' (alternative ' . $count++ . ')' : '';
  88             is exception { $tester->$method($_) }, undef, "call with good value for $name passes" . $tag;
  89         }
  90
  91         # negative test--does calling it with a bad value throw an exception?
  92         @vals = _list($badval);
  93         $count = 1;
  94         foreach (@vals)
  95         {
  96             my $tag = @vals ? ' (#' . $count++ . ')' : '';
  97             like exception { $tester->$method($_) }, qr/method \Q$method\E.+parameter 1\b.+\$bar\b.+Validation failed for '[^']+' with value\b/,
  98                     "call with bad value for $name dies";
  99         }
 100     }
 101
 102
 103     # try some mixed (i.e. some with a type, some without) and multiples
 104
 105     my $method = 'check_mixed_type_first';
 106     is eval qq{ method $method (Int \$bar, \$baz) {} 42 }, 42;
 107     is exception { $tester->$method(0, 'thing') }, undef, 'call with good values (type, notype) passes';
 108     like exception { $tester->$method('thing1', 'thing2') }, qr/method \Q$method\E.+parameter 1\b.+\$bar\b.+Validation failed for '[^']+' with value\b/,
 109             'call with bad values (type, notype) dies';
 110
 111     $method = 'check_mixed_type_second';
 112     is eval qq{ method $method (\$bar, Int \$baz) {} 42 }, 42;
 113     is exception { $tester->$method('thing', 1) }, undef, 'call with good values (notype, type) passes';
 114     like exception { $tester->$method('thing1', 'thing2') }, qr/method \Q$method\E.+parameter 2\b.+\$baz\b.+Validation failed for '[^']+' with value\b/,
 115             'call with bad values (notype, type) dies';
 116
 117     $method = 'check_multiple_types';
 118     is eval qq{ method $method (Int \$bar, Int \$baz) {} 42 }, 42;
 119     is exception { $tester->$method(1, 1) }, undef, 'call with good values (type, type) passes';
 120     # with two types, and bad values for both, they should fail in order of declaration
 121     like exception { $tester->$method('thing1', 'thing2') }, qr/method \Q$method\E.+parameter 1\b.+\$bar\b.+Validation failed for '[^']+' with value\b/,
 122             'call with bad values (type, type) dies';
 123
 124     # want to try one with undef as well to make sure we don't get an uninitialized warning
 125
 126     like exception { $tester->check_int(undef) }, qr/method check_int.+parameter 1\b.+\$bar\b.+Validation failed for '[^']+' with value\b/,
 127             'call with bad values (undef) dies';
 128
 129
 130
 131     # finally, some types that shouldn't be recognized
 132     my $type;
 133
 134     #$method = 'unknown_type';
 135     #$type = 'Bmoogle';
 136     #is eval qq{ method $method ($type \$bar) {} 42 }, 42;
 137     #like exception { $tester->$method(42) }, qr/ducks $tester, $type, "perhaps you forgot to load it?", $method/,
 138     #        'call with unrecognized type dies';
 139
 140     # this one is a bit specialer in that it involved an unrecognized parameterization
 141     $method = 'unknown_paramized_type';
 142     $type = 'Bmoogle[Int]';
 143     is eval qq{ method $method ($type \$bar) {} 42 }, undef;
 144     like $@, qr/\QCould not locate the base type (Bmoogle)/;
 145     like exception { $tester->$method(42) }, qr/\QCan't locate object method "unknown_paramized_type" via package "TypeCheck::Class"/;
 146
 147 }
 148
 149
 150 done_testing;