File Coverage

blib/lib/Type/Tiny/XS.pm
Criterion Covered Total %
statement 96 109 88.0
branch 47 70 67.1
condition 11 21 52.3
subroutine 14 15 93.3
pod 3 3 100.0
total 171 218 78.4


line stmt bran cond sub pod time code
1 18     18   123843 use 5.008005;
  18         72  
2 18     18   75 use strict;
  18         33  
  18         368  
3 18     18   73 use warnings;
  18         37  
  18         393  
4 18     18   71 use XSLoader ();
  18         29  
  18         1198  
5              
6             package Type::Tiny::XS;
7              
8             our $AUTHORITY = 'cpan:TOBYINK';
9             our $VERSION = '0.023';
10              
11             __PACKAGE__->XSLoader::load( $VERSION );
12              
13 18     18   98 use Scalar::Util qw(refaddr);
  18         34  
  18         3703  
14              
15             my %names = (
16             map +( $_ => __PACKAGE__ . "::$_" ), qw/
17             Any ArrayRef Bool ClassName CodeRef Defined
18             FileHandle GlobRef HashRef Int Num Object
19             Ref RegexpRef ScalarRef Str Undef Value
20             PositiveInt PositiveOrZeroInt NonEmptyStr
21             ArrayLike HashLike CodeLike StringLike
22             Map Tuple Enum AnyOf AllOf
23             /
24             );
25             $names{Item} = $names{Any};
26              
27             if ( $] lt '5.010000' ) {
28             require MRO::Compat;
29             *Type::Tiny::XS::Util::get_linear_isa = \&mro::get_linear_isa;
30            
31             my $overloaded = sub {
32             require overload;
33             overload::Overloaded( ref $_[0] or $_[0] )
34             and overload::Method( ( ref $_[0] or $_[0] ), $_[1] );
35             };
36            
37 18     18   113 no warnings qw( uninitialized redefine once );
  18         32  
  18         5528  
38             *StringLike = sub {
39             defined( $_[0] ) && !ref( $_[0] )
40             or Scalar::Util::blessed( $_[0] ) && $overloaded->( $_[0], q[""] );
41             };
42             *CodeLike = sub {
43             ref( $_[0] ) eq 'CODE'
44             or Scalar::Util::blessed( $_[0] ) && $overloaded->( $_[0], q[&{}] );
45             };
46             *HashLike = sub {
47             ref( $_[0] ) eq 'HASH'
48             or Scalar::Util::blessed( $_[0] ) && $overloaded->( $_[0], q[%{}] );
49             };
50             *ArrayLike = sub {
51             ref( $_[0] ) eq 'ARRAY'
52             or Scalar::Util::blessed( $_[0] ) && $overloaded->( $_[0], q[@{}] );
53             };
54             } #/ if ( $] < '5.010000' [)
55              
56             my %coderefs;
57              
58             sub _know {
59 579     579   964 my ( $coderef, $type ) = @_;
60 579         1367 $coderefs{ refaddr( $coderef ) } = $type;
61             }
62              
63             sub is_known {
64 3     3 1 1571 my $coderef = shift;
65 3         12 $coderefs{ refaddr( $coderef ) };
66             }
67              
68             for ( reverse sort keys %names ) {
69 18     18   112 no strict qw(refs);
  18         32  
  18         1294  
70             _know \&{ $names{$_} }, $_;
71             }
72              
73             my $id = 0;
74              
75             sub get_coderef_for {
76 44     44 1 26480 my $type = $_[0];
77            
78             return do {
79 18     18   111 no strict qw(refs);
  18         41  
  18         15209  
80 23         27 \&{ $names{$type} };
  23         104  
81 44 100       121 } if exists $names{$type};
82            
83 21         30 my $made;
84            
85 21 100 66     235 if ( $type =~ /^ArrayRef\[(.+)\]$/ ) {
    100 66        
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
86 7 50       49 my $child = get_coderef_for( $1 ) or return;
87 7         34 $made = _parameterize_ArrayRef_for( $child );
88             }
89            
90             elsif ( $] ge '5.010000' and $type =~ /^ArrayLike\[(.+)\]$/ ) {
91 1 50       3 my $child = get_coderef_for( $1 ) or return;
92 1         5 $made = _parameterize_ArrayLike_for( $child );
93             }
94            
95             elsif ( $type =~ /^HashRef\[(.+)\]$/ ) {
96 2 50       24 my $child = get_coderef_for( $1 ) or return;
97 2         8 $made = _parameterize_HashRef_for( $child );
98             }
99            
100             elsif ( $] ge '5.010000' and $type =~ /^HashLike\[(.+)\]$/ ) {
101 1 50       2 my $child = get_coderef_for( $1 ) or return;
102 1         5 $made = _parameterize_HashLike_for( $child );
103             }
104            
105             elsif ( $type =~ /^Map\[(.+),(.+)\]$/ ) {
106 2         4 my @children;
107 2 50       4 if ( eval { require Type::Parser } ) {
  2         1421  
108 2         6087 @children = map scalar( get_coderef_for( $_ ) ), _parse_parameters( $type );
109             }
110             else {
111 0         0 push @children, get_coderef_for( $1 );
112 0         0 push @children, get_coderef_for( $2 );
113             }
114 2 50       7 @children == 2 or return;
115 2   50     9 defined or return for @children;
116 2         9 $made = _parameterize_Map_for( \@children );
117             } #/ elsif ( $type =~ /^Map\[(.+),(.+)\]$/)
118            
119             elsif ( $type =~ /^(AnyOf|AllOf|Tuple)\[(.+)\]$/ ) {
120 4         11 my $base = $1;
121             my @children =
122             map scalar( get_coderef_for( $_ ) ),
123 4 50       5 ( eval { require Type::Parser } )
  4         407  
124             ? _parse_parameters( $type )
125             : split( /,/, $2 );
126 4   50     18 defined or return for @children;
127 4         24 my $maker = __PACKAGE__->can( "_parameterize_${base}_for" );
128 4 50       25 $made = $maker->( \@children ) if $maker;
129             } #/ elsif ( $type =~ /^(AnyOf|AllOf|Tuple)\[(.+)\]$/)
130            
131             elsif ( $type =~ /^Maybe\[(.+)\]$/ ) {
132 0 0       0 my $child = get_coderef_for( $1 ) or return;
133 0         0 $made = _parameterize_Maybe_for( $child );
134             }
135            
136             elsif ( $type =~ /^InstanceOf\[(.+)\]$/ ) {
137 1         3 my $class = $1;
138 1 50       6 return unless Type::Tiny::XS::Util::is_valid_class_name( $class );
139 1         11 $made = Type::Tiny::XS::Util::generate_isa_predicate_for( $class );
140             }
141            
142             elsif ( $type =~ /^HasMethods\[(.+)\]$/ ) {
143 0         0 my $methods = [ sort( split /,/, $1 ) ];
144 0   0     0 /^[^\W0-9]\w*$/ or return for @$methods;
145 0         0 $made = Type::Tiny::XS::Util::generate_can_predicate_for( $methods );
146             }
147            
148             # Type::Tiny::Enum > 1.010003 double-quotes its enums
149             elsif ( $type =~ /^Enum\[".*"\]$/ ) {
150 1 50       2 if ( eval { require Type::Parser } ) {
  1         8  
151 1         3 my $parsed = Type::Parser::parse( $type );
152 1 50       15182 if ( $parsed->{type} eq "parameterized" ) {
153 1         2 my @todo = $parsed->{params};
154 1         2 my @strings;
155             my $bad;
156 1         3 while ( my $todo = shift @todo ) {
157 6 100 66     25 if ( $todo->{type} eq 'list' ) {
    100 33        
    50          
158 1         2 push @todo, @{ $todo->{list} };
  1         5  
159             }
160             elsif ( $todo->{type} eq "expression"
161             && $todo->{op}->type eq Type::Parser::COMMA() )
162             {
163 2         12 push @todo, $todo->{lhs}, $todo->{rhs};
164             }
165             elsif ( $todo->{type} eq "primary" && $todo->{token}->type eq "QUOTELIKE" ) {
166 3         14 push @strings, eval( $todo->{token}->spelling );
167             }
168             else {
169             # Unexpected entry in the parse-tree, bail out
170 0         0 $bad = 1;
171             }
172             } #/ while ( my $todo = shift ...)
173 1 50       17 $made = _parameterize_Enum_for( \@strings ) unless $bad;
174             } #/ if ( $parsed->{type} eq...)
175             } #/ if ( eval { require Type::Parser...})
176             } #/ elsif ( $type =~ /^Enum\[".*"\]$/)
177            
178             elsif ( $type =~ /^Enum\[(.+)\]$/ ) {
179 2         12 my $strings = [ sort( split /,/, $1 ) ];
180 2         9 $made = _parameterize_Enum_for( $strings );
181             }
182            
183 21 50       65 if ( $made ) {
184 18     18   129 no strict qw(refs);
  18         33  
  18         7358  
185 21         95 my $slot = sprintf( '%s::AUTO::TC%d', __PACKAGE__, ++$id );
186 21         63 $names{$type} = $slot;
187 21         49 _know( $made, $type );
188 21         129 *$slot = $made;
189 21         64 return $made;
190             }
191            
192 0         0 return;
193             } #/ sub get_coderef_for
194              
195             sub get_subname_for {
196 0     0 1 0 my $type = $_[0];
197 0 0       0 get_coderef_for( $type ) unless exists $names{$type};
198 0         0 $names{$type};
199             }
200              
201             sub _parse_parameters {
202 6     6   6391 my $got = Type::Parser::parse( @_ );
203 6 50       6898 $got->{params} or return;
204 6         15 _handle_expr( $got->{params} );
205             }
206              
207             sub _handle_expr {
208 51     51   83 my $e = shift;
209            
210 51 100       79 if ( $e->{type} eq 'list' ) {
211 11         12 return map _handle_expr( $_ ), @{ $e->{list} };
  11         36  
212             }
213 40 100       72 if ( $e->{type} eq 'parameterized' ) {
214 5         11 my ( $base ) = _handle_expr( $e->{base} );
215 5         27 my @params = _handle_expr( $e->{params} );
216 5         70 return sprintf( '%s[%s]', $base, join( q[,], @params ) );
217             }
218 35 100 66     76 if ( $e->{type} eq 'expression' and $e->{op}->type eq Type::Parser::COMMA() ) {
219 12         70 return _handle_expr( $e->{lhs} ), _handle_expr( $e->{rhs} );
220             }
221 23 50       35 if ( $e->{type} eq 'primary' ) {
222 23         39 return $e->{token}->spelling;
223             }
224            
225 0           '****';
226             } #/ sub _handle_expr
227              
228             1;
229              
230             __END__