← 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/DuckType.pm
Statements Executed 29
Total Time 0.0010019 seconds
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMoose::Meta::TypeConstraint::DuckType::::BEGINMoose::Meta::TypeConstraint::DuckType::BEGIN
0000s0sMoose::Meta::TypeConstraint::DuckType::::__ANON__[:65]Moose::Meta::TypeConstraint::DuckType::__ANON__[:65]
0000s0sMoose::Meta::TypeConstraint::DuckType::::__ANON__[:66]Moose::Meta::TypeConstraint::DuckType::__ANON__[:66]
0000s0sMoose::Meta::TypeConstraint::DuckType::::__ANON__[:79]Moose::Meta::TypeConstraint::DuckType::__ANON__[:79]
0000s0sMoose::Meta::TypeConstraint::DuckType::::__ANON__[:80]Moose::Meta::TypeConstraint::DuckType::__ANON__[:80]
0000s0sMoose::Meta::TypeConstraint::DuckType::::_compile_hand_optimized_type_constraintMoose::Meta::TypeConstraint::DuckType::_compile_hand_optimized_type_constraint
0000s0sMoose::Meta::TypeConstraint::DuckType::::constraintMoose::Meta::TypeConstraint::DuckType::constraint
0000s0sMoose::Meta::TypeConstraint::DuckType::::create_child_typeMoose::Meta::TypeConstraint::DuckType::create_child_type
0000s0sMoose::Meta::TypeConstraint::DuckType::::equalsMoose::Meta::TypeConstraint::DuckType::equals
0000s0sMoose::Meta::TypeConstraint::DuckType::::get_messageMoose::Meta::TypeConstraint::DuckType::get_message
0000s0sMoose::Meta::TypeConstraint::DuckType::::newMoose::Meta::TypeConstraint::DuckType::new
LineStmts.Exclusive
Time
Avg.Code
1package Moose::Meta::TypeConstraint::DuckType;
2
3334µs11µsuse strict;
# spent 13µs making 1 call to strict::import
4328µs9µsuse warnings;
# spent 25µs making 1 call to warnings::import
5352µs17µsuse metaclass;
# spent 856µs making 1 call to metaclass::import
6
7334µs11µsuse Scalar::Util 'blessed';
# spent 46µs making 1 call to Exporter::import
8331µs10µsuse List::MoreUtils qw(all);
# spent 48µs making 1 call to Exporter::import
9336µs12µsuse Moose::Util 'english_list';
10
11367µs22µsuse Moose::Util::TypeConstraints ();
12
131800ns800nsour $VERSION = '1.15';
14124µs24µs$VERSION = eval $VERSION;
151600ns600nsour $AUTHORITY = 'cpan:STEVAN';
16
173664µs221µsuse base 'Moose::Meta::TypeConstraint';
# spent 76µs making 1 call to base::import
18
19122µs22µs__PACKAGE__->meta->add_attribute('methods' => (
# spent 573µs making 1 call to Class::MOP::Mixin::HasAttributes::add_attribute # spent 35µs making 1 call to Moose::Meta::TypeConstraint::DuckType::meta
20 accessor => 'methods',
21));
22
23sub new {
24 my ( $class, %args ) = @_;
25
26 $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
27
28 my $self = $class->_new(\%args);
29
30 $self->compile_type_constraint()
31 unless $self->_has_compiled_type_constraint;
32
33 return $self;
34}
35
36sub equals {
37 my ( $self, $type_or_name ) = @_;
38
39 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
40
41 return unless $other->isa(__PACKAGE__);
42
43 my @self_methods = sort @{ $self->methods };
44 my @other_methods = sort @{ $other->methods };
45
46 return unless @self_methods == @other_methods;
47
48 while ( @self_methods ) {
49 my $method = shift @self_methods;
50 my $other_method = shift @other_methods;
51
52 return unless $method eq $other_method;
53 }
54
55 return 1;
56}
57
58sub constraint {
59 my $self = shift;
60
61 my @methods = @{ $self->methods };
62
63 return sub {
64 my $obj = shift;
65 return all { $obj->can($_) } @methods
66 };
67}
68
69sub _compile_hand_optimized_type_constraint {
70 my $self = shift;
71
72 my @methods = @{ $self->methods };
73
74 sub {
75 my $obj = shift;
76
77 return blessed($obj)
78 && blessed($obj) ne 'Regexp'
79 && all { $obj->can($_) } @methods;
80 };
81}
82
83sub create_child_type {
84 my ($self, @args) = @_;
85 return Moose::Meta::TypeConstraint->new(@args, parent => $self);
86}
87
88sub get_message {
89 my $self = shift;
90 my ($value) = @_;
91
92 if ($self->has_message) {
93 return $self->SUPER::get_message(@_);
94 }
95
96 my @methods = grep { !$value->can($_) } @{ $self->methods };
97 my $class = blessed $value;
98 return $class
99 . " is missing methods "
100 . english_list(map { "'$_'" } @methods);
101}
102
103111µs11µs1;
104
105__END__
106
107=pod
108
109=head1 NAME
110
111Moose::Meta::TypeConstraint::DuckType - Type constraint for duck typing
112
113=head1 DESCRIPTION
114
115This class represents type constraints based on an enumerated list of
116required methods.
117
118=head1 INHERITANCE
119
120C<Moose::Meta::TypeConstraint::DuckType> is a subclass of
121L<Moose::Meta::TypeConstraint>.
122
123=head1 METHODS
124
125=over 4
126
127=item B<< Moose::Meta::TypeConstraint::DuckType->new(%options) >>
128
129This creates a new duck type constraint based on the given
130C<%options>.
131
132It takes the same options as its parent, with several
133exceptions. First, it requires an additional option, C<methods>. This
134should be an array reference containing a list of required method
135names. Second, it automatically sets the parent to the C<Object> type.
136
137Finally, it ignores any provided C<constraint> option. The constraint
138is generated automatically based on the provided C<methods>.
139
140=item B<< $constraint->methods >>
141
142Returns the array reference of required methods provided to the
143constructor.
144
145=item B<< $constraint->create_child_type >>
146
147This returns a new L<Moose::Meta::TypeConstraint> object with the type
148as its parent.
149
150Note that it does I<not> return a C<Moose::Meta::TypeConstraint::DuckType>
151object!
152
153=back
154
155=head1 BUGS
156
157See L<Moose/BUGS> for details on reporting bugs.
158
159=head1 AUTHOR
160
161Chris Prather E<lt>chris@prather.orgE<gt>
162
163Shawn M Moore E<lt>sartak@gmail.comE<gt>
164
165=head1 COPYRIGHT AND LICENSE
166
167Copyright 2006-2010 by Infinity Interactive, Inc.
168
169L<http://www.iinteractive.com>
170
171This library is free software; you can redistribute it and/or modify
172it under the same terms as Perl itself.
173
174=cut
175