lib/SQL/Translator/Types.pm

   1 package SQL::Translator::Types;
   2
   3 =head1 NAME
   4
   5 SQL::Translator::Types - Type checking functions
   6
   7 =head1 SYNOPSIS
   8
   9     package Foo;
  10     use Moo;
  11     use SQL::Translator::Types qw(schema_obj enum);
  12
  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,
  16     });
  17
  18 =head1 DESCRIPTIONS
  19
  20 This module exports functions that return coderefs suitable for L<Moo>
  21 C<isa> type checks.
  22 Errors are reported using L<SQL::Translator::Utils/throw>.
  23
  24 =cut
  25
  26 use strictures 1;
  27
  28 use SQL::Translator::Utils qw(throw);
  29 use Scalar::Util qw(blessed);
  30
  31 use Exporter qw(import);
  32 our @EXPORT_OK = qw(schema_obj enum);
  33
  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
  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
  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
 105 1;