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