File Coverage

blib/lib/Type/Library.pm
Criterion Covered Total %
statement 220 220 100.0
branch 67 82 81.7
condition 45 59 76.2
subroutine 37 37 100.0
pod 11 11 100.0
total 380 409 92.9


line stmt bran cond sub pod time code
1             package Type::Library;
2              
3 257     257   391899 use 5.008001;
  257         959  
4 257     257   1405 use strict;
  257         501  
  257         5688  
5 257     257   1270 use warnings;
  257         684  
  257         12025  
6              
7             BEGIN {
8 257     257   952 $Type::Library::AUTHORITY = 'cpan:TOBYINK';
9 257         11814 $Type::Library::VERSION = '2.004000';
10             }
11              
12             $Type::Library::VERSION =~ tr/_//d;
13              
14 257     257   97256 use Eval::TypeTiny qw< eval_closure set_subname type_to_coderef NICE_PROTOTYPES >;
  257         669  
  257         2023  
15 257     257   167430 use Scalar::Util qw< blessed refaddr >;
  257         754  
  257         14640  
16 257     257   62003 use Type::Tiny ();
  257         669  
  257         5035  
17 257     257   1469 use Types::TypeTiny ();
  257         524  
  257         227755  
18              
19             require Exporter::Tiny;
20             our @ISA = 'Exporter::Tiny';
21              
22 8     8   49 sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }
  8         52  
23              
24             ####
25             #### Hooks for Exporter::Tiny
26             ####
27              
28             # Handling for -base, -extends, and -utils tags.
29             #
30             sub _exporter_validate_opts {
31 1038     1038   1579859 my ( $class, $opts ) = ( shift, @_ );
32            
33 392         2093 $class->setup_type_library( @{$opts}{qw/ into utils extends /}, $opts )
34 1038 100 100     7677 if $_[0]{base} || $_[0]{extends};
35            
36 1038         5469 return $class->SUPER::_exporter_validate_opts( @_ );
37             }
38              
39             # In Exporter::Tiny, this method takes a sub name, a 'value' (i.e.
40             # potentially an options hashref for the export), and some global
41             # options, and returns a list of name+coderef pairs to actually
42             # export. We override it to provide some useful features.
43             #
44             sub _exporter_expand_sub {
45 18690     18690   787516 my ( $class, $name, $value, $globals ) = ( shift, @_ );
46            
47             # Handle exporting '+Type'.
48             #
49             # Note that this recurses, so if used in conjunction with the other
50             # special cases handled by this method, will still work.
51             #
52 18690 100 66     46080 if ( $name =~ /^\+(.+)/ and $class->has_type( "$1" ) ) {
53 13         74 my $type = $class->get_type( "$1" );
54 13         62 my $exported = $type->exportables;
55             return map $class->_exporter_expand_sub(
56             $_->{name},
57 13 50       90 +{ %{ $value || {} } },
  58         17361  
58             $globals,
59             ), @$exported;
60             }
61            
62             # Is the function being exported one which is associated with a
63             # type constraint? If so, which one. If not, then forget the rest
64             # and just use the superclass method.
65             #
66 18677 100 100     36444 if ( my $f = $class->meta->{'functions'}{$name}
67             and defined $class->meta->{'functions'}{$name}{'type'} ) {
68            
69 17726         28849 my $type = $f->{type};
70 17726         38374 my $tag = $f->{tags}[0];
71 17726         40991 my $typename = $type->name;
72            
73             # If $value has `of` or `where` options, then this is a
74             # custom type.
75             #
76 17726         26407 my $custom_type = 0;
77 17726         28114 for my $param ( qw/ of where / ) {
78 35452 100       65517 exists $value->{$param} or next;
79 3 50       7 defined $value->{-as} or _croak( "Parameter '-as' not supplied" );
80 3         12 $type = $type->$param( $value->{$param} );
81 3         5 $name = $value->{-as};
82 3         6 ++$custom_type;
83             }
84            
85             # If we're exporting a type itself, then export a custom
86             # function if they customized the type or want a Moose/Mouse
87             # type constraint.
88             #
89 17726 100       32871 if ( $tag eq 'types' ) {
90 8871         12396 my $post_method = q();
91 8871 50       17560 $post_method = '->mouse_type' if $globals->{mouse};
92 8871 50       15199 $post_method = '->moose_type' if $globals->{moose};
93 8871 100 66     26322 return ( $name => type_to_coderef( $type, post_method => $post_method ) )
94             if $post_method || $custom_type;
95             }
96            
97             # If they're exporting some other type of function, like
98             # 'to', 'is', or 'assert', then find the correct exportable
99             # by tag name, and return that.
100             #
101             # XXX: this will fail for tags like 'constants' where there
102             # will be multiple exportables which match!
103             #
104 17724 100 66     38650 if ( $custom_type and $tag ne 'types' ) {
105 1         4 my $exportable = $type->exportables_by_tag( $tag, $typename );
106 1   33     7 return ( $value->{-as} || $exportable->{name}, $exportable->{code} );
107             }
108             }
109            
110             # In all other cases, the superclass method will work.
111             #
112 18674         47900 return $class->SUPER::_exporter_expand_sub( @_ );
113             }
114              
115             # Mostly just rely on superclass to do the actual export, but add
116             # a couple of useful behaviours.
117             #
118             sub _exporter_install_sub {
119 18675     18675   679210 my ( $class, $name, $value, $globals, $sym ) = ( shift, @_ );
120            
121 18675         29356 my $into = $globals->{into};
122 18675         33418 my $type = $class->meta->{'functions'}{$name}{'type'};
123 18675         33843 my $tags = $class->meta->{'functions'}{$name}{'tags'};
124            
125             # Issue a warning if exporting a deprecated type constraint.
126             #
127             Exporter::Tiny::_carp(
128             "Exporting deprecated type %s to %s",
129             $type->qualified_name,
130             ref( $into ) ? "reference" : "package $into",
131 18675 50 100     57364 ) if ( defined $type and $type->deprecated and not $globals->{allow_deprecated} );
    100 100        
132            
133             # If exporting a type constraint into a real package, then
134             # add it to the package's type registry.
135             #
136 18675 100 66     113502 if ( !ref $into
      100        
      100        
137             and $into ne '-lexical'
138             and defined $type
139             and grep $_ eq 'types', @$tags ) {
140            
141             # If they're renaming it, figure out what name, and use that.
142             # XXX: `-as` can be a coderef, and can be in $globals in that case.
143 8303         24503 my ( $prefix ) = grep defined, $value->{-prefix}, $globals->{prefix}, q();
144 8303         17903 my ( $suffix ) = grep defined, $value->{-suffix}, $globals->{suffix}, q();
145 8303   66     26345 my $as = $prefix . ( $value->{-as} || $name ) . $suffix;
146            
147             $INC{'Type/Registry.pm'}
148             ? 'Type::Registry'->for_class( $into )->add_type( $type, $as )
149 8303 100       24872 : ( $Type::Registry::DELAYED{$into}{$as} = $type );
150             }
151            
152 18675         47163 $class->SUPER::_exporter_install_sub( @_ );
153             } #/ sub _exporter_install_sub
154              
155             sub _exporter_fail {
156 811     811   14038 my ( $class, $name, $value, $globals ) = ( shift, @_ );
157            
158             # Passing the `-declare` flag means that if a type isn't found, then
159             # we export a placeholder function instead of failing.
160 811 100       1900 if ( $globals->{declare} ) {
161             return (
162             $name,
163             type_to_coderef(
164             undef,
165             type_name => $name,
166 809   33     2568 type_library => $globals->{into} || _croak( "Parameter 'into' not supplied" ),
167             ),
168             );
169             } #/ if ( $globals->{declare...})
170            
171 2         17 return $class->SUPER::_exporter_fail( @_ );
172             } #/ sub _exporter_fail
173              
174             ####
175             #### Type library functionality
176             ####
177              
178             sub setup_type_library {
179 392     392 1 1203 my ( $class, $type_library, $install_utils, $extends, $opts ) = ( shift, @_ );
180            
181 392 50       1731 my @extends = ref( $extends ) ? @$extends : $extends ? $extends : ();
    100          
182 392 100       1368 unshift @extends, $class if $class ne __PACKAGE__;
183            
184 392 50       1157 if ( not ref $type_library ) {
185 257     257   2179 no strict "refs";
  257         601  
  257         54518  
186 392         637 push @{"$type_library\::ISA"}, $class;
  392         4324  
187 392         2143 ( my $file = $type_library ) =~ s{::}{/}g;
188 392   100     1975 $INC{"$file.pm"} ||= __FILE__;
189             }
190            
191 392 100       1195 if ( $install_utils ) {
192 4         1541 require Type::Utils;
193 4         59 'Type::Utils'->import(
194             { %$opts, into => $type_library },
195             '-default',
196             );
197             }
198            
199 392 100 66     9500 if ( @extends and not ref $type_library ) {
200 18         9677 require Type::Utils;
201 18         1253 my $wrapper = eval "sub { package $type_library; &Type::Utils::extends; }";
202 18         370 $wrapper->( @extends );
203             }
204             }
205              
206             sub meta {
207 257     257   2071 no strict "refs";
  257         636  
  257         9531  
208 257     257   1712 no warnings "once";
  257         679  
  257         81564  
209 118268 100   118268 1 306017 return $_[0] if blessed $_[0];
210 77768   100     92175 ${"$_[0]\::META"} ||= bless {}, $_[0];
  77768         302555  
211             }
212              
213             sub add_type {
214 12140     12140 1 37778 my $meta = shift->meta;
215 12140         29544 my $class = blessed( $meta ) ;
216            
217 12140 100       29388 _croak( 'Type library is immutable' ) if $meta->{immutable};
218            
219             my $type =
220             ref( $_[0] ) =~ /^Type::Tiny\b/ ? $_[0] :
221             blessed( $_[0] ) ? Types::TypeTiny::to_TypeTiny( $_[0] ) :
222 12136 100       52771 ref( $_[0] ) eq q(HASH) ? 'Type::Tiny'->new( library => $class, %{ $_[0] } ) :
  9361 50       54112  
    100          
223             "Type::Tiny"->new( library => $class, @_ );
224 12136         30110 my $name = $type->{name};
225            
226 12136 100       29631 if ( $meta->has_type( $name ) ) {
227 1         9 my $existing = $meta->get_type( $name );
228 1 50       5 return if $type->{uniq} == $existing->{uniq};
229 1         4 _croak( 'Type %s already exists in this library', $name );
230             }
231            
232 12135 50       28429 _croak( 'Type %s conflicts with coercion of same name', $name ) if $meta->has_coercion( $name );
233 12135 100       34141 _croak( 'Cannot add anonymous type to a library' ) if $type->is_anon;
234 12134   50     28406 $meta->{types} ||= {};
235 12134         30110 $meta->{types}{$name} = $type;
236            
237 257     257   2085 no strict "refs";
  257         710  
  257         10216  
238 257     257   1752 no warnings "redefine", "prototype";
  257         645  
  257         89576  
239            
240 12134         16024 for my $exportable ( @{ $type->exportables } ) {
  12134         28537  
241 48545         82458 my $name = $exportable->{name};
242 48545         61914 my $code = $exportable->{code};
243 48545         60546 my $tags = $exportable->{tags};
244             _croak( 'Function %s is provided by types %s and %s', $name, $meta->{'functions'}{$name}{'type'}->name, $type->name )
245 48545 100       100091 if $meta->{'functions'}{$name};
246 48544         124315 *{"$class\::$name"} = set_subname( "$class\::$name", $code );
  48544         215144  
247 48544         76049 push @{"$class\::EXPORT_OK"}, $name;
  48544         118056  
248 48544   100     83277 push @{ ${"$class\::EXPORT_TAGS"}{$_} ||= [] }, $name for @$tags;
  48544         56004  
  48544         181291  
249 48544         302098 $meta->{'functions'}{$name} = { type => $type, tags => $tags };
250             }
251            
252             $INC{'Type/Registry.pm'}
253             ? 'Type::Registry'->for_class( $class )->add_type( $type, $name )
254 12133 100       63432 : ( $Type::Registry::DELAYED{$class}{$name} = $type );
255            
256 12133         38188 return $type;
257             } #/ sub add_type
258              
259             # For Type::TinyX::Facets
260             # Only use this if you know what you're doing!
261             sub _remove_type {
262 1     1   15 my $meta = shift->meta;
263 1         5 my $type = $meta->get_type( $_[0] );
264 1         3 my $class = ref $meta;
265            
266 1 50       5 _croak( 'Type library is immutable' ) if $meta->{immutable};
267            
268 1         4 delete $meta->{types}{$type->name};
269            
270 257     257   2066 no strict "refs";
  257         576  
  257         10115  
271 257     257   1667 no warnings "redefine", "prototype";
  257         559  
  257         140686  
272            
273 1         2 my @clean;
274             my $_scrub = sub {
275 8     8   12 my ( $arr, $name ) = @_;
276 8         172 @$arr = grep $_ ne $name, @$arr;
277 1         5 };
278 1         2 for my $exportable ( @{ $type->exportables } ) {
  1         3  
279 4         8 my $name = $exportable->{name};
280 4         5 push @clean, $name;
281 4         6 &$_scrub( \@{"$class\::EXPORT_OK"}, $name );
  4         14  
282 4         5 for my $t ( @{ $exportable->{tags} } ) {
  4         7  
283 4   50     5 &$_scrub( ${"$class\::EXPORT_TAGS"}{$t} ||= [], $name );
  4         16  
284             }
285 4         16 delete $meta->{'functions'}{$name};
286             }
287 1         13 eval {
288 1         5 require namespace::clean;
289 1         8 'namespace::clean'->clean_subroutines( $class, @clean );
290             };
291            
292             delete 'Type::Registry'->for_class( $class )->{$type->name}
293 1 50       189 if $INC{'Type/Registry.pm'};
294 1         5 delete $Type::Registry::DELAYED{$class}{$type->name};
295            
296 1         5 return $type;
297             } #/ sub _remove_type
298              
299             sub get_type {
300 3410     3410 1 10261 my $meta = shift->meta;
301 3410         16054 $meta->{types}{ $_[0] };
302             }
303              
304             sub has_type {
305 13115     13115 1 27590 my $meta = shift->meta;
306 13115         42438 exists $meta->{types}{ $_[0] };
307             }
308              
309             sub type_names {
310 84     84 1 400 my $meta = shift->meta;
311 84         172 keys %{ $meta->{types} };
  84         1607  
312             }
313              
314             sub add_coercion {
315 896     896 1 2445 my $meta = shift->meta;
316 896         2832 my $class = blessed( $meta );
317            
318 896 50       2755 _croak( 'Type library is immutable' ) if $meta->{immutable};
319            
320 896         5721 require Type::Coercion;
321 896 100       7040 my $c = blessed( $_[0] ) ? $_[0] : "Type::Coercion"->new( @_ );
322 896         2483 my $name = $c->name;
323            
324 896 50       2478 _croak( 'Coercion %s already exists in this library', $name ) if $meta->has_coercion( $name );
325 896 100       2637 _croak( 'Coercion %s conflicts with type of same name', $name ) if $meta->has_type( $name );
326 895 50       2526 _croak( 'Cannot add anonymous type to a library' ) if $c->is_anon;
327            
328 895   50     2763 $meta->{coercions} ||= {};
329 895         2370 $meta->{coercions}{$name} = $c;
330            
331 257     257   2149 no strict "refs";
  257         631  
  257         10008  
332 257     257   1687 no warnings "redefine", "prototype";
  257         609  
  257         64815  
333            
334 895         2602 *{"$class\::$name"} = type_to_coderef( $c );
  895         6242  
335 895         4266 push @{"$class\::EXPORT_OK"}, $name;
  895         3129  
336 895   100     1609 push @{ ${"$class\::EXPORT_TAGS"}{'coercions'} ||= [] }, $name;
  895         1352  
  895         4881  
337 895         9131 $meta->{'functions'}{$name} = { coercion => $c, tags => [ 'coercions' ] };
338              
339 895         3718 return $c;
340             } #/ sub add_coercion
341              
342             sub get_coercion {
343 105     105 1 312 my $meta = shift->meta;
344 105         434 $meta->{coercions}{ $_[0] };
345             }
346              
347             sub has_coercion {
348 13031     13031 1 22409 my $meta = shift->meta;
349 13031         35226 exists $meta->{coercions}{ $_[0] };
350             }
351              
352             sub coercion_names {
353 84     84 1 277 my $meta = shift->meta;
354 84         195 keys %{ $meta->{coercions} };
  84         823  
355             }
356              
357             sub make_immutable {
358 339     339 1 1206 my $meta = shift->meta;
359 339         1408 my $class = ref( $meta );
360            
361 257     257   2090 no strict "refs";
  257         634  
  257         9990  
362 257     257   1666 no warnings "redefine", "prototype";
  257         675  
  257         45723  
363            
364 339         791 for my $type ( values %{ $meta->{types} } ) {
  339         2573  
365 11198         26669 $type->coercion->freeze;
366 11198 100 66     27268 next unless $type->has_coercion && $type->coercion->frozen;
367 574         3350 for my $e ( $type->exportables_by_tag( 'to' ) ) {
368 574         2379 my $qualified_name = $class . '::' . $e->{name};
369 574         3206 *$qualified_name = set_subname( $qualified_name, $e->{code} );
370             }
371             }
372            
373 339         5415 $meta->{immutable} = 1;
374             }
375              
376             1;
377              
378             __END__