lib/Mouse/Util/TypeConstraints.pm

   1 package Mouse::Util::TypeConstraints;
   2 use strict;
   3 use warnings;
   4 use base 'Exporter';
   5
   6 use Carp ();
   7 use Scalar::Util qw/blessed looks_like_number openhandle/;
   8
   9 our @EXPORT = qw(
  10     as where message from via type subtype coerce class_type role_type enum
  11     find_type_constraint
  12 );
  13
  14 my %TYPE;
  15 my %TYPE_SOURCE;
  16 my %COERCE;
  17 my %COERCE_KEYS;
  18
  19 sub as ($) {
  20     as => $_[0]
  21 }
  22 sub where (&) {
  23     where => $_[0]
  24 }
  25 sub message (&) {
  26     message => $_[0]
  27 }
  28
  29 sub from { @_ }
  30 sub via (&) {
  31     $_[0]
  32 }
  33
  34 BEGIN {
  35     no warnings 'uninitialized';
  36     %TYPE = (
  37         Any        => sub { 1 },
  38         Item       => sub { 1 },
  39         Bool       => sub {
  40             !defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0'
  41         },
  42         Undef      => sub { !defined($_[0]) },
  43         Defined    => sub { defined($_[0]) },
  44         Value      => sub { defined($_[0]) && !ref($_[0]) },
  45         Num        => sub { !ref($_[0]) && looks_like_number($_[0]) },
  46         Int        => sub { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ },
  47         Str        => sub { defined($_[0]) && !ref($_[0]) },
  48         ClassName  => sub { Mouse::is_class_loaded($_[0]) },
  49         Ref        => sub { ref($_[0]) },
  50
  51         ScalarRef  => sub { ref($_[0]) eq 'SCALAR' },
  52         ArrayRef   => sub { ref($_[0]) eq 'ARRAY'  },
  53         HashRef    => sub { ref($_[0]) eq 'HASH'   },
  54         CodeRef    => sub { ref($_[0]) eq 'CODE'   },
  55         RegexpRef  => sub { ref($_[0]) eq 'Regexp' },
  56         GlobRef    => sub { ref($_[0]) eq 'GLOB'   },
  57
  58         FileHandle => sub {
  59             ref($_[0]) eq 'GLOB' && openhandle($_[0])
  60             or
  61             blessed($_[0]) && $_[0]->isa("IO::Handle")
  62         },
  63
  64         Object     => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' },
  65     );
  66     foreach my $code (values %TYPE) {
  67         bless $code, 'Mouse::Meta::TypeConstraint';
  68     }
  69
  70     sub optimized_constraints { \%TYPE }
  71     my @TYPE_KEYS = keys %TYPE;
  72     sub list_all_builtin_type_constraints { @TYPE_KEYS }
  73
  74     @TYPE_SOURCE{@TYPE_KEYS} = (__PACKAGE__) x @TYPE_KEYS;
  75 }
  76
  77 sub type {
  78     my $pkg = caller(0);
  79     my($name, %conf) = @_;
  80     if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
  81         Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
  82     };
  83     my $constraint = $conf{where} || do {
  84         my $as = delete $conf{as} || 'Any';
  85         if (! exists $TYPE{$as}) {
  86             $TYPE{$as} = _build_type_constraint($as);
  87         }
  88         $TYPE{$as};
  89     };
  90
  91     $TYPE_SOURCE{$name} = $pkg;
  92     $TYPE{$name} = sub { local $_ = $_[0]; $constraint->($_[0]) };
  93 }
  94
  95 sub subtype {
  96     my $pkg = caller(0);
  97     my($name, %conf) = @_;
  98     if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
  99         Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
 100     };
 101     my $constraint = $conf{where};
 102     my $as_constraint = find_or_create_isa_type_constraint($conf{as} || 'Any');
 103
 104     $TYPE_SOURCE{$name} = $pkg;
 105     $TYPE{$name} = $constraint ?
 106         sub {
 107             local $_ = $_[0];
 108             $as_constraint->($_[0]) && $constraint->($_[0])
 109         } :
 110         sub {
 111             local $_ = $_[0];
 112             $as_constraint->($_[0]);
 113         }
 114     ;
 115
 116     return $name;
 117 }
 118
 119 sub coerce {
 120     my($name, %conf) = @_;
 121
 122     Carp::croak "Cannot find type '$name', perhaps you forgot to load it."
 123         unless $TYPE{$name};
 124
 125     unless ($COERCE{$name}) {
 126         $COERCE{$name}      = {};
 127         $COERCE_KEYS{$name} = [];
 128     }
 129     while (my($type, $code) = each %conf) {
 130         Carp::croak "A coercion action already exists for '$type'"
 131             if $COERCE{$name}->{$type};
 132
 133         if (! $TYPE{$type}) {
 134             # looks parameterized
 135             if ($type =~ /^[^\[]+\[.+\]$/) {
 136                 $TYPE{$type} = _build_type_constraint($type);
 137             } else {
 138                 Carp::croak "Could not find the type constraint ($type) to coerce from"
 139             }
 140         }
 141
 142         push @{ $COERCE_KEYS{$name} }, $type;
 143         $COERCE{$name}->{$type} = $code;
 144     }
 145 }
 146
 147 sub class_type {
 148     my($name, $conf) = @_;
 149     if ($conf && $conf->{class}) {
 150         # No, you're using this wrong
 151         warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?";
 152         subtype($name, as => $conf->{class});
 153     } else {
 154         subtype(
 155             $name => where => sub { $_->isa($name) }
 156         );
 157     }
 158 }
 159
 160 sub role_type {
 161     my($name, $conf) = @_;
 162     my $role = $conf->{role};
 163     subtype(
 164         $name => where => sub {
 165             return unless defined $_ && ref($_) && $_->isa('Mouse::Object');
 166             $_->meta->does_role($role);
 167         }
 168     );
 169 }
 170
 171 sub typecast_constraints {
 172     my($class, $pkg, $type_constraint, $types, $value) = @_;
 173
 174     local $_;
 175     for my $type (ref($types) eq 'ARRAY' ? @{ $types } : ( $types )) {
 176         next unless $COERCE{$type};
 177         for my $coerce_type (@{ $COERCE_KEYS{$type}}) {
 178             $_ = $value;
 179             next unless $TYPE{$coerce_type}->($value);
 180             $_ = $value;
 181             $_ = $COERCE{$type}->{$coerce_type}->($value);
 182             return $_ if $type_constraint->($_);
 183         }
 184     }
 185     return $value;
 186 }
 187
 188 my $serial_enum = 0;
 189 sub enum {
 190     # enum ['small', 'medium', 'large']
 191     if (ref($_[0]) eq 'ARRAY') {
 192         my @elements = @{ shift @_ };
 193
 194         my $name = 'Mouse::Util::TypeConstaints::Enum::Serial::'
 195                  . ++$serial_enum;
 196         enum($name, @elements);
 197         return $name;
 198     }
 199
 200     # enum size => 'small', 'medium', 'large'
 201     my $name = shift;
 202     my %is_valid = map { $_ => 1 } @_;
 203
 204     subtype(
 205         $name => where => sub { $is_valid{$_} }
 206     );
 207 }
 208
 209 sub _build_type_constraint {
 210
 211     my $spec = shift;
 212     my $code;
 213     $spec =~ s/\s+//g;
 214     if ($spec =~ /^([^\[]+)\[(.+)\]$/) {
 215         # parameterized
 216         my $constraint = $1;
 217         my $param      = $2;
 218         my $parent;
 219         if ($constraint eq 'Maybe') {
 220             $parent = _build_type_constraint('Undef');
 221         } else {
 222             $parent = _build_type_constraint($constraint);
 223         }
 224         my $child = _build_type_constraint($param);
 225         if ($constraint eq 'ArrayRef') {
 226             my $code_str =
 227                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 228                 "sub {\n" .
 229                 "    if (\$parent->(\$_[0])) {\n" .
 230                 "        foreach my \$e (\@{\$_[0]}) {\n" .
 231                 "            return () unless \$child->(\$e);\n" .
 232                 "        }\n" .
 233                 "        return 1;\n" .
 234                 "    }\n" .
 235                 "    return ();\n" .
 236                 "};\n"
 237             ;
 238             $code = eval $code_str or Carp::confess("Failed to generate inline type constraint: $@");
 239         } elsif ($constraint eq 'HashRef') {
 240             my $code_str =
 241                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 242                 "sub {\n" .
 243                 "    if (\$parent->(\$_[0])) {\n" .
 244                 "        foreach my \$e (values \%{\$_[0]}) {\n" .
 245                 "            return () unless \$child->(\$e);\n" .
 246                 "        }\n" .
 247                 "        return 1;\n" .
 248                 "    }\n" .
 249                 "    return ();\n" .
 250                 "};\n"
 251             ;
 252             $code = eval $code_str or Carp::confess($@);
 253         } elsif ($constraint eq 'Maybe') {
 254             my $code_str =
 255                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 256                 "sub {\n" .
 257                 "    return \$child->(\$_[0]) || \$parent->(\$_[0]);\n" .
 258                 "};\n"
 259             ;
 260             $code = eval $code_str or Carp::confess($@);
 261         } else {
 262             Carp::confess("Support for parameterized types other than ArrayRef or HashRef is not implemented yet");
 263         }
 264         $TYPE{$spec} = $code;
 265     } else {
 266         $code = $TYPE{ $spec };
 267         if (! $code) {
 268             my $code_str =
 269                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 270                 "sub {\n" .
 271                 "    Scalar::Util::blessed(\$_[0]) && \$_[0]->isa('$spec');\n" .
 272                 "}"
 273             ;
 274             $code = eval $code_str  or Carp::confess($@);
 275             $TYPE{$spec} = bless $code, 'Mouse::Meta::TypeConstraint';
 276         }
 277     }
 278     return bless $code, 'Mouse::Meta::TypeConstraint';
 279 }
 280
 281 sub find_type_constraint {
 282     my $type_constraint = shift;
 283     return $TYPE{$type_constraint};
 284 }
 285
 286 sub find_or_create_isa_type_constraint {
 287     my $type_constraint = shift;
 288
 289     my $code;
 290
 291     $type_constraint =~ s/\s+//g;
 292
 293     $code = $TYPE{$type_constraint};
 294     if (! $code) {
 295         my @type_constraints = split /\|/, $type_constraint;
 296         if (@type_constraints == 1) {
 297             $code = $TYPE{$type_constraints[0]} ||
 298                 _build_type_constraint($type_constraints[0]);
 299         } else {
 300             my @code_list = map {
 301                 $TYPE{$_} || _build_type_constraint($_)
 302             } @type_constraints;
 303             $code = bless sub {
 304                 my $i = 0;
 305                 for my $code (@code_list) {
 306                     return 1 if $code->($_[0]);
 307                 }
 308                 return 0;
 309             }, 'Mouse::Meta::TypeConstraint';
 310         }
 311     }
 312     return $code;
 313 }
 314
 315 package # Hide from pause
 316     Mouse::Meta::TypeConstraint;
 317
 318 sub check {
 319     $_[0]->($_[1])
 320 }
 321
 322
 323 1;
 324
 325 __END__
 326
 327 =head1 NAME
 328
 329 Mouse::Util::TypeConstraints - simple type constraints
 330
 331 =head1 METHODS
 332
 333 =head2 optimized_constraints -> HashRef[CODE]
 334
 335 Returns the simple type constraints that Mouse understands.
 336
 337 =head1 FUNCTIONS
 338
 339 =over 4
 340
 341 =item B<subtype 'Name' => as 'Parent' => where { } ...>
 342
 343 =item B<subtype as 'Parent' => where { } ...>
 344
 345 =item B<class_type ($class, ?$options)>
 346
 347 =item B<role_type ($role, ?$options)>
 348
 349 =item B<enum (\@values)>
 350
 351 =back
 352
 353 =cut
 354
 355