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 typecast_constraints {
  56     my($class, $pkg, $type, $value) = @_;
  57     return $value unless defined $COERCE->{$pkg} && defined $COERCE->{$pkg}->{$type};
  58
  59     my $optimized_constraints = optimized_constraints();
  60     for my $coerce_type (keys %{ $COERCE->{$pkg}->{$type} }) {
  61         local $_ = $value;
  62         if ($optimized_constraints->{$coerce_type}->()) {
  63             local $_ = $value;
  64             return $COERCE->{$pkg}->{$type}->{$coerce_type}->();
  65         }
  66     }
  67
  68     return $value;
  69 }
  70
  71 {
  72     no warnings 'uninitialized';
  73     my $optimized_constraints = {
  74         Any        => sub { 1 },
  75         Item       => sub { 1 },
  76         Bool       => sub {
  77             !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0'
  78         },
  79         Undef      => sub { !defined($_) },
  80         Defined    => sub { defined($_) },
  81         Value      => sub { defined($_) && !ref($_) },
  82         Num        => sub { !ref($_) && looks_like_number($_) },
  83         Int        => sub { defined($_) && !ref($_) && /^-?[0-9]+$/ },
  84         Str        => sub { defined($_) && !ref($_) },
  85         ClassName  => sub { Mouse::is_class_loaded($_) },
  86         Ref        => sub { ref($_) },
  87
  88         ScalarRef  => sub { ref($_) eq 'SCALAR' },
  89         ArrayRef   => sub { ref($_) eq 'ARRAY'  },
  90         HashRef    => sub { ref($_) eq 'HASH'   },
  91         CodeRef    => sub { ref($_) eq 'CODE'   },
  92         RegexpRef  => sub { ref($_) eq 'Regexp' },
  93         GlobRef    => sub { ref($_) eq 'GLOB'   },
  94
  95         FileHandle => sub {
  96                 ref($_) eq 'GLOB'
  97                 && openhandle($_)
  98             or
  99                 blessed($_)
 100                 && $_->isa("IO::Handle")
 101         },
 102
 103         Object     => sub { blessed($_) && blessed($_) ne 'Regexp' },
 104     };
 105     sub optimized_constraints {
 106         my($class, $pkg) = @_;
 107         my $subtypes = $SUBTYPE->{$pkg} || {};
 108         return { %{ $subtypes }, %{ $optimized_constraints } };
 109     }
 110 }
 111
 112 1;
 113
 114 __END__
 115
 116 =head1 NAME
 117
 118 Mouse::TypeRegistry - simple type constraints
 119
 120 =head1 METHODS
 121
 122 =head2 optimized_constraints -> HashRef[CODE]
 123
 124 Returns the simple type constraints that Mouse understands.
 125
 126 =cut
 127
 128