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 {
  41             '!defined(' . $_[1] . ') '
  42               . '|| ' . $_[1] . ' eq "" '
  43               . '|| "' . $_[1] . '" eq "1" '
  44               . '|| "' . $_[1] . '" eq "0"'
  45         };
  46
  47     subtype 'Value'
  48         => as 'Defined'
  49         => where { !ref($_) }
  50         => inline_as { 'defined(' . $_[1] . ') && !ref(' . $_[1] . ')' };
  51
  52     subtype 'Ref'
  53         => as 'Defined'
  54         => where { ref($_) }
  55         => inline_as { 'ref(' . $_[1] . ')' };
  56
  57     subtype 'Str'
  58         => as 'Value'
  59         => where { ref(\$_) eq 'SCALAR' || ref(\(my $val = $_)) eq 'SCALAR' }
  60         => inline_as {
  61             'defined(' . $_[1] . ') '
  62               . '&& (ref(\\' . $_[1] . ') eq "SCALAR"'
  63               . '|| ref(\\(my $val = ' . $_[1] . ')) eq "SCALAR" )'
  64         };
  65
  66     subtype 'Num'
  67         => as 'Str'
  68         => where { Scalar::Util::looks_like_number($_) }
  69         => inline_as {
  70             '!ref(' . $_[1] . ') '
  71               . '&& Scalar::Util::looks_like_number(' . $_[1] . ')'
  72         };
  73
  74     subtype 'Int'
  75         => as 'Num'
  76         => where { (my $val = $_) =~ /\A-?[0-9]+\z/ }
  77         => inline_as {
  78             'defined(' . $_[1] . ') '
  79               . '&& !ref(' . $_[1] . ') '
  80               . '&& (my $val = ' . $_[1] . ') =~ /\A-?[0-9]+\z/'
  81         };
  82
  83     subtype 'CodeRef'
  84         => as 'Ref'
  85         => where { ref($_) eq 'CODE' }
  86         => inline_as { 'ref(' . $_[1] . ') eq "CODE"' };
  87
  88     subtype 'RegexpRef'
  89         => as 'Ref'
  90         => where( \&_RegexpRef )
  91         => inline_as {
  92             'Moose::Util::TypeConstraints::Builtins::_RegexpRef(' . $_[1] . ')'
  93         };
  94
  95     subtype 'GlobRef'
  96         => as 'Ref'
  97         => where { ref($_) eq 'GLOB' }
  98         => inline_as { 'ref(' . $_[1] . ') eq "GLOB"' };
  99
 100     # NOTE: scalar filehandles are GLOB refs, but a GLOB ref is not always a
 101     # filehandle
 102     subtype 'FileHandle'
 103         => as 'Ref'
 104         => where {
 105             (ref($_) eq "GLOB" && Scalar::Util::openhandle($_))
 106          || (blessed($_) && $_->isa("IO::Handle"));
 107         }
 108         => inline_as {
 109             '(ref(' . $_[1] . ') eq "GLOB" '
 110               . '&& Scalar::Util::openhandle(' . $_[1] . ')) '
 111        . '|| (Scalar::Util::blessed(' . $_[1] . ') '
 112               . '&& ' . $_[1] . '->isa("IO::Handle"))'
 113         };
 114
 115     subtype 'Object'
 116         => as 'Ref'
 117         => where { blessed($_) }
 118         => inline_as { 'Scalar::Util::blessed(' . $_[1] . ')' };
 119
 120     # This type is deprecated.
 121     subtype 'Role'
 122         => as 'Object'
 123         => where { $_->can('does') };
 124
 125     subtype 'ClassName'
 126         => as 'Str'
 127         => where { Class::MOP::is_class_loaded($_) }
 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         => inline_as {
 136             'Class::MOP::is_class_loaded(' . $_[1] . ') '
 137               . '&& do {'
 138                   . 'my $meta = Class::MOP::class_of(' . $_[1] . ');'
 139                   . '$meta && $meta->isa("Moose::Meta::Role");'
 140               . '}'
 141         };
 142
 143     $registry->add_type_constraint(
 144         Moose::Meta::TypeConstraint::Parameterizable->new(
 145             name               => 'ScalarRef',
 146             package_defined_in => __PACKAGE__,
 147             parent =>
 148                 Moose::Util::TypeConstraints::find_type_constraint('Ref'),
 149             constraint => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' },
 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 {
 158                 'ref(' . $_[1] . ') eq "SCALAR" '
 159                   . '|| ref(' . $_[1] . ') eq "REF"'
 160             },
 161             inline_generator => sub {
 162                 my $self           = shift;
 163                 my $type_parameter = shift;
 164                 my $val            = shift;
 165                 '(ref(' . $val . ') eq "SCALAR" || ref(' . $val . ') eq "REF") '
 166                   . '&& ' . $type_parameter->_inline_check('${(' . $val . ')}')
 167             },
 168         )
 169     );
 170
 171     $registry->add_type_constraint(
 172         Moose::Meta::TypeConstraint::Parameterizable->new(
 173             name               => 'ArrayRef',
 174             package_defined_in => __PACKAGE__,
 175             parent =>
 176                 Moose::Util::TypeConstraints::find_type_constraint('Ref'),
 177             constraint => sub { ref($_) eq 'ARRAY' },
 178             constraint_generator => sub {
 179                 my $type_parameter = shift;
 180                 my $check = $type_parameter->_compiled_type_constraint;
 181                 return sub {
 182                     foreach my $x (@$_) {
 183                         ( $check->($x) ) || return;
 184                     }
 185                     1;
 186                     }
 187             },
 188             inlined          => sub { 'ref(' . $_[1] . ') eq "ARRAY"' },
 189             inline_generator => sub {
 190                 my $self           = shift;
 191                 my $type_parameter = shift;
 192                 my $val            = shift;
 193
 194                 'do {'
 195                     . 'my $check = ' . $val . ';'
 196                     . 'ref($check) eq "ARRAY" '
 197                         . '&& &List::MoreUtils::all('
 198                             . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, '
 199                             . '@{$check}'
 200                         . ')'
 201                 . '}';
 202             },
 203         )
 204     );
 205
 206     $registry->add_type_constraint(
 207         Moose::Meta::TypeConstraint::Parameterizable->new(
 208             name               => 'HashRef',
 209             package_defined_in => __PACKAGE__,
 210             parent =>
 211                 Moose::Util::TypeConstraints::find_type_constraint('Ref'),
 212             constraint => sub { ref($_) eq 'HASH' },
 213             constraint_generator => sub {
 214                 my $type_parameter = shift;
 215                 my $check = $type_parameter->_compiled_type_constraint;
 216                 return sub {
 217                     foreach my $x ( values %$_ ) {
 218                         ( $check->($x) ) || return;
 219                     }
 220                     1;
 221                     }
 222             },
 223             inlined          => sub { 'ref(' . $_[1] . ') eq "HASH"' },
 224             inline_generator => sub {
 225                 my $self           = shift;
 226                 my $type_parameter = shift;
 227                 my $val            = shift;
 228
 229                 'do {'
 230                     . 'my $check = ' . $val . ';'
 231                     . 'ref($check) eq "HASH" '
 232                         . '&& &List::MoreUtils::all('
 233                             . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, '
 234                             . 'values %{$check}'
 235                         . ')'
 236                 . '}';
 237             },
 238         )
 239     );
 240
 241     $registry->add_type_constraint(
 242         Moose::Meta::TypeConstraint::Parameterizable->new(
 243             name               => 'Maybe',
 244             package_defined_in => __PACKAGE__,
 245             parent =>
 246                 Moose::Util::TypeConstraints::find_type_constraint('Item'),
 247             constraint           => sub {1},
 248             constraint_generator => sub {
 249                 my $type_parameter = shift;
 250                 my $check = $type_parameter->_compiled_type_constraint;
 251                 return sub {
 252                     return 1 if not( defined($_) ) || $check->($_);
 253                     return;
 254                     }
 255             },
 256             inlined          => sub {'1'},
 257             inline_generator => sub {
 258                 my $self           = shift;
 259                 my $type_parameter = shift;
 260                 my $val            = shift;
 261                 '!defined(' . $val . ') '
 262                   . '|| (' . $type_parameter->_inline_check($val) . ')'
 263             },
 264         )
 265     );
 266 }
 267
 268 1;
 269
 270 __END__
 271
 272 =pod
 273
 274 =for pod_coverage_needs_some_pod
 275
 276 =cut
 277