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 $_[0]" };
  31
  32     subtype 'Defined'
  33         => as 'Item'
  34         => where { defined($_) }
  35         => inline_as { "defined $_[0]" };
  36
  37     subtype 'Bool'
  38         => as 'Item'
  39         => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }
  40         => inline_as { qq{!defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0'} };
  41
  42     subtype 'Value'
  43         => as 'Defined'
  44         => where { !ref($_) }
  45         => optimize_as( \&_Value )
  46         => inline_as { "defined $_[0] && ! ref $_[0]" };
  47
  48     subtype 'Ref'
  49         => as 'Defined'
  50         => where { ref($_) }
  51         => optimize_as( \&_Ref )
  52         => inline_as { "ref $_[0]" };
  53
  54     subtype 'Str'
  55         => as 'Value'
  56         => where { ref(\$_) eq 'SCALAR' }
  57         => optimize_as( \&_Str )
  58         => inline_as {
  59             return (  qq{defined $_[0]}
  60                     . qq{&& (   ref(\\             $_[0] ) eq 'SCALAR'}
  61                     . qq{    || ref(\\(my \$value = $_[0])) 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 $_[0] && Scalar::Util::looks_like_number($_[0])" };
  69
  70     subtype 'Int'
  71         => as 'Num'
  72         => where { "$_" =~ /^-?[0-9]+$/ }
  73         => optimize_as( \&_Int )
  74         => inline_as {
  75             return (  qq{defined $_[0]}
  76                     . qq{&& ! ref $_[0]}
  77                     . qq{&& ( my \$value = $_[0] ) =~ /\\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 $_[0] eq 'CODE'} };
  85
  86     subtype 'RegexpRef'
  87         => as 'Ref'
  88         => where( \&_RegexpRef )
  89         => optimize_as( \&_RegexpRef )
  90         => inline_as { "Moose::Util::TypeConstraints::Builtins::_RegexpRef( $_[0] )" };
  91
  92     subtype 'GlobRef'
  93         => as 'Ref'
  94         => where { ref($_) eq 'GLOB' }
  95         => optimize_as( \&_GlobRef )
  96         => inline_as { qq{ref $_[0] 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 $_[0] eq 'GLOB'}
 108                     . qq{&& Scalar::Util::openhandle( $_[0] )}
 109                     . qq{or Scalar::Util::blessed( $_[0] ) && $_[0]->isa("IO::Handle")} );
 110         };
 111
 112     subtype 'Object'
 113         => as 'Ref'
 114         => where { blessed($_) }
 115         => optimize_as( \&_Object )
 116         => inline_as { "Scalar::Util::blessed( $_[0] )" };
 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( $_[0] )" };
 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( $_[0] )}
 138                     . qq{&& ( Class::MOP::class_of( $_[0] ) || 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 $_[0] eq 'SCALAR' || ref $_[0] eq 'REF'}},
 158             inline_generator => sub {
 159                 my $type_parameter = shift;
 160                 my $val            = shift;
 161                 return $type_parameter->_inline_check(
 162                     '${ (' . $val . ') }' );
 163             },
 164         )
 165     );
 166
 167     $registry->add_type_constraint(
 168         Moose::Meta::TypeConstraint::Parameterizable->new(
 169             name               => 'ArrayRef',
 170             package_defined_in => __PACKAGE__,
 171             parent =>
 172                 Moose::Util::TypeConstraints::find_type_constraint('Ref'),
 173             constraint => sub { ref($_) eq 'ARRAY' },
 174             optimized => \&_ArrayRef,
 175             constraint_generator => sub {
 176                 my $type_parameter = shift;
 177                 my $check = $type_parameter->_compiled_type_constraint;
 178                 return sub {
 179                     foreach my $x (@$_) {
 180                         ( $check->($x) ) || return;
 181                     }
 182                     1;
 183                     }
 184             },
 185             inlined          => sub {qq{ref $_[0] eq 'ARRAY'}},
 186             inline_generator => sub {
 187                 my $type_parameter = shift;
 188                 my $val            = shift;
 189                 return
 190                       '&List::MoreUtils::all( sub { '
 191                     . $type_parameter->_inline_check('$_')
 192                     . " }, \@{$val} )";
 193             },
 194         )
 195     );
 196
 197     $registry->add_type_constraint(
 198         Moose::Meta::TypeConstraint::Parameterizable->new(
 199             name               => 'HashRef',
 200             package_defined_in => __PACKAGE__,
 201             parent =>
 202                 Moose::Util::TypeConstraints::find_type_constraint('Ref'),
 203             constraint => sub { ref($_) eq 'HASH' },
 204             optimized => \&_HashRef,
 205             constraint_generator => sub {
 206                 my $type_parameter = shift;
 207                 my $check = $type_parameter->_compiled_type_constraint;
 208                 return sub {
 209                     foreach my $x ( values %$_ ) {
 210                         ( $check->($x) ) || return;
 211                     }
 212                     1;
 213                     }
 214             },
 215             inlined          => sub {qq{ref $_[0] eq 'HASH'}},
 216             inline_generator => sub {
 217                 my $type_parameter = shift;
 218                 my $val            = shift;
 219                 return
 220                       '&List::MoreUtils::all( sub { '
 221                     . $type_parameter->_inline_check('$_')
 222                     . " }, values \%{$val} )";
 223             },
 224         )
 225     );
 226
 227     $registry->add_type_constraint(
 228         Moose::Meta::TypeConstraint::Parameterizable->new(
 229             name               => 'Maybe',
 230             package_defined_in => __PACKAGE__,
 231             parent =>
 232                 Moose::Util::TypeConstraints::find_type_constraint('Item'),
 233             constraint           => sub {1},
 234             constraint_generator => sub {
 235                 my $type_parameter = shift;
 236                 my $check = $type_parameter->_compiled_type_constraint;
 237                 return sub {
 238                     return 1 if not( defined($_) ) || $check->($_);
 239                     return;
 240                     }
 241             },
 242             inlined          => sub {'1'},
 243             inline_generator => sub {
 244                 my $type_parameter = shift;
 245                 my $val            = shift;
 246                 return
 247                     "(! defined $val) || ("
 248                     . $type_parameter->_inline_check($val) . ')';
 249             },
 250         )
 251     );
 252 }
 253
 254 sub _Value { defined($_[0]) && !ref($_[0]) }
 255
 256 sub _Ref { ref($_[0]) }
 257
 258 # We might need to use a temporary here to flatten LVALUEs, for instance as in
 259 # Str(substr($_,0,255)).
 260 sub _Str {
 261     defined($_[0])
 262       && (   ref(\             $_[0] ) eq 'SCALAR'
 263           || ref(\(my $value = $_[0])) eq 'SCALAR')
 264 }
 265
 266 sub _Num { !ref($_[0]) && looks_like_number($_[0]) }
 267
 268 # using a temporary here because regex matching promotes an IV to a PV,
 269 # and that confuses some things (like JSON.pm)
 270 sub _Int {
 271     my $value = $_[0];
 272     defined($value) && !ref($value) && $value =~ /\A-?[0-9]+\z/
 273 }
 274
 275 sub _ScalarRef { ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' }
 276 sub _ArrayRef  { ref($_[0]) eq 'ARRAY'  }
 277 sub _HashRef   { ref($_[0]) eq 'HASH'   }
 278 sub _CodeRef   { ref($_[0]) eq 'CODE'   }
 279 sub _GlobRef   { ref($_[0]) eq 'GLOB'   }
 280
 281 # RegexpRef is implemented in Moose.xs
 282
 283 sub _FileHandle {
 284     ref( $_[0] ) eq 'GLOB' && Scalar::Util::openhandle( $_[0] )
 285         or blessed( $_[0] ) && $_[0]->isa("IO::Handle");
 286 }
 287
 288 sub _Object { blessed($_[0]) }
 289
 290 sub _Role {
 291     Moose::Deprecated::deprecated(
 292         feature => 'Role type',
 293         message =>
 294             'The Role type has been deprecated. Maybe you meant to create a RoleName type? This type be will be removed in Moose 2.0200.'
 295     );
 296     blessed( $_[0] ) && $_[0]->can('does');
 297 }
 298
 299 sub _ClassName {
 300     return Class::MOP::is_class_loaded( $_[0] );
 301 }
 302
 303 sub _RoleName {
 304     _ClassName( $_[0] )
 305         && ( Class::MOP::class_of( $_[0] ) || return )
 306         ->isa('Moose::Meta::Role');
 307 }
 308
 309 1;