File Coverage

blib/lib/Mouse/Meta/TypeConstraint.pm
Criterion Covered Total %
statement 114 123 92.6
branch 59 68 86.7
condition 14 20 70.0
subroutine 14 15 93.3
pod 6 7 85.7
total 207 233 88.8


line stmt bran cond sub pod time code
1             package Mouse::Meta::TypeConstraint;
2 284     284   19220 use Mouse::Util qw(:meta); # enables strict and warnings
  284         661  
  284         1909  
3              
4             sub new {
5 6868     6868 1 14150 my $class = shift;
6 6868 100       26188 my %args = @_ == 1 ? %{$_[0]} : @_;
  2         8  
7              
8 6868 100       19054 $args{name} = '__ANON__' if !defined $args{name};
9              
10 6868         11375 my $type_parameter;
11 6868 100       16992 if(defined $args{parent}) { # subtyping
12 6550         10734 %args = (%{$args{parent}}, %args);
  6550         48570  
13              
14             # a child type must not inherit 'compiled_type_constraint'
15             # and 'hand_optimized_type_constraint' from the parent
16 6550         18045 delete $args{compiled_type_constraint}; # don't inherit it
17 6550         11838 delete $args{hand_optimized_type_constraint}; # don't inherit it
18              
19 6550         11499 $type_parameter = $args{type_parameter};
20 6550 100       18509 if(defined(my $parent_tp = $args{parent}{type_parameter})) {
21 16 100       89 if($parent_tp != $type_parameter) {
22 3 100       17 $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 13         31 $type_parameter = undef;
29             }
30             }
31             }
32              
33 6867         11579 my $check;
34              
35 6867 100       17568 if($check = delete $args{optimized}) { # likely to be builtins
    100          
36 5870         11193 $args{hand_optimized_type_constraint} = $check;
37 5870         10515 $args{compiled_type_constraint} = $check;
38             }
39             elsif(defined $type_parameter) { # parameterizing
40             my $generator = $args{constraint_generator}
41 53   66     194 || $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 51         395 my $parameterized_check = $generator->($type_parameter);
47 51 100       187 if(defined(my $my_check = $args{constraint})) {
48             $check = sub {
49 19   66 19   6804 return $parameterized_check->($_) && $my_check->($_);
50 7         43 };
51             }
52             else {
53 44         86 $check = $parameterized_check;
54             }
55 51         125 $args{constraint} = $check;
56             }
57             else { # common cases
58 944         1970 $check = $args{constraint};
59             }
60              
61 6865 50 66     31811 if(defined($check) && ref($check) ne 'CODE'){
62 0         0 $class->throw_error(
63             "Constraint for $args{name} is not a CODE reference");
64             }
65              
66 6865         15706 my $self = bless \%args, $class;
67             $self->compile_type_constraint()
68 6865 100       26326 if !$args{hand_optimized_type_constraint};
69              
70 6865 100       18498 if($args{type_constraints}) { # union types
71 20         42 foreach my $type(@{$self->{type_constraints}}){
  20         69  
72 40 100       188 if($type->has_coercion){
73             # set undef for has_coercion()
74 3         5 $self->{_compiled_type_coercion} = undef;
75 3         6 last;
76             }
77             }
78             }
79              
80 6865         33928 return $self;
81             }
82              
83             sub create_child_type {
84 0     0 1 0 my $self = shift;
85 0         0 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 30     30   81 my $self = shift;
106              
107 30 50       273 if(exists $self->{type_constraints}){ # union type
108 0         0 $self->throw_error(
109             "Cannot add additional type coercions to Union types '$self'");
110             }
111              
112 30   100     178 my $coercion_map = ($self->{coercion_map} ||= []);
113 30         154 my %has = map{ $_->[0]->name => undef } @{$coercion_map};
  3         29  
  30         92  
114              
115 30         131 for(my $i = 0; $i < @_; $i++){
116 36         85 my $from = $_[ $i];
117 36         84 my $action = $_[++$i];
118              
119 36 100       125 if(exists $has{$from}){
120 1         6 $self->throw_error("A coercion action already exists for '$from'");
121             }
122              
123 35 100       134 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 34         77 push @{$coercion_map}, [ $type => $action ];
  34         156  
128             }
129              
130 28         79 $self->{_compiled_type_coercion} = undef;
131 28         103 return;
132             }
133              
134             sub _compiled_type_coercion {
135 130     130   303 my($self) = @_;
136              
137 130         255 my $coercion = $self->{_compiled_type_coercion};
138 130 100       443 return $coercion if defined $coercion;
139              
140 27 100       99 if(!$self->{type_constraints}) {
141 24         51 my @coercions;
142 24         55 foreach my $pair(@{$self->{coercion_map}}) {
  24         79  
143 30         169 push @coercions,
144             [ $pair->[0]->_compiled_type_constraint, $pair->[1] ];
145             }
146              
147             $coercion = sub {
148 125     125   257 my($thing) = @_;
149 125         234 foreach my $pair (@coercions) {
150             #my ($constraint, $converter) = @$pair;
151 133 100       432 if ($pair->[0]->($thing)) {
152 117         398 return $pair->[1]->($thing) for $thing; # local $_ will cancel tie-ness due to perl's bug
153             }
154             }
155 8         39 return $thing;
156 24         146 };
157             }
158             else { # for union type
159 3         6 my @coercions;
160 3         4 foreach my $type(@{$self->{type_constraints}}){
  3         7  
161 8 100       21 if($type->has_coercion){
162 4         9 push @coercions, $type;
163             }
164             }
165 3 50       10 if(@coercions){
166             $coercion = sub {
167 5     5   12 my($thing) = @_;
168 5         12 foreach my $type(@coercions){
169 6         21 my $value = $type->coerce($thing);
170 6 100       34 return $value if $self->check($value);
171             }
172 2         17 return $thing;
173 3         15 };
174             }
175             }
176              
177 27         129 return( $self->{_compiled_type_coercion} = $coercion );
178             }
179              
180             sub coerce {
181 146     146 1 43715 my $self = shift;
182 146 100       901 return $_[0] if $self->check(@_);
183              
184 130 50       443 my $coercion = $self->_compiled_type_coercion
185             or $self->throw_error("Cannot coerce without a type coercion");
186 130         354 return $coercion->(@_);
187             }
188              
189             sub get_message {
190 833     833 1 1315591 my ($self, $value) = @_;
191 833 100       3244 if ( my $msg = $self->message ) {
192 11         49 return $msg->($value) for $value; # local $_ will cancel tie-ness due to perl's bug
193             }
194             else {
195 822 100 66     4300 if(not defined $value) {
    100          
196 42         103 $value = 'undef';
197             }
198             elsif( ref($value) && defined(&overload::StrVal) ) {
199 371         1111 $value = overload::StrVal($value);
200             }
201 822         4104 return "Validation failed for '$self' with value $value";
202             }
203             }
204              
205             sub is_a_type_of {
206 72     72 1 4758 my($self, $other) = @_;
207              
208             # ->is_a_type_of('__ANON__') is always false
209 72 50 66     389 return 0 if !ref($other) && $other eq '__ANON__';
210              
211 72         233 (my $other_name = $other) =~ s/\s+//g;
212              
213 72 100       395 return 1 if $self->name eq $other_name;
214              
215 50 50       345 if(exists $self->{type_constraints}){ # union
216 0         0 foreach my $type(@{$self->{type_constraints}}) {
  0         0  
217 0 0       0 return 1 if $type->name eq $other_name;
218             }
219             }
220              
221 50         256 for(my $p = $self->parent; defined $p; $p = $p->parent) {
222 121 100       776 return 1 if $p->name eq $other_name;
223             }
224              
225 20         85 return 0;
226             }
227              
228             # See also Moose::Meta::TypeConstraint::Parameterizable
229             sub parameterize {
230 45     45 0 135 my($self, $param, $name) = @_;
231              
232 45 50       188 if(!ref $param){
233 0         0 require Mouse::Util::TypeConstraints;
234 0         0 $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param);
235             }
236              
237 45   66     137 $name ||= sprintf '%s[%s]', $self->name, $param->name;
238 45         229 return Mouse::Meta::TypeConstraint->new(
239             name => $name,
240             parent => $self,
241             type_parameter => $param,
242             );
243             }
244              
245             sub assert_valid {
246 2     2 1 12 my ($self, $value) = @_;
247              
248 2 100       13 if(!$self->check($value)){
249 1         6 $self->throw_error($self->get_message($value));
250             }
251 1         3 return 1;
252             }
253              
254             # overloading stuff
255              
256 998     998   11343 sub _as_string { $_[0]->name } # overload ""
257             sub _identity; # overload 0+
258              
259             sub _unite { # overload infix:<|>
260 6     6   29 my($lhs, $rhs) = @_;
261 6         52 require Mouse::Util::TypeConstraints;
262 6         25 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;
269             __END__