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