X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FTypes.pm;h=754ca60c3f6be668fcc7a1ccb7cb8e60e12606ce;hb=99fa843eca73931cb10225f08d24190ae9a2fc87;hp=02a5b8afaa112ea0bb05e6a76012cb2217d1215a;hpb=45287c815973a11dea92e12cbefeca656fffa912;p=dbsrgits%2FSQL-Translator.git

diff --git a/lib/SQL/Translator/Types.pm b/lib/SQL/Translator/Types.pm
index 02a5b8a..754ca60 100644
--- a/lib/SQL/Translator/Types.pm
+++ b/lib/SQL/Translator/Types.pm
@@ -1,11 +1,45 @@
 package SQL::Translator::Types;
-use strictures 1;
+
+use warnings;
+use strict;
+
+=head1 NAME
+
+SQL::Translator::Types - Type checking functions
+
+=head1 SYNOPSIS
+
+    package Foo;
+    use Moo;
+    use SQL::Translator::Types qw(schema_obj enum);
+
+    has foo => ( is => 'rw', isa => schema_obj('Trigger') );
+    has bar => ( is => 'rw', isa => enum([qw(baz quux quuz)], {
+        msg => "Invalid value for bar: '%s'", icase => 1,
+    });
+
+=head1 DESCRIPTIONS
+
+This module exports functions that return coderefs suitable for L<Moo>
+C<isa> type checks.
+Errors are reported using L<SQL::Translator::Utils/throw>.
+
+=cut
 
 use SQL::Translator::Utils qw(throw);
 use Scalar::Util qw(blessed);
 
 use Exporter qw(import);
-our @EXPORT_OK = qw(schema_obj);
+our @EXPORT_OK = qw(schema_obj enum);
+
+=head1 FUNCTIONS
+
+=head2 schema_obj($type)
+
+Returns a coderef that checks that its arguments is an object of the
+class C<< SQL::Translator::Schema::I<$type> >>.
+
+=cut
 
 sub schema_obj {
     my ($class) = @_;
@@ -17,4 +51,56 @@ sub schema_obj {
     };
 }
 
+=head2 enum(\@strings, [$msg | \%parameters])
+
+Returns a coderef that checks that the argument is one of the provided
+C<@strings>.
+
+=head3 Parameters
+
+=over
+
+=item msg
+
+L<sprintf|perlfunc/sprintf> string for the error message.
+If no other parameters are needed, this can be provided on its own,
+instead of the C<%parameters> hashref.
+The invalid value is passed as the only argument.
+Defaults to C<Invalid value: '%s'>.
+
+=item icase
+
+If true, folds the values to lower case before checking for equality.
+
+=item allow_undef
+
+If true, allow C<undef> in addition to the specified strings.
+
+=item allow_false
+
+If true, allow any false value in addition to the specified strings.
+
+=back
+
+=cut
+
+sub enum {
+    my ($values, $args) = @_;
+    $args ||= {};
+    $args = { msg => $args } unless ref($args) eq 'HASH';
+    my $icase = !!$args->{icase};
+    my %values = map { ($icase ? lc : $_) => undef } @{$values};
+    my $msg = $args->{msg} || "Invalid value: '%s'";
+    my $extra_test =
+        $args->{allow_undef} ? sub { defined $_[0] } :
+        $args->{allow_false} ? sub { !!$_[0] } : undef;
+
+    return sub {
+        my $val = $icase ? lc $_[0] : $_[0];
+        throw(sprintf($msg, $val))
+            if (!defined($extra_test) || $extra_test->($val))
+                && !exists $values{$val};
+    };
+}
+
 1;