lib/SQL/Translator/Types.pm

   1 package SQL::Translator::Types;
   2
   3 use warnings;
   4 use strict;
   5
   6 =head1 NAME
   7
   8 SQL::Translator::Types - Type checking functions
   9
  10 =head1 SYNOPSIS
  11
  12     package Foo;
  13     use Moo;
  14     use SQL::Translator::Types qw(schema_obj enum);
  15
  16     has foo => ( is => 'rw', isa => schema_obj('Trigger') );
  17     has bar => ( is => 'rw', isa => enum([qw(baz quux quuz)], {
  18         msg => "Invalid value for bar: '%s'", icase => 1,
  19     });
  20
  21 =head1 DESCRIPTIONS
  22
  23 This module exports functions that return coderefs suitable for L<Moo>
  24 C<isa> type checks.
  25 Errors are reported using L<SQL::Translator::Utils/throw>.
  26
  27 =cut
  28
  29 use SQL::Translator::Utils qw(throw);
  30 use Scalar::Util qw(blessed);
  31
  32 use Exporter qw(import);
  33 our @EXPORT_OK = qw(schema_obj enum);
  34
  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
  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
  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
 106 1;