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