lib/Moose/Util/TypeConstraints/Builtins.pm

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