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