File | /usr/local/lib/perl/5.10.0/Moose/Meta/TypeConstraint/DuckType.pm |
Statements Executed | 29 |
Total Time | 0.0010019 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN | Moose::Meta::TypeConstraint::DuckType::
0 | 0 | 0 | 0s | 0s | __ANON__[:65] | Moose::Meta::TypeConstraint::DuckType::
0 | 0 | 0 | 0s | 0s | __ANON__[:66] | Moose::Meta::TypeConstraint::DuckType::
0 | 0 | 0 | 0s | 0s | __ANON__[:79] | Moose::Meta::TypeConstraint::DuckType::
0 | 0 | 0 | 0s | 0s | __ANON__[:80] | Moose::Meta::TypeConstraint::DuckType::
0 | 0 | 0 | 0s | 0s | _compile_hand_optimized_type_constraint | Moose::Meta::TypeConstraint::DuckType::
0 | 0 | 0 | 0s | 0s | constraint | Moose::Meta::TypeConstraint::DuckType::
0 | 0 | 0 | 0s | 0s | create_child_type | Moose::Meta::TypeConstraint::DuckType::
0 | 0 | 0 | 0s | 0s | equals | Moose::Meta::TypeConstraint::DuckType::
0 | 0 | 0 | 0s | 0s | get_message | Moose::Meta::TypeConstraint::DuckType::
0 | 0 | 0 | 0s | 0s | new | Moose::Meta::TypeConstraint::DuckType::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | package Moose::Meta::TypeConstraint::DuckType; | |||
2 | ||||
3 | 3 | 34µs | 11µs | use strict; # spent 13µs making 1 call to strict::import |
4 | 3 | 28µs | 9µs | use warnings; # spent 25µs making 1 call to warnings::import |
5 | 3 | 52µs | 17µs | use metaclass; # spent 856µs making 1 call to metaclass::import |
6 | ||||
7 | 3 | 34µs | 11µs | use Scalar::Util 'blessed'; # spent 46µs making 1 call to Exporter::import |
8 | 3 | 31µs | 10µs | use List::MoreUtils qw(all); # spent 48µs making 1 call to Exporter::import |
9 | 3 | 36µs | 12µs | use Moose::Util 'english_list'; # spent 294µs making 1 call to Sub::Exporter::__ANON__[/usr/local/share/perl/5.10.0/Sub/Exporter.pm:756] |
10 | ||||
11 | 3 | 67µs | 22µs | use Moose::Util::TypeConstraints (); |
12 | ||||
13 | 1 | 800ns | 800ns | our $VERSION = '1.15'; |
14 | 1 | 24µs | 24µs | $VERSION = eval $VERSION; |
15 | 1 | 600ns | 600ns | our $AUTHORITY = 'cpan:STEVAN'; |
16 | ||||
17 | 3 | 664µs | 221µs | use base 'Moose::Meta::TypeConstraint'; # spent 76µs making 1 call to base::import |
18 | ||||
19 | 1 | 22µs | 22µ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 | ||||
23 | sub 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 | ||||
36 | sub 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 | ||||
58 | sub 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 | ||||
69 | sub _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 | ||||
83 | sub create_child_type { | |||
84 | my ($self, @args) = @_; | |||
85 | return Moose::Meta::TypeConstraint->new(@args, parent => $self); | |||
86 | } | |||
87 | ||||
88 | sub 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 | ||||
103 | 1 | 11µs | 11µs | 1; |
104 | ||||
105 | __END__ | |||
106 | ||||
107 | =pod | |||
108 | ||||
109 | =head1 NAME | |||
110 | ||||
111 | Moose::Meta::TypeConstraint::DuckType - Type constraint for duck typing | |||
112 | ||||
113 | =head1 DESCRIPTION | |||
114 | ||||
115 | This class represents type constraints based on an enumerated list of | |||
116 | required methods. | |||
117 | ||||
118 | =head1 INHERITANCE | |||
119 | ||||
120 | C<Moose::Meta::TypeConstraint::DuckType> is a subclass of | |||
121 | L<Moose::Meta::TypeConstraint>. | |||
122 | ||||
123 | =head1 METHODS | |||
124 | ||||
125 | =over 4 | |||
126 | ||||
127 | =item B<< Moose::Meta::TypeConstraint::DuckType->new(%options) >> | |||
128 | ||||
129 | This creates a new duck type constraint based on the given | |||
130 | C<%options>. | |||
131 | ||||
132 | It takes the same options as its parent, with several | |||
133 | exceptions. First, it requires an additional option, C<methods>. This | |||
134 | should be an array reference containing a list of required method | |||
135 | names. Second, it automatically sets the parent to the C<Object> type. | |||
136 | ||||
137 | Finally, it ignores any provided C<constraint> option. The constraint | |||
138 | is generated automatically based on the provided C<methods>. | |||
139 | ||||
140 | =item B<< $constraint->methods >> | |||
141 | ||||
142 | Returns the array reference of required methods provided to the | |||
143 | constructor. | |||
144 | ||||
145 | =item B<< $constraint->create_child_type >> | |||
146 | ||||
147 | This returns a new L<Moose::Meta::TypeConstraint> object with the type | |||
148 | as its parent. | |||
149 | ||||
150 | Note that it does I<not> return a C<Moose::Meta::TypeConstraint::DuckType> | |||
151 | object! | |||
152 | ||||
153 | =back | |||
154 | ||||
155 | =head1 BUGS | |||
156 | ||||
157 | See L<Moose/BUGS> for details on reporting bugs. | |||
158 | ||||
159 | =head1 AUTHOR | |||
160 | ||||
161 | Chris Prather E<lt>chris@prather.orgE<gt> | |||
162 | ||||
163 | Shawn M Moore E<lt>sartak@gmail.comE<gt> | |||
164 | ||||
165 | =head1 COPYRIGHT AND LICENSE | |||
166 | ||||
167 | Copyright 2006-2010 by Infinity Interactive, Inc. | |||
168 | ||||
169 | L<http://www.iinteractive.com> | |||
170 | ||||
171 | This library is free software; you can redistribute it and/or modify | |||
172 | it under the same terms as Perl itself. | |||
173 | ||||
174 | =cut | |||
175 |