File Coverage

blib/lib/MooX/Types/MooseLike/Base.pm

Criterion	Covered	Total	%
statement	129	186	69.3
branch	71	112	63.3
condition	15	18	83.3
subroutine	61	76	80.2
pod	0	7	0.0
total	276	399	69.1

package MooX::Types::MooseLike::Base;
use strict;
use warnings FATAL => 'all';
use Scalar::Util qw(blessed);
use List::Util;
use MooX::Types::MooseLike qw( exception_message inflate_type );
use Exporter 5.57 'import';
our @EXPORT_OK = ();

our $VERSION = 0.29;

# These types act like those found in Moose::Util::TypeConstraints.
# Generally speaking, the same test is used.
sub some_basic_type_definitions {
  return
    (
    {
      name => 'Any',
      test => sub { 1 },
      message =>
        sub { "If you get here you've achieved the impossible, congrats." }
    },
    {
      name => 'Item',
      test => sub { 1 },
      message =>
        sub { "If you get here you've achieved the impossible, congrats" }
    },
    {
      name => 'Bool',

      #  	test    => sub { $_[0] == 0 || $_[0] == 1 },
      test => sub {
        !defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0';
        },
      message => sub { return exception_message($_[0], 'a Boolean') },
    },

    # Maybe has no test for itself, rather only the parameter type does
    {
      name    => 'Maybe',
      test    => sub { 1 },
      message => sub { 'Maybe only uses its parameterized type message' },
      parameterizable => sub { return if (not defined $_[0]); $_[0] },
    },
    {
      name    => 'Undef',
      test    => sub { !defined($_[0]) },
      message => sub { return exception_message($_[0], 'undef') },
    },
    );
}

sub defined_type_definitions {
  return
    ({
      name    => 'Defined',
      test    => sub { defined($_[0]) },
      message => sub { return exception_message($_[0], 'defined') },
    },
    {
      name    => 'Value',
      test    => sub { defined $_[0] and not ref($_[0]) },
      message => sub { return exception_message($_[0], 'a value') },
    },
    {
      name => 'Str',
      test => sub { defined $_[0] and (ref(\$_[0]) eq 'SCALAR') },
      message => sub { return exception_message($_[0], 'a string') },
    },
    {
      name    => 'Num',
      test    => sub {
          my $val = $_[0];
          defined $val and
        ($val =~ /\A[+-]?[0-9]+\z/) ||
        ( $val =~ /\A(?:[+-]?)            # matches optional +- in the beginning
          (?=[0-9]|\.[0-9])               # matches previous +- only if there is something like 3 or .3
          [0-9]*                          # matches 0-9 zero or more times
          (?:\.[0-9]+)?                   # matches optional .89 or nothing
          (?:[Ee](?:[+-]?[0-9]+))?        # matches E1 or e1 or e-1 or e+1 etc
          \z/x );
      },
      message => sub {
        my $nbr = shift;
        if (not defined $nbr) {
          $nbr = 'undef';
        }
        elsif (not (length $nbr)) {
          $nbr = 'The empty string';
        }
        return exception_message($nbr, 'a number');
        },
    },
    {
      name    => 'Int',
      test    => sub { defined $_[0] and ("$_[0]" =~ /^-?[0-9]+$/x) },
      message => sub {
        my $nbr = shift;
        if (not defined $nbr) {
          $nbr = 'undef';
        }
        elsif (not (length $nbr)) {
          $nbr = 'The empty string';
        }
        return exception_message($nbr, 'an integer');
        },
    },
    );
}

sub ref_type_definitions {
  return
    (
    {
      name    => 'Ref',
      test    => sub { defined $_[0] and ref($_[0]) },
      message => sub { return exception_message($_[0], 'a reference') },
    },

    {
      name => 'ScalarRef',
      test => sub { defined $_[0] and ref($_[0]) eq 'SCALAR' },
      message => sub { return exception_message($_[0], 'a ScalarRef') },
      parameterizable => sub { ${ $_[0] } },
      inflate => sub {
        require Moose::Util::TypeConstraints;
        if (my $params = shift) {
          return Moose::Util::TypeConstraints::_create_parameterized_type_constraint(
            Moose::Util::TypeConstraints::find_type_constraint('ScalarRef'),
            inflate_type(@$params),
          );
        }
        return Moose::Util::TypeConstraints::find_type_constraint('ScalarRef');
        },
    },
    {
      name => 'ArrayRef',
      test => sub { defined $_[0] and ref($_[0]) eq 'ARRAY' },
      message => sub { return exception_message($_[0], 'an ArrayRef') },
      parameterizable => sub { @{ $_[0] } },
      inflate => sub {
        require Moose::Util::TypeConstraints;
        if (my $params = shift) {
          return Moose::Util::TypeConstraints::_create_parameterized_type_constraint(
            Moose::Util::TypeConstraints::find_type_constraint('ArrayRef'),
            inflate_type(@$params),
          );
        }
        return Moose::Util::TypeConstraints::find_type_constraint('ArrayRef');
        },
    },
    {
      name => 'HashRef',
      test => sub { defined $_[0] and ref($_[0]) eq 'HASH' },
      message => sub { return exception_message($_[0], 'a HashRef') },
      parameterizable => sub { values %{ $_[0] } },
      inflate => sub {
        require Moose::Util::TypeConstraints;
        if (my $params = shift) {
          return Moose::Util::TypeConstraints::_create_parameterized_type_constraint(
            Moose::Util::TypeConstraints::find_type_constraint('HashRef'),
            inflate_type(@$params),
          );
        }
        return Moose::Util::TypeConstraints::find_type_constraint('HashRef');
        },
    },
    {
      name => 'CodeRef',
      test => sub { defined $_[0] and ref($_[0]) eq 'CODE' },
      message => sub { return exception_message($_[0], 'a CodeRef') },
    },
    {
      name => 'RegexpRef',
      test => sub { defined $_[0] and ref($_[0]) eq 'Regexp' },
      message => sub { return exception_message($_[0], 'a RegexpRef') },
    },
    {
      name => 'GlobRef',
      test => sub { defined $_[0] and ref($_[0]) eq 'GLOB' },
      message => sub { return exception_message($_[0], 'a GlobRef') },
    },
    );
}

sub filehandle_type_definitions {
  return
    (
    {
      name => 'FileHandle',
      test => sub {
        defined $_[0]
          and Scalar::Util::openhandle($_[0])
          or (blessed($_[0]) && $_[0]->isa("IO::Handle"));
        },
      message => sub { return exception_message($_[0], 'a FileHandle') },
    },
    );
}

sub blessed_type_definitions {## no critic qw(Subroutines::ProhibitExcessComplexity)
  return
    (
    {
      name => 'Object',
      test => sub { defined $_[0] and blessed($_[0]) and blessed($_[0]) ne 'Regexp' },
      message => sub { return exception_message($_[0], 'an Object') },
    },
    {
      name => 'InstanceOf',
      test => sub {
        my ($instance, @classes) = (shift, @_);
        return if not defined $instance;
        return if not blessed($instance);
        my @missing_classes = grep { !$instance->isa($_) } @classes;
        return (scalar @missing_classes ? 0 : 1);
        },
      message => sub {
        my $instance = shift;
        return "No instance given" if not defined $instance;
        return "$instance is not blessed" if not blessed($instance);
        my @missing_classes = grep { !$instance->isa($_) } @_;
        my $s = (scalar @missing_classes) > 1 ? 'es' : '';
        my $missing_classes = join ' ', @missing_classes;
        return "$instance is not an instance of the class${s}: $missing_classes";
        },
      inflate => sub {
        require Moose::Meta::TypeConstraint::Class;
        if (my $classes = shift) {
          if (@$classes == 1) {
            return Moose::Meta::TypeConstraint::Class->new(class => @$classes);
          }
          elsif (@$classes > 1) {
            return Moose::Meta::TypeConstraint->new(
              parent     => Moose::Util::TypeConstraints::find_type_constraint('Object'),
              constraint => sub {
                  my $instance = shift;
                  my @missing_classes = grep { !$instance->isa($_) } @$classes;
                  return (scalar @missing_classes ? 0 : 1);
                },
            );
          }
        }
        return Moose::Util::TypeConstraints::find_type_constraint('Object');
      },
    },
    {
      name => 'ConsumerOf',
      test => sub {
        my ($instance, @roles) = (shift, @_);
        return if not defined $instance;
        return if not blessed($instance);
        return if (!$instance->can('does'));
        my @missing_roles = grep { !$instance->does($_) } @roles;
        return (scalar @missing_roles ? 0 : 1);
        },
      message => sub {
        my $instance = shift;
        return "No instance given" if not defined $instance;
        return "$instance is not blessed" if not blessed($instance);
        return "$instance is not a consumer of roles" if (!$instance->can('does'));
        my @missing_roles = grep { !$instance->does($_) } @_;
        my $s = (scalar @missing_roles) > 1 ? 's' : '';
        my $missing_roles = join ' ', @missing_roles;
        return "$instance does not consume the required role${s}: $missing_roles";
        },
      inflate => sub {
        require Moose::Meta::TypeConstraint::Role;
        if (my $roles = shift) {
          if (@$roles == 1) {
            return Moose::Meta::TypeConstraint::Role->new(role => @$roles);
          }
          elsif (@$roles > 1) {
            return Moose::Meta::TypeConstraint->new(
              parent     => Moose::Util::TypeConstraints::find_type_constraint('Object'),
              constraint => sub {
                  my $instance = shift;
                  return if (!$instance->can('does'));
                  my @missing_roles = grep { !$instance->does($_) } @$roles;
                  return (scalar @missing_roles ? 0 : 1);
                },
            );
          }
        }
        return Moose::Util::TypeConstraints::find_type_constraint('Object');
      },
    },
    {
      name => 'HasMethods',
      test => sub {
        my ($instance, @methods) = (shift, @_);
        return if not defined $instance;
        return if not blessed($instance);
        my @missing_methods = grep { !$instance->can($_) } @methods;
        return (scalar @missing_methods ? 0 : 1);
        },
      message => sub {
        my $instance = shift;
        return "No instance given" if not defined $instance;
        return "$instance is not blessed" if not blessed($instance);
        my @missing_methods = grep { !$instance->can($_) } @_;
        my $s = (scalar @missing_methods) > 1 ? 's' : '';
        my $missing_methods = join ' ', @missing_methods;
        return "$instance does not have the required method${s}: $missing_methods";
        },
      inflate => sub {
        require Moose::Meta::TypeConstraint::DuckType;
        if (my $methods = shift) {
          return Moose::Meta::TypeConstraint::DuckType->new(methods => $methods);
        }
        return Moose::Util::TypeConstraints::find_type_constraint('Object');
      },
    },
    {
      name => 'Enum',
      test => sub {
        my ($value, @possible_values) = @_;
        return if not defined $value;
        return List::Util::first { $value eq $_ } @possible_values;
        },
      message => sub {
        my ($value, @possible_values) = @_;
        my $possible_values = join(', ', @possible_values);
        return exception_message($value, "any of the possible values: ${possible_values}");
      },
      inflate => sub {
        require Moose::Meta::TypeConstraint::Enum;
        if (my $possible_values = shift) {
          return Moose::Meta::TypeConstraint::Enum->new(values => $possible_values);
        }
        die "Enum cannot be inflated to a Moose type without any possible values";
      },
    },
    );
}

sub logic_type_definitions {
  return
    (
    {
      name => 'AnyOf',
      test => sub {
        my ($value, @types) = @_;
        foreach my $type (@types) {
          return 1 if (eval {$type->($value); 1;});
        }
        return;
        },
      message => sub { return exception_message($_[0], 'any of the types') },
      inflate => sub {
        require Moose::Meta::TypeConstraint::Union;
        if (my $types = shift) {
          return Moose::Meta::TypeConstraint::Union->new(
            type_constraints => [ map inflate_type($_), @$types ],
          );
        }
        die "AnyOf cannot be inflated to a Moose type without any possible types";
        },
    },
    {
      name => 'AllOf',
      test => sub { return 1; },
      message => sub { 'AllOf only uses its parameterized type messages' },
      parameterizable => sub { $_[0] },
      inflate => 0,
    },
    );
}

sub type_definitions {
  return
    [
    some_basic_type_definitions()
    ,defined_type_definitions()
    ,ref_type_definitions()
    ,filehandle_type_definitions()
    ,blessed_type_definitions()
    ,logic_type_definitions()
    ];
}

MooX::Types::MooseLike::register_types(type_definitions(), __PACKAGE__);

# Export an 'all' tag so one can easily import all types like so:
# use MooX::Types::MooseLike::Base qw(:all)
our %EXPORT_TAGS = ('all' => \@EXPORT_OK);

1;

__END__