1 package Mouse::Util::TypeConstraints;
7 use Scalar::Util qw/blessed looks_like_number openhandle/;
10 as where message from via type subtype coerce class_type role_type enum
34 no warnings 'uninitialized';
39 !defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0'
41 Undef => sub { !defined($_[0]) },
42 Defined => sub { defined($_[0]) },
43 Value => sub { defined($_[0]) && !ref($_[0]) },
44 Num => sub { !ref($_[0]) && looks_like_number($_[0]) },
45 Int => sub { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ },
46 Str => sub { defined($_[0]) && !ref($_[0]) },
47 ClassName => sub { Mouse::is_class_loaded($_[0]) },
48 Ref => sub { ref($_[0]) },
50 ScalarRef => sub { ref($_[0]) eq 'SCALAR' },
51 ArrayRef => sub { ref($_[0]) eq 'ARRAY' },
52 HashRef => sub { ref($_[0]) eq 'HASH' },
53 CodeRef => sub { ref($_[0]) eq 'CODE' },
54 RegexpRef => sub { ref($_[0]) eq 'Regexp' },
55 GlobRef => sub { ref($_[0]) eq 'GLOB' },
58 ref($_[0]) eq 'GLOB' && openhandle($_[0])
60 blessed($_[0]) && $_[0]->isa("IO::Handle")
63 Object => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' },
65 foreach my $code (values %TYPE) {
66 bless $code, 'Mouse::Meta::TypeConstraint';
69 sub optimized_constraints { \%TYPE }
70 my @TYPE_KEYS = keys %TYPE;
71 sub list_all_builtin_type_constraints { @TYPE_KEYS }
73 @TYPE_SOURCE{@TYPE_KEYS} = (__PACKAGE__) x @TYPE_KEYS;
78 my($name, %conf) = @_;
79 if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
80 Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
82 my $constraint = $conf{where} || do {
83 my $as = delete $conf{as} || 'Any';
84 if (! exists $TYPE{$as}) {
85 $TYPE{$as} = _build_type_constraint($as);
90 $TYPE_SOURCE{$name} = $pkg;
91 $TYPE{$name} = sub { local $_ = $_[0]; $constraint->($_[0]) };
96 my($name, %conf) = @_;
97 if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
98 Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
100 my $constraint = $conf{where};
101 my $as_constraint = find_or_create_isa_type_constraint($conf{as} || 'Any');
103 $TYPE_SOURCE{$name} = $pkg;
104 $TYPE{$name} = $constraint ?
107 $as_constraint->($_[0]) && $constraint->($_[0])
111 $as_constraint->($_[0]);
119 my($name, %conf) = @_;
121 Carp::croak "Cannot find type '$name', perhaps you forgot to load it."
124 unless ($COERCE{$name}) {
126 $COERCE_KEYS{$name} = [];
128 while (my($type, $code) = each %conf) {
129 Carp::croak "A coercion action already exists for '$type'"
130 if $COERCE{$name}->{$type};
132 if (! $TYPE{$type}) {
133 # looks parameterized
134 if ($type =~ /^[^\[]+\[.+\]$/) {
135 _build_type_constraint($type);
137 Carp::croak "Could not find the type constraint ($type) to coerce from"
141 push @{ $COERCE_KEYS{$name} }, $type;
142 $COERCE{$name}->{$type} = $code;
147 my($name, $conf) = @_;
148 if ($conf && $conf->{class}) {
149 # No, you're using this wrong
150 warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?";
151 subtype($name, as => $conf->{class});
154 $name => where => sub { $_->isa($name) }
160 my($name, $conf) = @_;
161 my $role = $conf->{role};
163 $name => where => sub {
164 return unless defined $_ && ref($_) && $_->isa('Mouse::Object');
165 $_->meta->does_role($role);
170 sub typecast_constraints {
171 my($class, $pkg, $type_constraint, $types, $value) = @_;
174 for my $type (ref($types) eq 'ARRAY' ? @{ $types } : ( $types )) {
175 next unless $COERCE{$type};
176 for my $coerce_type (@{ $COERCE_KEYS{$type}}) {
178 next unless $TYPE{$coerce_type}->($value);
180 $_ = $COERCE{$type}->{$coerce_type}->($value);
181 return $_ if $type_constraint->($_);
189 # enum ['small', 'medium', 'large']
190 if (ref($_[0]) eq 'ARRAY') {
191 my @elements = @{ shift @_ };
193 my $name = 'Mouse::Util::TypeConstaints::Enum::Serial::'
195 enum($name, @elements);
199 # enum size => 'small', 'medium', 'large'
201 my %is_valid = map { $_ => 1 } @_;
204 $name => where => sub { $is_valid{$_} }
208 sub _build_type_constraint {
212 if ($spec =~ /^([^\[]+)\[(.+)\]$/) {
217 if ($constraint eq 'Maybe') {
218 $parent = _build_type_constraint('Undef');
220 $parent = _build_type_constraint($constraint);
222 my $child = _build_type_constraint($param);
223 if ($constraint eq 'ArrayRef') {
225 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
227 " if (\$parent->(\$_[0])) {\n" .
228 " foreach my \$e (\@{\$_[0]}) {\n" .
229 " return () unless \$child->(\$e);\n" .
236 $code = eval $code_str or Carp::confess("Failed to generate inline type constraint: $@");
237 } elsif ($constraint eq 'HashRef') {
239 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
241 " if (\$parent->(\$_[0])) {\n" .
242 " foreach my \$e (values \%{\$_[0]}) {\n" .
243 " return () unless \$child->(\$e);\n" .
250 $code = eval $code_str or Carp::confess($@);
251 } elsif ($constraint eq 'Maybe') {
253 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
255 " return \$child->(\$_[0]) || \$parent->(\$_[0]);\n" .
258 $code = eval $code_str or Carp::confess($@);
260 Carp::confess("Support for parameterized types other than ArrayRef or HashRef is not implemented yet");
262 $TYPE{$spec} = $code;
264 $code = $TYPE{ $spec };
267 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
269 " Scalar::Util::blessed(\$_[0]) && \$_[0]->isa('$spec');\n" .
272 $code = eval $code_str or Carp::confess($@);
273 $TYPE{$spec} = bless $code, 'Mouse::Meta::TypeConstraint';
276 return bless $code, 'Mouse::Meta::TypeConstraint';
279 sub find_type_constraint {
280 my $type_constraint = shift;
281 return $TYPE{$type_constraint};
284 sub find_or_create_isa_type_constraint {
285 my $type_constraint = shift;
289 $type_constraint =~ s/\s+//g;
290 my @type_constraints = split /\|/, $type_constraint;
291 if (@type_constraints == 1) {
292 $code = $TYPE{$type_constraints[0]} ||
293 _build_type_constraint($type_constraints[0]);
295 my @code_list = map {
296 $TYPE{$_} || _build_type_constraint($_)
300 for my $code (@code_list) {
301 return 1 if $code->($_[0]);
304 }, 'Mouse::Meta::TypeConstraint';
309 package # Hide from pause
310 Mouse::Meta::TypeConstraint;
323 Mouse::Util::TypeConstraints - simple type constraints
327 =head2 optimized_constraints -> HashRef[CODE]
329 Returns the simple type constraints that Mouse understands.
335 =item B<subtype 'Name' => as 'Parent' => where { } ...>
337 =item B<subtype as 'Parent' => where { } ...>
339 =item B<class_type ($class, ?$options)>
341 =item B<role_type ($role, ?$options)>
343 =item B<enum (\@values)>