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