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 my $optimized_constraints;
  34 my $optimized_constraints_base;
  35 {
  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
  68     sub optimized_constraints { \%TYPE }
  69     my @TYPE_KEYS = keys %TYPE;
  70     sub list_all_builtin_type_constraints { @TYPE_KEYS }
  71
  72     @TYPE_SOURCE{@TYPE_KEYS} = (__PACKAGE__) x @TYPE_KEYS;
  73 }
  74
  75 sub type {
  76     my $pkg = caller(0);
  77     my($name, %conf) = @_;
  78     if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
  79         Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
  80     };
  81     my $constraint = $conf{where} || do { $TYPE{delete $conf{as} || 'Any' } };
  82
  83     $TYPE_SOURCE{$name} = $pkg;
  84     $TYPE{$name} = sub { local $_=$_[0]; $constraint->($_) };
  85 }
  86
  87 sub subtype {
  88     my $pkg = caller(0);
  89     my($name, %conf) = @_;
  90     if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
  91         Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
  92     };
  93     my $constraint = $conf{where} || do {
  94         my $as = delete $conf{as} || 'Any';
  95         if (! exists $TYPE{$as}) { # Perhaps it's a parameterized source?
  96             Mouse::Meta::Attribute::_build_type_constraint($as);
  97         }
  98         $TYPE{$as};
  99     };
 100     my $as         = $conf{as} || '';
 101
 102     $TYPE_SOURCE{$name} = $pkg;
 103
 104     if ($as = $TYPE{$as}) {
 105         $TYPE{$name} = sub { local $_=$_[0]; $as->($_) && $constraint->($_) };
 106     } else {
 107         $TYPE{$name} = sub { local $_=$_[0]; $constraint->($_) };
 108     }
 109 }
 110
 111 sub coerce {
 112     my($name, %conf) = @_;
 113
 114     Carp::croak "Cannot find type '$name', perhaps you forgot to load it."
 115         unless $TYPE{$name};
 116
 117     unless ($COERCE{$name}) {
 118         $COERCE{$name}      = {};
 119         $COERCE_KEYS{$name} = [];
 120     }
 121     while (my($type, $code) = each %conf) {
 122         Carp::croak "A coercion action already exists for '$type'"
 123             if $COERCE{$name}->{$type};
 124
 125         if (! $TYPE{$type}) {
 126             # looks parameterized
 127             if ($type =~ /^[^\[]+\[.+\]$/) {
 128                 Mouse::Meta::Attribute::_build_type_constraint($type);
 129             } else {
 130                 Carp::croak "Could not find the type constraint ($type) to coerce from"
 131             }
 132         }
 133
 134         push @{ $COERCE_KEYS{$name} }, $type;
 135         $COERCE{$name}->{$type} = $code;
 136     }
 137 }
 138
 139 sub class_type {
 140     my $pkg = caller(0);
 141     my($name, $conf) = @_;
 142     my $class = $conf->{class};
 143     subtype(
 144         $name => where => sub { $_->isa($class) }
 145     );
 146 }
 147
 148 sub role_type {
 149     my($name, $conf) = @_;
 150     my $role = $conf->{role};
 151     subtype(
 152         $name => where => sub {
 153             return unless defined $_ && ref($_) && $_->isa('Mouse::Object');
 154             $_->meta->does_role($role);
 155         }
 156     );
 157 }
 158
 159 sub typecast_constraints {
 160     my($class, $pkg, $type_constraint, $types, $value) = @_;
 161
 162     local $_;
 163     for my $type (ref($types) eq 'ARRAY' ? @{ $types } : ( $types )) {
 164         next unless $COERCE{$type};
 165         for my $coerce_type (@{ $COERCE_KEYS{$type}}) {
 166             $_ = $value;
 167             next unless $TYPE{$coerce_type}->($value);
 168             $_ = $value;
 169             $_ = $COERCE{$type}->{$coerce_type}->($value);
 170             return $_ if $type_constraint->($_);
 171         }
 172     }
 173     return $value;
 174 }
 175
 176 my $serial_enum = 0;
 177 sub enum {
 178     # enum ['small', 'medium', 'large']
 179     if (ref($_[0]) eq 'ARRAY') {
 180         my @elements = @{ shift @_ };
 181
 182         my $name = 'Mouse::Util::TypeConstaints::Enum::Serial::'
 183                  . ++$serial_enum;
 184         enum($name, @elements);
 185         return $name;
 186     }
 187
 188     # enum size => 'small', 'medium', 'large'
 189     my $name = shift;
 190     my %is_valid = map { $_ => 1 } @_;
 191
 192     subtype(
 193         $name => where => sub { $is_valid{$_} }
 194     );
 195 }
 196
 197 1;
 198
 199 __END__
 200
 201 =head1 NAME
 202
 203 Mouse::Util::TypeConstraints - simple type constraints
 204
 205 =head1 METHODS
 206
 207 =head2 optimized_constraints -> HashRef[CODE]
 208
 209 Returns the simple type constraints that Mouse understands.
 210
 211 =head1 FUNCTIONS
 212
 213 =over 4
 214
 215 =item B<subtype 'Name' => as 'Parent' => where { } ...>
 216
 217 =item B<subtype as 'Parent' => where { } ...>
 218
 219 =item B<class_type ($class, ?$options)>
 220
 221 =item B<role_type ($role, ?$options)>
 222
 223 =item B<enum (\@values)>
 224
 225 =back
 226
 227 =cut
 228
 229