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     Carp::croak("wrong arguments count") unless @_==4;
 190
 191     local $_;
 192     for my $type ( split /\|/, $types ) {
 193         next unless $COERCE{$type};
 194         for my $coerce_type (@{ $COERCE_KEYS{$type}}) {
 195             $_ = $value;
 196             next unless $TYPE{$coerce_type}->check($value);
 197             $_ = $value;
 198             $_ = $COERCE{$type}->{$coerce_type}->($value);
 199             return $_ if $types->check($_);
 200         }
 201     }
 202     return $value;
 203 }
 204
 205 my $serial_enum = 0;
 206 sub enum {
 207     # enum ['small', 'medium', 'large']
 208     if (ref($_[0]) eq 'ARRAY') {
 209         my @elements = @{ shift @_ };
 210
 211         my $name = 'Mouse::Util::TypeConstaints::Enum::Serial::'
 212                  . ++$serial_enum;
 213         enum($name, @elements);
 214         return $name;
 215     }
 216
 217     # enum size => 'small', 'medium', 'large'
 218     my $name = shift;
 219     my %is_valid = map { $_ => 1 } @_;
 220
 221     subtype(
 222         $name => where => sub { $is_valid{$_} }
 223     );
 224 }
 225
 226 sub _build_type_constraint {
 227
 228     my $spec = shift;
 229     my $code;
 230     $spec =~ s/\s+//g;
 231     if ($spec =~ /^([^\[]+)\[(.+)\]$/) {
 232         # parameterized
 233         my $constraint = $1;
 234         my $param      = $2;
 235         my $parent;
 236         if ($constraint eq 'Maybe') {
 237             $parent = _build_type_constraint('Undef');
 238         } else {
 239             $parent = _build_type_constraint($constraint);
 240         }
 241         my $child = _build_type_constraint($param);
 242         if ($constraint eq 'ArrayRef') {
 243             my $code_str =
 244                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 245                 "sub {\n" .
 246                 "    if (\$parent->check(\$_[0])) {\n" .
 247                 "        foreach my \$e (\@{\$_[0]}) {\n" .
 248                 "            return () unless \$child->check(\$e);\n" .
 249                 "        }\n" .
 250                 "        return 1;\n" .
 251                 "    }\n" .
 252                 "    return ();\n" .
 253                 "};\n"
 254             ;
 255             $code = eval $code_str or Carp::confess("Failed to generate inline type constraint: $@");
 256         } elsif ($constraint eq 'HashRef') {
 257             my $code_str =
 258                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 259                 "sub {\n" .
 260                 "    if (\$parent->check(\$_[0])) {\n" .
 261                 "        foreach my \$e (values \%{\$_[0]}) {\n" .
 262                 "            return () unless \$child->check(\$e);\n" .
 263                 "        }\n" .
 264                 "        return 1;\n" .
 265                 "    }\n" .
 266                 "    return ();\n" .
 267                 "};\n"
 268             ;
 269             $code = eval $code_str or Carp::confess($@);
 270         } elsif ($constraint eq 'Maybe') {
 271             my $code_str =
 272                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 273                 "sub {\n" .
 274                 "    return \$child->check(\$_[0]) || \$parent->check(\$_[0]);\n" .
 275                 "};\n"
 276             ;
 277             $code = eval $code_str or Carp::confess($@);
 278         } else {
 279             Carp::confess("Support for parameterized types other than Maybe, ArrayRef or HashRef is not implemented yet");
 280         }
 281         $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
 282     } else {
 283         $code = $TYPE{ $spec };
 284         if (! $code) {
 285             my $code_str =
 286                 "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
 287                 "sub {\n" .
 288                 "    Scalar::Util::blessed(\$_[0]) && \$_[0]->isa('$spec');\n" .
 289                 "}"
 290             ;
 291             $code = eval $code_str  or Carp::confess($@);
 292             $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
 293         }
 294     }
 295     return Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
 296 }
 297
 298 sub find_type_constraint {
 299     my $type_constraint = shift;
 300     return $TYPE{$type_constraint};
 301 }
 302
 303 sub find_or_create_isa_type_constraint {
 304     my $type_constraint = shift;
 305
 306     my $code;
 307
 308     $type_constraint =~ s/\s+//g;
 309
 310     $code = $TYPE{$type_constraint};
 311     if (! $code) {
 312         my @type_constraints = split /\|/, $type_constraint;
 313         if (@type_constraints == 1) {
 314             $code = $TYPE{$type_constraints[0]} ||
 315                 _build_type_constraint($type_constraints[0]);
 316         } else {
 317             my @code_list = map {
 318                 $TYPE{$_} || _build_type_constraint($_)
 319             } @type_constraints;
 320             $code = Mouse::Meta::TypeConstraint->new(
 321                 _compiled_type_constraint => sub {
 322                     my $i = 0;
 323                     for my $code (@code_list) {
 324                         return 1 if $code->check($_[0]);
 325                     }
 326                     return 0;
 327                 },
 328                 name => $type_constraint,
 329             );
 330         }
 331     }
 332     return $code;
 333 }
 334
 335 1;
 336
 337 __END__
 338
 339 =head1 NAME
 340
 341 Mouse::Util::TypeConstraints - simple type constraints
 342
 343 =head1 METHODS
 344
 345 =head2 optimized_constraints -> HashRef[CODE]
 346
 347 Returns the simple type constraints that Mouse understands.
 348
 349 =head1 FUNCTIONS
 350
 351 =over 4
 352
 353 =item B<subtype 'Name' => as 'Parent' => where { } ...>
 354
 355 =item B<subtype as 'Parent' => where { } ...>
 356
 357 =item B<class_type ($class, ?$options)>
 358
 359 =item B<role_type ($role, ?$options)>
 360
 361 =item B<enum (\@values)>
 362
 363 =back
 364
 365 =cut
 366
 367