mirror of
https://github.com/percona/percona-toolkit.git
synced 2025-09-10 21:19:59 +00:00
99 lines
3.1 KiB
Perl
99 lines
3.1 KiB
Perl
package Lmo::Types;
|
|
|
|
use strict;
|
|
use warnings qw( FATAL all );
|
|
|
|
use Carp ();
|
|
use Scalar::Util qw(looks_like_number blessed);
|
|
|
|
# Basic types for isa. If you want a new type, either add it here,
|
|
# or give isa a coderef.
|
|
|
|
our %TYPES = (
|
|
Bool => sub { !$_[0] || (defined $_[0] && looks_like_number($_[0]) && $_[0] == 1) },
|
|
Num => sub { defined $_[0] && looks_like_number($_[0]) },
|
|
Int => sub { defined $_[0] && looks_like_number($_[0]) && $_[0] == int($_[0]) },
|
|
Str => sub { defined $_[0] },
|
|
Object => sub { defined $_[0] && blessed($_[0]) },
|
|
FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened },
|
|
|
|
map {
|
|
my $type = /R/ ? $_ : uc $_;
|
|
$_ . "Ref" => sub { ref $_[0] eq $type }
|
|
} qw(Array Code Hash Regexp Glob Scalar)
|
|
);
|
|
|
|
sub check_type_constaints {
|
|
my ($attribute, $type_check, $check_name, $val) = @_;
|
|
( ref($type_check) eq 'CODE'
|
|
? $type_check->($val)
|
|
: (ref $val eq $type_check
|
|
|| ($val && $val eq $type_check)
|
|
|| (exists $TYPES{$type_check} && $TYPES{$type_check}->($val)))
|
|
)
|
|
|| Carp::confess(
|
|
qq<Attribute ($attribute) does not pass the type constraint because: >
|
|
. qq<Validation failed for '$check_name' with value >
|
|
. (defined $val ? Lmo::Dumper($val) : 'undef') )
|
|
}
|
|
|
|
# Nested (or parametized) constraints look like this: ArrayRef[CONSTRAINT] or
|
|
# Maybe[CONSTRAINT]. This function returns a coderef that implements one of
|
|
# these.
|
|
sub _nested_constraints {
|
|
my ($attribute, $aggregate_type, $type) = @_;
|
|
|
|
my $inner_types;
|
|
if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
|
|
# If the inner constraint -- the part within brackets -- is also a parametized
|
|
# constraint, then call this function recursively.
|
|
$inner_types = _nested_constraints($1, $2);
|
|
}
|
|
else {
|
|
# Otherwise, try checking if it's one of the built-in types.
|
|
$inner_types = $TYPES{$type};
|
|
}
|
|
|
|
if ( $aggregate_type eq 'ArrayRef' ) {
|
|
return sub {
|
|
my ($val) = @_;
|
|
return unless ref($val) eq ref([]);
|
|
|
|
if ($inner_types) {
|
|
for my $value ( @{$val} ) {
|
|
return unless $inner_types->($value)
|
|
}
|
|
}
|
|
else {
|
|
# $inner_types isn't set, we are dealing with a class name.
|
|
for my $value ( @{$val} ) {
|
|
return unless $value && ($value eq $type
|
|
|| (Scalar::Util::blessed($value) && $value->isa($type)));
|
|
}
|
|
}
|
|
return 1;
|
|
};
|
|
}
|
|
elsif ( $aggregate_type eq 'Maybe' ) {
|
|
return sub {
|
|
my ($value) = @_;
|
|
# For Maybe, undef is valid
|
|
return 1 if ! defined($value);
|
|
# Otherwise, defer to the inner type
|
|
if ($inner_types) {
|
|
return unless $inner_types->($value)
|
|
}
|
|
else {
|
|
return unless $value eq $type
|
|
|| (Scalar::Util::blessed($value) && $value->isa($type));
|
|
}
|
|
return 1;
|
|
}
|
|
}
|
|
else {
|
|
Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
|
|
}
|
|
}
|
|
|
|
1;
|