1# This program is copyright 2013 Percona Ireland Ltd. 2# Feedback and improvements are welcome. 3# 4# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 5# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 6# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 7# 8# This program is free software; you can redistribute it and/or modify it under 9# the terms of the GNU General Public License as published by the Free Software 10# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar 11# systems, you can issue `man perlgpl' or `man perlartistic' to read these 12# licenses. 13# 14# You should have received a copy of the GNU General Public License along with 15# this program; if not, write to the Free Software Foundation, Inc., 59 Temple 16# Place, Suite 330, Boston, MA 02111-1307 USA. 17# ########################################################################### 18# Lmo::Types package 19# ########################################################################### 20package Lmo::Types; 21 22use strict; 23use warnings qw( FATAL all ); 24 25use Carp (); 26use Scalar::Util qw(looks_like_number blessed); 27 28# Basic types for isa. If you want a new type, either add it here, 29# or give isa a coderef. 30 31our %TYPES = ( 32 Bool => sub { !$_[0] || (defined $_[0] && looks_like_number($_[0]) && $_[0] == 1) }, 33 Num => sub { defined $_[0] && looks_like_number($_[0]) }, 34 Int => sub { defined $_[0] && looks_like_number($_[0]) && $_[0] == int($_[0]) }, 35 Str => sub { defined $_[0] }, 36 Object => sub { defined $_[0] && blessed($_[0]) }, 37 FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, 38 39 map { 40 my $type = /R/ ? $_ : uc $_; 41 $_ . "Ref" => sub { ref $_[0] eq $type } 42 } qw(Array Code Hash Regexp Glob Scalar) 43); 44 45sub check_type_constaints { 46 my ($attribute, $type_check, $check_name, $val) = @_; 47 ( ref($type_check) eq 'CODE' 48 ? $type_check->($val) 49 : (ref $val eq $type_check 50 || ($val && $val eq $type_check) 51 || (exists $TYPES{$type_check} && $TYPES{$type_check}->($val))) 52 ) 53 || Carp::confess( 54 qq<Attribute ($attribute) does not pass the type constraint because: > 55 . qq<Validation failed for '$check_name' with value > 56 . (defined $val ? Lmo::Dumper($val) : 'undef') ) 57} 58 59# Nested (or parametized) constraints look like this: ArrayRef[CONSTRAINT] or 60# Maybe[CONSTRAINT]. This function returns a coderef that implements one of 61# these. 62sub _nested_constraints { 63 my ($attribute, $aggregate_type, $type) = @_; 64 65 my $inner_types; 66 if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { 67 # If the inner constraint -- the part within brackets -- is also a parametized 68 # constraint, then call this function recursively. 69 $inner_types = _nested_constraints($1, $2); 70 } 71 else { 72 # Otherwise, try checking if it's one of the built-in types. 73 $inner_types = $TYPES{$type}; 74 } 75 76 if ( $aggregate_type eq 'ArrayRef' ) { 77 return sub { 78 my ($val) = @_; 79 return unless ref($val) eq ref([]); 80 81 if ($inner_types) { 82 for my $value ( @{$val} ) { 83 return unless $inner_types->($value) 84 } 85 } 86 else { 87 # $inner_types isn't set, we are dealing with a class name. 88 for my $value ( @{$val} ) { 89 return unless $value && ($value eq $type 90 || (Scalar::Util::blessed($value) && $value->isa($type))); 91 } 92 } 93 return 1; 94 }; 95 } 96 elsif ( $aggregate_type eq 'Maybe' ) { 97 return sub { 98 my ($value) = @_; 99 # For Maybe, undef is valid 100 return 1 if ! defined($value); 101 # Otherwise, defer to the inner type 102 if ($inner_types) { 103 return unless $inner_types->($value) 104 } 105 else { 106 return unless $value eq $type 107 || (Scalar::Util::blessed($value) && $value->isa($type)); 108 } 109 return 1; 110 } 111 } 112 else { 113 Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); 114 } 115} 116 1171; 118# ########################################################################### 119# End Lmo::Types package 120# ########################################################################### 121