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