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__ |