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
  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($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0'
  42         },
  43         Undef      => sub { !defined($_) },
  44         Defined    => sub { defined($_) },
  45         Value      => sub { defined($_) && !ref($_) },
  46         Num        => sub { !ref($_) && looks_like_number($_) },
  47         Int        => sub { defined($_) && !ref($_) && /^-?[0-9]+$/ },
  48         Str        => sub { defined($_) && !ref($_) },
  49         ClassName  => sub { Mouse::is_class_loaded($_) },
  50         Ref        => sub { ref($_) },
  51
  52         ScalarRef  => sub { ref($_) eq 'SCALAR' },
  53         ArrayRef   => sub { ref($_) eq 'ARRAY'  },
  54         HashRef    => sub { ref($_) eq 'HASH'   },
  55         CodeRef    => sub { ref($_) eq 'CODE'   },
  56         RegexpRef  => sub { ref($_) eq 'Regexp' },
  57         GlobRef    => sub { ref($_) eq 'GLOB'   },
  58
  59         FileHandle => sub {
  60             ref($_) eq 'GLOB' && openhandle($_)
  61             or
  62             blessed($_) && $_->isa("IO::Handle")
  63         },
  64
  65         Object     => sub { blessed($_) && blessed($_) 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} = $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 { $TYPE{delete $conf{as} || 'Any' } };
  94     my $as         = $conf{as} || '';
  95
  96     $TYPE_SOURCE{$name} = $pkg;
  97
  98     if ($as = $TYPE{$as}) {
  99         $TYPE{$name} = sub { $as->($_) && $constraint->($_) };
 100     } else {
 101         $TYPE{$name} = $constraint;
 102     }
 103 }
 104
 105 sub coerce {
 106     my($name, %conf) = @_;
 107
 108     Carp::croak "Cannot find type '$name', perhaps you forgot to load it."
 109         unless $TYPE{$name};
 110
 111     unless ($COERCE{$name}) {
 112         $COERCE{$name}      = {};
 113         $COERCE_KEYS{$name} = [];
 114     }
 115     while (my($type, $code) = each %conf) {
 116         Carp::croak "A coercion action already exists for '$type'"
 117             if $COERCE{$name}->{$type};
 118
 119         Carp::croak "Could not find the type constraint ($type) to coerce from"
 120             unless $TYPE{$type};
 121
 122         push @{ $COERCE_KEYS{$name} }, $type;
 123         $COERCE{$name}->{$type} = $code;
 124     }
 125 }
 126
 127 sub class_type {
 128     my $pkg = caller(0);
 129     my($name, $conf) = @_;
 130     my $class = $conf->{class};
 131     subtype(
 132         $name => where => sub { $_->isa($class) }
 133     );
 134 }
 135
 136 sub role_type {
 137     my($name, $conf) = @_;
 138     my $role = $conf->{role};
 139     subtype(
 140         $name => where => sub {
 141             return unless defined $_ && ref($_) && $_->isa('Mouse::Object');
 142             $_->meta->does_role($role);
 143         }
 144     );
 145 }
 146
 147 sub typecast_constraints {
 148     my($class, $pkg, $type_constraint, $types, $value) = @_;
 149
 150     local $_;
 151     for my $type (ref($types) eq 'ARRAY' ? @{ $types } : ( $types )) {
 152         next unless $COERCE{$type};
 153         for my $coerce_type (@{ $COERCE_KEYS{$type}}) {
 154             $_ = $value;
 155             next unless $TYPE{$coerce_type}->();
 156             $_ = $value;
 157             $_ = $COERCE{$type}->{$coerce_type}->();
 158             return $_ if $type_constraint->();
 159         }
 160     }
 161     return $value;
 162 }
 163
 164 1;
 165
 166 __END__
 167
 168 =head1 NAME
 169
 170 Mouse::Util::TypeConstraints - simple type constraints
 171
 172 =head1 METHODS
 173
 174 =head2 optimized_constraints -> HashRef[CODE]
 175
 176 Returns the simple type constraints that Mouse understands.
 177
 178 =cut
 179
 180