lib/DBIx/Class/_Types.pm

   1 package # hide from PAUSE
   2   DBIx::Class::_Types;
   3
   4 use strict;
   5 use warnings;
   6 use Carp qw(confess);
   7
   8 use Path::Class;
   9 use Sub::Name;
  10 use Scalar::Util qw(blessed looks_like_number reftype);
  11 use Class::Load qw(load_optional_class);
  12
  13 sub import {
  14   my ($package, @methods) = @_;
  15   my $caller = caller;
  16   for my $method (@methods) {
  17     my $check = $package->can($method) or confess "$package does not export $method";
  18     my $coerce = $package->can("coerce_$method");
  19     my $full_method = "${caller}::${method}";
  20     { no strict;
  21       *{$full_method} = subname $full_method => sub {
  22         my %args = @_;
  23         ($coerce && $args{coerce} && wantarray)
  24           ? ( $check, coerce => $coerce )
  25           : $check;
  26       };
  27     }
  28   }
  29 }
  30
  31 sub error {
  32   my ($default, $value, %args) = @_;
  33   if(my $err = $args{err}) {
  34     confess $err->($value);
  35   } else {
  36     confess $default;
  37   }
  38 }
  39
  40 sub Str {
  41   error("Value $_[0] must be a string")
  42     unless Defined(@_) && !ref $_[0];
  43 }
  44
  45 sub Dir {
  46   error("Value $_[0] must be a Path::Class::Dir")
  47     unless Object(@_) && $_[0]->isa("Path::Class::Dir");
  48 }
  49
  50 sub coerce_Dir{ dir($_[0]) }
  51
  52 sub File {
  53   error("Value $_[0] must be a Path::Class::File")
  54     unless Object(@_) && $_[0]->isa("Path::Class::File");
  55 }
  56
  57 sub coerce_File { file($_[0]) }
  58
  59 sub Defined {
  60   error("Value must be Defined", @_)
  61     unless defined($_[0]);
  62 }
  63
  64 sub UnDefined {
  65   error("Value must be UnDefined", @_)
  66     unless !defined($_[0]);
  67 }
  68
  69 sub Bool {
  70   error("$_[0] is not a valid Boolean", @_)
  71     unless(!defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0');
  72 }
  73
  74 sub Number {
  75   error("weight must be a Number greater than or equal to 0, not $_[0]", @_)
  76     unless(Defined(@_) && looks_like_number($_[0]));
  77 }
  78
  79 sub Integer {
  80   error("$_[0] must be an Integer", @_)
  81     unless(Number(@_) && (int($_[0]) == $_[0]));
  82 }
  83
  84 sub HashRef {
  85   error("$_[0] must be a HashRef", @_)
  86     unless(Defined(@_) && (reftype($_[0]) eq 'HASH'));
  87 }
  88
  89 sub ArrayRef {
  90   error("$_[0] must be an ArrayRef", @_)
  91     unless(Defined(@_) && (reftype($_[0]) eq 'ARRAY'));
  92 }
  93
  94 sub _json_to_data {
  95   my ($json_str) = @_;
  96   require JSON::Any;
  97   JSON::Any->import(qw(DWIW XS JSON));
  98   my $json = JSON::Any->new(allow_barekey => 1, allow_singlequote => 1, relaxed=>1);
  99   my $ret = $json->jsonToObj($json_str);
 100   return $ret;
 101 }
 102
 103 sub DBICHashRef {
 104   HashRef(@_);
 105 }
 106
 107 sub coerce_DBICHashRef {
 108   !ref $_[0] ? _json_to_data(@_)
 109     : reftype $_[0] eq 'HASH' ? $_[0]
 110     : error("Cannot coerce @{[reftype $_[0]]}")
 111   ;
 112 }
 113
 114 sub DBICConnectInfo {
 115   ArrayRef(@_);
 116 }
 117
 118 sub coerce_DBICConnectInfo {
 119   !ref $_[0] ? _json_to_data(@_)
 120     : reftype $_[0] eq 'ARRAY' ? $_[0]
 121     : reftype $_[0] eq 'HASH'  ? [ $_[0] ]
 122     : error("Cannot coerce @{[reftype $_[0]]}")
 123   ;
 124 }
 125
 126 sub PositiveNumber {
 127   error("value must be a Number greater than or equal to 0, not $_[0]", @_)
 128     unless(Number(@_) && ($_[0] >= 0));
 129 }
 130
 131 sub PositiveInteger {
 132   error("Value must be a Number greater than or equal to 0, not $_[0]", @_)
 133     unless(Integer(@_) && ($_[0] >= 0));
 134 }
 135
 136 sub LoadableClass {
 137   error("$_[0] is not a loadable Class", @_)
 138     unless(load_optional_class($_[0]));
 139 }
 140
 141 sub Object {
 142   error("Value is not an Object", @_)
 143     unless(Defined(@_) && blessed($_[0]));
 144 }
 145
 146 sub DBICStorageDBI {
 147   error("Need an Object of type DBIx::Class::Storage::DBI, not ".ref($_[0]), @_)
 148     unless(Object(@_) && ($_[0]->isa('DBIx::Class::Storage::DBI')));
 149 }
 150
 151 sub DBICStorageDBIReplicatedPool {
 152   error("Need an Object of type DBIx::Class::Storage::DBI::Replicated::Pool, not ".ref($_[0]), @_)
 153     unless(Object(@_) && ($_[0]->isa('DBIx::Class::Storage::DBI::Replicated::Pool')));
 154 }
 155
 156 sub DBICSchema {
 157   error("Need an Object of type DBIx::Class::Schema, not ".ref($_[0]), @_)
 158     unless(Object(@_) && ($_[0]->isa('DBIx::Class::Schema')));
 159 }
 160
 161 sub DBICSchemaClass {
 162   error("Need an Object of type DBIx::Class::Schema, not ".ref($_[0]), @_)
 163     unless(LoadableClass(@_) && ($_[0]->isa('DBIx::Class::Schema')));
 164 }
 165
 166 sub DoesDBICStorageReplicatedBalancer {
 167   error("$_[0] does not do DBIx::Class::Storage::DBI::Replicated::Balancer", @_)
 168     unless(Object(@_) && $_[0]->does('DBIx::Class::Storage::DBI::Replicated::Balancer') );
 169 }
 170
 171 1;
 172