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     return $name;
 110 }
 111
 112 sub coerce {
 113     my($name, %conf) = @_;
 114
 115     Carp::croak "Cannot find type '$name', perhaps you forgot to load it."
 116         unless $TYPE{$name};
 117
 118     unless ($COERCE{$name}) {
 119         $COERCE{$name}      = {};
 120         $COERCE_KEYS{$name} = [];
 121     }
 122     while (my($type, $code) = each %conf) {
 123         Carp::croak "A coercion action already exists for '$type'"
 124             if $COERCE{$name}->{$type};
 125
 126         if (! $TYPE{$type}) {
 127             # looks parameterized
 128             if ($type =~ /^[^\[]+\[.+\]$/) {
 129                 Mouse::Meta::Attribute::_build_type_constraint($type);
 130             } else {
 131                 Carp::croak "Could not find the type constraint ($type) to coerce from"
 132             }
 133         }
 134
 135         push @{ $COERCE_KEYS{$name} }, $type;
 136         $COERCE{$name}->{$type} = $code;
 137     }
 138 }
 139
 140 sub class_type {
 141     my($name, $conf) = @_;
 142     if ($conf && $conf->{class}) {
 143         # No, you're using this wrong
 144         warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?";
 145         subtype($name, as => $conf->{class});
 146     } else {
 147         subtype(
 148             $name => where => sub { $_->isa($name) }
 149         );
 150     }
 151 }
 152
 153 sub role_type {
 154     my($name, $conf) = @_;
 155     my $role = $conf->{role};
 156     subtype(
 157         $name => where => sub {
 158             return unless defined $_ && ref($_) && $_->isa('Mouse::Object');
 159             $_->meta->does_role($role);
 160         }
 161     );
 162 }
 163
 164 sub typecast_constraints {
 165     my($class, $pkg, $type_constraint, $types, $value) = @_;
 166
 167     local $_;
 168     for my $type (ref($types) eq 'ARRAY' ? @{ $types } : ( $types )) {
 169         next unless $COERCE{$type};
 170         for my $coerce_type (@{ $COERCE_KEYS{$type}}) {
 171             $_ = $value;
 172             next unless $TYPE{$coerce_type}->($value);
 173             $_ = $value;
 174             $_ = $COERCE{$type}->{$coerce_type}->($value);
 175             return $_ if $type_constraint->($_);
 176         }
 177     }
 178     return $value;
 179 }
 180
 181 my $serial_enum = 0;
 182 sub enum {
 183     # enum ['small', 'medium', 'large']
 184     if (ref($_[0]) eq 'ARRAY') {
 185         my @elements = @{ shift @_ };
 186
 187         my $name = 'Mouse::Util::TypeConstaints::Enum::Serial::'
 188                  . ++$serial_enum;
 189         enum($name, @elements);
 190         return $name;
 191     }
 192
 193     # enum size => 'small', 'medium', 'large'
 194     my $name = shift;
 195     my %is_valid = map { $_ => 1 } @_;
 196
 197     subtype(
 198         $name => where => sub { $is_valid{$_} }
 199     );
 200 }
 201
 202 1;
 203
 204 __END__
 205
 206 =head1 NAME
 207
 208 Mouse::Util::TypeConstraints - simple type constraints
 209
 210 =head1 METHODS
 211
 212 =head2 optimized_constraints -> HashRef[CODE]
 213
 214 Returns the simple type constraints that Mouse understands.
 215
 216 =head1 FUNCTIONS
 217
 218 =over 4
 219
 220 =item B<subtype 'Name' => as 'Parent' => where { } ...>
 221
 222 =item B<subtype as 'Parent' => where { } ...>
 223
 224 =item B<class_type ($class, ?$options)>
 225
 226 =item B<role_type ($role, ?$options)>
 227
 228 =item B<enum (\@values)>
 229
 230 =back
 231
 232 =cut
 233
 234