line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
2
|
|
|
|
|
|
|
package DBIx::DataModel::Statement; |
3
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
4
|
|
|
|
|
|
|
# see POD doc at end of file |
5
|
|
|
|
|
|
|
|
6
|
13
|
|
|
13
|
|
7474
|
use warnings; |
|
13
|
|
|
|
|
33
|
|
|
13
|
|
|
|
|
481
|
|
7
|
13
|
|
|
13
|
|
84
|
use strict; |
|
13
|
|
|
|
|
35
|
|
|
13
|
|
|
|
|
350
|
|
8
|
13
|
|
|
13
|
|
76
|
use List::MoreUtils qw/firstval any/; |
|
13
|
|
|
|
|
28
|
|
|
13
|
|
|
|
|
158
|
|
9
|
13
|
|
|
13
|
|
10504
|
use Scalar::Util qw/weaken dualvar/; |
|
13
|
|
|
|
|
28
|
|
|
13
|
|
|
|
|
834
|
|
10
|
13
|
|
|
13
|
|
2805
|
use POSIX qw/LONG_MAX/; |
|
13
|
|
|
|
|
36151
|
|
|
13
|
|
|
|
|
166
|
|
11
|
13
|
|
|
13
|
|
13665
|
use Clone qw/clone/; |
|
13
|
|
|
|
|
5412
|
|
|
13
|
|
|
|
|
780
|
|
12
|
13
|
|
|
13
|
|
95
|
use Carp::Clan qw[^(DBIx::DataModel::|SQL::Abstract)]; |
|
13
|
|
|
|
|
29
|
|
|
13
|
|
|
|
|
183
|
|
13
|
13
|
|
|
13
|
|
1313
|
use Try::Tiny qw/try catch/; |
|
13
|
|
|
|
|
37
|
|
|
13
|
|
|
|
|
821
|
|
14
|
13
|
|
|
13
|
|
85
|
use Module::Load qw/load/; |
|
13
|
|
|
|
|
34
|
|
|
13
|
|
|
|
|
129
|
|
15
|
13
|
|
|
13
|
|
934
|
use mro qw/c3/; |
|
13
|
|
|
|
|
28
|
|
|
13
|
|
|
|
|
109
|
|
16
|
|
|
|
|
|
|
|
17
|
13
|
|
|
13
|
|
412
|
use DBIx::DataModel; |
|
13
|
|
|
|
|
27
|
|
|
13
|
|
|
|
|
105
|
|
18
|
13
|
|
|
13
|
|
82
|
use DBIx::DataModel::Meta::Utils qw/define_readonly_accessors does/; |
|
13
|
|
|
|
|
39
|
|
|
13
|
|
|
|
|
845
|
|
19
|
13
|
|
|
13
|
|
103
|
use namespace::clean; |
|
13
|
|
|
|
|
30
|
|
|
13
|
|
|
|
|
125
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
22
|
|
|
|
|
|
|
# internals |
23
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
use overload |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# overload the stringification operator so that Devel::StackTrace is happy; |
28
|
|
|
|
|
|
|
# also useful to show the SQL (if in sqlized state) |
29
|
|
|
|
|
|
|
'""' => sub { |
30
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
31
|
0
|
|
|
0
|
|
0
|
my $string = try {my ($sql, @bind) = $self->sql; |
32
|
0
|
|
|
|
|
0
|
__PACKAGE__ . "($sql // " . join(", ", @bind) . ")"; } |
33
|
0
|
|
0
|
|
|
0
|
|| overload::StrVal($self); |
34
|
|
|
|
|
|
|
} |
35
|
13
|
|
|
13
|
|
6783
|
; |
|
13
|
|
|
|
|
33
|
|
|
13
|
|
|
|
|
115
|
|
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
# sequence of states. Stored as dualvars for both ordering and printing |
39
|
|
|
|
|
|
|
use constant { |
40
|
13
|
|
|
|
|
70696
|
NEW => dualvar(1, "new" ), |
41
|
|
|
|
|
|
|
REFINED => dualvar(2, "refined" ), |
42
|
|
|
|
|
|
|
SQLIZED => dualvar(3, "sqlized" ), |
43
|
|
|
|
|
|
|
PREPARED => dualvar(4, "prepared"), |
44
|
|
|
|
|
|
|
EXECUTED => dualvar(5, "executed"), |
45
|
13
|
|
|
13
|
|
1676
|
}; |
|
13
|
|
|
|
|
30
|
|
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
50
|
|
|
|
|
|
|
# PUBLIC METHODS |
51
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
sub new { |
54
|
172
|
|
|
172
|
0
|
541
|
my ($class, $source, %other_args) = @_; |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
# check $source |
57
|
172
|
50
|
33
|
|
|
1721
|
$source |
58
|
|
|
|
|
|
|
&& $source->isa('DBIx::DataModel::Source') |
59
|
|
|
|
|
|
|
or croak "invalid source for DBIx::DataModel::Statement->new()"; |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# build the object |
62
|
172
|
|
|
|
|
1029
|
my $self = bless {status => NEW, |
63
|
|
|
|
|
|
|
args => {}, |
64
|
|
|
|
|
|
|
pre_bound_params => {}, |
65
|
|
|
|
|
|
|
bound_params => [], |
66
|
|
|
|
|
|
|
source => $source}, $class; |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
# add placeholder_regex |
69
|
172
|
|
|
|
|
824
|
my $prefix = $source->schema->{placeholder_prefix}; |
70
|
172
|
|
|
|
|
1613
|
$self->{placeholder_regex} = qr/^\Q$prefix\E(.+)/; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
# parse remaining args, if any |
73
|
172
|
100
|
|
|
|
604
|
$self->refine(%other_args) if %other_args; |
74
|
|
|
|
|
|
|
|
75
|
172
|
|
|
|
|
555
|
return $self; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
# accessors |
80
|
|
|
|
|
|
|
define_readonly_accessors( __PACKAGE__, qw/source status/); |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
# proxy methods |
83
|
495
|
|
|
495
|
0
|
1290
|
sub meta_source {shift->{source}->metadm} |
84
|
1261
|
|
|
1261
|
0
|
3396
|
sub schema {shift->{source}->schema} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# back to the original state |
88
|
|
|
|
|
|
|
sub reset { |
89
|
0
|
|
|
0
|
0
|
0
|
my ($self, %other_args) = @_; |
90
|
|
|
|
|
|
|
|
91
|
0
|
|
|
|
|
0
|
my $new = (ref $self)->new($self->{source}, %other_args); |
92
|
0
|
|
|
|
|
0
|
%$self = (%$new); |
93
|
|
|
|
|
|
|
|
94
|
0
|
|
|
|
|
0
|
return $self; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
sub arg { |
99
|
159
|
|
|
159
|
0
|
352
|
my ($self, $arg_name) = @_; |
100
|
|
|
|
|
|
|
|
101
|
159
|
|
50
|
|
|
488
|
my $args = $self->{args} || {}; |
102
|
159
|
|
|
|
|
584
|
return $args->{$arg_name}; |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
108
|
|
|
|
|
|
|
# PUBLIC METHODS IN RELATION WITH SELECT() |
109
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
sub sql { |
113
|
13
|
|
|
13
|
0
|
36
|
my ($self) = @_; |
114
|
|
|
|
|
|
|
|
115
|
13
|
50
|
|
|
|
34
|
$self->status >= SQLIZED |
116
|
|
|
|
|
|
|
or croak "can't call sql() when in status ". $self->status; |
117
|
|
|
|
|
|
|
|
118
|
12
|
|
|
|
|
82
|
return wantarray ? ($self->{sql}, @{$self->{bound_params}}) |
119
|
13
|
100
|
|
|
|
60
|
: $self->{sql}; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
sub bind { |
124
|
173
|
|
|
173
|
0
|
481
|
my ($self, @args) = @_; |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
# arguments can be a list, a hashref or an arrayref |
127
|
173
|
100
|
|
|
|
522
|
if (@args == 1) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
128
|
151
|
50
|
|
|
|
617
|
if (does $args[0], 'HASH') { |
|
|
0
|
|
|
|
|
|
129
|
151
|
|
|
|
|
1374
|
@args = %{$args[0]}; |
|
151
|
|
|
|
|
480
|
|
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
elsif (does $args[0], 'ARRAY') { |
132
|
0
|
|
|
|
|
0
|
my $i = 0; @args = map {($i++, $_)} @{$args[0]}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
else { |
135
|
0
|
|
|
|
|
0
|
croak "unexpected arg type to bind()"; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
elsif (@args == 3) { # name => value, \%datatype (see L) |
139
|
|
|
|
|
|
|
# transform into ->bind($name => [$value, \%datatype]) |
140
|
1
|
|
|
|
|
3
|
@args = ($args[0], [$args[1], $args[2]]); |
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
elsif (@args % 2 == 1) { |
143
|
0
|
|
|
|
|
0
|
croak "odd number of args to bind()"; |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
# do bind (different behaviour according to status) |
147
|
173
|
|
|
|
|
506
|
my %args = @args; |
148
|
173
|
100
|
|
|
|
557
|
if ($self->status < SQLIZED) { |
149
|
26
|
|
|
|
|
114
|
while (my ($k, $v) = each %args) { |
150
|
34
|
|
|
|
|
129
|
$self->{pre_bound_params}{$k} = $v; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
else { |
154
|
147
|
|
|
|
|
573
|
while (my ($k, $v) = each %args) { |
155
|
49
|
100
|
|
|
|
192
|
my $indices = $self->{param_indices}{$k} |
156
|
|
|
|
|
|
|
or next; # silently ignore that binding (named placeholder unused) |
157
|
30
|
|
|
|
|
169
|
$self->{bound_params}[$_] = $v foreach @$indices; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# THINK : probably we should check here that $args{__schema}, if present, |
162
|
|
|
|
|
|
|
# is the same as $self->schema (same database connection) ... but how |
163
|
|
|
|
|
|
|
# to check for "sameness" on database handles ? |
164
|
|
|
|
|
|
|
|
165
|
173
|
|
|
|
|
438
|
return $self; |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
sub refine { |
170
|
113
|
|
|
113
|
0
|
489
|
my ($self, %more_args) = @_; |
171
|
|
|
|
|
|
|
|
172
|
113
|
50
|
|
|
|
332
|
$self->status <= REFINED |
173
|
|
|
|
|
|
|
or croak "can't refine() when in status " . $self->status; |
174
|
113
|
|
|
|
|
263
|
$self->{status} = REFINED; |
175
|
|
|
|
|
|
|
|
176
|
113
|
|
|
|
|
211
|
my $args = $self->{args}; |
177
|
|
|
|
|
|
|
|
178
|
113
|
|
|
|
|
412
|
while (my ($k, $v) = each %more_args) { |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
SWITCH: |
181
|
181
|
|
|
|
|
350
|
for ($k) { |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# -where : combine with previous 'where' clauses in same statement |
184
|
181
|
100
|
|
|
|
514
|
/^-where$/ and do { |
185
|
60
|
|
|
|
|
138
|
my $sqla = $self->schema->sql_abstract; |
186
|
60
|
|
|
|
|
294
|
$args->{-where} = $sqla->merge_conditions($args->{-where}, $v); |
187
|
60
|
|
|
|
|
2443
|
last SWITCH; |
188
|
|
|
|
|
|
|
}; |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
# -fetch : special select() on primary key |
191
|
121
|
100
|
|
|
|
304
|
/^-fetch$/ and do { |
192
|
|
|
|
|
|
|
# build a -where clause on primary key |
193
|
7
|
100
|
|
|
|
25
|
my $primary_key = ref($v) ? $v : [$v]; |
194
|
7
|
|
|
|
|
20
|
my @pk_columns = $self->meta_source->primary_key; |
195
|
|
|
|
|
|
|
@pk_columns |
196
|
7
|
50
|
|
|
|
23
|
or croak "fetch: no primary key in source " . $self->meta_source; |
197
|
7
|
50
|
|
|
|
23
|
@pk_columns == @$primary_key |
198
|
|
|
|
|
|
|
or croak sprintf "fetch from %s: primary key should have %d values", |
199
|
|
|
|
|
|
|
$self->meta_source, scalar(@pk_columns); |
200
|
7
|
100
|
|
7
|
|
53
|
List::MoreUtils::all {defined $_} @$primary_key |
|
7
|
|
|
|
|
23
|
|
201
|
|
|
|
|
|
|
or croak "fetch from " . $self->meta_source . ": " |
202
|
|
|
|
|
|
|
. "undefined val in primary key"; |
203
|
|
|
|
|
|
|
|
204
|
6
|
|
|
|
|
23
|
my %where = (); |
205
|
6
|
|
|
|
|
20
|
@where{@pk_columns} = @$primary_key; |
206
|
6
|
|
|
|
|
16
|
my $sqla = $self->schema->sql_abstract; |
207
|
6
|
|
|
|
|
31
|
$args->{-where} = $sqla->merge_conditions($args->{-where}, \%where); |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
# want a single record as result |
210
|
6
|
|
|
|
|
221
|
$args->{-result_as} = "firstrow"; |
211
|
|
|
|
|
|
|
|
212
|
6
|
|
|
|
|
32
|
last SWITCH; |
213
|
|
|
|
|
|
|
}; |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# -columns : store in $self->{args}{-columns}; can restrict previous list |
216
|
114
|
100
|
|
|
|
324
|
/^-columns$/ and do { |
217
|
36
|
100
|
|
|
|
132
|
my @cols = does($v, 'ARRAY') ? @$v : ($v); |
218
|
36
|
50
|
|
|
|
425
|
if (my $old_cols = $args->{-columns}) { |
219
|
0
|
0
|
0
|
|
|
0
|
unless (@$old_cols == 1 && $old_cols->[0] eq '*' ) { |
220
|
0
|
|
|
|
|
0
|
foreach my $col (@cols) { |
221
|
0
|
0
|
|
0
|
|
0
|
any {$_ eq $col} @$old_cols |
|
0
|
|
|
|
|
0
|
|
222
|
|
|
|
|
|
|
or croak "can't restrict -columns on '$col' (was not in the) " |
223
|
|
|
|
|
|
|
. "previous -columns list"; |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
} |
227
|
36
|
|
|
|
|
89
|
$args->{-columns} = \@cols; |
228
|
36
|
|
|
|
|
157
|
last SWITCH; |
229
|
|
|
|
|
|
|
}; |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# other args are just stored, they will be used later |
233
|
|
|
|
|
|
|
/^-( order_by | group_by | having | for |
234
|
|
|
|
|
|
|
| union(?:_all)? | intersect | except | minus |
235
|
|
|
|
|
|
|
| result_as | post_SQL | pre_exec | post_exec | post_bless |
236
|
|
|
|
|
|
|
| limit | offset | page_size | page_index |
237
|
|
|
|
|
|
|
| column_types | prepare_attrs | dbi_prepare_method |
238
|
|
|
|
|
|
|
| _left_cols | where_on | join_with_USING |
239
|
|
|
|
|
|
|
)$/x |
240
|
78
|
50
|
|
|
|
409
|
and do {$args->{$k} = $v; last SWITCH}; |
|
78
|
|
|
|
|
213
|
|
|
78
|
|
|
|
|
325
|
|
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
# TODO : this hard-coded list of args should be more abstract |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
# otherwise |
245
|
0
|
|
|
|
|
0
|
croak "invalid arg : $k"; |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
} # end SWITCH |
248
|
|
|
|
|
|
|
} # end while |
249
|
|
|
|
|
|
|
|
250
|
112
|
|
|
|
|
306
|
return $self; |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
sub sqlize { |
257
|
144
|
|
|
144
|
0
|
323
|
my ($self, @args) = @_; |
258
|
|
|
|
|
|
|
|
259
|
144
|
50
|
|
|
|
308
|
$self->status < SQLIZED |
260
|
|
|
|
|
|
|
or croak "can't sqlize() when in status ". $self->status; |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
# merge new args into $self->{args} |
263
|
144
|
50
|
|
|
|
360
|
$self->refine(@args) if @args; |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
# shortcuts |
266
|
144
|
|
|
|
|
260
|
my $args = $self->{args}; |
267
|
144
|
|
|
|
|
282
|
my $meta_source = $self->meta_source; |
268
|
144
|
|
|
|
|
316
|
my $source_where = $meta_source->{where}; |
269
|
144
|
|
|
|
|
294
|
my $sql_abstract = $self->schema->sql_abstract; |
270
|
144
|
|
100
|
|
|
517
|
my $result_as = $args->{-result_as} || ""; |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
# build arguments for SQL::Abstract::More |
273
|
144
|
100
|
|
|
|
340
|
$self->refine(-where => $source_where) if $source_where; |
274
|
144
|
|
|
|
|
585
|
my @args_to_copy = qw/-columns -where |
275
|
|
|
|
|
|
|
-union -union_all -intersect -except -minus |
276
|
|
|
|
|
|
|
-order_by -group_by -having |
277
|
|
|
|
|
|
|
-limit -offset -page_size -page_index/; |
278
|
144
|
|
|
|
|
443
|
my %sqla_args = (-from => clone($self->source->db_from), |
279
|
|
|
|
|
|
|
-want_details => 1); |
280
|
144
|
|
66
|
|
|
1957
|
defined $args->{$_} and $sqla_args{$_} = $args->{$_} for @args_to_copy; |
281
|
144
|
|
66
|
|
|
841
|
$sqla_args{-columns} ||= $meta_source->default_columns; |
282
|
144
|
100
|
50
|
|
|
477
|
$sqla_args{-limit} ||= 1 |
|
|
|
100
|
|
|
|
|
283
|
|
|
|
|
|
|
if $result_as eq 'firstrow' && $self->schema->autolimit_firstrow; |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
# "-for" (e.g. "update", "read only") |
286
|
144
|
100
|
|
|
|
350
|
if ($result_as ne 'subquery') { |
287
|
141
|
100
|
|
|
|
557
|
if ($args->{-for}) { |
|
|
50
|
|
|
|
|
|
288
|
2
|
|
|
|
|
10
|
$sqla_args{-for} = $args->{-for}; |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
elsif (!exists $args->{-for}) { |
291
|
139
|
|
|
|
|
337
|
$sqla_args{-for} = $self->schema->select_implicitly_for; |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
# "where_on" : conditions to be added in joins |
296
|
144
|
100
|
|
|
|
532
|
if (my $where_on = $args->{-where_on}) { |
297
|
|
|
|
|
|
|
# check proper usage |
298
|
3
|
100
|
|
|
|
10
|
does $sqla_args{-from}, 'ARRAY' |
299
|
|
|
|
|
|
|
or croak "datasource for '-where_on' was not a join"; |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
# retrieve components of the join and check again for proper usage |
302
|
2
|
|
|
|
|
20
|
my ($join_op, $first_table, @other_join_args) = @{$sqla_args{-from}}; |
|
2
|
|
|
|
|
7
|
|
303
|
2
|
50
|
|
|
|
7
|
$join_op eq '-join' |
304
|
|
|
|
|
|
|
or croak "datasource for '-where_on' was not a join"; |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
# reverse index (table_name => $join_hash) |
307
|
2
|
|
|
|
|
7
|
my %by_dest_table = reverse @other_join_args; |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
# insert additional conditions into appropriate places |
310
|
2
|
|
|
|
|
9
|
while (my ($table, $additional_cond) = each %$where_on) { |
311
|
4
|
50
|
|
|
|
10
|
my $join_cond = $by_dest_table{$table} |
312
|
|
|
|
|
|
|
or croak "-where_on => {'$table' => ..}: this table is not in the join"; |
313
|
|
|
|
|
|
|
$join_cond->{condition} |
314
|
|
|
|
|
|
|
= $sql_abstract->merge_conditions($join_cond->{condition}, |
315
|
4
|
|
|
|
|
12
|
$additional_cond); |
316
|
4
|
|
|
|
|
129
|
delete $join_cond->{using}; |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
# TODO: should be able to use paths and aliases as keys, instead of |
320
|
|
|
|
|
|
|
# database table names. |
321
|
|
|
|
|
|
|
# TOCHECK: is this stuff still compatible with the bind() method ? |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
# adjust join conditions for ON clause or for USING clause |
325
|
143
|
100
|
|
|
|
425
|
if (does $sqla_args{-from}, 'ARRAY') { |
326
|
43
|
50
|
|
|
|
480
|
$sqla_args{-from}[0] eq '-join' |
327
|
|
|
|
|
|
|
or croak "datasource is an arrayref but does not start with -join"; |
328
|
|
|
|
|
|
|
my $join_with_USING |
329
|
|
|
|
|
|
|
= exists $args->{-join_with_USING} ? $args->{-join_with_USING} |
330
|
43
|
100
|
|
|
|
122
|
: $self->schema->{join_with_USING}; |
331
|
43
|
|
|
|
|
96
|
for (my $i = 2; $i < @{$sqla_args{-from}}; $i += 2) { |
|
115
|
|
|
|
|
264
|
|
332
|
72
|
|
|
|
|
121
|
my $join_cond = $sqla_args{-from}[$i]; |
333
|
72
|
100
|
|
|
|
127
|
if ($join_with_USING) { |
334
|
4
|
50
|
|
|
|
15
|
delete $join_cond->{condition} if $join_cond->{using}; |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
else { |
337
|
68
|
|
|
|
|
167
|
delete $join_cond->{using}; |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
# generate SQL |
343
|
143
|
|
|
|
|
1468
|
my $sqla_result = $sql_abstract->select(%sqla_args); |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
# maybe post-process the SQL |
346
|
143
|
50
|
|
|
|
139362
|
if ($args->{-post_SQL}) { |
347
|
0
|
|
|
|
|
0
|
($sqla_result->{sql}, @{$sqla_result->{bind}}) |
348
|
0
|
|
|
|
|
0
|
= $args->{-post_SQL}->($sqla_result->{sql}, @{$sqla_result->{bind}}); |
|
0
|
|
|
|
|
0
|
|
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
# keep $sql / @bind / aliases in $self, and set new status |
352
|
143
|
|
|
|
|
419
|
$self->{bound_params} = $sqla_result->{bind}; |
353
|
143
|
|
|
|
|
873
|
$self->{$_} = $sqla_result->{$_} for qw/sql aliased_tables aliased_columns/; |
354
|
143
|
|
|
|
|
332
|
$self->{status} = SQLIZED; |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# analyze placeholders, and replace by pre_bound params if applicable |
357
|
143
|
50
|
|
|
|
428
|
if (my $regex = $self->{placeholder_regex}) { |
358
|
143
|
|
|
|
|
312
|
for (my $i = 0; $i < @{$self->{bound_params}}; $i++) { |
|
303
|
|
|
|
|
786
|
|
359
|
|
|
|
|
|
|
$self->{bound_params}[$i] =~ $regex |
360
|
160
|
100
|
|
|
|
754
|
and push @{$self->{param_indices}{$1}}, $i; |
|
30
|
|
|
|
|
211
|
|
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
} |
363
|
143
|
50
|
|
|
|
669
|
$self->bind($self->{pre_bound_params}) if $self->{pre_bound_params}; |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
# compute callback to apply to data rows |
366
|
143
|
|
|
|
|
283
|
my $callback = $self->{args}{-post_bless}; |
367
|
143
|
|
|
|
|
555
|
weaken(my $weak_self = $self); # weaken to avoid a circular ref in closure |
368
|
|
|
|
|
|
|
$self->{row_callback} = sub { |
369
|
114
|
|
|
114
|
|
174
|
my $row = shift; |
370
|
114
|
|
|
|
|
338
|
$weak_self->bless_from_DB($row); |
371
|
114
|
50
|
|
|
|
277
|
$callback->($row) if $callback; |
372
|
143
|
|
|
|
|
661
|
}; |
373
|
|
|
|
|
|
|
|
374
|
143
|
|
|
|
|
802
|
return $self; |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
sub prepare { |
380
|
137
|
|
|
137
|
0
|
295
|
my ($self, @args) = @_; |
381
|
|
|
|
|
|
|
|
382
|
137
|
|
|
|
|
396
|
my $meta_source = $self->meta_source; |
383
|
|
|
|
|
|
|
|
384
|
137
|
50
|
33
|
|
|
542
|
$self->sqlize(@args) if @args or $self->status < SQLIZED; |
385
|
|
|
|
|
|
|
|
386
|
136
|
50
|
|
|
|
381
|
$self->status == SQLIZED |
387
|
|
|
|
|
|
|
or croak "can't prepare() when in status " . $self->status; |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
# log the statement and bind values |
390
|
136
|
|
|
|
|
366
|
$self->schema->_debug("PREPARE $self->{sql} / @{$self->{bound_params}}"); |
|
136
|
|
|
|
|
1125
|
|
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
# call the database |
393
|
136
|
50
|
|
|
|
354
|
my $dbh = $self->schema->dbh or croak "Schema has no dbh"; |
394
|
|
|
|
|
|
|
my $method = $self->{args}{-dbi_prepare_method} |
395
|
136
|
|
33
|
|
|
644
|
|| $self->schema->dbi_prepare_method; |
396
|
136
|
|
|
|
|
385
|
my @prepare_args = ($self->{sql}); |
397
|
136
|
50
|
|
|
|
356
|
if (my $prepare_attrs = $self->{args}{-prepare_attrs}) { |
398
|
0
|
|
|
|
|
0
|
push @prepare_args, $prepare_attrs; |
399
|
|
|
|
|
|
|
} |
400
|
136
|
|
|
|
|
1199
|
$self->{sth} = $dbh->$method(@prepare_args); |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
# new status and return |
403
|
136
|
|
|
|
|
25062
|
$self->{status} = PREPARED; |
404
|
136
|
|
|
|
|
359
|
return $self; |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
sub sth { |
409
|
502
|
|
|
502
|
0
|
1003
|
my ($self) = @_; |
410
|
|
|
|
|
|
|
|
411
|
502
|
50
|
|
|
|
1300
|
$self->prepare if $self->status < PREPARED; |
412
|
502
|
|
|
|
|
1750
|
return $self->{sth}; |
413
|
|
|
|
|
|
|
} |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
sub execute { |
418
|
137
|
|
|
137
|
0
|
437
|
my ($self, @bind_args) = @_; |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
# if not prepared yet, prepare it |
421
|
137
|
100
|
|
|
|
326
|
$self->prepare if $self->status < PREPARED; |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
# TODO: DON'T REMEMBER why the line below was here. Keep it around for a while ... |
424
|
136
|
50
|
|
|
|
466
|
push @bind_args, offset => $self->{offset} if $self->{offset}; |
425
|
|
|
|
|
|
|
|
426
|
136
|
100
|
|
|
|
383
|
$self->bind(@bind_args) if @bind_args; |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
# shortcuts |
429
|
136
|
|
|
|
|
266
|
my $args = $self->{args}; |
430
|
136
|
|
|
|
|
405
|
my $sth = $self->sth; |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
# previous row_count, row_num and reuse_row are no longer valid |
433
|
136
|
|
|
|
|
350
|
delete $self->{reuse_row}; |
434
|
136
|
|
|
|
|
279
|
delete $self->{row_count}; |
435
|
136
|
|
|
|
|
375
|
$self->{row_num} = $self->offset; |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
# pre_exec callback |
438
|
136
|
100
|
|
|
|
428
|
$args->{-pre_exec}->($sth) if $args->{-pre_exec}; |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
# check that all placeholders were properly bound to values |
441
|
136
|
|
|
|
|
271
|
my @unbound; |
442
|
136
|
100
|
|
|
|
236
|
while (my ($k, $indices) = each %{$self->{param_indices} || {}}) { |
|
166
|
|
|
|
|
939
|
|
443
|
30
|
50
|
|
|
|
114
|
exists $self->{bound_params}[$indices->[0]] or push @unbound, $k; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
not @unbound |
446
|
136
|
50
|
|
|
|
427
|
or croak "unbound placeholders (probably a missing foreign key) : " |
447
|
|
|
|
|
|
|
. CORE::join(", ", @unbound); |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
# bind parameters and execute |
450
|
136
|
|
|
|
|
343
|
my $sqla = $self->schema->sql_abstract; |
451
|
136
|
|
|
|
|
268
|
$sqla->bind_params($sth, @{$self->{bound_params}}); |
|
136
|
|
|
|
|
731
|
|
452
|
136
|
|
|
|
|
9025
|
$sth->execute; |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
# post_exec callback |
455
|
136
|
100
|
|
|
|
16844
|
$args->{-post_exec}->($sth) if $args->{-post_exec}; |
456
|
|
|
|
|
|
|
|
457
|
136
|
|
|
|
|
330
|
$self->{status} = EXECUTED; |
458
|
136
|
|
|
|
|
307
|
return $self; |
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
my %cache_result_class; |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
sub select { |
468
|
145
|
|
|
145
|
0
|
281
|
my $self = shift; |
469
|
|
|
|
|
|
|
|
470
|
145
|
100
|
|
|
|
647
|
$self->refine(@_) if @_; |
471
|
|
|
|
|
|
|
|
472
|
143
|
|
100
|
|
|
478
|
my $arg_result_as = $self->arg(-result_as) || 'rows'; |
473
|
|
|
|
|
|
|
|
474
|
143
|
100
|
|
|
|
504
|
SWITCH: |
475
|
|
|
|
|
|
|
my ($result_as, @subclass_args) |
476
|
|
|
|
|
|
|
= does($arg_result_as, 'ARRAY') ? @$arg_result_as : ($arg_result_as); |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
# historically,some kinds of results accepted various aliases |
479
|
143
|
|
|
|
|
1328
|
$result_as =~ s/^flat(?:_array|)$/flat_arrayref/; |
480
|
143
|
|
|
|
|
266
|
$result_as =~ s/^arrayref$/rows/; |
481
|
143
|
|
|
|
|
228
|
$result_as =~ s/^fast-statement$/fast_statement/; |
482
|
|
|
|
|
|
|
|
483
|
143
|
|
|
|
|
323
|
for ($result_as) { |
484
|
143
|
50
|
100
|
|
|
640
|
my $subclass = $cache_result_class{$_} |
485
|
|
|
|
|
|
|
||= $self->_find_result_class($_) |
486
|
|
|
|
|
|
|
or croak "didn't find any ResultAs subclass to implement -result_as => '$_'"; |
487
|
142
|
|
|
|
|
838
|
my $result_maker = $subclass->new(@subclass_args); |
488
|
142
|
|
|
|
|
501
|
return $result_maker->get_result($self); |
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
sub row_count { |
494
|
6
|
|
|
6
|
0
|
25895
|
my ($self) = @_; |
495
|
|
|
|
|
|
|
|
496
|
6
|
50
|
|
|
|
23
|
if (! exists $self->{row_count}) { |
497
|
6
|
100
|
|
|
|
21
|
$self->sqlize if $self->status < SQLIZED; |
498
|
6
|
|
|
|
|
20
|
my ($sql, @bind) = $self->sql; |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
# get syntax used for LIMIT clauses ... |
501
|
6
|
|
|
|
|
58
|
my $sqla = $self->schema->sql_abstract; |
502
|
6
|
|
|
|
|
24
|
my ($limit_sql, undef, undef) = $sqla->limit_offset(0, 0); |
503
|
6
|
|
|
|
|
140
|
$limit_sql =~ s/([()?*])/\\$1/g; |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
# ...and use it to remove the LIMIT clause and associated bind vals, if any |
506
|
6
|
100
|
|
|
|
89
|
if ($limit_sql =~ /ROWNUM/) { # special case for Oracle syntax, complex ... |
|
|
100
|
|
|
|
|
|
507
|
|
|
|
|
|
|
# see source code of SQL::Abstract::More |
508
|
2
|
|
|
|
|
18
|
$limit_sql =~ s/%s/(.*)/; |
509
|
2
|
100
|
|
|
|
40
|
if ($sql =~ s/^$limit_sql/$1/) { |
510
|
1
|
|
|
|
|
4
|
splice @bind, -2; |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
elsif ($sql =~ s[\b$limit_sql][]i) { # regular LIMIT/OFFSET syntaxes |
514
|
3
|
|
|
|
|
9
|
splice @bind, -2; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
# decide if the SELECT COUNT should wrap the original SQL in a subquery; |
518
|
|
|
|
|
|
|
# this is needed with clauses like below that change the number of rows |
519
|
6
|
|
|
|
|
36
|
my $should_wrap = $sql =~ /\b(UNION|INTERSECT|MINUS|EXCEPT|DISTINCT)\b/i; |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
# if no wrap required, attempt to directly substitute COUNT(*) for the |
522
|
|
|
|
|
|
|
# column names ...but if it fails, wrap anyway |
523
|
6
|
|
66
|
|
|
38
|
$should_wrap ||= ! ($sql =~ s[^SELECT\b.*?\bFROM\b][SELECT COUNT(*) FROM]i); |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
# wrap SQL if needed, using a subquery alias because it's required for |
526
|
|
|
|
|
|
|
# some DBMS (like PostgreSQL) |
527
|
6
|
100
|
|
|
|
24
|
$should_wrap and $sql = "SELECT COUNT(*) FROM " |
528
|
|
|
|
|
|
|
. $sqla->table_alias("( $sql )", "count_wrapper"); |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
# log the statement and bind values |
531
|
6
|
|
|
|
|
122
|
$self->schema->_debug("PREPARE $sql / @bind"); |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
# call the database |
534
|
6
|
50
|
|
|
|
15
|
my $dbh = $self->schema->dbh or croak "Schema has no dbh"; |
535
|
6
|
|
|
|
|
16
|
my $method = $self->schema->dbi_prepare_method; |
536
|
6
|
|
|
|
|
40
|
my $sth = $dbh->$method($sql); |
537
|
6
|
|
|
|
|
903
|
$sth->execute(@bind); |
538
|
6
|
|
|
|
|
705
|
($self->{row_count}) = $sth->fetchrow_array; |
539
|
6
|
|
|
|
|
229
|
$sth->finish; |
540
|
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
|
542
|
6
|
|
|
|
|
191
|
return $self->{row_count}; |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
sub row_num { |
547
|
132
|
|
|
132
|
0
|
277
|
my ($self) = @_; |
548
|
132
|
|
|
|
|
328
|
return $self->{row_num}; |
549
|
|
|
|
|
|
|
} |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
sub next { |
553
|
180
|
|
|
180
|
0
|
395
|
my ($self, $n_rows) = @_; |
554
|
|
|
|
|
|
|
|
555
|
180
|
100
|
|
|
|
478
|
$self->execute if $self->status < EXECUTED; |
556
|
|
|
|
|
|
|
|
557
|
179
|
50
|
|
|
|
431
|
my $sth = $self->sth or croak "absent sth in statement"; |
558
|
179
|
50
|
|
|
|
492
|
my $callback = $self->{row_callback} or croak "absent callback in statement"; |
559
|
|
|
|
|
|
|
|
560
|
179
|
100
|
|
|
|
447
|
if (not defined $n_rows) { # if user wants a single row |
561
|
|
|
|
|
|
|
# fetch a single record, either into the reusable row, or into a fresh hash |
562
|
|
|
|
|
|
|
my $row = $self->{reuse_row} ? ($sth->fetch ? $self->{reuse_row} : undef) |
563
|
85
|
100
|
|
|
|
412
|
: $sth->fetchrow_hashref; |
|
|
100
|
|
|
|
|
|
564
|
85
|
100
|
|
|
|
5843
|
if ($row) { |
565
|
51
|
|
|
|
|
129
|
$callback->($row); |
566
|
51
|
|
|
|
|
95
|
$self->{row_num} +=1; |
567
|
|
|
|
|
|
|
} |
568
|
85
|
|
|
|
|
278
|
return $row; |
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
else { # if user wants an arrayref of size $n_rows |
571
|
94
|
50
|
|
|
|
237
|
$n_rows > 0 or croak "->next() : invalid argument, $n_rows"; |
572
|
94
|
50
|
|
|
|
271
|
not $self->{reuse_row} or croak "reusable row, cannot retrieve several"; |
573
|
94
|
|
|
|
|
161
|
my @rows; |
574
|
94
|
|
|
|
|
256
|
while ($n_rows--) { |
575
|
157
|
100
|
|
|
|
578
|
my $row = $sth->fetchrow_hashref or last; |
576
|
63
|
|
|
|
|
4980
|
push @rows, $row; |
577
|
|
|
|
|
|
|
} |
578
|
94
|
|
|
|
|
5643
|
$callback->($_) foreach @rows; |
579
|
94
|
|
|
|
|
189
|
$self->{row_num} += @rows; |
580
|
94
|
|
|
|
|
295
|
return \@rows; |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
# NOTE: ->next() returns a $row, while ->next(1) returns an arrayref of 1 row |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
sub all { |
588
|
95
|
|
|
95
|
0
|
236
|
my ($self) = @_; |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
# just call next() with a huge number |
591
|
95
|
|
|
|
|
251
|
return $self->_next_and_finish(POSIX::LONG_MAX); |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
|
595
|
135
|
100
|
|
135
|
0
|
655
|
sub page_size { shift->{args}{-page_size} || POSIX::LONG_MAX } |
596
|
135
|
100
|
|
135
|
0
|
740
|
sub page_index { shift->{args}{-page_index} || 1 } |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
sub offset { |
599
|
269
|
|
|
269
|
0
|
522
|
my ($self) = @_; |
600
|
|
|
|
|
|
|
|
601
|
269
|
100
|
|
|
|
693
|
if (!exists $self->{offset}) { |
602
|
|
|
|
|
|
|
# compute on demand -- will default to 0 if there is no pagination |
603
|
|
|
|
|
|
|
$self->{offset} = exists $self->{args}{-offset} ? $self->{args}{-offset} |
604
|
136
|
100
|
|
|
|
534
|
: ($self->page_index - 1) * $self->page_size; |
605
|
|
|
|
|
|
|
} |
606
|
|
|
|
|
|
|
|
607
|
269
|
|
|
|
|
704
|
return $self->{offset}; |
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
sub page_count { |
613
|
0
|
|
|
0
|
0
|
0
|
my ($self) = @_; |
614
|
|
|
|
|
|
|
|
615
|
0
|
0
|
|
|
|
0
|
my $row_count = $self->row_count or return 0; |
616
|
0
|
|
0
|
|
|
0
|
my $page_size = $self->page_size || 1; |
617
|
|
|
|
|
|
|
|
618
|
0
|
|
|
|
|
0
|
return int(($row_count - 1) / $page_size) + 1; |
619
|
|
|
|
|
|
|
} |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
sub page_boundaries { |
623
|
1
|
|
|
1
|
0
|
6
|
my ($self) = @_; |
624
|
|
|
|
|
|
|
|
625
|
1
|
|
|
|
|
4
|
my $first = $self->offset + 1; |
626
|
1
|
|
|
|
|
4
|
my $last = $self->offset + $self->nb_fetched_rows; |
627
|
|
|
|
|
|
|
|
628
|
1
|
|
|
|
|
6
|
return ($first, $last); |
629
|
|
|
|
|
|
|
} |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
sub page_rows { |
633
|
0
|
|
|
0
|
0
|
0
|
my ($self) = @_; |
634
|
0
|
|
|
|
|
0
|
return $self->_next_and_finish($self->page_size); |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
sub bless_from_DB { |
639
|
135
|
|
|
135
|
0
|
281
|
my ($self, $row) = @_; |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
# inject ref to $schema if in multi-schema mode or if temporary |
642
|
|
|
|
|
|
|
# db_schema is set |
643
|
135
|
|
|
|
|
309
|
my $schema = $self->schema; |
644
|
|
|
|
|
|
|
$row->{__schema} = $schema unless $schema->{is_singleton} |
645
|
135
|
100
|
66
|
|
|
634
|
&& !$schema->{db_schema}; |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
# bless into appropriate class |
648
|
135
|
|
|
|
|
317
|
bless $row, $self->meta_source->class; |
649
|
|
|
|
|
|
|
# apply handlers |
650
|
135
|
100
|
|
|
|
523
|
$self->{from_DB_handlers} or $self->_compute_from_DB_handlers; |
651
|
135
|
|
|
|
|
232
|
while (my ($column_name, $handler) |
652
|
392
|
|
|
|
|
1176
|
= each %{$self->{from_DB_handlers}}) { |
653
|
|
|
|
|
|
|
exists $row->{$column_name} |
654
|
257
|
100
|
|
|
|
690
|
and $handler->($row->{$column_name}, $row, $column_name, 'from_DB'); |
655
|
|
|
|
|
|
|
} |
656
|
|
|
|
|
|
|
|
657
|
135
|
|
|
|
|
450
|
return $row; |
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
sub headers { |
662
|
22
|
|
|
22
|
0
|
40
|
my $self = shift; |
663
|
|
|
|
|
|
|
|
664
|
22
|
50
|
|
|
|
58
|
$self->status == EXECUTED |
665
|
|
|
|
|
|
|
or $self->execute(@_); |
666
|
|
|
|
|
|
|
|
667
|
22
|
|
50
|
|
|
48
|
my $hash_key_name = $self->sth->{FetchHashKeyName} || 'NAME'; |
668
|
22
|
|
|
|
|
58
|
return @{$self->sth->{$hash_key_name}}; |
|
22
|
|
|
|
|
43
|
|
669
|
|
|
|
|
|
|
} |
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
sub finish { |
673
|
131
|
|
|
131
|
0
|
242
|
my $self = shift; |
674
|
|
|
|
|
|
|
|
675
|
131
|
|
|
|
|
336
|
$self->{nb_fetched_rows} = $self->row_num - $self->offset; |
676
|
131
|
|
|
|
|
318
|
$self->sth->finish; |
677
|
|
|
|
|
|
|
} |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
sub nb_fetched_rows { |
681
|
2
|
|
|
2
|
0
|
9
|
my ($self) = @_; |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
exists $self->{nb_fetched_rows} |
684
|
2
|
50
|
|
|
|
7
|
or croak "->nb_fetched_rows() can only be called on a finished statement"; |
685
|
|
|
|
|
|
|
|
686
|
2
|
|
|
|
|
10
|
return $self->{nb_fetched_rows}; |
687
|
|
|
|
|
|
|
} |
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
sub make_fast { |
693
|
11
|
|
|
11
|
0
|
41
|
my ($self) = @_; |
694
|
|
|
|
|
|
|
|
695
|
11
|
50
|
|
|
|
37
|
$self->status == EXECUTED |
696
|
|
|
|
|
|
|
or croak "cannot make_fast() when in state " . $self->status; |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
# create a reusable hash and bind_columns to it (see L) |
699
|
11
|
|
|
|
|
31
|
my %row; |
700
|
11
|
|
|
|
|
29
|
$self->sth->bind_columns(\(@row{$self->headers})); |
701
|
11
|
|
|
|
|
1205
|
$self->{reuse_row} = \%row; |
702
|
|
|
|
|
|
|
} |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
706
|
|
|
|
|
|
|
# PRIVATE METHODS IN RELATION WITH SELECT() |
707
|
|
|
|
|
|
|
#---------------------------------------------------------------------- |
708
|
|
|
|
|
|
|
|
709
|
|
|
|
|
|
|
sub _forbid_callbacks { |
710
|
5
|
|
|
5
|
|
15
|
my ($self, $subclass) = @_; |
711
|
|
|
|
|
|
|
|
712
|
5
|
|
|
|
|
19
|
my $callbacks = CORE::join ", ", grep {$self->arg($_)} |
|
15
|
|
|
|
|
29
|
|
713
|
|
|
|
|
|
|
qw/-pre_exec -post_exec -post_bless/; |
714
|
5
|
50
|
|
|
|
23
|
if ($callbacks) { |
715
|
0
|
|
|
|
|
0
|
$subclass =~ s/^.*:://; |
716
|
0
|
|
|
|
|
0
|
croak "$callbacks incompatible with -result_as=>'$subclass'"; |
717
|
|
|
|
|
|
|
} |
718
|
|
|
|
|
|
|
} |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
sub _next_and_finish { |
723
|
113
|
|
|
113
|
|
179
|
my $self = shift; |
724
|
113
|
|
|
|
|
312
|
my $row_or_rows = $self->next( @_ ); # pass original parameters |
725
|
112
|
|
|
|
|
382
|
$self->finish; |
726
|
112
|
|
|
|
|
4118
|
return $row_or_rows; |
727
|
|
|
|
|
|
|
} |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
sub _compute_from_DB_handlers { |
730
|
61
|
|
|
61
|
|
155
|
my ($self) = @_; |
731
|
61
|
|
|
|
|
133
|
my $meta_source = $self->meta_source; |
732
|
61
|
|
|
|
|
141
|
my $meta_schema = $self->schema->metadm; |
733
|
61
|
|
|
|
|
296
|
my %handlers = $meta_source->_consolidate_hash('column_handlers'); |
734
|
61
|
|
|
|
|
284
|
my %aliased_tables = $meta_source->aliased_tables; |
735
|
|
|
|
|
|
|
|
736
|
|
|
|
|
|
|
# iterate over aliased_columns |
737
|
61
|
100
|
|
|
|
144
|
while (my ($alias, $column) = each %{$self->{aliased_columns} || {}}) { |
|
82
|
|
|
|
|
436
|
|
738
|
21
|
|
|
|
|
40
|
my $table_name; |
739
|
21
|
100
|
|
|
|
116
|
$column =~ s{^([^()]+) # supposed table name (without parens) |
740
|
|
|
|
|
|
|
\. # followed by a dot |
741
|
|
|
|
|
|
|
(?=[^()]+$) # followed by supposed col name (without parens) |
742
|
|
|
|
|
|
|
}{}x |
743
|
|
|
|
|
|
|
and $table_name = $1; |
744
|
21
|
100
|
|
|
|
56
|
if (!$table_name) { |
745
|
12
|
|
|
|
|
37
|
$handlers{$alias} = $handlers{$column}; |
746
|
|
|
|
|
|
|
} |
747
|
|
|
|
|
|
|
else { |
748
|
9
|
|
66
|
|
|
38
|
$table_name = $aliased_tables{$table_name} || $table_name; |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
my $table = $meta_schema->table($table_name) |
751
|
16
|
|
|
16
|
|
84
|
|| (firstval {($_->{db_name} || '') eq $table_name} |
752
|
|
|
|
|
|
|
($meta_source, $meta_source->ancestors)) |
753
|
0
|
|
|
0
|
|
0
|
|| (firstval {uc($_->{db_name} || '') eq uc($table_name)} |
754
|
9
|
50
|
33
|
|
|
31
|
($meta_source, $meta_source->ancestors)) |
755
|
|
|
|
|
|
|
or croak "unknown table name: $table_name"; |
756
|
|
|
|
|
|
|
|
757
|
9
|
|
|
|
|
38
|
$handlers{$alias} = $table->{column_handlers}->{$column}; |
758
|
|
|
|
|
|
|
} |
759
|
|
|
|
|
|
|
} |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
# handlers may be overridden from args{-column_types} |
762
|
61
|
100
|
|
|
|
251
|
if (my $col_types = $self->{args}{-column_types}) { |
763
|
1
|
|
|
|
|
5
|
while (my ($type_name, $columns) = each %$col_types) { |
764
|
1
|
50
|
|
|
|
6
|
$columns = [$columns] unless does $columns, 'ARRAY'; |
765
|
1
|
50
|
|
|
|
16
|
my $type = $self->schema->metadm->type($type_name) |
766
|
|
|
|
|
|
|
or croak "no such column type: $type_name"; |
767
|
1
|
|
|
|
|
8
|
$handlers{$_} = $type->{handlers} foreach @$columns; |
768
|
|
|
|
|
|
|
} |
769
|
|
|
|
|
|
|
} |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
# just keep the "from_DB" handlers |
772
|
61
|
|
|
|
|
123
|
my $from_DB_handlers = {}; |
773
|
61
|
|
|
|
|
207
|
while (my ($column, $col_handlers) = each %handlers) { |
774
|
161
|
100
|
|
|
|
452
|
my $from_DB_handler = $col_handlers->{from_DB} or next; |
775
|
113
|
|
|
|
|
321
|
$from_DB_handlers->{$column} = $from_DB_handler; |
776
|
|
|
|
|
|
|
} |
777
|
61
|
|
|
|
|
164
|
$self->{from_DB_handlers} = $from_DB_handlers; |
778
|
|
|
|
|
|
|
|
779
|
61
|
|
|
|
|
156
|
return $self; |
780
|
|
|
|
|
|
|
} |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
sub _find_result_class { |
783
|
35
|
|
|
35
|
|
77
|
my $self = shift; |
784
|
35
|
|
|
|
|
112
|
my $name = ucfirst shift; |
785
|
35
|
|
|
|
|
104
|
my $schema = $self->schema; |
786
|
35
|
|
33
|
|
|
138
|
my $schema_class = ref $schema || $schema; |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
# try to find subclass $name within namespace of schema or ancestors |
789
|
35
|
|
|
|
|
95
|
foreach my $namespace (@{$schema->resultAs_classes}) { |
|
35
|
|
|
|
|
168
|
|
790
|
68
|
|
|
|
|
219
|
my $class = "${namespace}::ResultAs::${name}"; |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
# see if that class is already loaded (by checking for a 'get_result' method) |
793
|
68
|
|
|
|
|
110
|
my $is_loaded = defined &{$class."::get_result"}; |
|
68
|
|
|
|
|
369
|
|
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
# otherwise, try to load the module |
796
|
68
|
|
|
68
|
|
3771
|
$is_loaded ||= try {load $class; 1} |
|
34
|
|
|
|
|
1051
|
|
797
|
68
|
100
|
66
|
34
|
|
744
|
catch {die $_ if $_ !~ /^Can't locate(?! object method)/}; |
|
34
|
|
|
|
|
1397
|
|
798
|
|
|
|
|
|
|
|
799
|
67
|
100
|
|
|
|
1140
|
return $class if $is_loaded; # true : class is found, exit loop |
800
|
|
|
|
|
|
|
} |
801
|
|
|
|
|
|
|
|
802
|
0
|
|
|
|
|
|
return; # false : class not found |
803
|
|
|
|
|
|
|
} |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
1; # End of DBIx::DataModel::Statement |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
__END__ |