1 package SQL::Translator::Types;
5 SQL::Translator::Types - Type checking functions
11 use SQL::Translator::Types qw(schema_obj enum);
13 has foo => ( is => 'rw', isa => schema_obj('Trigger') );
14 has bar => ( is => 'rw', isa => enum([qw(baz quux quuz)], {
15 msg => "Invalid value for bar: '%s'", icase => 1,
20 This module exports functions that return coderefs suitable for L<Moo>
22 Errors are reported using L<SQL::Translator::Utils/throw>.
28 use SQL::Translator::Utils qw(throw);
29 use Scalar::Util qw(blessed);
31 use Exporter qw(import);
32 our @EXPORT_OK = qw(schema_obj enum);
36 =head2 schema_obj($type)
38 Returns a coderef that checks that its arguments is an object of the
39 class C<< SQL::Translator::Schema::I<$type> >>.
46 $class = 'SQL::Translator::Schema' . ($class eq 'Schema' ? '' : "::$class");
48 throw("Not a $name object")
49 unless blessed($_[0]) and $_[0]->isa($class);
53 =head2 enum(\@strings, [$msg | \%parameters])
55 Returns a coderef that checks that the argument is one of the provided
64 L<sprintf|perlfunc/sprintf> string for the error message.
65 If no other parameters are needed, this can be provided on its own,
66 instead of the C<%parameters> hashref.
67 The invalid value is passed as the only argument.
68 Defaults to C<Invalid value: '%s'>.
72 If true, folds the values to lower case before checking for equality.
76 If true, allow C<undef> in addition to the specified strings.
80 If true, allow any false value in addition to the specified strings.
87 my ($values, $args) = @_;
89 $args = { msg => $args } unless ref($args) eq 'HASH';
90 my $icase = !!$args->{icase};
91 my %values = map { ($icase ? lc : $_) => undef } @{$values};
92 my $msg = $args->{msg} || "Invalid value: '%s'";
94 $args->{allow_undef} ? sub { defined $_[0] } :
95 $args->{allow_false} ? sub { !!$_[0] } : undef;
98 my $val = $icase ? lc $_[0] : $_[0];
99 throw(sprintf($msg, $val))
100 if (!defined($extra_test) || $extra_test->($val))
101 && !exists $values{$val};