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