File Coverage

blib/lib/Type/Tiny/Duck.pm
Criterion Covered Total %
statement 72 81 88.8
branch 17 26 65.3
condition 4 9 44.4
subroutine 21 22 95.4
pod 5 5 100.0
total 119 143 83.2


line stmt bran cond sub pod time code
1             package Type::Tiny::Duck;
2              
3 25     25   71084 use 5.008001;
  25         97  
4 25     25   131 use strict;
  25         47  
  25         569  
5 25     25   110 use warnings;
  25         53  
  25         1208  
6              
7             BEGIN {
8 25     25   73 $Type::Tiny::Duck::AUTHORITY = 'cpan:TOBYINK';
9 25         1022 $Type::Tiny::Duck::VERSION = '2.004000';
10             }
11              
12             $Type::Tiny::Duck::VERSION =~ tr/_//d;
13              
14 25     25   156 use Scalar::Util qw< blessed >;
  25         49  
  25         2407  
15              
16 1     1   6 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  1         5  
17              
18 25     25   685 use Exporter::Tiny 1.004001 ();
  25         4878  
  25         593  
19 25     25   2230 use Type::Tiny::ConstrainedObject ();
  25         50  
  25         32773  
20             our @ISA = qw( Type::Tiny::ConstrainedObject Exporter::Tiny );
21              
22 3     3   10 sub _short_name { 'Duck' }
23              
24             sub _exporter_fail {
25 1     1   177 my ( $class, $type_name, $methods, $globals ) = @_;
26 1         2 my $caller = $globals->{into};
27 1         4 my $type = $class->new(
28             name => $type_name,
29             methods => [ @$methods ],
30             );
31             $INC{'Type/Registry.pm'}
32             ? 'Type::Registry'->for_class( $caller )->add_type( $type, $type_name )
33             : ( $Type::Registry::DELAYED{$caller}{$type_name} = $type )
34 1 50 33     12 unless( ref($caller) or $caller eq '-lexical' or $globals->{'lexical'} );
    50 33        
35 1         2 return map +( $_->{name} => $_->{code} ), @{ $type->exportables };
  1         10  
36             }
37              
38             sub new {
39 51     51 1 188 my $proto = shift;
40            
41 51 50       259 my %opts = ( @_ == 1 ) ? %{ $_[0] } : @_;
  0         0  
42 51 100       215 _croak "Need to supply list of methods" unless exists $opts{methods};
43            
44 50 50       185 $opts{methods} = [ $opts{methods} ] unless ref $opts{methods};
45            
46 50         83 if ( Type::Tiny::_USE_XS ) {
47 50         76 my $methods = join ",", sort( @{ $opts{methods} } );
  50         230  
48 50         249 my $xsub = Type::Tiny::XS::get_coderef_for( "HasMethods[$methods]" );
49 50 100       3146 $opts{compiled_type_constraint} = $xsub if $xsub;
50             }
51             elsif ( Type::Tiny::_USE_MOUSE ) {
52             require Mouse::Util::TypeConstraints;
53             my $maker = "Mouse::Util::TypeConstraints"->can( "generate_can_predicate_for" );
54             $opts{compiled_type_constraint} = $maker->( $opts{methods} ) if $maker;
55             }
56            
57 50         358 return $proto->SUPER::new( %opts );
58             } #/ sub new
59              
60             sub _lockdown {
61 47     47   116 my ( $self, $callback ) = @_;
62 47         155 $callback->( $self->{methods} );
63             }
64              
65 115     115 1 425 sub methods { $_[0]{methods} }
66 205   66 205 1 1306 sub inlined { $_[0]{inlined} ||= $_[0]->_build_inlined }
67              
68 396     396 1 1307 sub has_inlined { !!1 }
69              
70 658     658   1677 sub _is_null_constraint { 0 }
71              
72             sub _build_constraint {
73 7     7   14 my $self = shift;
74 7         12 my @methods = @{ $self->methods };
  7         37  
75             return sub {
76 21 50   21   161 blessed( $_[0] )
77             and not grep( !$_[0]->can( $_ ), @methods );
78 7         54 };
79             }
80              
81             sub _build_inlined {
82 45     45   487 my $self = shift;
83 45         67 my @methods = @{ $self->methods };
  45         101  
84            
85 45         79 my $xsub;
86 45         72 if ( Type::Tiny::_USE_XS ) {
87 45         69 my $methods = join ",", sort( @{ $self->methods } );
  45         96  
88 45         194 $xsub = Type::Tiny::XS::get_subname_for( "HasMethods[$methods]" );
89             }
90            
91             sub {
92 205     205   298 my $var = $_[1];
93 205         302 local $" = q{ };
94            
95             # If $var is $_ or $_->{foo} or $foo{$_} or somesuch, then we
96             # can't use it within the grep expression, so we need to save
97             # it into a temporary variable ($tmp).
98 205 100       968 my $code =
99             ( $var =~ /\$_/ )
100             ? qq{ Scalar::Util::blessed($var) and not do { my \$tmp = $var; grep(!\$tmp->can(\$_), qw/@methods/) } }
101             : qq{ Scalar::Util::blessed($var) and not grep(!$var->can(\$_), qw/@methods/) };
102            
103 205 100       510 return qq{do { $Type::Tiny::SafePackage use Scalar::Util (); $code }}
104             if $Type::Tiny::AvoidCallbacks;
105 180 50       739 return "$xsub\($var\)"
106             if $xsub;
107 0         0 $code;
108 45         604 };
109             } #/ sub _build_inlined
110              
111             sub _instantiate_moose_type {
112 0     0   0 my $self = shift;
113 0         0 my %opts = @_;
114 0         0 delete $opts{parent};
115 0         0 delete $opts{constraint};
116 0         0 delete $opts{inlined};
117            
118 0         0 require Moose::Meta::TypeConstraint::DuckType;
119 0         0 return "Moose::Meta::TypeConstraint::DuckType"
120             ->new( %opts, methods => $self->methods );
121             } #/ sub _instantiate_moose_type
122              
123             sub validate_explain {
124 1     1 1 2 my $self = shift;
125 1         3 my ( $value, $varname ) = @_;
126 1 50       4 $varname = '$_' unless defined $varname;
127            
128 1 50       9 return undef if $self->check( $value );
129 1 50       8 return ["Not a blessed reference"] unless blessed( $value );
130            
131 1         540 require Type::Utils;
132             return [
133             sprintf(
134             '"%s" requires that the reference can %s',
135             $self,
136 1         5 Type::Utils::english_list( map qq["$_"], @{ $self->methods } ),
137             ),
138             map sprintf( 'The reference cannot "%s"', $_ ),
139             grep !$value->can( $_ ),
140 1         5 @{ $self->methods }
  1         4  
141             ];
142             } #/ sub validate_explain
143              
144             push @Type::Tiny::CMP, sub {
145             my $A = shift->find_constraining_type;
146             my $B = shift->find_constraining_type;
147             return Type::Tiny::CMP_UNKNOWN
148             unless $A->isa( __PACKAGE__ ) && $B->isa( __PACKAGE__ );
149            
150             my %seen;
151             for my $word ( @{ $A->methods } ) {
152             $seen{$word} += 1;
153             }
154             for my $word ( @{ $B->methods } ) {
155             $seen{$word} += 2;
156             }
157            
158             my $values = join( '', CORE::values %seen );
159             if ( $values =~ /^3*$/ ) {
160             return Type::Tiny::CMP_EQUIVALENT;
161             }
162             elsif ( $values !~ /2/ ) {
163             return Type::Tiny::CMP_SUBTYPE;
164             }
165             elsif ( $values !~ /1/ ) {
166             return Type::Tiny::CMP_SUPERTYPE;
167             }
168            
169             return Type::Tiny::CMP_UNKNOWN;
170             };
171              
172             1;
173              
174             __END__