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   15914 use Mouse::Util qw(:meta); # enables strict and warnings
  284         294  
  284         1195  
3              
4             sub new {
5 6868     6868 1 5826 my $class = shift;
6 6868 100       15115 my %args = @_ == 1 ? %{$_[0]} : @_;
  2         6  
7              
8 6868 100       9526 $args{name} = '__ANON__' if !defined $args{name};
9              
10 6868         4321 my $type_parameter;
11 6868 100       8723 if(defined $args{parent}) { # subtyping
12 6550         4210 %args = (%{$args{parent}}, %args);
  6550         33177  
13              
14             # a child type must not inherit 'compiled_type_constraint'
15             # and 'hand_optimized_type_constraint' from the parent
16 6550         9073 delete $args{compiled_type_constraint}; # don't inherit it
17 6550         4463 delete $args{hand_optimized_type_constraint}; # don't inherit it
18              
19 6550         4770 $type_parameter = $args{type_parameter};
20 6550 100       10266 if(defined(my $parent_tp = $args{parent}{type_parameter})) {
21 16 100       73 if($parent_tp != $type_parameter) {
22 3 100       8 $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         22 $type_parameter = undef;
29             }
30             }
31             }
32              
33 6867         4328 my $check;
34              
35 6867 100       8965 if($check = delete $args{optimized}) { # likely to be builtins
    100          
36 5870         4581 $args{hand_optimized_type_constraint} = $check;
37 5870         4425 $args{compiled_type_constraint} = $check;
38             }
39             elsif(defined $type_parameter) { # parameterizing
40             my $generator = $args{constraint_generator}
41 53   66     132 || $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         433 my $parameterized_check = $generator->($type_parameter);
47 51 100       119 if(defined(my $my_check = $args{constraint})) {
48             $check = sub {
49 19   66 19   4459 return $parameterized_check->($_) && $my_check->($_);
50 7         29 };
51             }
52             else {
53 44         55 $check = $parameterized_check;
54             }
55 51         81 $args{constraint} = $check;
56             }
57             else { # common cases
58 944         914 $check = $args{constraint};
59             }
60              
61 6865 50 66     19974 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         6870 my $self = bless \%args, $class;
67             $self->compile_type_constraint()
68 6865 100       13505 if !$args{hand_optimized_type_constraint};
69              
70 6865 100       9377 if($args{type_constraints}) { # union types
71 20         21 foreach my $type(@{$self->{type_constraints}}){
  20         48  
72 40 100       93 if($type->has_coercion){
73             # set undef for has_coercion()
74 3         3 $self->{_compiled_type_coercion} = undef;
75 3         4 last;
76             }
77             }
78             }
79              
80 6865         20769 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   39 my $self = shift;
106              
107 30 50       86 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     205 my $coercion_map = ($self->{coercion_map} ||= []);
113 30         40 my %has = map{ $_->[0]->name => undef } @{$coercion_map};
  3         19  
  30         71  
114              
115 30         93 for(my $i = 0; $i < @_; $i++){
116 36         47 my $from = $_[ $i];
117 36         259 my $action = $_[++$i];
118              
119 36 100       75 if(exists $has{$from}){
120 1         5 $self->throw_error("A coercion action already exists for '$from'");
121             }
122              
123 35 100       84 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         40 push @{$coercion_map}, [ $type => $action ];
  34         122  
128             }
129              
130 28         46 $self->{_compiled_type_coercion} = undef;
131 28         59 return;
132             }
133              
134             sub _compiled_type_coercion {
135 130     130   133 my($self) = @_;
136              
137 130         133 my $coercion = $self->{_compiled_type_coercion};
138 130 100       307 return $coercion if defined $coercion;
139              
140 27 100       72 if(!$self->{type_constraints}) {
141 24         29 my @coercions;
142 24         28 foreach my $pair(@{$self->{coercion_map}}) {
  24         63  
143 30         120 push @coercions,
144             [ $pair->[0]->_compiled_type_constraint, $pair->[1] ];
145             }
146              
147             $coercion = sub {
148 125     125   107 my($thing) = @_;
149 125         138 foreach my $pair (@coercions) {
150             #my ($constraint, $converter) = @$pair;
151 133 100       292 if ($pair->[0]->($thing)) {
152 117         251 return $pair->[1]->($thing) for $thing; # local $_ will cancel tie-ness due to perl's bug
153             }
154             }
155 8         22 return $thing;
156 24         118 };
157             }
158             else { # for union type
159 3         4 my @coercions;
160 3         6 foreach my $type(@{$self->{type_constraints}}){
  3         5  
161 8 100       15 if($type->has_coercion){
162 4         6 push @coercions, $type;
163             }
164             }
165 3 50       5 if(@coercions){
166             $coercion = sub {
167 5     5   5 my($thing) = @_;
168 5         6 foreach my $type(@coercions){
169 6         14 my $value = $type->coerce($thing);
170 6 100       22 return $value if $self->check($value);
171             }
172 2         13 return $thing;
173 3         10 };
174             }
175             }
176              
177 27         96 return( $self->{_compiled_type_coercion} = $coercion );
178             }
179              
180             sub coerce {
181 146     146 1 32068 my $self = shift;
182 146 100       481 return $_[0] if $self->check(@_);
183              
184 130 50       269 my $coercion = $self->_compiled_type_coercion
185             or $self->throw_error("Cannot coerce without a type coercion");
186 130         183 return $coercion->(@_);
187             }
188              
189             sub get_message {
190 833     833 1 904580 my ($self, $value) = @_;
191 833 100       2273 if ( my $msg = $self->message ) {
192 11         41 return $msg->($value) for $value; # local $_ will cancel tie-ness due to perl's bug
193             }
194             else {
195 822 100 66     3289 if(not defined $value) {
    100          
196 42         57 $value = 'undef';
197             }
198             elsif( ref($value) && defined(&overload::StrVal) ) {
199 371         759 $value = overload::StrVal($value);
200             }
201 822         3207 return "Validation failed for '$self' with value $value";
202             }
203             }
204              
205             sub is_a_type_of {
206 73     73 1 4023 my($self, $other) = @_;
207              
208             # ->is_a_type_of('__ANON__') is always false
209 73 50 66     337 return 0 if !ref($other) && $other eq '__ANON__';
210              
211 73         158 (my $other_name = $other) =~ s/\s+//g;
212              
213 73 100       307 return 1 if $self->name eq $other_name;
214              
215 51 50       279 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 51         187 for(my $p = $self->parent; defined $p; $p = $p->parent) {
222 122 100       598 return 1 if $p->name eq $other_name;
223             }
224              
225 20         71 return 0;
226             }
227              
228             # See also Moose::Meta::TypeConstraint::Parameterizable
229             sub parameterize {
230 45     45 0 67 my($self, $param, $name) = @_;
231              
232 45 50       120 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     90 $name ||= sprintf '%s[%s]', $self->name, $param->name;
238 45         169 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 9 my ($self, $value) = @_;
247              
248 2 100       11 if(!$self->check($value)){
249 1         4 $self->throw_error($self->get_message($value));
250             }
251 1         2 return 1;
252             }
253              
254             # overloading stuff
255              
256 998     998   9734 sub _as_string { $_[0]->name } # overload ""
257             sub _identity; # overload 0+
258              
259             sub _unite { # overload infix:<|>
260 6     6   14 my($lhs, $rhs) = @_;
261 6         24 require Mouse::Util::TypeConstraints;
262 6         11 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__