lib/Moose/Util/TypeConstraints/Builtins.pm

   1 package Moose::Util::TypeConstraints::Builtins;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Scalar::Util qw( blessed looks_like_number reftype );
   7
   8 sub type { goto &Moose::Util::TypeConstraints::type }
   9 sub subtype { goto &Moose::Util::TypeConstraints::subtype }
  10 sub as { goto &Moose::Util::TypeConstraints::as }
  11 sub where (&) { goto &Moose::Util::TypeConstraints::where }
  12 sub optimize_as (&) { goto &Moose::Util::TypeConstraints::optimize_as }
  13 sub inline_as (&) { goto &Moose::Util::TypeConstraints::inline_as }
  14
  15 sub define_builtins {
  16     my $registry = shift;
  17
  18     type 'Any'    # meta-type including all
  19         => where {1}
  20         => inline_as { '1' };
  21
  22     subtype 'Item'  # base-type
  23         => as 'Any';
  24
  25     subtype 'Undef'
  26         => as 'Item'
  27         => where { !defined($_) }
  28         => inline_as { "! defined $_[0]" };
  29
  30     subtype 'Defined'
  31         => as 'Item'
  32         => where { defined($_) }
  33         => inline_as { "defined $_[0]" };
  34
  35     subtype 'Bool'
  36         => as 'Item'
  37         => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }
  38         => inline_as { qq{!defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0'} };
  39
  40     subtype 'Value'
  41         => as 'Defined'
  42         => where { !ref($_) }
  43         => optimize_as( \&_Value )
  44         => inline_as { "defined $_[0] && ! ref $_[0]" };
  45
  46     subtype 'Ref'
  47         => as 'Defined'
  48         => where { ref($_) }
  49         => optimize_as( \&_Ref )
  50         => inline_as { "ref $_[0]" };
  51
  52     subtype 'Str'
  53         => as 'Value'
  54         => where { ref(\$_) eq 'SCALAR' }
  55         => optimize_as( \&_Str )
  56         => inline_as {
  57             return (  qq{defined $_[0]}
  58                     . qq{&& (   ref(\\             $_[0] ) eq 'SCALAR'}
  59                     . qq{    || ref(\\(my \$value = $_[0])) eq 'SCALAR')} );
  60         };
  61
  62     subtype 'Num'
  63         => as 'Str'
  64         => where { Scalar::Util::looks_like_number($_) }
  65         => optimize_as( \&_Num )
  66         => inline_as { "!ref $_[0] && Scalar::Util::looks_like_number($_[0])" };
  67
  68     subtype 'Int'
  69         => as 'Num'
  70         => where { "$_" =~ /^-?[0-9]+$/ }
  71         => optimize_as( \&_Int )
  72         => inline_as {
  73             return (  qq{defined $_[0]}
  74                     . qq{&& ! ref $_[0]}
  75                     . qq{&& ( my \$value = $_[0] ) =~ /\\A-?[0-9]+\\z/} );
  76         };
  77
  78     subtype 'CodeRef'
  79         => as 'Ref'
  80         => where { ref($_) eq 'CODE' }
  81         => optimize_as( \&_CodeRef )
  82         => inline_as { qq{ref( $_[0] ) eq 'CODE'} };
  83
  84     subtype 'RegexpRef'
  85         => as 'Ref'
  86         => where( \&_RegexpRef )
  87         => optimize_as( \&_RegexpRef )
  88         => inline_as { "_RegexpRef( $_[0] )" };
  89
  90     subtype 'GlobRef'
  91         => as 'Ref'
  92         => where { ref($_) eq 'GLOB' }
  93         => optimize_as( \&_GlobRef )
  94         => inline_as { qq{ref( $_[0] ) eq 'GLOB'} };
  95
  96     # NOTE: scalar filehandles are GLOB refs, but a GLOB ref is not always a
  97     # filehandle
  98     subtype 'FileHandle'
  99         => as 'GlobRef'
 100         => where {
 101             Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") );
 102         }
 103         => optimize_as( \&_FileHandle )
 104         => inline_as {
 105             return (  qq{ref( $_[0] ) eq 'GLOB'}
 106                     . qq{&& Scalar::Util::openhandle( $_[0] )}
 107                     . qq{or blessed( $_[0] ) && $_[0]->isa("IO::Handle")} );
 108         };
 109
 110     subtype 'Object'
 111         => as 'Ref'
 112         => where { blessed($_) }
 113         => optimize_as( \&_Object )
 114         => inline_as { "Scalar::Util::blessed( $_[0] )" };
 115
 116     # This type is deprecated.
 117     subtype 'Role'
 118         => as 'Object'
 119         => where { $_->can('does') }
 120         => optimize_as( \&_Role );
 121
 122     subtype 'ClassName'
 123         => as 'Str'
 124         => where { Class::MOP::is_class_loaded($_) }
 125         => optimize_as( \&_ClassName )
 126         => inline_as { "Class::MOP::is_class_loaded( $_[0] )" };
 127
 128     subtype 'RoleName'
 129         => as 'ClassName'
 130         => where {
 131             (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role');
 132         }
 133         => optimize_as( \&_RoleName )
 134         => inline_as {
 135             return (  qq{Class::MOP::is_class_loaded( $_[0] )}
 136                     . qq{&& ( Class::MOP::class_of( $_[0] ) || return )}
 137                     . qq{       ->isa('Moose::Meta::Role')} );
 138         };
 139
 140     $registry->add_type_constraint(
 141         Moose::Meta::TypeConstraint::Parameterizable->new(
 142             name               => 'ScalarRef',
 143             package_defined_in => __PACKAGE__,
 144             parent =>
 145                 Moose::Util::TypeConstraints::find_type_constraint('Ref'),
 146             constraint => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' },
 147             optimized            => \&_ScalarRef,
 148             constraint_generator => sub {
 149                 my $type_parameter = shift;
 150                 my $check = $type_parameter->_compiled_type_constraint;
 151                 return sub {
 152                     return $check->( ${$_} );
 153                 };
 154             }
 155         )
 156     );
 157
 158     $registry->add_type_constraint(
 159         Moose::Meta::TypeConstraint::Parameterizable->new(
 160             name               => 'ArrayRef',
 161             package_defined_in => __PACKAGE__,
 162             parent =>
 163                 Moose::Util::TypeConstraints::find_type_constraint('Ref'),
 164             constraint => sub { ref($_) eq 'ARRAY' },
 165             optimized => \&_ArrayRef,
 166             constraint_generator => sub {
 167                 my $type_parameter = shift;
 168                 my $check = $type_parameter->_compiled_type_constraint;
 169                 return sub {
 170                     foreach my $x (@$_) {
 171                         ( $check->($x) ) || return;
 172                     }
 173                     1;
 174                     }
 175             }
 176         )
 177     );
 178
 179     $registry->add_type_constraint(
 180         Moose::Meta::TypeConstraint::Parameterizable->new(
 181             name               => 'HashRef',
 182             package_defined_in => __PACKAGE__,
 183             parent =>
 184                 Moose::Util::TypeConstraints::find_type_constraint('Ref'),
 185             constraint => sub { ref($_) eq 'HASH' },
 186             optimized => \&_HashRef,
 187             constraint_generator => sub {
 188                 my $type_parameter = shift;
 189                 my $check = $type_parameter->_compiled_type_constraint;
 190                 return sub {
 191                     foreach my $x ( values %$_ ) {
 192                         ( $check->($x) ) || return;
 193                     }
 194                     1;
 195                     }
 196             }
 197         )
 198     );
 199
 200     $registry->add_type_constraint(
 201         Moose::Meta::TypeConstraint::Parameterizable->new(
 202             name               => 'Maybe',
 203             package_defined_in => __PACKAGE__,
 204             parent =>
 205                 Moose::Util::TypeConstraints::find_type_constraint('Item'),
 206             constraint           => sub {1},
 207             constraint_generator => sub {
 208                 my $type_parameter = shift;
 209                 my $check = $type_parameter->_compiled_type_constraint;
 210                 return sub {
 211                     return 1 if not( defined($_) ) || $check->($_);
 212                     return;
 213                     }
 214             }
 215         )
 216     );
 217 }
 218
 219 sub _Value { defined($_[0]) && !ref($_[0]) }
 220
 221 sub _Ref { ref($_[0]) }
 222
 223 # We might need to use a temporary here to flatten LVALUEs, for instance as in
 224 # Str(substr($_,0,255)).
 225 sub _Str {
 226     defined($_[0])
 227       && (   ref(\             $_[0] ) eq 'SCALAR'
 228           || ref(\(my $value = $_[0])) eq 'SCALAR')
 229 }
 230
 231 sub _Num { !ref($_[0]) && looks_like_number($_[0]) }
 232
 233 # using a temporary here because regex matching promotes an IV to a PV,
 234 # and that confuses some things (like JSON.pm)
 235 sub _Int {
 236     my $value = $_[0];
 237     defined($value) && !ref($value) && $value =~ /\A-?[0-9]+\z/
 238 }
 239
 240 sub _ScalarRef { ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' }
 241 sub _ArrayRef  { ref($_[0]) eq 'ARRAY'  }
 242 sub _HashRef   { ref($_[0]) eq 'HASH'   }
 243 sub _CodeRef   { ref($_[0]) eq 'CODE'   }
 244 sub _GlobRef   { ref($_[0]) eq 'GLOB'   }
 245
 246 # RegexpRef is implemented in Moose.xs
 247
 248 sub _FileHandle {
 249     ref( $_[0] ) eq 'GLOB' && Scalar::Util::openhandle( $_[0] )
 250         or blessed( $_[0] ) && $_[0]->isa("IO::Handle");
 251 }
 252
 253 sub _Object { blessed($_[0]) }
 254
 255 sub _Role {
 256     Moose::Deprecated::deprecated(
 257         feature => 'Role type',
 258         message =>
 259             'The Role type has been deprecated. Maybe you meant to create a RoleName type? This type be will be removed in Moose 2.0200.'
 260     );
 261     blessed( $_[0] ) && $_[0]->can('does');
 262 }
 263
 264 sub _ClassName {
 265     return Class::MOP::is_class_loaded( $_[0] );
 266 }
 267
 268 sub _RoleName {
 269     _ClassName( $_[0] )
 270         && ( Class::MOP::class_of( $_[0] ) || return )
 271         ->isa('Moose::Meta::Role');
 272 }
 273
 274 1;