Filename | /opt/perl-5.18.1/lib/site_perl/5.18.1/darwin-thread-multi-2level/Mouse/Meta/TypeConstraint.pm |
Statements | Executed 413 statements in 1.97ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
22 | 3 | 1 | 345µs | 355µs | new | Mouse::Meta::TypeConstraint::
1 | 1 | 1 | 16µs | 61µs | BEGIN@2 | Mouse::Meta::TypeConstraint::
3 | 1 | 1 | 10µs | 10µs | compile_type_constraint (xsub) | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | __ANON__[:156] | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | __ANON__[:173] | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | __ANON__[:50] | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | _add_type_coercions | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | _as_string | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | _compiled_type_coercion | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | _unite | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | assert_valid | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | coerce | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | create_child_type | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | get_message | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | is_a_type_of | Mouse::Meta::TypeConstraint::
0 | 0 | 0 | 0s | 0s | parameterize | Mouse::Meta::TypeConstraint::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Mouse::Meta::TypeConstraint; | ||||
2 | 2 | 1.63ms | 2 | 105µs | # spent 61µs (16+45) within Mouse::Meta::TypeConstraint::BEGIN@2 which was called:
# once (16µs+45µs) by Mouse::Meta::Attribute::BEGIN@6 at line 2 # spent 61µs making 1 call to Mouse::Meta::TypeConstraint::BEGIN@2
# spent 45µs making 1 call to Mouse::Exporter::do_import |
3 | |||||
4 | # spent 355µs (345+10) within Mouse::Meta::TypeConstraint::new which was called 22 times, avg 16µs/call:
# 20 times (311µs+7µs) by Mouse::BEGIN@18 at line 69 of Mouse/Util/TypeConstraints.pm, avg 16µs/call
# once (15µs+3µs) by Mouse::BEGIN@18 at line 29 of Mouse/Util/TypeConstraints.pm
# once (18µs+0s) by Mouse::Util::TypeConstraints::_define_type at line 168 of Mouse/Util/TypeConstraints.pm | ||||
5 | 22 | 4µs | my $class = shift; | ||
6 | 22 | 34µs | my %args = @_ == 1 ? %{$_[0]} : @_; | ||
7 | |||||
8 | 22 | 4µs | $args{name} = '__ANON__' if !defined $args{name}; | ||
9 | |||||
10 | 22 | 200ns | my $type_parameter; | ||
11 | 22 | 3µs | if(defined $args{parent}) { # subtyping | ||
12 | 21 | 128µs | %args = (%{$args{parent}}, %args); | ||
13 | |||||
14 | # a child type must not inherit 'compiled_type_constraint' | ||||
15 | # and 'hand_optimized_type_constraint' from the parent | ||||
16 | 21 | 8µs | delete $args{compiled_type_constraint}; # don't inherit it | ||
17 | 21 | 5µs | delete $args{hand_optimized_type_constraint}; # don't inherit it | ||
18 | |||||
19 | 21 | 4µs | $type_parameter = $args{type_parameter}; | ||
20 | 21 | 11µs | if(defined(my $parent_tp = $args{parent}{type_parameter})) { | ||
21 | if($parent_tp != $type_parameter) { | ||||
22 | $type_parameter->is_a_type_of($parent_tp) | ||||
23 | or $class->throw_error( | ||||
24 | "$type_parameter is not a subtype of $parent_tp", | ||||
25 | ); | ||||
26 | } | ||||
27 | else { | ||||
28 | $type_parameter = undef; | ||||
29 | } | ||||
30 | } | ||||
31 | } | ||||
32 | |||||
33 | 22 | 600ns | my $check; | ||
34 | |||||
35 | 22 | 10µs | if($check = delete $args{optimized}) { # likely to be builtins | ||
36 | 19 | 4µs | $args{hand_optimized_type_constraint} = $check; | ||
37 | 19 | 4µs | $args{compiled_type_constraint} = $check; | ||
38 | } | ||||
39 | elsif(defined $type_parameter) { # parameterizing | ||||
40 | my $generator = $args{constraint_generator} | ||||
41 | || $class->throw_error( | ||||
42 | "The $args{name} constraint cannot be used," | ||||
43 | . " because $type_parameter doesn't subtype" | ||||
44 | . " from a parameterizable type"); | ||||
45 | |||||
46 | my $parameterized_check = $generator->($type_parameter); | ||||
47 | if(defined(my $my_check = $args{constraint})) { | ||||
48 | $check = sub { | ||||
49 | return $parameterized_check->($_) && $my_check->($_); | ||||
50 | }; | ||||
51 | } | ||||
52 | else { | ||||
53 | $check = $parameterized_check; | ||||
54 | } | ||||
55 | $args{constraint} = $check; | ||||
56 | } | ||||
57 | else { # common cases | ||||
58 | 3 | 600ns | $check = $args{constraint}; | ||
59 | } | ||||
60 | |||||
61 | 22 | 7µs | if(defined($check) && ref($check) ne 'CODE'){ | ||
62 | $class->throw_error( | ||||
63 | "Constraint for $args{name} is not a CODE reference"); | ||||
64 | } | ||||
65 | |||||
66 | 22 | 20µs | my $self = bless \%args, $class; | ||
67 | 22 | 26µs | 3 | 10µs | $self->compile_type_constraint() # spent 10µs making 3 calls to Mouse::Meta::TypeConstraint::compile_type_constraint, avg 3µs/call |
68 | if !$args{hand_optimized_type_constraint}; | ||||
69 | |||||
70 | 22 | 2µs | if($args{type_constraints}) { # union types | ||
71 | foreach my $type(@{$self->{type_constraints}}){ | ||||
72 | if($type->has_coercion){ | ||||
73 | # set undef for has_coercion() | ||||
74 | $self->{_compiled_type_coercion} = undef; | ||||
75 | last; | ||||
76 | } | ||||
77 | } | ||||
78 | } | ||||
79 | |||||
80 | 22 | 56µs | return $self; | ||
81 | } | ||||
82 | |||||
83 | sub create_child_type { | ||||
84 | my $self = shift; | ||||
85 | return ref($self)->new(@_, parent => $self); | ||||
86 | } | ||||
87 | |||||
88 | sub name; | ||||
89 | sub parent; | ||||
90 | sub message; | ||||
91 | sub has_coercion; | ||||
92 | |||||
93 | sub check; | ||||
94 | |||||
95 | sub type_parameter; | ||||
96 | sub __is_parameterized; | ||||
97 | |||||
98 | sub _compiled_type_constraint; | ||||
99 | sub _compiled_type_coercion; | ||||
100 | |||||
101 | sub compile_type_constraint; | ||||
102 | |||||
103 | |||||
104 | sub _add_type_coercions { # ($self, @pairs) | ||||
105 | my $self = shift; | ||||
106 | |||||
107 | if(exists $self->{type_constraints}){ # union type | ||||
108 | $self->throw_error( | ||||
109 | "Cannot add additional type coercions to Union types '$self'"); | ||||
110 | } | ||||
111 | |||||
112 | my $coercion_map = ($self->{coercion_map} ||= []); | ||||
113 | my %has = map{ $_->[0]->name => undef } @{$coercion_map}; | ||||
114 | |||||
115 | for(my $i = 0; $i < @_; $i++){ | ||||
116 | my $from = $_[ $i]; | ||||
117 | my $action = $_[++$i]; | ||||
118 | |||||
119 | if(exists $has{$from}){ | ||||
120 | $self->throw_error("A coercion action already exists for '$from'"); | ||||
121 | } | ||||
122 | |||||
123 | my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from) | ||||
124 | or $self->throw_error( | ||||
125 | "Could not find the type constraint ($from) to coerce from"); | ||||
126 | |||||
127 | push @{$coercion_map}, [ $type => $action ]; | ||||
128 | } | ||||
129 | |||||
130 | $self->{_compiled_type_coercion} = undef; | ||||
131 | return; | ||||
132 | } | ||||
133 | |||||
134 | sub _compiled_type_coercion { | ||||
135 | my($self) = @_; | ||||
136 | |||||
137 | my $coercion = $self->{_compiled_type_coercion}; | ||||
138 | return $coercion if defined $coercion; | ||||
139 | |||||
140 | if(!$self->{type_constraints}) { | ||||
141 | my @coercions; | ||||
142 | foreach my $pair(@{$self->{coercion_map}}) { | ||||
143 | push @coercions, | ||||
144 | [ $pair->[0]->_compiled_type_constraint, $pair->[1] ]; | ||||
145 | } | ||||
146 | |||||
147 | $coercion = sub { | ||||
148 | my($thing) = @_; | ||||
149 | foreach my $pair (@coercions) { | ||||
150 | #my ($constraint, $converter) = @$pair; | ||||
151 | if ($pair->[0]->($thing)) { | ||||
152 | return $pair->[1]->($thing) for $thing; # local $_ will cancel tie-ness due to perl's bug | ||||
153 | } | ||||
154 | } | ||||
155 | return $thing; | ||||
156 | }; | ||||
157 | } | ||||
158 | else { # for union type | ||||
159 | my @coercions; | ||||
160 | foreach my $type(@{$self->{type_constraints}}){ | ||||
161 | if($type->has_coercion){ | ||||
162 | push @coercions, $type; | ||||
163 | } | ||||
164 | } | ||||
165 | if(@coercions){ | ||||
166 | $coercion = sub { | ||||
167 | my($thing) = @_; | ||||
168 | foreach my $type(@coercions){ | ||||
169 | my $value = $type->coerce($thing); | ||||
170 | return $value if $self->check($value); | ||||
171 | } | ||||
172 | return $thing; | ||||
173 | }; | ||||
174 | } | ||||
175 | } | ||||
176 | |||||
177 | return( $self->{_compiled_type_coercion} = $coercion ); | ||||
178 | } | ||||
179 | |||||
180 | sub coerce { | ||||
181 | my $self = shift; | ||||
182 | return $_[0] if $self->check(@_); | ||||
183 | |||||
184 | my $coercion = $self->_compiled_type_coercion | ||||
185 | or $self->throw_error("Cannot coerce without a type coercion"); | ||||
186 | return $coercion->(@_); | ||||
187 | } | ||||
188 | |||||
189 | sub get_message { | ||||
190 | my ($self, $value) = @_; | ||||
191 | if ( my $msg = $self->message ) { | ||||
192 | return $msg->($value) for $value; # local $_ will cancel tie-ness due to perl's bug | ||||
193 | } | ||||
194 | else { | ||||
195 | if(not defined $value) { | ||||
196 | $value = 'undef'; | ||||
197 | } | ||||
198 | elsif( ref($value) && defined(&overload::StrVal) ) { | ||||
199 | $value = overload::StrVal($value); | ||||
200 | } | ||||
201 | return "Validation failed for '$self' with value $value"; | ||||
202 | } | ||||
203 | } | ||||
204 | |||||
205 | sub is_a_type_of { | ||||
206 | my($self, $other) = @_; | ||||
207 | |||||
208 | # ->is_a_type_of('__ANON__') is always false | ||||
209 | return 0 if !ref($other) && $other eq '__ANON__'; | ||||
210 | |||||
211 | (my $other_name = $other) =~ s/\s+//g; | ||||
212 | |||||
213 | return 1 if $self->name eq $other_name; | ||||
214 | |||||
215 | if(exists $self->{type_constraints}){ # union | ||||
216 | foreach my $type(@{$self->{type_constraints}}) { | ||||
217 | return 1 if $type->name eq $other_name; | ||||
218 | } | ||||
219 | } | ||||
220 | |||||
221 | for(my $p = $self->parent; defined $p; $p = $p->parent) { | ||||
222 | return 1 if $p->name eq $other_name; | ||||
223 | } | ||||
224 | |||||
225 | return 0; | ||||
226 | } | ||||
227 | |||||
228 | # See also Moose::Meta::TypeConstraint::Parameterizable | ||||
229 | sub parameterize { | ||||
230 | my($self, $param, $name) = @_; | ||||
231 | |||||
232 | if(!ref $param){ | ||||
233 | require Mouse::Util::TypeConstraints; | ||||
234 | $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param); | ||||
235 | } | ||||
236 | |||||
237 | $name ||= sprintf '%s[%s]', $self->name, $param->name; | ||||
238 | return Mouse::Meta::TypeConstraint->new( | ||||
239 | name => $name, | ||||
240 | parent => $self, | ||||
241 | type_parameter => $param, | ||||
242 | ); | ||||
243 | } | ||||
244 | |||||
245 | sub assert_valid { | ||||
246 | my ($self, $value) = @_; | ||||
247 | |||||
248 | if(!$self->check($value)){ | ||||
249 | $self->throw_error($self->get_message($value)); | ||||
250 | } | ||||
251 | return 1; | ||||
252 | } | ||||
253 | |||||
254 | # overloading stuff | ||||
255 | |||||
256 | sub _as_string { $_[0]->name } # overload "" | ||||
257 | sub _identity; # overload 0+ | ||||
258 | |||||
259 | sub _unite { # overload infix:<|> | ||||
260 | my($lhs, $rhs) = @_; | ||||
261 | require Mouse::Util::TypeConstraints; | ||||
262 | return Mouse::Util::TypeConstraints::_find_or_create_union_type( | ||||
263 | $lhs, | ||||
264 | Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($rhs), | ||||
265 | ); | ||||
266 | } | ||||
267 | |||||
268 | 1 | 3µs | 1; | ||
269 | __END__ | ||||
# spent 10µs within Mouse::Meta::TypeConstraint::compile_type_constraint which was called 3 times, avg 3µs/call:
# 3 times (10µs+0s) by Mouse::Meta::TypeConstraint::new at line 67, avg 3µs/call |