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__ |