← Index
NYTProf Performance Profile   « block view • line view • sub view »
For mongo_pain.pl
  Run on Fri Mar 25 17:00:29 2011
Reported on Fri Mar 25 17:07:07 2011

Filename/usr/local/lib/perl/5.10.1/Mouse/Meta/TypeConstraint.pm
StatementsExecuted 547 statements in 2.63ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
2931730µs751µsMouse::Meta::TypeConstraint::::newMouse::Meta::TypeConstraint::new
31121µs21µsMouse::Meta::TypeConstraint::::compile_type_constraintMouse::Meta::TypeConstraint::compile_type_constraint (xsub)
194418µs18µsMouse::Meta::TypeConstraint::::_compiled_type_constraintMouse::Meta::TypeConstraint::_compiled_type_constraint (xsub)
11116µs66µsMouse::Meta::TypeConstraint::::BEGIN@2Mouse::Meta::TypeConstraint::BEGIN@2
2115µs5µsMouse::Meta::TypeConstraint::::_identityMouse::Meta::TypeConstraint::_identity (xsub)
0000s0sMouse::Meta::TypeConstraint::::__ANON__[:157]Mouse::Meta::TypeConstraint::__ANON__[:157]
0000s0sMouse::Meta::TypeConstraint::::__ANON__[:174]Mouse::Meta::TypeConstraint::__ANON__[:174]
0000s0sMouse::Meta::TypeConstraint::::__ANON__[:50]Mouse::Meta::TypeConstraint::__ANON__[:50]
0000s0sMouse::Meta::TypeConstraint::::_add_type_coercionsMouse::Meta::TypeConstraint::_add_type_coercions
0000s0sMouse::Meta::TypeConstraint::::_as_stringMouse::Meta::TypeConstraint::_as_string
0000s0sMouse::Meta::TypeConstraint::::_compiled_type_coercionMouse::Meta::TypeConstraint::_compiled_type_coercion
0000s0sMouse::Meta::TypeConstraint::::_uniteMouse::Meta::TypeConstraint::_unite
0000s0sMouse::Meta::TypeConstraint::::assert_validMouse::Meta::TypeConstraint::assert_valid
0000s0sMouse::Meta::TypeConstraint::::coerceMouse::Meta::TypeConstraint::coerce
0000s0sMouse::Meta::TypeConstraint::::create_child_typeMouse::Meta::TypeConstraint::create_child_type
0000s0sMouse::Meta::TypeConstraint::::get_messageMouse::Meta::TypeConstraint::get_message
0000s0sMouse::Meta::TypeConstraint::::is_a_type_ofMouse::Meta::TypeConstraint::is_a_type_of
0000s0sMouse::Meta::TypeConstraint::::parameterizeMouse::Meta::TypeConstraint::parameterize
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Mouse::Meta::TypeConstraint;
231.83ms2115µs
# spent 66µs (16+50) within Mouse::Meta::TypeConstraint::BEGIN@2 which was called: # once (16µs+50µs) by Mouse::Meta::Attribute::BEGIN@6 at line 2
use Mouse::Util qw(:meta); # enables strict and warnings
# spent 66µs making 1 call to Mouse::Meta::TypeConstraint::BEGIN@2 # spent 50µs making 1 call to Mouse::Exporter::do_import
3
4
# spent 751µs (730+21) within Mouse::Meta::TypeConstraint::new which was called 29 times, avg 26µs/call: # 20 times (383µs+11µs) by Mouse::BEGIN@18 at line 69 of Mouse/Util/TypeConstraints.pm, avg 20µs/call # 8 times (293µs+0s) by Mouse::Util::TypeConstraints::_define_type at line 168 of Mouse/Util/TypeConstraints.pm, avg 37µs/call # once (54µs+11µs) by Mouse::BEGIN@18 at line 29 of Mouse/Util/TypeConstraints.pm
sub new {
5348498µs my $class = shift;
6 my %args = @_ == 1 ? %{$_[0]} : @_;
7
8 $args{name} = '__ANON__' if !defined $args{name};
9
10 my $type_parameter;
11140259µs if(defined $args{parent}) { # subtyping
12 %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 delete $args{compiled_type_constraint}; # don't inherit it
17 delete $args{hand_optimized_type_constraint}; # don't inherit it
18
19 $type_parameter = $args{type_parameter};
20 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 my $check;
34
355532µs if($check = delete $args{optimized}) { # likely to be builtins
36 $args{hand_optimized_type_constraint} = $check;
37 $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 $check = $args{constraint};
59 }
60
61 if(defined($check) && ref($check) ne 'CODE'){
62 $class->throw_error(
63 "Constraint for $args{name} is not a CODE reference");
64 }
65
66 my $self = bless \%args, $class;
67321µs $self->compile_type_constraint()
# spent 21µs making 3 calls to Mouse::Meta::TypeConstraint::compile_type_constraint, avg 7µs/call
68 if !$args{hand_optimized_type_constraint};
69
70 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 return $self;
81}
82
83sub create_child_type {
84 my $self = shift;
85 return ref($self)->new(@_, parent => $self);
86}
87
88sub name;
89sub parent;
90sub message;
91sub has_coercion;
92
93sub check;
94
95sub type_parameter;
96sub __is_parameterized;
97
98sub _compiled_type_constraint;
99sub _compiled_type_coercion;
100
101sub compile_type_constraint;
102
103
104sub _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
134sub _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 local $_ = $thing;
153 return $pair->[1]->($thing);
154 }
155 }
156 return $thing;
157 };
158 }
159 else { # for union type
160 my @coercions;
161 foreach my $type(@{$self->{type_constraints}}){
162 if($type->has_coercion){
163 push @coercions, $type;
164 }
165 }
166 if(@coercions){
167 $coercion = sub {
168 my($thing) = @_;
169 foreach my $type(@coercions){
170 my $value = $type->coerce($thing);
171 return $value if $self->check($value);
172 }
173 return $thing;
174 };
175 }
176 }
177
178 return( $self->{_compiled_type_coercion} = $coercion );
179}
180
181sub coerce {
182 my $self = shift;
183 return $_[0] if $self->check(@_);
184
185 my $coercion = $self->_compiled_type_coercion
186 or $self->throw_error("Cannot coerce without a type coercion");
187 return $coercion->(@_);
188}
189
190sub get_message {
191 my ($self, $value) = @_;
192 if ( my $msg = $self->message ) {
193 local $_ = $value;
194 return $msg->($value);
195 }
196 else {
197 if(not defined $value) {
198 $value = 'undef';
199 }
200 elsif( ref($value) && defined(&overload::StrVal) ) {
201 $value = overload::StrVal($value);
202 }
203 return "Validation failed for '$self' with value $value";
204 }
205}
206
207sub is_a_type_of {
208 my($self, $other) = @_;
209
210 # ->is_a_type_of('__ANON__') is always false
211 return 0 if !ref($other) && $other eq '__ANON__';
212
213 (my $other_name = $other) =~ s/\s+//g;
214
215 return 1 if $self->name eq $other_name;
216
217 if(exists $self->{type_constraints}){ # union
218 foreach my $type(@{$self->{type_constraints}}) {
219 return 1 if $type->name eq $other_name;
220 }
221 }
222
223 for(my $p = $self->parent; defined $p; $p = $p->parent) {
224 return 1 if $p->name eq $other_name;
225 }
226
227 return 0;
228}
229
230# See also Moose::Meta::TypeConstraint::Parameterizable
231sub parameterize {
232 my($self, $param, $name) = @_;
233
234 if(!ref $param){
235 require Mouse::Util::TypeConstraints;
236 $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param);
237 }
238
239 $name ||= sprintf '%s[%s]', $self->name, $param->name;
240 return Mouse::Meta::TypeConstraint->new(
241 name => $name,
242 parent => $self,
243 type_parameter => $param,
244 );
245}
246
247sub assert_valid {
248 my ($self, $value) = @_;
249
250 if(!$self->check($value)){
251 $self->throw_error($self->get_message($value));
252 }
253 return 1;
254}
255
256# overloading stuff
257
258sub _as_string { $_[0]->name } # overload ""
259sub _identity; # overload 0+
260
261sub _unite { # overload infix:<|>
262 my($lhs, $rhs) = @_;
263 require Mouse::Util::TypeConstraints;
264 return Mouse::Util::TypeConstraints::_find_or_create_union_type(
265 $lhs,
266 Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($rhs),
267 );
268}
269
27013µs1;
271__END__
 
# spent 18µs within Mouse::Meta::TypeConstraint::_compiled_type_constraint which was called 19 times, avg 953ns/call: # 14 times (12µs+0s) by Mouse::Object::new at line 13 of mongo_pain.pl, avg 864ns/call # 2 times (3µs+0s) by Mouse::Object::new at line 531 of MongoDB/Connection.pm, avg 1µs/call # 2 times (2µs+0s) by Mouse::Object::new at line 108 of MongoDB/Database.pm, avg 1µs/call # once (1µs+0s) by MongoDB::Collection::full_name at line 300 of MongoDB/Collection.pm
sub Mouse::Meta::TypeConstraint::_compiled_type_constraint; # xsub
# spent 5µs within Mouse::Meta::TypeConstraint::_identity which was called 2 times, avg 2µs/call: # 2 times (5µs+0s) by Mouse::init_meta at line 143 of Mouse.pm, avg 2µs/call
sub Mouse::Meta::TypeConstraint::_identity; # xsub
# spent 21µs within Mouse::Meta::TypeConstraint::compile_type_constraint which was called 3 times, avg 7µs/call: # 3 times (21µs+0s) by Mouse::Meta::TypeConstraint::new at line 67, avg 7µs/call
sub Mouse::Meta::TypeConstraint::compile_type_constraint; # xsub
Report produced by the NYTProf 4.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.