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                 _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     if ($spec =~ /^([^\[]+)\[(.+)\]$/) {
 214         # parameterized
 215         my $constraint = $1;
 216         my $param      = $2;
 217         my $parent;
 218         if ($constraint eq 'Maybe') {
 219             $parent = _build_type_constraint('Undef');
 220         } else {
 221             $parent = _build_type_constraint($constraint);
 222         }
 223         my $child = _build_type_constraint($param);
 224         if ($constraint eq 'ArrayRef') {
 225             my $code_str =
 226                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 227                 "sub {\n" .
 228                 "    if (\$parent->(\$_[0])) {\n" .
 229                 "        foreach my \$e (\@{\$_[0]}) {\n" .
 230                 "            return () unless \$child->(\$e);\n" .
 231                 "        }\n" .
 232                 "        return 1;\n" .
 233                 "    }\n" .
 234                 "    return ();\n" .
 235                 "};\n"
 236             ;
 237             $code = eval $code_str or Carp::confess("Failed to generate inline type constraint: $@");
 238         } elsif ($constraint eq 'HashRef') {
 239             my $code_str =
 240                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 241                 "sub {\n" .
 242                 "    if (\$parent->(\$_[0])) {\n" .
 243                 "        foreach my \$e (values \%{\$_[0]}) {\n" .
 244                 "            return () unless \$child->(\$e);\n" .
 245                 "        }\n" .
 246                 "        return 1;\n" .
 247                 "    }\n" .
 248                 "    return ();\n" .
 249                 "};\n"
 250             ;
 251             $code = eval $code_str or Carp::confess($@);
 252         } elsif ($constraint eq 'Maybe') {
 253             my $code_str =
 254                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 255                 "sub {\n" .
 256                 "    return \$child->(\$_[0]) || \$parent->(\$_[0]);\n" .
 257                 "};\n"
 258             ;
 259             $code = eval $code_str or Carp::confess($@);
 260         } else {
 261             Carp::confess("Support for parameterized types other than ArrayRef or HashRef is not implemented yet");
 262         }
 263         $TYPE{$spec} = $code;
 264     } else {
 265         $code = $TYPE{ $spec };
 266         if (! $code) {
 267             my $code_str =
 268                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 269                 "sub {\n" .
 270                 "    Scalar::Util::blessed(\$_[0]) && \$_[0]->isa('$spec');\n" .
 271                 "}"
 272             ;
 273             $code = eval $code_str  or Carp::confess($@);
 274             $TYPE{$spec} = bless $code, 'Mouse::Meta::TypeConstraint';
 275         }
 276     }
 277     return bless $code, 'Mouse::Meta::TypeConstraint';
 278 }
 279
 280 sub find_type_constraint {
 281     my $type_constraint = shift;
 282     return $TYPE{$type_constraint};
 283 }
 284
 285 sub find_or_create_isa_type_constraint {
 286     my $type_constraint = shift;
 287
 288     my $code;
 289
 290     $type_constraint =~ s/\s+//g;
 291     my @type_constraints = split /\|/, $type_constraint;
 292     if (@type_constraints == 1) {
 293         $code = $TYPE{$type_constraints[0]} ||
 294             _build_type_constraint($type_constraints[0]);
 295     } else {
 296         my @code_list = map {
 297             $TYPE{$_} || _build_type_constraint($_)
 298         } @type_constraints;
 299         $code = bless sub {
 300             my $i = 0;
 301             for my $code (@code_list) {
 302                 return 1 if $code->($_[0]);
 303             }
 304             return 0;
 305         }, 'Mouse::Meta::TypeConstraint';
 306     }
 307     return $code;
 308 }
 309
 310 package # Hide from pause
 311     Mouse::Meta::TypeConstraint;
 312
 313 sub check {
 314     $_[0]->($_[1])
 315 }
 316
 317
 318 1;
 319
 320 __END__
 321
 322 =head1 NAME
 323
 324 Mouse::Util::TypeConstraints - simple type constraints
 325
 326 =head1 METHODS
 327
 328 =head2 optimized_constraints -> HashRef[CODE]
 329
 330 Returns the simple type constraints that Mouse understands.
 331
 332 =head1 FUNCTIONS
 333
 334 =over 4
 335
 336 =item B<subtype 'Name' => as 'Parent' => where { } ...>
 337
 338 =item B<subtype as 'Parent' => where { } ...>
 339
 340 =item B<class_type ($class, ?$options)>
 341
 342 =item B<role_type ($role, ?$options)>
 343
 344 =item B<enum (\@values)>
 345
 346 =back
 347
 348 =cut
 349
 350