lib/Catalyst/Model/DBIC/Schema/Types.pm

   1 package  # hide from PAUSE
   2     Catalyst::Model::DBIC::Schema::Types;
   3
   4 use MooseX::Types -declare => [qw/
   5     ConnectInfo ConnectInfos Replicants SchemaClass CreateOption
   6     Schema LoadedClass
   7 /];
   8
   9 use Carp::Clan '^Catalyst::Model::DBIC::Schema';
  10 use MooseX::Types::Moose qw/ArrayRef HashRef CodeRef Str ClassName/;
  11 use MooseX::Types::LoadableClass qw/LoadableClass/;
  12 use Scalar::Util 'reftype';
  13 use List::MoreUtils 'all';
  14 use Module::Runtime;
  15
  16 use namespace::clean -except => 'meta';
  17
  18 # So I restored the custom Type LoadedClass because 'LoadableClass' doesn't really
  19 # exactly do the same thing, which busted the Replication trait.  Please don't
  20 # "clean this up" -JNAP
  21
  22 subtype LoadedClass,
  23     as ClassName;
  24
  25 coerce LoadedClass,
  26     from Str, # N.B. deliberate paranoia against $_ clobbering below
  27     via { my $classname = $_; Module::Runtime::use_module($classname); $classname };
  28
  29 subtype SchemaClass,
  30     as LoadableClass,
  31     where { $_->isa('DBIx::Class::Schema') };
  32
  33 class_type Schema, { class => 'DBIx::Class::Schema' };
  34
  35 subtype ConnectInfo,
  36     as HashRef,
  37     where { exists $_->{dsn} || exists $_->{dbh_maker} },
  38     message { 'Does not look like a valid connect_info' };
  39
  40 coerce ConnectInfo,
  41     from Str,
  42     via(\&_coerce_connect_info_from_str),
  43     from ArrayRef,
  44     via(\&_coerce_connect_info_from_arrayref),
  45     from CodeRef,
  46     via { +{ dbh_maker => $_ } },
  47 ;
  48
  49 # { connect_info => [ ... ] } coercion would be nice, but no chained coercions
  50 # yet.
  51 # Also no coercion from base type (yet,) but in Moose git already.
  52 #    from HashRef,
  53 #    via { $_->{connect_info} },
  54
  55 subtype ConnectInfos,
  56     as ArrayRef[ConnectInfo],
  57     message { "Not a valid array of connect_info's" };
  58
  59 coerce ConnectInfos,
  60     from Str,
  61     via { [ _coerce_connect_info_from_str() ] },
  62     from CodeRef,
  63     via { [ +{ dbh_maker => $_ } ]  },
  64     from HashRef,
  65     via { [ $_ ] },
  66     from ArrayRef,
  67     via { [ map {
  68         !ref $_ ? _coerce_connect_info_from_str()
  69             : reftype $_ eq 'HASH' ? $_
  70             : reftype $_ eq 'CODE' ? +{ dbh_maker => $_ }
  71             : reftype $_ eq 'ARRAY' ? _coerce_connect_info_from_arrayref()
  72             : croak 'invalid connect_info'
  73     } @$_ ] };
  74
  75 # Helper stuff
  76
  77 subtype CreateOption,
  78     as Str,
  79     where { /^(?:static|dynamic)\z/ },
  80     message { "Invalid create option, must be one of 'static' or 'dynamic'" };
  81
  82 sub _coerce_connect_info_from_arrayref {
  83     my %connect_info;
  84
  85     # make a copy
  86     $_ = [ @$_ ];
  87
  88     my $slurp_hashes = sub {
  89         for my $i (0..1) {
  90             my $extra = shift @$_;
  91             last unless $extra;
  92             croak "invalid connect_info"
  93                 unless ref $extra && reftype $extra eq 'HASH';
  94
  95             %connect_info = (%connect_info, %$extra);
  96         }
  97     };
  98
  99     if (!ref $_->[0]) { # array style
 100         $connect_info{dsn}      = shift @$_;
 101         $connect_info{user}     = shift @$_ if !ref $_->[0];
 102         $connect_info{password} = shift @$_ if !ref $_->[0];
 103
 104         $slurp_hashes->();
 105
 106         croak "invalid connect_info" if @$_;
 107     } elsif (ref $_->[0] && reftype $_->[0] eq 'CODE') {
 108         $connect_info{dbh_maker} = shift @$_;
 109
 110         $slurp_hashes->();
 111
 112         croak "invalid connect_info" if @$_;
 113     } elsif (@$_ == 1 && ref $_->[0] && reftype $_->[0] eq 'HASH') {
 114         return $_->[0];
 115     } else {
 116         croak "invalid connect_info";
 117     }
 118
 119     unless ($connect_info{dbh_maker}) {
 120         for my $key (qw/user password/) {
 121             $connect_info{$key} = ''
 122                 if not defined $connect_info{$key};
 123         }
 124     }
 125
 126     \%connect_info;
 127 }
 128
 129 sub _coerce_connect_info_from_str {
 130     +{ dsn => $_, user => '', password => '' }
 131 }
 132
 133 1;