lib/Moose/Util/TypeConstraints/Builtins.pm

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