File Coverage

blib/lib/Catalyst/Model/DBIC/Schema/Types.pm
Criterion Covered Total %
statement 47 48 97.9
branch 17 22 77.2
condition 5 12 41.6
subroutine 11 11 100.0
pod n/a
total 80 93 86.0


line stmt bran cond sub pod time code
1             package # hide from PAUSE
2             Catalyst::Model::DBIC::Schema::Types;
3              
4 6         43 use MooseX::Types -declare => [qw/
5             ConnectInfo ConnectInfos Replicants SchemaClass CreateOption
6             Schema LoadedClass
7 6     6   2932 /];
  6         190098  
8              
9 6     6   48528 use Carp::Clan '^Catalyst::Model::DBIC::Schema';
  6         16  
  6         67  
10 6     6   3291 use MooseX::Types::Moose qw/ArrayRef HashRef CodeRef Str ClassName/;
  6         89182  
  6         51  
11 6     6   38409 use MooseX::Types::LoadableClass qw/LoadableClass/;
  6         344750  
  6         39  
12 6     6   9637 use Scalar::Util 'reftype';
  6         15  
  6         409  
13 6     6   4544 use List::MoreUtils 'all';
  6         86175  
  6         49  
14 6     6   6747 use Module::Runtime;
  6         20  
  6         63  
15              
16 6     6   385 use namespace::clean -except => 'meta';
  6         21  
  6         67  
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 21     21   27688 my %connect_info;
84              
85             # make a copy
86 21         74 $_ = [ @$_ ];
87              
88             my $slurp_hashes = sub {
89 18     18   63 for my $i (0..1) {
90 25         58 my $extra = shift @$_;
91 25 100       63 last unless $extra;
92 10 50 33     52 croak "invalid connect_info"
93             unless ref $extra && reftype $extra eq 'HASH';
94              
95 10         63 %connect_info = (%connect_info, %$extra);
96             }
97 21         115 };
98              
99 21 100 66     132 if (!ref $_->[0]) { # array style
    100 33        
    50 33        
100 16         53 $connect_info{dsn} = shift @$_;
101 16 50       70 $connect_info{user} = shift @$_ if !ref $_->[0];
102 16 50       64 $connect_info{password} = shift @$_ if !ref $_->[0];
103              
104 16         51 $slurp_hashes->();
105              
106 16 100       66 croak "invalid connect_info" if @$_;
107             } elsif (ref $_->[0] && reftype $_->[0] eq 'CODE') {
108 2         9 $connect_info{dbh_maker} = shift @$_;
109              
110 2         8 $slurp_hashes->();
111              
112 2 50       9 croak "invalid connect_info" if @$_;
113             } elsif (@$_ == 1 && ref $_->[0] && reftype $_->[0] eq 'HASH') {
114 3         103 return $_->[0];
115             } else {
116 0         0 croak "invalid connect_info";
117             }
118              
119 17 100       50 unless ($connect_info{dbh_maker}) {
120 15         37 for my $key (qw/user password/) {
121             $connect_info{$key} = ''
122 30 100       101 if not defined $connect_info{$key};
123             }
124             }
125              
126 17         342 \%connect_info;
127             }
128              
129             sub _coerce_connect_info_from_str {
130 2     2   74 +{ dsn => $_, user => '', password => '' }
131             }
132              
133             1;