Type::Tiny support

lib/Method/Signatures.pm

@@ -11,6 +11,8 @@ use Devel::Pragma qw(my_hints);
 our $VERSION = '20130505';
 
 our $DEBUG = $ENV{METHOD_SIGNATURES_DEBUG} || 0;
+our $TYPES_FLAVOUR = $ENV{METHOD_SIGNATURES_TYPES_FLAVOUR} || 'any_moose';
+our @ADDITIONAL_TYPES;
 
 our @CARP_NOT;
 
@@ -33,6 +35,7 @@ Method::Signatures - method and function declarations with signatures and no sou
     package Foo;
 
     use Method::Signatures;
+    use Method::Signatures qw(type_tiny); # will use Type::Tiny for types
 
     method new (%args) {
         return bless {%args}, $self;
@@ -76,6 +79,31 @@ Also does type checking, understanding all the types that Moose (or Mouse) would
 And it does all this with B<no source filters>.
 
 
+=head2 Module loading and types libraries
+
+By default, C<Method::Signature> will use C<Any::Moose> and C<Moose> or
+C<Mouse> types library to perform type checking. However you can choose to use
+C<Type::Tiny> for type checking. By deafult C<Type::Tiny> will be loaded with
+the C<Types::Standard> library, but you can add more types, by using the
+<load_types> option. Check out this example:
+
+  # default, uses Moose/Mouse
+  use Method::Signatures;
+
+  # same as above
+  use Method::Signatures { types_flavour => 'any_moose' }
+
+  # uses Type::Tiny with Types::Standard types
+  use Method::Signatures qw(type_tiny);
+
+  # same as above
+  use Method::Signatures { types_flavour => 'type_tiny' };
+
+  # uses Type::Tiny with Types::Standard and Types::XSD
+  use Method::Signatures { types_flavour => 'type_tiny',
+                           load_types => 'Types::XSD' };
+
+
 =head2 Signature syntax
 
     func echo($message) {
@@ -678,10 +706,19 @@ sub import {
             $caller = $arg->{into}   if exists $arg->{into};
             $hints->{METHOD_SIGNATURES_compile_at_BEGIN} = $arg->{compile_at_BEGIN}
                                      if exists $arg->{compile_at_BEGIN};
+            $TYPES_FLAVOUR = $arg->{types_flavour} if exists $arg->{types_flavour};
+            if (my $load_types = $arg->{load_types}) {
+                ref $load_types eq 'ARRAY'
+                  or $load_types = [ $load_types ];
+                @ADDITIONAL_TYPES = @$load_types;
+            }
         }
         elsif ($arg eq ':DEBUG') {
             $DEBUG = 1;
         }
+        elsif ($arg eq 'type_tiny') {
+            $TYPES_FLAVOUR = 'type_tiny';
+        }
         else {
             require Carp;
             Carp::croak("Invalid Module::Signatures argument $arg");
@@ -1209,23 +1246,40 @@ sub required_arg {
 # does it.
 our %mutc;
 
+my %_types_flavour_to_mutc = (
+    any_moose => sub {
+        require Any::Moose;
+        Any::Moose->import('::Util::TypeConstraints');
+        no strict 'refs';
+        my $class = any_moose('::Util::TypeConstraints');
+        $mutc{findit}     = \&{ $class . '::find_or_parse_type_constraint' };
+        $mutc{pull}       = \&{ $class . '::find_type_constraint'          };
+        $mutc{make_class} = \&{ $class . '::class_type'                    };
+        $mutc{make_role}  = \&{ $class . '::role_type'                     };
+        $mutc{isa_class}  = $mutc{pull}->("ClassName");
+        $mutc{isa_role}   = $mutc{pull}->("RoleName");
+    },
+    type_tiny => sub {
+        require Type::Registry;
+        Type::Registry->import();
+        #    no strict 'refs';
+        my $class = 'Type::Registry';
+        $mutc{class} = $class;
+        my $registry = $class->for_me;
+        $registry->add_types(-Standard);
+        foreach my $type_to_load (@ADDITIONAL_TYPES) {
+            $registry->add_types($type_to_load);
+        }
+        $mutc{findit} = sub { $registry->lookup(@_) };
+    }
+);
+
+
 # This is a helper function to initialize our %mutc variable.
 sub _init_mutc
 {
-    require Any::Moose;
-    Any::Moose->import('::Util::TypeConstraints');
-
-    no strict 'refs';
-    my $class = any_moose('::Util::TypeConstraints');
-    $mutc{class} = $class;
-
-    $mutc{findit}     = \&{ $class . '::find_or_parse_type_constraint' };
-    $mutc{pull}       = \&{ $class . '::find_type_constraint'          };
-    $mutc{make_class} = \&{ $class . '::class_type'                    };
-    $mutc{make_role}  = \&{ $class . '::role_type'                     };
-
-    $mutc{isa_class}  = $mutc{pull}->("ClassName");
-    $mutc{isa_role}   = $mutc{pull}->("RoleName");
+    ($_types_flavour_to_mutc{$TYPES_FLAVOUR} || $_types_flavour_to_mutc{any_moose})
+      ->();
 }
 
 # This is a helper function to find (or create) the constraint we need for a given type.  It would

t/type_check.t

@@ -7,9 +7,6 @@ use Test::More;
 use Test::Warn;
 use Test::Exception;
 
-use Method::Signatures;
-
-
 { package Foo::Bar; sub new { bless {}, __PACKAGE__; } }
 { package Foo::Baz; sub new { bless {}, __PACKAGE__; } }
 

t/type_check_type_tiny.t

@@ -0,0 +1,158 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+use Test::Exception;
+
+SKIP:
+{
+eval { require Type::Tiny; } or skip "Type::Tiny required for testing Type::Tiny types", 1;
+
+require Method::Signatures;
+Method::Signatures->import(qw(type_tiny));
+
+
+{ package Foo::Bar; sub new { bless {}, __PACKAGE__; } }
+{ package Foo::Baz; sub new { bless {}, __PACKAGE__; } }
+
+our $foobar = Foo::Bar->new;
+our $foobaz = Foo::Baz->new;
+
+
+# types to check below
+# the test name needs to be interpolated into a method name, so it must be a valid identifier
+# either good value or bad value can be an array reference:
+#   *   if it is, it is taken to be multiple values to try
+#   *   if you want to pass an array reference, you have to put it inside another array reference
+#   *   so, [ 42, undef ] makes two calls: one with 42, and one with undef
+#   *   but [[ 42, undef ]] makes one call, passing [ 42, undef ]
+our @TYPES =
+(
+##  Test Name       =>  Type                =>  Good Value                      =>  Bad Value
+    int             =>  'Int'               =>  42                              =>  'foo'                               ,
+    bool            =>  'Bool'              =>  0                               =>  'fool'                              ,
+    aref            =>  'ArrayRef',         =>  [[ 42, undef ]]                 =>  42                                  ,
+
+# The Bad Value returns a slightly different error than expected. So the test
+# should pass, but for now it fails. Should fix this
+#    class           =>  'Foo::Bar'          =>  $foobar                         =>  $foobaz                             ,
+    maybe_int       =>  'Maybe[Int]'        =>  [ 42, undef ]                   =>  'foo'                               ,
+    paramized_aref  =>  'ArrayRef[Num]'     =>  [[ 6.5, 42, 1e23 ]]             =>  [[ 6.5, 42, 'thing' ]]              ,
+    paramized_href  =>  'HashRef[Num]'      =>  { a => 6.5, b => 2, c => 1e23 } =>  { a => 6.5, b => 42, c => 'thing' } ,
+    paramized_nested=>  'HashRef[ArrayRef[Int]]'
+                                            =>  { foo=>[1..3], bar=>[1] }       =>  { foo=>['a'] }                               ,
+   paramized_sref  =>  'ScalarRef[Num]'    =>  \42                             =>  \'thing'                            ,
+    int_or_aref     =>  'Int|ArrayRef[Int]' =>  [ 42 , [42 ] ]                  =>  'foo'                               ,
+    int_or_aref_or_undef
+                    =>  'Int|ArrayRef[Int]|Undef'
+                                            =>  [ 42 , [42 ], undef ]           =>  'foo'                               ,
+);
+
+
+our $tester;
+{
+    package TypeCheck::Class;
+
+    use strict;
+    use warnings;
+
+    use Test::More;
+    use Test::Warn;
+    use Test::Exception;
+
+    use lib 't/lib';
+    use GenErrorRegex qw< badval_error badtype_error >;
+
+    use Method::Signatures;
+
+    method new ($class:) { bless {}, $class; }
+
+    sub _list { return ref $_[0] eq 'ARRAY' ? @{$_[0]} : ( $_[0] ); }
+
+
+    $tester = __PACKAGE__->new;
+    while (@TYPES)
+    {
+        my ($name, $type, $goodval, $badval) = splice @TYPES, 0, 4;
+        note "name/type/goodval/badval $name/$type/$goodval/$badval";
+        my $method = "check_$name";
+        no strict 'refs';
+
+        # make sure the declaration of the method doesn't throw a warning
+        warning_is { eval qq{ method $method ($type \$bar) {} } } undef, "no warnings from declaring $name param";
+
+        # positive test--can we call it with a good value?
+        my @vals = _list($goodval);
+        my $count = 1;
+        foreach (@vals)
+        {
+            my $tag = @vals ? ' (alternative ' . $count++ . ')' : '';
+            lives_ok {
+                $tester->$method($_)
+            } "call with good value for $name passes" . $tag;
+        }
+
+        # negative test--does calling it with a bad value throw an exception?
+        @vals = _list($badval);
+        $count = 1;
+        foreach (@vals)
+        {
+            my $tag = @vals ? ' (#' . $count++ . ')' : '';
+            throws_ok { $tester->$method($_) } badval_error($tester, bar => $type, $_, $method),
+                    "call with bad value for $name dies";
+        }
+    }
+
+
+    # try some mixed (i.e. some with a type, some without) and multiples
+
+    my $method = 'check_mixed_type_first';
+    warning_is { eval qq{ method $method (Int \$bar, \$baz) {} } } undef, 'no warnings (type, notype)';
+    lives_ok { $tester->$method(0, 'thing') } 'call with good values (type, notype) passes';
+    throws_ok { $tester->$method('thing1', 'thing2') } badval_error($tester, bar => Int => thing1 => $method),
+            'call with bad values (type, notype) dies';
+
+    $method = 'check_mixed_type_second';
+    warning_is { eval qq{ method $method (\$bar, Int \$baz) {} } } undef, 'no warnings (notype, type)';
+    lives_ok { $tester->$method('thing', 1) } 'call with good values (notype, type) passes';
+    throws_ok { $tester->$method('thing1', 'thing2') } badval_error($tester, baz => Int => thing2 => $method),
+            'call with bad values (notype, type) dies';
+
+    $method = 'check_multiple_types';
+    warning_is { eval qq{ method $method (Int \$bar, Int \$baz) {} } } undef, 'no warnings when type loaded';
+    lives_ok { $tester->$method(1, 1) } 'call with good values (type, type) passes';
+    # with two types, and bad values for both, they should fail in order of declaration
+    throws_ok { $tester->$method('thing1', 'thing2') } badval_error($tester, bar => Int => thing1 => $method),
+            'call with bad values (type, type) dies';
+
+    # want to try one with undef as well to make sure we don't get an uninitialized warning
+
+    warning_is { eval { $tester->check_int(undef) } } undef, 'no warning for undef value in type checking';
+    like $@, badval_error($tester, bar => Int => undef, 'check_int'),
+            'call with undefined Int arg is okay';
+
+
+    # # finally, some types that shouldn't be recognized
+    # my $type;
+
+    # $method = 'unknown_type';
+    # $type = 'Bmoogle';
+    # warning_is { eval qq{ method $method ($type \$bar) {} } } undef, 'no warnings when weird type loaded';
+    # throws_ok { $tester->$method(42) } badtype_error($tester, $type, "perhaps you forgot to load it?", $method),
+    #         'call with unrecognized type dies';
+
+    # # this one is a bit specialer in that it involved an unrecognized parameterization
+    # $method = 'unknown_paramized_type';
+    # $type = 'Bmoogle[Int]';
+    # warning_is { eval qq{ method $method ($type \$bar) {} } } undef, 'no warnings when weird paramized type loaded';
+    # throws_ok { $tester->$method(42) } badtype_error($tester, $type, "looks like it doesn't parse correctly", $method),
+    #         'call with unrecognized paramized type dies';
+
+}
+
+}
+
+done_testing;