← Index
Performance Profile   « block view • line view • sub view »
For t/test-parsing
  Run on Sun Nov 14 09:49:57 2010
Reported on Sun Nov 14 09:50:12 2010

File /usr/local/lib/perl/5.10.0/Moose/Meta/TypeConstraint/Union.pm
Statements Executed 23
Total Time 0.0012873 seconds
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMoose::Meta::TypeConstraint::Union::::BEGINMoose::Meta::TypeConstraint::Union::BEGIN
0000s0sMoose::Meta::TypeConstraint::Union::::__ANON__[:123]Moose::Meta::TypeConstraint::Union::__ANON__[:123]
0000s0sMoose::Meta::TypeConstraint::Union::::__ANON__[:20]Moose::Meta::TypeConstraint::Union::__ANON__[:20]
0000s0sMoose::Meta::TypeConstraint::Union::::__ANON__[:34]Moose::Meta::TypeConstraint::Union::__ANON__[:34]
0000s0sMoose::Meta::TypeConstraint::Union::::__ANON__[:74]Moose::Meta::TypeConstraint::Union::__ANON__[:74]
0000s0sMoose::Meta::TypeConstraint::Union::::_actually_compile_type_constraintMoose::Meta::TypeConstraint::Union::_actually_compile_type_constraint
0000s0sMoose::Meta::TypeConstraint::Union::::coercionMoose::Meta::TypeConstraint::Union::coercion
0000s0sMoose::Meta::TypeConstraint::Union::::create_child_typeMoose::Meta::TypeConstraint::Union::create_child_type
0000s0sMoose::Meta::TypeConstraint::Union::::equalsMoose::Meta::TypeConstraint::Union::equals
0000s0sMoose::Meta::TypeConstraint::Union::::find_type_forMoose::Meta::TypeConstraint::Union::find_type_for
0000s0sMoose::Meta::TypeConstraint::Union::::has_coercionMoose::Meta::TypeConstraint::Union::has_coercion
0000s0sMoose::Meta::TypeConstraint::Union::::is_a_type_ofMoose::Meta::TypeConstraint::Union::is_a_type_of
0000s0sMoose::Meta::TypeConstraint::Union::::is_subtype_ofMoose::Meta::TypeConstraint::Union::is_subtype_of
0000s0sMoose::Meta::TypeConstraint::Union::::newMoose::Meta::TypeConstraint::Union::new
0000s0sMoose::Meta::TypeConstraint::Union::::parentsMoose::Meta::TypeConstraint::Union::parents
0000s0sMoose::Meta::TypeConstraint::Union::::validateMoose::Meta::TypeConstraint::Union::validate
LineStmts.Exclusive
Time
Avg.Code
1
2package Moose::Meta::TypeConstraint::Union;
3
4322µs7µsuse strict;
# spent 7µs making 1 call to strict::import
5326µs9µsuse warnings;
# spent 23µs making 1 call to warnings::import
6351µs17µsuse metaclass;
# spent 791µs making 1 call to metaclass::import
7
83134µs45µsuse Moose::Meta::TypeCoercion::Union;
# spent 9µs making 1 call to import
9
10362µs21µsuse List::Util qw(first);
# spent 42µs making 1 call to Exporter::import
11
121700ns700nsour $VERSION = '1.15';
13121µs21µs$VERSION = eval $VERSION;
141600ns600nsour $AUTHORITY = 'cpan:STEVAN';
15
163935µs312µsuse base 'Moose::Meta::TypeConstraint';
# spent 88µs making 1 call to base::import
17
18__PACKAGE__->meta->add_attribute('type_constraints' => (
19 accessor => 'type_constraints',
20 default => sub { [] }
21125µs25µs));
# spent 597µs making 1 call to Class::MOP::Mixin::HasAttributes::add_attribute # spent 35µs making 1 call to Moose::Meta::TypeConstraint::Union::meta
22
23sub new {
24 my ($class, %options) = @_;
25
26 my $name = join '|' => sort { $a cmp $b }
27 map { $_->name } @{ $options{type_constraints} };
28
29 my $self = $class->SUPER::new(
30 name => $name,
31 %options,
32 );
33
34 $self->_set_constraint(sub { $self->check($_[0]) });
35
36 return $self;
37}
38
39# XXX - this is a rather gross implementation of laziness for the benefit of
40# MX::Types. If we try to call ->has_coercion on the objects during object
41# construction, this does not work when defining a recursive constraint with
42# MX::Types.
43sub coercion {
44 my $self = shift;
45
46 return $self->{coercion} if exists $self->{coercion};
47
48 # Using any instead of grep here causes a weird error with some corner
49 # cases when MX::Types is in use. See RT #61001.
50 if ( grep { $_->has_coercion } @{ $self->type_constraints } ) {
51 return $self->{coercion} = Moose::Meta::TypeCoercion::Union->new(
52 type_constraint => $self );
53 }
54 else {
55 return $self->{coercion} = undef;
56 }
57}
58
59sub has_coercion {
60 return defined $_[0]->coercion;
61}
62
63sub _actually_compile_type_constraint {
64 my $self = shift;
65
66 my @constraints = @{ $self->type_constraints };
67
68 return sub {
69 my $value = shift;
70 foreach my $type (@constraints) {
71 return 1 if $type->check($value);
72 }
73 return undef;
74 };
75}
76
77
78sub equals {
79 my ( $self, $type_or_name ) = @_;
80
81 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
82
83 return unless $other->isa(__PACKAGE__);
84
85 my @self_constraints = @{ $self->type_constraints };
86 my @other_constraints = @{ $other->type_constraints };
87
88 return unless @self_constraints == @other_constraints;
89
90 # FIXME presort type constraints for efficiency?
91 constraint: foreach my $constraint ( @self_constraints ) {
92 for ( my $i = 0; $i < @other_constraints; $i++ ) {
93 if ( $constraint->equals($other_constraints[$i]) ) {
94 splice @other_constraints, $i, 1;
95 next constraint;
96 }
97 }
98 }
99
100 return @other_constraints == 0;
101}
102
103sub parents {
104 my $self = shift;
105 $self->type_constraints;
106}
107
108sub validate {
109 my ($self, $value) = @_;
110 my $message;
111 foreach my $type (@{$self->type_constraints}) {
112 my $err = $type->validate($value);
113 return unless defined $err;
114 $message .= ($message ? ' and ' : '') . $err
115 if defined $err;
116 }
117 return ($message . ' in (' . $self->name . ')') ;
118}
119
120sub find_type_for {
121 my ($self, $value) = @_;
122
123 return first { $_->check($value) } @{ $self->type_constraints };
124}
125
126sub is_a_type_of {
127 my ($self, $type_name) = @_;
128 foreach my $type (@{$self->type_constraints}) {
129 return 1 if $type->is_a_type_of($type_name);
130 }
131 return 0;
132}
133
134sub is_subtype_of {
135 my ($self, $type_name) = @_;
136 foreach my $type (@{$self->type_constraints}) {
137 return 1 if $type->is_subtype_of($type_name);
138 }
139 return 0;
140}
141
142sub create_child_type {
143 my ( $self, %opts ) = @_;
144
145 my $constraint
146 = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
147
148 # if we have a type constraint union, and no
149 # type check, this means we are just aliasing
150 # the union constraint, which means we need to
151 # handle this differently.
152 # - SL
153 if ( not( defined $opts{constraint} )
154 && $self->has_coercion ) {
155 $constraint->coercion(
156 Moose::Meta::TypeCoercion::Union->new(
157 type_constraint => $self,
158 )
159 );
160 }
161
162 return $constraint;
163}
164
165110µs10µs1;
166
167__END__
168
169=pod
170
171=head1 NAME
172
173Moose::Meta::TypeConstraint::Union - A union of Moose type constraints
174
175=head1 DESCRIPTION
176
177This metaclass represents a union of type constraints. A union takes
178multiple type constraints, and is true if any one of its member
179constraints is true.
180
181=head1 INHERITANCE
182
183C<Moose::Meta::TypeConstraint::Union> is a subclass of
184L<Moose::Meta::TypeConstraint>.
185
186=over 4
187
188=item B<< Moose::Meta::TypeConstraint::Union->new(%options) >>
189
190This creates a new class type constraint based on the given
191C<%options>.
192
193It takes the same options as its parent. It also requires an
194additional option, C<type_constraints>. This is an array reference
195containing the L<Moose::Meta::TypeConstraint> objects that are the
196members of the union type. The C<name> option defaults to the names
197all of these member types sorted and then joined by a pipe (|).
198
199The constructor sets the implementation of the constraint so that is
200simply calls C<check> on the newly created object.
201
202Finally, the constructor also makes sure that the object's C<coercion>
203attribute is a L<Moose::Meta::TypeCoercion::Union> object.
204
205=item B<< $constraint->type_constraints >>
206
207This returns the array reference of C<type_constraints> provided to
208the constructor.
209
210=item B<< $constraint->parents >>
211
212This returns the same constraint as the C<type_constraints> method.
213
214=item B<< $constraint->check($value) >>
215
216=item B<< $constraint->validate($value) >>
217
218These two methods simply call the relevant method on each of the
219member type constraints in the union. If any type accepts the value,
220the value is valid.
221
222With C<validate> the error message returned includes all of the error
223messages returned by the member type constraints.
224
225=item B<< $constraint->equals($type_name_or_object) >>
226
227A type is considered equal if it is also a union type, and the two
228unions have the same member types.
229
230=item B<< $constraint->find_type_for($value) >>
231
232This returns the first member type constraint for which C<check($value)> is
233true, allowing you to determine which of the Union's member type constraints
234a given value matches.
235
236=item B<< $constraint->is_a_type_of($type_name_or_object) >>
237
238This returns true if any of the member type constraints return true
239for the C<is_a_type_of> method.
240
241=item B<< $constraint->is_subtype_of >>
242
243This returns true if any of the member type constraints return true
244for the C<is_a_subtype_of> method.
245
246=item B<< $constraint->create_child_type(%options) >>
247
248This returns a new L<Moose::Meta::TypeConstraint> object with the type
249as its parent.
250
251=back
252
253=head1 BUGS
254
255See L<Moose/BUGS> for details on reporting bugs.
256
257=head1 AUTHOR
258
259Stevan Little E<lt>stevan@iinteractive.comE<gt>
260
261=head1 COPYRIGHT AND LICENSE
262
263Copyright 2006-2010 by Infinity Interactive, Inc.
264
265L<http://www.iinteractive.com>
266
267This library is free software; you can redistribute it and/or modify
268it under the same terms as Perl itself.
269
270=cut