Commit | Line | Data |
45287c81 |
1 | package SQL::Translator::Types; |
4e43db0d |
2 | |
3 | =head1 NAME |
4 | |
5 | SQL::Translator::Types - Type checking functions |
6 | |
7 | =head1 SYNOPSIS |
8 | |
9 | package Foo; |
10 | use Moo; |
4c3f67fa |
11 | use SQL::Translator::Types qw(schema_obj enum); |
4e43db0d |
12 | |
13 | has foo => ( is => 'rw', isa => schema_obj('Trigger') ); |
4c3f67fa |
14 | has bar => ( is => 'rw', isa => enum([q(baz quux quuz)], { |
15 | msg => "Invalid value for bar: '%s'", icase => 1, |
16 | }); |
4e43db0d |
17 | |
18 | =head1 DESCRIPTIONS |
19 | |
92638f32 |
20 | This module exports functions that return coderefs suitable for L<Moo> |
4e43db0d |
21 | C<isa> type checks. |
22 | Errors are reported using L<SQL::Translator::Utils/throw>. |
23 | |
24 | =cut |
25 | |
45287c81 |
26 | use strictures 1; |
27 | |
28 | use SQL::Translator::Utils qw(throw); |
29 | use Scalar::Util qw(blessed); |
30 | |
31 | use Exporter qw(import); |
4c3f67fa |
32 | our @EXPORT_OK = qw(schema_obj enum); |
45287c81 |
33 | |
4e43db0d |
34 | =head1 FUNCTIONS |
35 | |
36 | =head2 schema_obj($type) |
37 | |
38 | Returns a coderef that checks that its arguments is an object of the |
39 | class C<< SQL::Translator::Schema::I<$type> >>. |
40 | |
41 | =cut |
42 | |
45287c81 |
43 | sub schema_obj { |
44 | my ($class) = @_; |
45 | my $name = lc $class; |
46 | $class = 'SQL::Translator::Schema' . ($class eq 'Schema' ? '' : "::$class"); |
47 | return sub { |
48 | throw("Not a $name object") |
49 | unless blessed($_[0]) and $_[0]->isa($class); |
50 | }; |
51 | } |
52 | |
4c3f67fa |
53 | =head2 enum(\@strings, [$msg | \%parameters]) |
54 | |
55 | Returns a coderef that checks that the argument is one of the provided |
56 | C<@strings>. |
57 | |
58 | =head3 Parameters |
59 | |
60 | =over |
61 | |
62 | =item msg |
63 | |
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'>. |
69 | |
70 | =item icase |
71 | |
72 | If true, folds the values to lower case before checking for equality. |
73 | |
74 | =item allow_undef |
75 | |
76 | If true, allow C<undef> in addition to the specified strings. |
77 | |
78 | =item allow_false |
79 | |
80 | If true, allow any false value in addition to the specified strings. |
81 | |
82 | =back |
83 | |
84 | =cut |
85 | |
86 | sub enum { |
87 | my ($values, $args) = @_; |
88 | $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'"; |
93 | my $extra_test = |
94 | $args->{allow_undef} ? sub { defined $_[0] } : |
95 | $args->{allow_false} ? sub { !!$_[0] } : undef; |
96 | |
97 | return sub { |
98 | my $val = $icase ? lc $_[0] : $_[0]; |
99 | throw(sprintf($msg, $val)) |
100 | if (!defined($extra_test) || $extra_test->($val)) |
101 | && !exists $values{$val}; |
102 | }; |
103 | } |
104 | |
45287c81 |
105 | 1; |