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