lib/Mouse/TypeRegistry.pm

   1 #!/usr/bin/env perl
   2 package Mouse::TypeRegistry;
   3 use strict;
   4 use warnings;
   5 use Scalar::Util qw/looks_like_number blessed openhandle/;
   6
   7 no warnings 'uninitialized';
   8 sub optimized_constraints {
   9     return {
  10         Any        => sub { 1 },
  11         Item       => sub { 1 },
  12         Bool       => sub {
  13             !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0'
  14         },
  15         Undef      => sub { !defined($_) },
  16         Defined    => sub { defined($_) },
  17         Value      => sub { defined($_) && !ref($_) },
  18         Num        => sub { !ref($_) && looks_like_number($_) },
  19         Int        => sub { defined($_) && !ref($_) && /^-?[0-9]+$/ },
  20         Str        => sub { defined($_) && !ref($_) },
  21         Ref        => sub { ref($_) },
  22
  23         ScalarRef  => sub { ref($_) eq 'SCALAR' },
  24         ArrayRef   => sub { ref($_) eq 'ARRAY'  },
  25         HashRef    => sub { ref($_) eq 'HASH'   },
  26         CodeRef    => sub { ref($_) eq 'CODE'   },
  27         RegexpRef  => sub { ref($_) eq 'Regexp' },
  28         GlobRef    => sub { ref($_) eq 'GLOB'   },
  29
  30         FileHandle => sub {
  31                 ref($_) eq 'GLOB'
  32                 && openhandle($_)
  33             or
  34                 blessed($_)
  35                 && $_->isa("IO::Handle")
  36         },
  37
  38         Object     => sub { blessed($_) && blessed($_) ne 'Regexp' },
  39
  40         ClassName  => sub {
  41             return if ref($_);
  42             return unless defined($_) && length($_);
  43
  44             # walk the symbol table tree to avoid autovififying
  45             # \*{${main::}{"Foo::"}} == \*main::Foo::
  46
  47             my $pack = \*::;
  48             foreach my $part (split('::', $_)) {
  49                 return unless exists ${$$pack}{"${part}::"};
  50                 $pack = \*{${$$pack}{"${part}::"}};
  51             }
  52
  53             # check for $VERSION or @ISA
  54             return 1 if exists ${$$pack}{VERSION}
  55                     && defined *{${$$pack}{VERSION}}{SCALAR};
  56             return 1 if exists ${$$pack}{ISA}
  57                     && defined *{${$$pack}{ISA}}{ARRAY};
  58
  59             # check for any method
  60             foreach ( keys %{$$pack} ) {
  61                 next if substr($_, -2, 2) eq '::';
  62                 return 1 if defined *{${$$pack}{$_}}{CODE};
  63             }
  64
  65             # fail
  66             return;
  67         },
  68     };
  69 }
  70
  71 1;
  72