lib/Mouse/TypeRegistry.pm

   1 #!/usr/bin/env perl
   2 package Mouse::TypeRegistry;
   3 use strict;
   4 use warnings;
   5
   6 use Mouse::Util qw/blessed looks_like_number openhandle/;
   7
   8 my $SUBTYPE = +{};
   9 my $COERCE = +{};
  10
  11 sub import {
  12     my $class  = shift;
  13     my %args   = @_;
  14     my $caller = caller(0);
  15
  16     $SUBTYPE->{$caller} ||= +{};
  17     $COERCE->{$caller}  ||= +{};
  18
  19     if (defined $args{'-export'} && ref($args{'-export'}) eq 'ARRAY') {
  20         no strict 'refs';
  21         *{"$caller\::import"} = sub { _import(@_) };
  22     }
  23
  24     no strict 'refs';
  25     *{"$caller\::subtype"}     = \&_subtype;
  26     *{"$caller\::coerce"}      = \&_coerce;
  27     *{"$caller\::class_type"}  = \&_class_type;
  28     *{"$caller\::role_type"}   = \&_role_type;
  29 }
  30
  31 sub _import {
  32     my($class, @types) = @_;
  33     return unless exists $SUBTYPE->{$class} && exists $COERCE->{$class};
  34     my $pkg = caller(1);
  35     return unless @types;
  36     copy_types($class, $pkg, @types);
  37 }
  38
  39 sub _subtype {
  40     my $pkg = caller(0);
  41     my($name, $stuff) = @_;
  42     if (ref $stuff eq 'HASH') {
  43         my $as = $stuff->{as};
  44         $stuff = optimized_constraints()->{$as};
  45     }
  46     $SUBTYPE->{$pkg}->{$name} = $stuff;
  47 }
  48
  49 sub _coerce {
  50     my $pkg = caller(0);
  51     my($name, $conf) = @_;
  52     $COERCE->{$pkg}->{$name} = $conf;
  53 }
  54
  55 sub _class_type {
  56     my $pkg = caller(0);
  57     $SUBTYPE->{$pkg} ||= +{};
  58     my($name, $conf) = @_;
  59     my $class = $conf->{class};
  60     $SUBTYPE->{$pkg}->{$name} = sub {
  61         defined $_ && ref($_) eq $class;
  62     };
  63 }
  64
  65 sub _role_type {
  66     my $pkg = caller(0);
  67     $SUBTYPE->{$pkg} ||= +{};
  68     my($name, $conf) = @_;
  69     my $role = $conf->{role};
  70     $SUBTYPE->{$pkg}->{$name} = sub {
  71         return unless defined $_ && ref($_) && $_->isa('Mouse::Object');
  72         $_->meta->does_role($role);
  73     };
  74 }
  75
  76 sub typecast_constraints {
  77     my($class, $pkg, $type, $value) = @_;
  78     return $value unless defined $COERCE->{$pkg} && defined $COERCE->{$pkg}->{$type};
  79
  80     my $optimized_constraints = optimized_constraints();
  81     for my $coerce_type (keys %{ $COERCE->{$pkg}->{$type} }) {
  82         local $_ = $value;
  83         if ($optimized_constraints->{$coerce_type}->()) {
  84             local $_ = $value;
  85             return $COERCE->{$pkg}->{$type}->{$coerce_type}->();
  86         }
  87     }
  88
  89     return $value;
  90 }
  91
  92 {
  93     no warnings 'uninitialized';
  94     my $optimized_constraints = {
  95         Any        => sub { 1 },
  96         Item       => sub { 1 },
  97         Bool       => sub {
  98             !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0'
  99         },
 100         Undef      => sub { !defined($_) },
 101         Defined    => sub { defined($_) },
 102         Value      => sub { defined($_) && !ref($_) },
 103         Num        => sub { !ref($_) && looks_like_number($_) },
 104         Int        => sub { defined($_) && !ref($_) && /^-?[0-9]+$/ },
 105         Str        => sub { defined($_) && !ref($_) },
 106         ClassName  => sub { Mouse::is_class_loaded($_) },
 107         Ref        => sub { ref($_) },
 108
 109         ScalarRef  => sub { ref($_) eq 'SCALAR' },
 110         ArrayRef   => sub { ref($_) eq 'ARRAY'  },
 111         HashRef    => sub { ref($_) eq 'HASH'   },
 112         CodeRef    => sub { ref($_) eq 'CODE'   },
 113         RegexpRef  => sub { ref($_) eq 'Regexp' },
 114         GlobRef    => sub { ref($_) eq 'GLOB'   },
 115
 116         FileHandle => sub {
 117                 ref($_) eq 'GLOB'
 118                 && openhandle($_)
 119             or
 120                 blessed($_)
 121                 && $_->isa("IO::Handle")
 122         },
 123
 124         Object     => sub { blessed($_) && blessed($_) ne 'Regexp' },
 125     };
 126     sub optimized_constraints {
 127         my($class, $pkg) = @_;
 128         my $subtypes = $SUBTYPE->{$pkg} || {};
 129         return { %{ $subtypes }, %{ $optimized_constraints } };
 130     }
 131 }
 132
 133 1;
 134
 135 __END__
 136
 137 =head1 NAME
 138
 139 Mouse::TypeRegistry - simple type constraints
 140
 141 =head1 METHODS
 142
 143 =head2 optimized_constraints -> HashRef[CODE]
 144
 145 Returns the simple type constraints that Mouse understands.
 146
 147 =cut
 148
 149