File Coverage

blib/lib/DBIx/Class/Candy.pm
Criterion Covered Total %
statement 167 176 94.8
branch 23 36 63.8
condition 2 5 40.0
subroutine 33 33 100.0
pod 0 15 0.0
total 225 265 84.9


line stmt bran cond sub pod time code
1             package DBIx::Class::Candy;
2             $DBIx::Class::Candy::VERSION = '0.005003';
3 5     5   349108 use strict;
  5         15  
  5         163  
4 5     5   34 use warnings;
  5         10  
  5         190  
5              
6 5     5   1229 use namespace::clean;
  5         32465  
  5         52  
7             require DBIx::Class::Candy::Exports;
8 5     5   2513 use MRO::Compat;
  5         7053  
  5         172  
9 5     5   3019 use Sub::Exporter 'build_exporter';
  5         53350  
  5         38  
10 5     5   1398 use Carp 'croak';
  5         18  
  5         10109  
11              
12             # ABSTRACT: Sugar for your favorite ORM, DBIx::Class
13              
14             my %aliases = (
15             column => 'add_columns',
16             primary_key => 'set_primary_key',
17             unique_constraint => 'add_unique_constraint',
18             relationship => 'add_relationship',
19             );
20              
21             my @methods = qw(
22             resultset_class
23             resultset_attributes
24             remove_columns
25             remove_column
26             table
27             source_name
28              
29             inflate_column
30              
31             belongs_to
32             has_many
33             might_have
34             has_one
35             many_to_many
36              
37             sequence
38             );
39              
40 12   50 12 0 60 sub base { return $_[1] || 'DBIx::Class::Core' }
41              
42 7     7 0 20 sub perl_version { return $_[1] }
43              
44 7     7 0 68 sub autotable { $_[1] }
45              
46 10     10 0 37 sub experimental { $_[1] }
47              
48             sub _extract_part {
49 21     21   72 my ($self, $class) = @_;
50 21 100       243 if (my ( $part ) = $class =~ /(?:::Schema)?::Result::(.+)$/) {
51 20         88 return $part
52             } else {
53 1         214 croak 'unrecognized naming scheme!'
54             }
55             }
56              
57             my $decamelize = sub {
58             my $s = shift;
59             $s =~ s{([^a-zA-Z]?)([A-Z]*)([A-Z])([a-z]?)}{
60             my $fc = pos($s)==0;
61             my ($p0,$p1,$p2,$p3) = ($1,lc$2,lc$3,$4);
62             my $t = $p0 || $fc ? $p0 : '_';
63             $t .= $p3 ? $p1 ? "${p1}_$p2$p3" : "$p2$p3" : "$p1$p2";
64             $t;
65             }ge;
66             $s;
67             };
68              
69             sub gen_table {
70 21     21 0 12655 my ( $self, $class, $version ) = @_;
71 21 100       177 if ($version eq 'singular') {
    50          
72 2         10 my $part = $self->_extract_part($class);
73 2         9 $part =~ s/:://g;
74 2         7 return $decamelize->($part);
75             } elsif ($version == 1) {
76 19         119 my $part = $self->_extract_part($class);
77 18         3928 require Lingua::EN::Inflect;
78 18         134553 $part =~ s/:://g;
79 18         89 $part = $decamelize->($part);
80 18         217 return join q{_}, split /\s+/, Lingua::EN::Inflect::PL(join q{ }, split /_/, $part);
81             }
82             }
83              
84             sub import {
85 20     20   14936 my $self = shift;
86              
87 20         86 my $inheritor = caller(0);
88 20         132 my $args = $self->parse_arguments(\@_);
89 20         125 my $perl_version = $self->perl_version($args->{perl_version});
90 20         147 my $experimental = $self->experimental($args->{experimental});
91 20         90 my @rest = @{$args->{rest}};
  20         69  
92              
93 20         120 $self->set_base($inheritor, $args->{base});
94 19         66 $inheritor->load_components(@{$args->{components}});
  19         426  
95 19         351 my @custom_methods;
96             my %custom_aliases;
97             {
98 19         50 my @custom = $self->gen_custom_imports($inheritor);
  19         108  
99 19         64 @custom_methods = @{$custom[0]};
  19         61  
100 19         55 %custom_aliases = %{$custom[1]};
  19         134  
101             }
102              
103 19     19   126 my $set_table = sub {};
104 19 100       128 if (my $v = $self->autotable($args->{autotable})) {
105 15         83 my $table_name = $self->gen_table($inheritor, $v);
106 15         18260 my $ran = 0;
107 75 100   75   1080 $set_table = sub { $inheritor->table($table_name) unless $ran++ }
108 15         109 }
109 19         114 @_ = ($self, @rest);
110             my $import = build_exporter({
111             exports => [
112             has_column => $self->gen_has_column($inheritor, $set_table),
113             primary_column => $self->gen_primary_column($inheritor, $set_table),
114             unique_column => $self->gen_unique_column($inheritor, $set_table),
115 247         636 (map { $_ => $self->gen_proxy($inheritor, $set_table) } @methods, @custom_methods),
116 19         170 (map { $_ => $self->gen_rename_proxy($inheritor, $set_table, %aliases, %custom_aliases) }
  76         314  
117             keys %aliases, keys %custom_aliases),
118             ],
119             groups => {
120             default => [
121             qw(has_column primary_column unique_column), @methods, @custom_methods, keys %aliases, keys %custom_aliases
122             ],
123             },
124             installer => $self->installer,
125             collectors => [
126             INIT => $self->gen_INIT($perl_version, \%custom_aliases, \@custom_methods, $inheritor, $experimental),
127             ],
128             });
129              
130 19         17476 goto $import
131             }
132              
133             sub gen_custom_imports {
134 19     19 0 87 my ($self, $inheritor) = @_;
135 19         49 my @methods;
136             my %aliases;
137 19         47 for (@{mro::get_linear_isa($inheritor)}) {
  19         125  
138 465 50       1100 if (my $a = $DBIx::Class::Candy::Exports::aliases{$_}) {
139 0         0 %aliases = (%aliases, %$a)
140             }
141 465 50       1174 if (my $m = $DBIx::Class::Candy::Exports::methods{$_}) {
142 0         0 @methods = (@methods, @$m)
143             }
144             }
145 19         102 return(\@methods, \%aliases)
146             }
147              
148             sub parse_arguments {
149 20     20 0 57 my $self = shift;
150 20         55 my @args = @{shift @_};
  20         80  
151              
152 20         87 my $skipnext;
153             my $base;
154 20         0 my @rest;
155 20         51 my $perl_version = undef;
156 20         56 my $components = [];
157 20         55 my $autotable = 0;
158 20         42 my $experimental;
159              
160 20         97 for my $idx ( 0 .. $#args ) {
161 26         71 my $val = $args[$idx];
162              
163 26 50       95 next unless defined $val;
164 26 100       87 if ($skipnext) {
165 13         30 $skipnext--;
166 13         40 next;
167             }
168              
169 13 100       65 if ( $val eq '-base' ) {
    50          
    0          
    0          
    0          
170 10         38 $base = $args[$idx + 1];
171 10         33 $skipnext = 1;
172             } elsif ( $val eq '-autotable' ) {
173 3         12 $autotable = $args[$idx + 1];
174 3 50       21 $autotable = ord $autotable if length $autotable == 1;
175 3         25 $skipnext = 1;
176             } elsif ( $val eq '-perl5' ) {
177 0         0 $perl_version = ord $args[$idx + 1];
178 0         0 $skipnext = 1;
179             } elsif ( $val eq '-experimental' ) {
180 0         0 $experimental = $args[$idx + 1];
181 0         0 $skipnext = 1;
182             } elsif ( $val eq '-components' ) {
183 0         0 $components = $args[$idx + 1];
184 0         0 $skipnext = 1;
185             } else {
186 0         0 push @rest, $val;
187             }
188             }
189              
190             return {
191 20         182 autotable => $autotable,
192             base => $base,
193             perl_version => $perl_version,
194             components => $components,
195             rest => \@rest,
196             experimental => $experimental,
197             };
198             }
199              
200             sub gen_primary_column {
201 19     19 0 72 my ($self, $inheritor, $set_table) = @_;
202             sub {
203 19     19   552 my $i = $inheritor;
204             sub {
205 16         12620 my $column = shift;
206 16         40 my $info = shift;
207 16         66 $set_table->();
208 16         7460 $i->add_columns($column => $info);
209 16         7181 $i->set_primary_key($i->primary_columns, $column);
210             }
211 19         110 }
212 19         153 }
213              
214             sub gen_unique_column {
215 19     19 0 63 my ($self, $inheritor, $set_table) = @_;
216             sub {
217 19     19   513 my $i = $inheritor;
218             sub {
219 9         5153 my $column = shift;
220 9         24 my $info = shift;
221 9         38 $set_table->();
222 9         98 $i->add_columns($column => $info);
223 9         5409 $i->add_unique_constraint([ $column ]);
224             }
225 19         110 }
226 19         118 }
227              
228             sub gen_has_column {
229 19     19 0 72 my ($self, $inheritor, $set_table) = @_;
230             sub {
231 19     19   10405 my $i = $inheritor;
232             sub {
233 2         1010 my $column = shift;
234 2         8 $set_table->();
235 2         20 $i->add_columns($column => { @_ })
236             }
237 19         128 }
238 19         171 }
239              
240             sub gen_rename_proxy {
241 76     76 0 323 my ($self, $inheritor, $set_table, %aliases) = @_;
242             sub {
243 76     76   1945 my ($class, $name) = @_;
244 76         169 my $meth = $aliases{$name};
245 76         141 my $i = $inheritor;
246 41         23317 sub { $set_table->(); $i->$meth(@_) }
  41         2953  
247 76         354 }
248 76         621 }
249              
250             sub gen_proxy {
251 247     247 0 521 my ($self, $inheritor, $set_table) = @_;
252             sub {
253 247     247   6530 my ($class, $name) = @_;
254 247         450 my $i = $inheritor;
255 26         22609 sub { $set_table->(); $i->$name(@_) }
  26         3082  
256 247         1256 }
257 247         1194 }
258              
259             sub installer {
260 19     19 0 71 my ($self) = @_;
261             sub {
262 19     19   248 Sub::Exporter::default_installer @_;
263 19         20670 my %subs = @{ $_[1] };
  19         205  
264 19         321 namespace::clean->import( -cleanee => $_[0]{into}, keys %subs )
265             }
266 19         175 }
267              
268             sub set_base {
269 20     20 0 73 my ($self, $inheritor, $base) = @_;
270              
271             # inlined from parent.pm
272 20         91 for ( my @useless = $self->base($base) ) {
273 20         324 s{::|'}{/}g;
274 20         1964 require "$_.pm"; # dies if the file is not found
275             }
276              
277             {
278 5     5   51 no strict 'refs';
  5         15  
  5         1459  
  20         390757  
279             # This is more efficient than push for the new MRO
280             # at least until the new MRO is fixed
281 20         55 @{"$inheritor\::ISA"} = (@{"$inheritor\::ISA"} , $self->base($base));
  20         808  
  20         176  
282             }
283             }
284              
285             sub gen_INIT {
286 19     19 0 76 my ($self, $perl_version, $custom_aliases, $custom_methods, $inheritor, $experimental) = @_;
287             sub {
288 19     19   2263 my $orig = $_[1]->{import_args};
289 19         63 $_[1]->{import_args} = [];
290 19         59 %$custom_aliases = ();
291 19         51 @$custom_methods = ();
292              
293 19         183 strict->import;
294 19         298 warnings->import;
295              
296 19 100       80 if ($perl_version) {
297 12         99 require feature;
298 12         1104 feature->import(":5.$perl_version")
299             }
300              
301 19 100       84 if ($experimental) {
302 9         1985 require experimental;
303 9 50 33     9919 die 'experimental arg must be an arrayref!'
304             unless ref $experimental && ref $experimental eq 'ARRAY';
305             # to avoid experimental referring to the method
306 9         86 experimental::->import(@$experimental)
307             }
308              
309 19         672 mro::set_mro($inheritor, 'c3');
310              
311 19         63 1;
312             }
313 19         244 }
314              
315             1;
316              
317             __END__