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