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