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