1 package Mouse::Util::TypeConstraints;
7 use Scalar::Util qw/blessed looks_like_number openhandle/;
8 use Mouse::Meta::TypeConstraint;
11 as where message from via type subtype coerce class_type role_type enum
36 no warnings 'uninitialized';
41 !defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0'
43 Undef => sub { !defined($_[0]) },
44 Defined => sub { defined($_[0]) },
45 Value => sub { defined($_[0]) && !ref($_[0]) },
46 Num => sub { !ref($_[0]) && looks_like_number($_[0]) },
47 Int => sub { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ },
48 Str => sub { defined($_[0]) && !ref($_[0]) },
49 ClassName => sub { Mouse::is_class_loaded($_[0]) },
50 Ref => sub { ref($_[0]) },
52 ScalarRef => sub { ref($_[0]) eq 'SCALAR' },
53 ArrayRef => sub { ref($_[0]) eq 'ARRAY' },
54 HashRef => sub { ref($_[0]) eq 'HASH' },
55 CodeRef => sub { ref($_[0]) eq 'CODE' },
56 RegexpRef => sub { ref($_[0]) eq 'Regexp' },
57 GlobRef => sub { ref($_[0]) eq 'GLOB' },
60 ref($_[0]) eq 'GLOB' && openhandle($_[0])
62 blessed($_[0]) && $_[0]->isa("IO::Handle")
65 Object => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' },
67 while (my ($name, $code) = each %TYPE) {
68 $TYPE{$name} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $name );
71 sub optimized_constraints { \%TYPE }
72 my @TYPE_KEYS = keys %TYPE;
73 sub list_all_builtin_type_constraints { @TYPE_KEYS }
75 @TYPE_SOURCE{@TYPE_KEYS} = (__PACKAGE__) x @TYPE_KEYS;
80 my($name, %conf) = @_;
81 if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
82 Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
84 my $constraint = $conf{where} || do {
85 my $as = delete $conf{as} || 'Any';
86 if (! exists $TYPE{$as}) {
87 $TYPE{$as} = _build_type_constraint($as);
92 $TYPE_SOURCE{$name} = $pkg;
93 $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
95 _compiled_type_constraint => sub {
97 if (ref $constraint eq 'CODE') {
100 $constraint->check($_[0])
108 my($name, %conf) = @_;
109 if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
110 Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
112 my $constraint = $conf{where};
113 my $as_constraint = find_or_create_isa_type_constraint($conf{as} || 'Any');
115 $TYPE_SOURCE{$name} = $pkg;
116 $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
118 _compiled_type_constraint => (
122 $as_constraint->check($_[0]) && $constraint->($_[0])
126 $as_constraint->check($_[0]);
135 my($name, %conf) = @_;
137 Carp::croak "Cannot find type '$name', perhaps you forgot to load it."
140 unless ($COERCE{$name}) {
142 $COERCE_KEYS{$name} = [];
144 while (my($type, $code) = each %conf) {
145 Carp::croak "A coercion action already exists for '$type'"
146 if $COERCE{$name}->{$type};
148 if (! $TYPE{$type}) {
149 # looks parameterized
150 if ($type =~ /^[^\[]+\[.+\]$/) {
151 $TYPE{$type} = _build_type_constraint($type);
153 Carp::croak "Could not find the type constraint ($type) to coerce from"
157 unshift @{ $COERCE_KEYS{$name} }, $type;
158 $COERCE{$name}->{$type} = $code;
163 my($name, $conf) = @_;
164 if ($conf && $conf->{class}) {
165 # No, you're using this wrong
166 warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?";
167 subtype($name, as => $conf->{class});
170 $name => where => sub { $_->isa($name) }
176 my($name, $conf) = @_;
177 my $role = $conf->{role};
179 $name => where => sub {
180 return unless defined $_ && ref($_) && $_->isa('Mouse::Object');
181 $_->meta->does_role($role);
186 # this is an original method for Mouse
187 sub typecast_constraints {
188 my($class, $pkg, $types, $value) = @_;
189 Carp::croak("wrong arguments count") unless @_==4;
192 for my $type ( split /\|/, $types ) {
193 next unless $COERCE{$type};
194 for my $coerce_type (@{ $COERCE_KEYS{$type}}) {
196 next unless $TYPE{$coerce_type}->check($value);
198 $_ = $COERCE{$type}->{$coerce_type}->($value);
199 return $_ if $types->check($_);
207 # enum ['small', 'medium', 'large']
208 if (ref($_[0]) eq 'ARRAY') {
209 my @elements = @{ shift @_ };
211 my $name = 'Mouse::Util::TypeConstaints::Enum::Serial::'
213 enum($name, @elements);
217 # enum size => 'small', 'medium', 'large'
219 my %is_valid = map { $_ => 1 } @_;
222 $name => where => sub { $is_valid{$_} }
226 sub _build_type_constraint {
231 if ($spec =~ /^([^\[]+)\[(.+)\]$/) {
236 if ($constraint eq 'Maybe') {
237 $parent = _build_type_constraint('Undef');
239 $parent = _build_type_constraint($constraint);
241 my $child = _build_type_constraint($param);
242 if ($constraint eq 'ArrayRef') {
244 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
246 " if (\$parent->check(\$_[0])) {\n" .
247 " foreach my \$e (\@{\$_[0]}) {\n" .
248 " return () unless \$child->check(\$e);\n" .
255 $code = eval $code_str or Carp::confess("Failed to generate inline type constraint: $@");
256 } elsif ($constraint eq 'HashRef') {
258 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
260 " if (\$parent->check(\$_[0])) {\n" .
261 " foreach my \$e (values \%{\$_[0]}) {\n" .
262 " return () unless \$child->check(\$e);\n" .
269 $code = eval $code_str or Carp::confess($@);
270 } elsif ($constraint eq 'Maybe') {
272 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
274 " return \$child->check(\$_[0]) || \$parent->check(\$_[0]);\n" .
277 $code = eval $code_str or Carp::confess($@);
279 Carp::confess("Support for parameterized types other than Maybe, ArrayRef or HashRef is not implemented yet");
281 $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
283 $code = $TYPE{ $spec };
285 # is $spec a known role? If so, constrain with 'does' instead of 'isa'
286 require Mouse::Meta::Role;
287 my $check = Mouse::Meta::Role->_metaclass_cache($spec)?
290 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
292 " Scalar::Util::blessed(\$_[0]) && \$_[0]->$check('$spec');\n" .
295 $code = eval $code_str or Carp::confess($@);
296 $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
299 return Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
302 sub find_type_constraint {
303 my $type_constraint = shift;
304 return $TYPE{$type_constraint};
307 sub find_or_create_isa_type_constraint {
308 my $type_constraint = shift;
312 $type_constraint =~ s/\s+//g;
314 $code = $TYPE{$type_constraint};
316 my @type_constraints = split /\|/, $type_constraint;
317 if (@type_constraints == 1) {
318 $code = $TYPE{$type_constraints[0]} ||
319 _build_type_constraint($type_constraints[0]);
321 my @code_list = map {
322 $TYPE{$_} || _build_type_constraint($_)
324 $code = Mouse::Meta::TypeConstraint->new(
325 _compiled_type_constraint => sub {
327 for my $code (@code_list) {
328 return 1 if $code->check($_[0]);
332 name => $type_constraint,
345 Mouse::Util::TypeConstraints - simple type constraints
349 =head2 optimized_constraints -> HashRef[CODE]
351 Returns the simple type constraints that Mouse understands.
357 =item B<subtype 'Name' => as 'Parent' => where { } ...>
359 =item B<subtype as 'Parent' => where { } ...>
361 =item B<class_type ($class, ?$options)>
363 =item B<role_type ($role, ?$options)>
365 =item B<enum (\@values)>