File Coverage

blib/lib/Type/Tiny/Role.pm
Criterion Covered Total %
statement 68 68 100.0
branch 18 28 64.2
condition 5 12 41.6
subroutine 23 23 100.0
pod 5 5 100.0
total 119 136 87.5


line stmt bran cond sub pod time code
1             package Type::Tiny::Role;
2              
3 25     25   70660 use 5.008001;
  25         98  
4 25     25   136 use strict;
  25         52  
  25         690  
5 25     25   133 use warnings;
  25         39  
  25         1260  
6              
7             BEGIN {
8 25     25   90 $Type::Tiny::Role::AUTHORITY = 'cpan:TOBYINK';
9 25         1165 $Type::Tiny::Role::VERSION = '2.004000';
10             }
11              
12             $Type::Tiny::Role::VERSION =~ tr/_//d;
13              
14 25     25   167 use Scalar::Util qw< blessed weaken >;
  25         41  
  25         3035  
15              
16 1     1   6 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  1         5  
17              
18 25     25   657 use Exporter::Tiny 1.004001 ();
  25         4914  
  25         693  
19 25     25   8504 use Type::Tiny::ConstrainedObject ();
  25         61  
  25         20738  
20             our @ISA = qw( Type::Tiny::ConstrainedObject Exporter::Tiny );
21              
22 3     3   10 sub _short_name { 'Role' }
23              
24             sub _exporter_fail {
25 1     1   167 my ( $class, $name, $opts, $globals ) = @_;
26 1         2 my $caller = $globals->{into};
27            
28 1 50       4 $opts->{name} = $name unless exists $opts->{name}; $opts->{name} =~ s/:://g;
  1         6  
29 1 50       4 $opts->{role} = $name unless exists $opts->{role};
30 1         3 my $type = $class->new($opts);
31            
32             $INC{'Type/Registry.pm'}
33             ? 'Type::Registry'->for_class( $caller )->add_type( $type )
34             : ( $Type::Registry::DELAYED{$caller}{$type->name} = $type )
35 1 50 33     13 unless( ref($caller) or $caller eq '-lexical' or $globals->{'lexical'} );
    50 33        
36 1         1 return map +( $_->{name} => $_->{code} ), @{ $type->exportables };
  1         5  
37             }
38              
39             my %cache;
40              
41             sub new {
42 53     53 1 606 my $proto = shift;
43 53 100       287 my %opts = ( @_ == 1 ) ? %{ $_[0] } : @_;
  2         12  
44 53 100       235 _croak "Need to supply role name" unless exists $opts{role};
45 52         293 return $proto->SUPER::new( %opts );
46             }
47              
48 75     75 1 226 sub role { $_[0]{role} }
49 385   66 385 1 2143 sub inlined { $_[0]{inlined} ||= $_[0]->_build_inlined }
50              
51 750     750 1 2647 sub has_inlined { !!1 }
52              
53 1343     1343   3232 sub _is_null_constraint { 0 }
54              
55             sub _build_constraint {
56 15     15   32 my $self = shift;
57 15         32 my $role = $self->role;
58             return sub {
59 27 50   27   143 blessed( $_ ) and do {
60 27   33     99 my $method = $_->can( 'DOES' ) || $_->can( 'isa' );
61 27         182 $_->$method( $role );
62             }
63 15         108 };
64             } #/ sub _build_constraint
65              
66             sub _build_inlined {
67 49     49   86 my $self = shift;
68 49         119 my $role = $self->role;
69             sub {
70 385     385   538 my $var = $_[1];
71 385         1346 my $code =
72             qq{Scalar::Util::blessed($var) and do { my \$method = $var->can('DOES')||$var->can('isa'); $var->\$method(q[$role]) }};
73 385 100       886 return qq{do { use Scalar::Util (); $code }} if $Type::Tiny::AvoidCallbacks;
74 340         751 $code;
75 49         358 };
76             } #/ sub _build_inlined
77              
78             sub _build_default_message {
79 2     2   4 my $self = shift;
80 2         5 my $c = $self->role;
81             return sub {
82 1     1   4 sprintf '%s did not pass type constraint (not DOES %s)',
83             Type::Tiny::_dd( $_[0] ), $c;
84             }
85 2 100       9 if $self->is_anon;
86 1         5 my $name = "$self";
87             return sub {
88 1     1   5 sprintf '%s did not pass type constraint "%s" (not DOES %s)',
89             Type::Tiny::_dd( $_[0] ), $name, $c;
90 1         8 };
91             } #/ sub _build_default_message
92              
93             sub validate_explain {
94 2     2 1 4 my $self = shift;
95 2         5 my ( $value, $varname ) = @_;
96 2 50       5 $varname = '$_' unless defined $varname;
97            
98 2 50       17 return undef if $self->check( $value );
99 2 50       32 return ["Not a blessed reference"] unless blessed( $value );
100 2 50       7 return ["Reference provides no DOES method to check roles"]
101             unless $value->can( 'DOES' );
102            
103 2 50       8 my $display_var = $varname eq q{$_} ? '' : sprintf( ' (in %s)', $varname );
104            
105             return [
106 2         7 sprintf( '"%s" requires that the reference does %s', $self, $self->role ),
107             sprintf( "The reference%s doesn't %s", $display_var, $self->role ),
108             ];
109             } #/ sub validate_explain
110              
111             1;
112              
113             __END__