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.23;
# 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 { defined $_[0] and Scalar::Util::looks_like_number($_[0]) },
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') },
},
{
name => 'AHRef',
test => sub {
defined $_[0] and
(ref($_[0]) eq 'ARRAY')
and ($_[0]->[0])
and (List::Util::first { ref($_) eq 'HASH' } @{ $_[0] });
},
message => sub { return exception_message($_[0], 'an ArrayRef[HashRef]') },
inflate => 0,
},
);
}
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 $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 $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 $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 $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 $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 $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__
=head1 NAME
MooX::Types::MooseLike::Base - Moose like types for Moo
=head1 SYNOPSIS
package MyPackage;
use Moo;
use MooX::Types::MooseLike::Base qw(:all);
has "beers_by_day_of_week" => (
isa => HashRef
);
has "current_BAC" => (
isa => Num
);
# Also supporting is_$type. For example, is_Int() can be used as follows
has 'legal_age' => (
is => 'ro',
isa => sub { die "$_[0] is not of legal age"
unless (is_Int($_[0]) && $_[0] > 17) },
);
=head1 DESCRIPTION
Moo attributes (like Moose) have an 'isa' property.
This module provides some basic types for this property.
One can import all types with ':all' tag or import
a list of types like:
use MooX::Types::MooseLike::Base qw/HashRef CodeRef/;
so one could then declare some attributtes like:
has 'contact' => (
is => 'ro',
isa => HashRef,
);
has 'guest_list' => (
is => 'ro',
isa => ArrayRef,
);
has 'records' => (
is => 'ro',
isa => ArrayRef[Int],
);
These types provide a check that the contact attribute is a hash reference,
that the guest_list is an array reference, and that the records are an array
of hash references.
=head1 TYPES (1st class functions - return a coderef)
=head2 Any
Any type (test is always true)
=head2 Item
Synonymous with Any type
=head2 Undef
A type that is not defined
=head2 Defined
A type that is defined
=head2 Bool
A boolean 1|0 type
=head2 Value
A non-reference type
=head2 Ref
A reference type
=head2 Str
A non-reference type where a reference to it is a SCALAR
=head2 Num
A number type
=head2 Int
An integer type
=head2 ArrayRef
An ArrayRef (ARRAY) type
=head2 HashRef
A HashRef (HASH) type
=head2 CodeRef
A CodeRef (CODE) type
=head2 RegexpRef
A regular expression reference type
=head2 GlobRef
A glob reference type
=head2 FileHandle
A type that is either a builtin perl filehandle or an IO::Handle object
=head2 Object
A type that is an object (think blessed)
=head1 PARAMETERIZED TYPES
=head2 Parameterizing Types With a Single Type
The following types can be parameterized with other types.
=head3 ArrayRef
For example, ArrayRef[HashRef]
=head3 HashRef
=head3 ScalarRef
=head3 Maybe
For example, Maybe[Int] would be an integer or undef
=head2 Parameterizing Types With Multiple Types
=head3 AnyOf
Check if the attribute is any of the listed types (think union)
Takes a list of types as the argument. For example:
isa => AnyOf[Int, ArrayRef[Int], HashRef[Int]]
Note: AnyOf is passed an ArrayRef[CodeRef]
=head3 AllOf
Check if the attribute is all of the listed types (think intersection)
Takes a list of types as the argument. For example:
isa => AllOf[
InstanceOf['Human'],
ConsumerOf['Air'],
HasMethods['breath', 'dance']
],
=head2 Parameterizing Types With (Multiple) Strings
In addition, we have some parameterized types that take string arguments.
=head3 InstanceOf
Check if the attribute is an object instance of one or more classes.
Uses C<blessed> and C<isa> to do so.
Takes a list of class names as the argument. For example:
isa => InstanceOf['MyClass','MyOtherClass']
Note: InstanceOf is passed an ArrayRef[Str]
=head3 ConsumerOf
Check if the attribute is blessed and consumes one or more roles.
Uses C<blessed> and C<does> to do so.
Takes a list of role names as the arguments. For example:
isa => ConsumerOf['My::Role', 'My::AnotherRole']
=head3 HasMethods
Check if the attribute is blessed and has one or more methods.
Uses C<blessed> and C<can> to do so.
Takes a list of method names as the arguments. For example:
isa => HasMethods[qw/postulate contemplate liberate/]
=head3 Enum
Check if the attribute is one of the enumerated strings.
Takes a list of possible string values. For example:
isa => Enum['rock', 'spock', 'paper', 'lizard', 'scissors']
=head1 AUTHOR
Mateu Hunter C<hunter@missoula.org>
=head1 THANKS
mst has provided critical guidance on the design
=head1 COPYRIGHT
Copyright 2011-2013 Mateu Hunter
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut