line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package DBIx::Oro; |
2
|
23
|
|
|
23
|
|
33995
|
use strict; |
|
23
|
|
|
|
|
49
|
|
|
23
|
|
|
|
|
730
|
|
3
|
23
|
|
|
23
|
|
137
|
use warnings; |
|
23
|
|
|
|
|
56
|
|
|
23
|
|
|
|
|
1182
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '0.32_1'; |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
# See the bottom of this file for the POD documentation. |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
# Todo: Fix treatments in joined tables! |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
# Todo: Are combined indices necessarily in the same order? |
12
|
|
|
|
|
|
|
# In that case update and select etc. need ordered |
13
|
|
|
|
|
|
|
# keys! |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# Todo: Improve documentation |
16
|
|
|
|
|
|
|
# - =head1 ADVANCED CONCEPTS |
17
|
|
|
|
|
|
|
# - Joined tables |
18
|
|
|
|
|
|
|
# - Treatments |
19
|
|
|
|
|
|
|
# - Caching |
20
|
|
|
|
|
|
|
# - Injected SQL |
21
|
|
|
|
|
|
|
# - explain |
22
|
|
|
|
|
|
|
# - on_connect |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# Todo: -prefix is not documented! |
25
|
|
|
|
|
|
|
# Todo: Put 'created' in SQLite driver |
26
|
|
|
|
|
|
|
# implement ->errstr |
27
|
|
|
|
|
|
|
# implement "-with" (?) |
28
|
|
|
|
|
|
|
# Debug: $lemma_oro->insert({ |
29
|
|
|
|
|
|
|
# wcl => $_, |
30
|
|
|
|
|
|
|
# lemma => $inter |
31
|
|
|
|
|
|
|
# },{ |
32
|
|
|
|
|
|
|
# token => $search_for |
33
|
|
|
|
|
|
|
# }); |
34
|
|
|
|
|
|
|
# (Should raise error) |
35
|
|
|
|
|
|
|
# Todo: Support left outer join (Maybe with id => 1, maybe => 1 in join hash) |
36
|
|
|
|
|
|
|
# Todo: Create all Queries in DBIx::Oro::Query |
37
|
|
|
|
|
|
|
# Todo: To change queries from different drivers, |
38
|
|
|
|
|
|
|
# use events. |
39
|
|
|
|
|
|
|
# Todo: Return key -column_order => [] with fetchall_arrayref. |
40
|
|
|
|
|
|
|
# Todo: my $value = $oro->value(Table => 'Field') # Ähnlich wie count |
41
|
|
|
|
|
|
|
# Todo: Oder my ($value) = $oro->value(Table => Field => { -limit => 1 }) # und es gibt ein Array zurück |
42
|
|
|
|
|
|
|
# Todo: Check for BDB-support: |
43
|
|
|
|
|
|
|
# http://charlesleifer.com/blog/sqlite-small-fast-reliable-choose-any-three-/ |
44
|
|
|
|
|
|
|
|
45
|
23
|
|
|
23
|
|
341
|
use v5.10.1; |
|
23
|
|
|
|
|
73
|
|
46
|
|
|
|
|
|
|
|
47
|
23
|
|
|
23
|
|
181
|
use Scalar::Util qw/blessed/; |
|
23
|
|
|
|
|
50
|
|
|
23
|
|
|
|
|
1400
|
|
48
|
23
|
|
|
23
|
|
150
|
use Carp qw/carp croak/; |
|
23
|
|
|
|
|
57
|
|
|
23
|
|
|
|
|
1487
|
|
49
|
|
|
|
|
|
|
our @CARP_NOT; |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# Database connection |
52
|
23
|
|
|
23
|
|
37311
|
use DBI; |
|
23
|
|
|
|
|
407194
|
|
|
23
|
|
|
|
|
230542
|
|
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
our $AS_REGEX = qr/(?::~?`?[-_a-zA-Z0-9]+`?)/; |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
our $OP_REGEX = qr/^(?i: |
57
|
|
|
|
|
|
|
(?:[\<\>\!=]?\=?)|<>| |
58
|
|
|
|
|
|
|
(?:!|not[_ ])? |
59
|
|
|
|
|
|
|
(?:match|like|glob|regex|between)| |
60
|
|
|
|
|
|
|
(?:eq|ne|[gl][te]|not) |
61
|
|
|
|
|
|
|
)$/x; |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
our $KEY_REGEX = qr/`?[_\.0-9a-zA-Z]+`?/; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
our $KEY_REGEX_NOPREF = qr/`?[_0-9a-zA-Z]+`?/; |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
our $NUM_RE = qr/^\s*(\d+)\s*$/; |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
our $SFIELD_REGEX = |
70
|
|
|
|
|
|
|
qr/(?:$KEY_REGEX|(?:$KEY_REGEX\.)?\*|"[^"]*"|'[^']*')/; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
our $FIELD_OP_REGEX = qr/[-\+\/\%\*,]/; |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
our $FUNCTION_REGEX = |
75
|
|
|
|
|
|
|
qr/([_a-zA-Z0-9]* |
76
|
|
|
|
|
|
|
\(\s*(?:$SFIELD_REGEX|(?-1)) |
77
|
|
|
|
|
|
|
(?:\s*$FIELD_OP_REGEX\s*(?:$SFIELD_REGEX|(?-1)))*\s*\))/x; |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
our $VALID_FIELD_REGEX = |
80
|
|
|
|
|
|
|
qr/^(?:$SFIELD_REGEX|$FUNCTION_REGEX)$AS_REGEX?$/; |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
our $VALID_GROUPORDER_REGEX = |
83
|
|
|
|
|
|
|
qr/^[-\+]?(?:$KEY_REGEX|$FUNCTION_REGEX)$/; |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
our $FIELD_REST_RE = qr/^(.+?)(:~?)([^:"~][^:"]*?)$/; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
our $CACHE_COMMENT = 'From Cache'; |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
our $ITEMS_PER_PAGE = 25; |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
our @EXTENSIONS = (); |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# Import extension |
94
|
|
|
|
|
|
|
sub import { |
95
|
46
|
|
|
46
|
|
741
|
my $class = shift; |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
# Load extensions |
98
|
46
|
|
|
|
|
1465
|
foreach (@_) { |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# Load extensions |
101
|
0
|
|
|
|
|
0
|
my $module = qq{DBIx::Oro::Extension::$_}; |
102
|
0
|
0
|
|
|
|
0
|
unless (eval "require $module; 1;") { |
103
|
0
|
0
|
|
|
|
0
|
croak qq{Unable to load extension "$_"} and return; |
104
|
|
|
|
|
|
|
}; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
# Push to extension array |
107
|
0
|
|
|
|
|
0
|
push(@EXTENSIONS, $_); |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# Start import for extensions |
110
|
0
|
|
|
|
|
0
|
$module->import; |
111
|
|
|
|
|
|
|
}; |
112
|
|
|
|
|
|
|
}; |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
# Constructor |
116
|
|
|
|
|
|
|
sub new { |
117
|
27
|
|
|
27
|
1
|
20636
|
my $class = shift; |
118
|
27
|
|
|
|
|
52
|
my ($self, %param); |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
# SQLite - one parameter |
121
|
27
|
100
|
66
|
|
|
240
|
if (@_ == 1) { |
|
|
100
|
66
|
|
|
|
|
122
|
1
|
|
|
|
|
3
|
@param{qw/driver file/} = ('SQLite', shift); |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# SQLite - two parameter |
126
|
|
|
|
|
|
|
elsif (@_ == 2 && ref $_[1] && ref $_[1] eq 'CODE') { |
127
|
6
|
|
|
|
|
26
|
@param{qw/driver file init/} = ('SQLite', @_); |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
# Hash |
131
|
|
|
|
|
|
|
else { |
132
|
20
|
|
|
|
|
72
|
%param = @_; |
133
|
|
|
|
|
|
|
}; |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# Init by default |
136
|
27
|
|
|
|
|
42
|
${$param{in_txn}} = 0; |
|
27
|
|
|
|
|
63
|
|
137
|
27
|
|
|
|
|
72
|
$param{last_sql} = ''; |
138
|
|
|
|
|
|
|
|
139
|
27
|
|
|
|
|
55
|
my $pwd = delete $param{password}; |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
# Set default to SQLite |
142
|
27
|
|
100
|
|
|
88
|
$param{driver} //= 'SQLite'; |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
# Load driver |
145
|
27
|
|
|
|
|
77
|
my $package = 'DBIx::Oro::Driver::' . $param{driver}; |
146
|
27
|
50
|
|
|
|
1777
|
unless (eval 'require ' . $package . '; 1;') { |
147
|
0
|
|
|
|
|
0
|
croak 'Unable to load ' . $package; |
148
|
0
|
|
|
|
|
0
|
return; |
149
|
|
|
|
|
|
|
}; |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# On_connect event |
152
|
27
|
|
|
|
|
111
|
my $on_connect = delete $param{on_connect}; |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# Get driver specific handle |
155
|
27
|
|
|
|
|
237
|
$self = $package->new( %param ); |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
# No database created |
158
|
27
|
50
|
|
|
|
103
|
return unless $self; |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
# Connection identifier (for _password) |
161
|
27
|
|
|
|
|
85
|
$self->{_id} = "$self"; |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# Set password securely |
164
|
27
|
50
|
|
|
|
86
|
$self->_password($pwd) if $pwd; |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# On connect events |
167
|
27
|
|
|
|
|
57
|
$self->{on_connect} = {}; |
168
|
27
|
|
|
|
|
56
|
$self->{_connect_cb} = 1; |
169
|
|
|
|
|
|
|
|
170
|
27
|
50
|
|
|
|
63
|
if ($on_connect) { |
171
|
0
|
0
|
|
|
|
0
|
$self->on_connect( |
|
|
0
|
|
|
|
|
|
172
|
|
|
|
|
|
|
ref $on_connect eq 'HASH' ? |
173
|
|
|
|
|
|
|
%$on_connect : $on_connect |
174
|
|
|
|
|
|
|
) or return; |
175
|
|
|
|
|
|
|
}; |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
# Connect to database |
178
|
27
|
50
|
|
|
|
94
|
$self->_connect or croak 'Unable to connect to database'; |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
# Savepoint array |
181
|
|
|
|
|
|
|
# First element is a counter |
182
|
27
|
|
|
|
|
156
|
$self->{savepoint} = [1]; |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
# Initialize database and return Oro instance |
185
|
27
|
50
|
|
|
|
166
|
return $self if $self->_init; |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
# Fail |
188
|
0
|
|
|
|
|
0
|
return; |
189
|
|
|
|
|
|
|
}; |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# New table object |
193
|
|
|
|
|
|
|
sub table { |
194
|
26
|
|
|
26
|
1
|
34
|
my $self = shift; |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# Joined table |
197
|
|
|
|
|
|
|
my %param = ( |
198
|
26
|
|
|
|
|
34
|
table => do { |
199
|
26
|
100
|
|
|
|
60
|
if (ref($_[0])) { |
200
|
3
|
|
|
|
|
15
|
[ _join_tables( shift(@_) ) ]; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
# Table name |
204
|
|
|
|
|
|
|
else { |
205
|
23
|
|
|
|
|
76
|
shift; |
206
|
|
|
|
|
|
|
}; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
); |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
# Clone parameters |
211
|
26
|
|
|
|
|
70
|
foreach (qw/dbh created in_txn savepoint pid tid |
212
|
|
|
|
|
|
|
dsn _connect_cb on_connect/) { |
213
|
234
|
|
|
|
|
415
|
$param{$_} = $self->{$_}; |
214
|
|
|
|
|
|
|
}; |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
# Connection identifier (for _password) |
217
|
26
|
|
|
|
|
72
|
$param{_id} = "$self"; |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
# Bless object with hash |
220
|
26
|
|
|
|
|
97
|
bless \%param, ref $self; |
221
|
|
|
|
|
|
|
}; |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# Database handle |
225
|
|
|
|
|
|
|
# Based on DBIx::Connector |
226
|
|
|
|
|
|
|
sub dbh { |
227
|
1431
|
|
|
1431
|
1
|
5772
|
my $self = shift; |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
# Store new database handle |
230
|
1431
|
50
|
|
|
|
2465
|
return ($self->{dbh} = shift) if $_[0]; |
231
|
|
|
|
|
|
|
|
232
|
1431
|
100
|
|
|
|
1425
|
return $self->{dbh} if ${$self->{in_txn}}; |
|
1431
|
|
|
|
|
3533
|
|
233
|
|
|
|
|
|
|
|
234
|
510
|
|
|
|
|
747
|
state $c = 'Unable to connect to database'; |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
# Check for thread id |
237
|
510
|
50
|
33
|
|
|
6022
|
if (defined $self->{tid} && $self->{tid} != threads->tid) { |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
238
|
0
|
|
0
|
|
|
0
|
return $self->_connect || croak $c; |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
# Check for process id |
242
|
|
|
|
|
|
|
elsif ($self->{pid} != $$) { |
243
|
0
|
|
0
|
|
|
0
|
return $self->_connect || croak $c; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
elsif ($self->{dbh}->{Active}) { |
247
|
507
|
|
|
|
|
1819
|
return $self->{dbh}; |
248
|
|
|
|
|
|
|
}; |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
# Return handle if active |
251
|
3
|
|
33
|
|
|
16
|
return $self->_connect || croak $c; |
252
|
|
|
|
|
|
|
}; |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
# Last executed SQL |
256
|
|
|
|
|
|
|
sub last_sql { |
257
|
29
|
|
|
29
|
1
|
1010
|
my $self = shift; |
258
|
29
|
|
|
|
|
65
|
my $last_sql = $self->{last_sql}; |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
# Check for recurrent placeholders |
261
|
29
|
50
|
|
|
|
454
|
if ($last_sql =~ m/(?:UNION|\?(?:, \?){3,}|(?:\(\?(?:, \?)*\), ){3,})/) { |
262
|
|
|
|
|
|
|
|
263
|
0
|
|
|
|
|
0
|
our $c; |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
# Count Union selects |
266
|
|
|
|
|
|
|
state $UNION_RE = |
267
|
0
|
|
|
|
|
0
|
qr/(?{$c=1})(SELECT \?(?:, \?)*)(?: UNION \1(?{$c++})){3,}/; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
# Count Union selects |
270
|
|
|
|
|
|
|
state $BRACKET_RE = |
271
|
0
|
|
|
|
|
0
|
qr/(?{$c=1})(\(\?(?:, \?)*\))(?:, \1(?{$c++})){3,}/; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
# Count recurring placeholders |
274
|
|
|
|
|
|
|
state $PLACEHOLDER_RE = |
275
|
0
|
|
|
|
|
0
|
qr/(?{$c=1})\?(?:, \?(?{$c++})){3,}/; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
# Rewrite placeholders with count |
278
|
0
|
|
|
|
|
0
|
for ($last_sql) { |
279
|
0
|
|
|
|
|
0
|
s/$UNION_RE/WITH $c x UNION $1/og; |
280
|
0
|
|
|
|
|
0
|
s/$BRACKET_RE/$c x $1/og; |
281
|
0
|
|
|
|
|
0
|
s/$PLACEHOLDER_RE/$c x ?/og; |
282
|
|
|
|
|
|
|
}; |
283
|
|
|
|
|
|
|
}; |
284
|
|
|
|
|
|
|
|
285
|
29
|
100
|
50
|
|
|
161
|
return $last_sql || '' unless wantarray; |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
# Return as array |
288
|
17
|
100
|
|
|
|
42
|
return ('', 0) unless $last_sql; |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
# Check if database request |
291
|
16
|
|
|
|
|
27
|
state $offset = -1 * length $CACHE_COMMENT; |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
return ( |
294
|
16
|
|
|
|
|
76
|
$last_sql, |
295
|
|
|
|
|
|
|
substr($last_sql, $offset) eq $CACHE_COMMENT |
296
|
|
|
|
|
|
|
); |
297
|
|
|
|
|
|
|
}; |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
# Database driver |
301
|
0
|
|
|
0
|
1
|
0
|
sub driver { '' }; |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
# Extensions |
305
|
|
|
|
|
|
|
sub extension { |
306
|
0
|
|
|
0
|
0
|
0
|
return @EXTENSIONS; |
307
|
|
|
|
|
|
|
}; |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
# Insert values to database |
311
|
|
|
|
|
|
|
# This is the MySQL way |
312
|
|
|
|
|
|
|
sub insert { |
313
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
# Get table name |
316
|
0
|
0
|
|
|
|
0
|
my $table = _table_name($self, \@_) or return; |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# No parameters |
319
|
0
|
0
|
|
|
|
0
|
return unless $_[0]; |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
# Properties |
322
|
0
|
0
|
0
|
|
|
0
|
my $prop = shift if ref $_[0] eq 'HASH' && ref $_[1]; |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
# Single insert |
325
|
0
|
0
|
|
|
|
0
|
if (ref $_[0] eq 'HASH') { |
|
|
0
|
|
|
|
|
|
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
# Param |
328
|
0
|
|
|
|
|
0
|
my %param = %{ shift(@_) }; |
|
0
|
|
|
|
|
0
|
|
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
# Create insert arrays |
331
|
0
|
|
|
|
|
0
|
my (@keys, @values); |
332
|
|
|
|
|
|
|
|
333
|
0
|
|
|
|
|
0
|
while (my ($key, $value) = each %param) { |
334
|
|
|
|
|
|
|
# Insert pairs |
335
|
0
|
0
|
0
|
|
|
0
|
next if !ref $key && $key !~ $DBIx::Oro::KEY_REGEX; |
336
|
0
|
|
|
|
|
0
|
push @keys, $key; |
337
|
0
|
|
|
|
|
0
|
push @values, _stringify($value); |
338
|
|
|
|
|
|
|
}; |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
# Nothing to insert |
341
|
0
|
0
|
|
|
|
0
|
return unless @keys; |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
# Create insert string |
344
|
0
|
|
|
|
|
0
|
my $sql = 'INSERT '; |
345
|
|
|
|
|
|
|
|
346
|
0
|
0
|
0
|
|
|
0
|
if ($prop && (my $oc = $prop->{-on_conflict})) { |
347
|
0
|
0
|
|
|
|
0
|
if ($oc eq 'replace') { |
|
|
0
|
|
|
|
|
|
348
|
0
|
|
|
|
|
0
|
$sql = 'REPLACE ' |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
elsif ($oc eq 'ignore') { |
351
|
0
|
|
|
|
|
0
|
$sql .= 'IGNORE ' |
352
|
|
|
|
|
|
|
}; |
353
|
|
|
|
|
|
|
}; |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
$sql .= 'INTO ' . $table . |
356
|
0
|
|
|
|
|
0
|
' (' . join(', ', map { "`$_`" } @keys) . ') VALUES (' . _q(\@values) . ')'; |
|
0
|
|
|
|
|
0
|
|
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
# Prepare and execute |
359
|
0
|
|
|
|
|
0
|
return scalar $self->prep_and_exec( $sql, \@values ); |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
# Multiple inserts |
363
|
|
|
|
|
|
|
elsif (ref($_[0]) eq 'ARRAY') { |
364
|
|
|
|
|
|
|
|
365
|
0
|
0
|
|
|
|
0
|
return unless $_[1]; |
366
|
|
|
|
|
|
|
|
367
|
0
|
|
|
|
|
0
|
my @keys = @{ shift(@_) }; |
|
0
|
|
|
|
|
0
|
|
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
# Default values |
370
|
0
|
|
|
|
|
0
|
my @default = (); |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
# Check if keys are defaults |
373
|
0
|
|
|
|
|
0
|
my $i = 0; |
374
|
0
|
|
|
|
|
0
|
my @default_keys; |
375
|
0
|
|
|
|
|
0
|
while ($keys[$i]) { |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
# No default - next |
378
|
0
|
0
|
|
|
|
0
|
$i++, next unless ref $keys[$i]; |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
# Has default value |
381
|
0
|
|
|
|
|
0
|
my ($key, $value) = @{ splice( @keys, $i, 1) }; |
|
0
|
|
|
|
|
0
|
|
382
|
0
|
|
|
|
|
0
|
push(@default_keys, $key); |
383
|
0
|
|
|
|
|
0
|
push(@default, _stringify($value)); |
384
|
|
|
|
|
|
|
}; |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
# Unshift default keys to front |
387
|
0
|
|
|
|
|
0
|
unshift(@keys, @default_keys); |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
my $sql .= 'INSERT INTO ' . $table . |
390
|
0
|
|
|
|
|
0
|
' (' . join(', ', map { "`$_`" } @keys) . ') ' . |
|
0
|
|
|
|
|
0
|
|
391
|
|
|
|
|
|
|
'VALUES '; |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
# Add data in brackets |
394
|
0
|
|
|
|
|
0
|
$sql .= join(', ', ('(' ._q(\@keys) . ')') x scalar @_ ); |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
# Prepare and execute with prepended defaults |
397
|
|
|
|
|
|
|
return $self->prep_and_exec( |
398
|
|
|
|
|
|
|
$sql, |
399
|
0
|
|
|
|
|
0
|
[ map { (@default, @$_); } @_ ] |
|
0
|
|
|
|
|
0
|
|
400
|
|
|
|
|
|
|
); |
401
|
|
|
|
|
|
|
}; |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
# Unknown query |
404
|
0
|
|
|
|
|
0
|
return; |
405
|
|
|
|
|
|
|
}; |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
# Update existing values in the database |
409
|
|
|
|
|
|
|
sub update { |
410
|
25
|
|
|
25
|
1
|
48
|
my $self = shift; |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
# Get table name |
413
|
25
|
50
|
|
|
|
64
|
my $table = _table_name($self, \@_) or return; |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
# No parameters |
416
|
25
|
50
|
|
|
|
64
|
return unless $_[0]; |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
# Get pairs |
419
|
25
|
|
|
|
|
61
|
my ($pairs, $values) = _get_pairs( shift(@_) ); |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
# Nothing to update |
422
|
25
|
50
|
|
|
|
64
|
return unless @$pairs; |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
# No arrays or operators allowed |
425
|
25
|
|
|
|
|
55
|
foreach (@$pairs) { |
426
|
25
|
100
|
|
|
|
419
|
return unless $_ =~ /^$KEY_REGEX\s+(?:=|IS\s)/o; |
427
|
|
|
|
|
|
|
}; |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
# Set undef to pairs |
430
|
24
|
|
|
|
|
53
|
my @pairs = map { $_ =~ s{ IS NULL$}{ = NULL}io; $_ } @$pairs; |
|
24
|
|
|
|
|
77
|
|
|
24
|
|
|
|
|
72
|
|
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
# Generate sql |
433
|
24
|
|
|
|
|
79
|
my $sql = 'UPDATE ' . $table . ' SET ' . join(', ', @pairs); |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
# Condition |
436
|
24
|
50
|
|
|
|
71
|
if ($_[0]) { |
437
|
24
|
|
|
|
|
54
|
my ($cond_pairs, $cond_values) = _get_pairs( shift(@_) ); |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
# No conditions given |
440
|
24
|
50
|
|
|
|
71
|
if (@$cond_pairs) { |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
# Append condition |
443
|
24
|
|
|
|
|
67
|
$sql .= ' WHERE ' . join(' AND ', @$cond_pairs); |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
# Append values |
446
|
24
|
|
|
|
|
58
|
push(@$values, @$cond_values); |
447
|
|
|
|
|
|
|
}; |
448
|
|
|
|
|
|
|
}; |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
# Prepare and execute |
451
|
24
|
|
|
|
|
53
|
my $rv = $self->prep_and_exec($sql, $values); |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
# Return value |
454
|
24
|
100
|
100
|
|
|
221
|
return (!$rv || $rv eq '0E0') ? 0 : $rv; |
455
|
|
|
|
|
|
|
}; |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
# Select from table |
459
|
|
|
|
|
|
|
sub select { |
460
|
125
|
|
|
125
|
1
|
35729
|
my $self = shift; |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
# Get table object |
463
|
125
|
|
|
|
|
360
|
my ($tables, |
464
|
|
|
|
|
|
|
$fields, |
465
|
|
|
|
|
|
|
$join_pairs, |
466
|
|
|
|
|
|
|
$treatment, |
467
|
|
|
|
|
|
|
$field_alias) = _table_obj($self, \@_); |
468
|
|
|
|
|
|
|
|
469
|
125
|
|
|
|
|
244
|
my @pairs = @$join_pairs; |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
# Fields to select |
472
|
125
|
100
|
100
|
|
|
581
|
if ($_[0] && ref($_[0]) eq 'ARRAY') { |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
# Not allowed for join selects |
475
|
38
|
50
|
|
|
|
109
|
return if $fields->[0]; |
476
|
|
|
|
|
|
|
|
477
|
38
|
|
|
|
|
158
|
($fields, $treatment) = _fields($tables->[0], shift(@_) ); |
478
|
|
|
|
|
|
|
|
479
|
38
|
|
|
|
|
112
|
$fields = [ $fields ]; |
480
|
|
|
|
|
|
|
}; |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
# Default |
483
|
125
|
|
100
|
|
|
455
|
$fields->[0] ||= '*'; |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
# Create sql query |
486
|
125
|
|
|
|
|
402
|
my $sql = join(', ', @$fields) . ' FROM ' . join(', ', @$tables); |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
# Append condition |
489
|
125
|
|
|
|
|
156
|
my @values; |
490
|
|
|
|
|
|
|
|
491
|
125
|
|
|
|
|
170
|
my ($cond, $prep); |
492
|
125
|
100
|
66
|
|
|
643
|
if (($_[0] && ref($_[0]) eq 'HASH') || @$join_pairs) { |
|
|
|
66
|
|
|
|
|
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
# Condition |
495
|
104
|
|
|
|
|
139
|
my ($pairs, $values); |
496
|
104
|
50
|
33
|
|
|
359
|
if ($_[0] && ref($_[0]) eq 'HASH') { |
497
|
104
|
|
|
|
|
267
|
($pairs, $values, $prep) = _get_pairs( shift(@_), $field_alias); |
498
|
|
|
|
|
|
|
|
499
|
104
|
|
|
|
|
215
|
push(@values, @$values); |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
# Add to pairs |
502
|
104
|
100
|
|
|
|
267
|
push(@pairs, @$pairs) if $pairs->[0]; |
503
|
|
|
|
|
|
|
}; |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
# Add where clause |
506
|
104
|
100
|
|
|
|
348
|
$sql .= ' WHERE ' . join(' AND ', @pairs) if @pairs; |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
# Add distinct information |
509
|
104
|
100
|
|
|
|
242
|
if ($prep) { |
510
|
63
|
100
|
|
|
|
156
|
$sql = 'DISTINCT ' . $sql if delete $prep->{'distinct'}; |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
# Apply restrictions |
513
|
63
|
|
|
|
|
170
|
$sql .= _restrictions($prep, \@values); |
514
|
|
|
|
|
|
|
}; |
515
|
|
|
|
|
|
|
}; |
516
|
|
|
|
|
|
|
|
517
|
125
|
|
|
|
|
179
|
my $result; |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
# Check cache |
520
|
125
|
|
|
|
|
169
|
my ($chi, $key, $chi_param); |
521
|
125
|
50
|
66
|
|
|
375
|
if ($prep && $prep->{cache}) { |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
# Cache parameters |
524
|
0
|
|
|
|
|
0
|
($chi, $key, $chi_param) = @{delete $prep->{cache}}; |
|
0
|
|
|
|
|
0
|
|
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
# Generate key |
527
|
0
|
0
|
|
|
|
0
|
$key = 'SELECT ' . $sql . '-' . join('-', @values) unless $key; |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
# Get cache result |
530
|
0
|
|
|
|
|
0
|
$result = $chi->get($key); |
531
|
|
|
|
|
|
|
}; |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
# Unknown restrictions |
534
|
125
|
100
|
|
|
|
309
|
if (scalar keys %$prep) { |
535
|
1
|
|
|
|
|
484
|
carp 'Unknown restriction option: ' . join(', ', keys %$prep); |
536
|
|
|
|
|
|
|
}; |
537
|
|
|
|
|
|
|
|
538
|
125
|
|
|
|
|
174
|
my ($rv, $sth); |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
# Result was not cached |
541
|
125
|
50
|
|
|
|
219
|
unless ($result) { |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
# Prepare and execute |
544
|
125
|
|
|
|
|
466
|
($rv, $sth) = $self->prep_and_exec('SELECT ' . $sql, \@values); |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
# No statement created |
547
|
125
|
100
|
|
|
|
408
|
return unless $sth; |
548
|
|
|
|
|
|
|
} |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
else { |
551
|
|
|
|
|
|
|
# Last sql command |
552
|
0
|
|
|
|
|
0
|
$self->{last_sql} = 'SELECT ' . $sql . ' -- ' . $CACHE_COMMENT; |
553
|
|
|
|
|
|
|
}; |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
# Prepare treatments |
556
|
123
|
|
|
|
|
191
|
my (@treatment, %treatsub); |
557
|
123
|
100
|
|
|
|
246
|
if ($treatment) { |
558
|
8
|
|
|
|
|
39
|
@treatment = keys %$treatment; |
559
|
8
|
|
|
|
|
24
|
foreach (@treatment) { |
560
|
8
|
|
|
|
|
11
|
$treatsub{$_} = shift(@{$treatment->{$_}}); |
|
8
|
|
|
|
|
30
|
|
561
|
|
|
|
|
|
|
}; |
562
|
|
|
|
|
|
|
}; |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
# Release callback |
565
|
123
|
0
|
33
|
|
|
334
|
if ($_[0] && ref $_[0] && ref $_[0] eq 'CODE' ) { |
|
|
|
33
|
|
|
|
|
566
|
0
|
|
|
|
|
0
|
my $cb = shift; |
567
|
|
|
|
|
|
|
|
568
|
0
|
|
|
|
|
0
|
carp 'Calling select with an iteration callback is deprecated since v0.31'; |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
# Iterate through dbi result |
571
|
0
|
|
|
|
|
0
|
my ($i, $row) = (0); |
572
|
0
|
0
|
|
|
|
0
|
while ($row = $sth ? $sth->fetchrow_hashref : $result->[$i]) { |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
# Iterate for cache result |
575
|
0
|
0
|
0
|
|
|
0
|
push(@$result, $row) if $chi && $sth; |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
# Increment for cached results |
578
|
0
|
|
|
|
|
0
|
$i++; |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
# Treat result |
581
|
0
|
0
|
|
|
|
0
|
if ($treatment) { |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
# Treat each treatable row value |
584
|
0
|
|
|
|
|
0
|
foreach ( grep { exists $row->{$_} } @treatment) { |
|
0
|
|
|
|
|
0
|
|
585
|
|
|
|
|
|
|
$row->{$_} = $treatsub{$_}->( |
586
|
0
|
|
|
|
|
0
|
$row->{$_}, @{ $treatment->{$_} } |
|
0
|
|
|
|
|
0
|
|
587
|
|
|
|
|
|
|
); |
588
|
|
|
|
|
|
|
}; |
589
|
|
|
|
|
|
|
}; |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
# Finish if callback returns -1 |
592
|
0
|
|
|
|
|
0
|
local $_ = $row; |
593
|
0
|
|
|
|
|
0
|
my $rv = $cb->($row); |
594
|
0
|
0
|
0
|
|
|
0
|
if ($rv && $rv eq '-1') { |
595
|
0
|
|
|
|
|
0
|
$result = undef; |
596
|
0
|
|
|
|
|
0
|
last; |
597
|
|
|
|
|
|
|
}; |
598
|
|
|
|
|
|
|
}; |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
# Save to cache |
601
|
0
|
0
|
0
|
|
|
0
|
if ($sth && $chi && $result) { |
|
|
|
0
|
|
|
|
|
602
|
0
|
|
|
|
|
0
|
$chi->set($key => $result, $chi_param); |
603
|
|
|
|
|
|
|
}; |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
# Came from cache |
606
|
0
|
0
|
0
|
|
|
0
|
return if !$sth && $chi; |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
# Finish statement |
609
|
0
|
|
|
|
|
0
|
$sth->finish; |
610
|
0
|
|
|
|
|
0
|
return; |
611
|
|
|
|
|
|
|
}; |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
# Create array ref |
614
|
123
|
50
|
|
|
|
271
|
unless ($result) { |
615
|
123
|
|
|
|
|
1052
|
$result = $sth->fetchall_arrayref({}); |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
# Save to stash |
618
|
123
|
50
|
33
|
|
|
23700
|
if ($chi && $result) { |
619
|
0
|
|
|
|
|
0
|
$chi->set($key => $result, $chi_param); |
620
|
|
|
|
|
|
|
}; |
621
|
|
|
|
|
|
|
}; |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
# Return array ref |
624
|
123
|
100
|
|
|
|
2446
|
return $result unless $treatment; |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
# Treat each row |
627
|
8
|
|
|
|
|
22
|
foreach my $row (@$result) { |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
# Treat each treatable row value |
630
|
12
|
|
|
|
|
21
|
foreach (@treatment) { |
631
|
|
|
|
|
|
|
$row->{$_} = $treatsub{$_}->( |
632
|
12
|
|
|
|
|
85
|
$row->{$_}, @{$treatment->{$_}} |
633
|
12
|
50
|
|
|
|
34
|
) if $row->{$_}; |
634
|
|
|
|
|
|
|
}; |
635
|
|
|
|
|
|
|
}; |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
# Return result |
638
|
8
|
|
|
|
|
166
|
$result; |
639
|
|
|
|
|
|
|
}; |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
# List elements |
643
|
|
|
|
|
|
|
sub list { |
644
|
21
|
|
|
21
|
1
|
126621
|
my $self = shift; |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
# Get callback |
647
|
21
|
100
|
66
|
|
|
126
|
my $cb = pop if ref $_[-1] && ref $_[-1] eq 'CODE'; |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
# Get param hash reference |
650
|
21
|
50
|
33
|
|
|
79
|
my $param = pop if ref $_[-1] && ref $_[-1] eq 'HASH'; |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
# Get table object |
653
|
21
|
100
|
|
|
|
79
|
$self = $self->table( @_ ) if $_[0]; |
654
|
|
|
|
|
|
|
|
655
|
21
|
|
|
|
|
29
|
my (%condition, %pagination); |
656
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
# Check numerical values |
658
|
21
|
|
100
|
|
|
48
|
my $start_index = _check_param($param, 'startIndex', 'num') // 0; |
659
|
21
|
|
|
|
|
31
|
my $count = _check_param($param, 'count', 'num'); |
660
|
21
|
|
100
|
|
|
38
|
my $start_page = _check_param($param, 'startPage', 'num') // 1; |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
# Set caching condition |
663
|
21
|
50
|
|
|
|
53
|
$condition{-cache} = delete $param->{-cache} if $param->{-cache}; |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
### Sorting parameters |
666
|
21
|
|
|
|
|
23
|
my %sort; |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
# Check, if parameter is a field |
669
|
21
|
|
|
|
|
31
|
my $sort_by = _check_param($param, 'sortBy'); |
670
|
21
|
50
|
33
|
|
|
287
|
if ($sort_by && $sort_by =~ s/^\s*($KEY_REGEX)\s*$/$1/) { |
671
|
|
|
|
|
|
|
|
672
|
21
|
|
100
|
|
|
74
|
$param->{sortOrder} //= 'ascending'; |
673
|
21
|
100
|
|
|
|
75
|
my $sort_order = index(lc($param->{sortOrder}), 'desc') == 0 ? 'descending' : undef; |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
# Set SQL limitation |
676
|
21
|
100
|
|
|
|
61
|
$pagination{-order} = $sort_order ? "-$sort_by" : $sort_by; |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
# Set sort information |
679
|
21
|
|
|
|
|
39
|
$sort{sortBy} = $sort_by; |
680
|
21
|
100
|
|
|
|
45
|
$sort{sortOrder} = $sort_order if $sort_order; |
681
|
|
|
|
|
|
|
}; |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
# Set SQL limitations |
684
|
21
|
|
|
|
|
34
|
$pagination{-offset} = $start_index; |
685
|
21
|
|
66
|
|
|
60
|
$pagination{-limit} = $count || $ITEMS_PER_PAGE; |
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
# Not first page |
688
|
21
|
100
|
|
|
|
41
|
if ($start_page > 1) { |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
# Set SQL limitations |
691
|
2
|
|
50
|
|
|
44
|
$pagination{-offset} //= 0; |
692
|
2
|
|
|
|
|
8
|
$pagination{-offset} += (($start_page - 1) * $pagination{-limit}); |
693
|
|
|
|
|
|
|
}; |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
### Filter parameters |
697
|
21
|
|
|
|
|
25
|
my %filter; |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
# Filter parameter is set |
700
|
21
|
|
|
|
|
31
|
my $filter_by = _check_param($param, 'filterBy'); |
701
|
21
|
50
|
|
|
|
46
|
if ($filter_by) { |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
# Filter operation is set |
704
|
21
|
|
|
|
|
30
|
my $filter_op = _check_param($param, 'filterOp'); |
705
|
21
|
50
|
|
|
|
43
|
if ($filter_op) { |
706
|
21
|
|
|
|
|
39
|
$filter_op = lc $filter_op; |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
# Set parameters for response |
709
|
21
|
|
|
|
|
30
|
$filter{filterBy} = $filter_by; |
710
|
21
|
|
|
|
|
29
|
$filter{filterOp} = $filter_op; |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
# Check for presence |
713
|
21
|
100
|
|
|
|
45
|
if ($filter_op eq 'present') { |
|
|
100
|
|
|
|
|
|
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
# Create SQL condition |
716
|
4
|
|
|
|
|
13
|
$condition{$filter_by} = { not => undef }; |
717
|
|
|
|
|
|
|
} |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
# Check for absence |
720
|
|
|
|
|
|
|
elsif ($filter_op eq 'absent') { |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
# Create SQL condition |
723
|
1
|
|
|
|
|
3
|
$condition{$filter_by} = undef; |
724
|
|
|
|
|
|
|
} |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
# Check with filterValue |
727
|
|
|
|
|
|
|
else { |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
# Get filterValue |
730
|
16
|
50
|
|
|
|
27
|
if (my $fv = _check_param($param, 'filterValue')) { |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
# Set filter value for response |
733
|
16
|
|
|
|
|
39
|
$filter{filterValue} = $fv; |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
# Check for equality |
736
|
16
|
100
|
|
|
|
56
|
if ($filter_op eq 'equals') { |
|
|
100
|
|
|
|
|
|
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
# Equals the value |
739
|
1
|
|
|
|
|
2
|
$condition{$filter_by} = $fv; |
740
|
|
|
|
|
|
|
} |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
# Check for disparaty |
743
|
|
|
|
|
|
|
elsif ($filter_op eq 'disparate') { |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
# Equals the value |
746
|
1
|
|
|
|
|
4
|
$condition{$filter_by} = { ne => $fv }; |
747
|
|
|
|
|
|
|
} |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
# Check with SQL like |
750
|
|
|
|
|
|
|
else { |
751
|
14
|
|
|
|
|
31
|
$fv =~ s/([\%_])/\\$1/g; |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
# Check for containing |
754
|
14
|
100
|
|
|
|
36
|
if ($filter_op eq 'contains') { |
|
|
50
|
|
|
|
|
|
755
|
1
|
|
|
|
|
4
|
$condition{$filter_by} = { like => "%${fv}%" }; |
756
|
|
|
|
|
|
|
} |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
# Check for beginning |
759
|
|
|
|
|
|
|
elsif ($filter_op eq 'startswith') { |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
# Set response operation |
762
|
13
|
|
|
|
|
18
|
$filter{filterOp} = 'startsWith'; |
763
|
13
|
|
|
|
|
53
|
$condition{$filter_by} = { like => "${fv}%" }; |
764
|
|
|
|
|
|
|
}; |
765
|
|
|
|
|
|
|
}; |
766
|
|
|
|
|
|
|
} |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
# No filterValue - reset |
769
|
|
|
|
|
|
|
else { |
770
|
0
|
|
|
|
|
0
|
%filter = (); |
771
|
|
|
|
|
|
|
}; |
772
|
|
|
|
|
|
|
}; |
773
|
|
|
|
|
|
|
}; |
774
|
|
|
|
|
|
|
}; |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
# Get count |
777
|
21
|
|
|
|
|
63
|
my $total_results = $self->count(\%condition); |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
# Something went wrong |
780
|
21
|
100
|
|
|
|
78
|
return unless defined $total_results; |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
# Check fields |
783
|
20
|
|
|
|
|
28
|
my @fields; |
784
|
20
|
100
|
|
|
|
49
|
if ($param->{fields}) { |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
# Fields is a reference |
787
|
5
|
100
|
|
|
|
15
|
if (ref $param->{fields}) { |
788
|
1
|
|
|
|
|
2
|
@fields = @{ $param->{fields} }; |
|
1
|
|
|
|
|
5
|
|
789
|
|
|
|
|
|
|
} |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
# Fields is a string |
792
|
|
|
|
|
|
|
else { |
793
|
|
|
|
|
|
|
@fields = |
794
|
9
|
|
|
|
|
104
|
grep { /^$KEY_REGEX$/ } |
795
|
9
|
|
|
|
|
20
|
map { s/\s//g; $_ } |
|
9
|
|
|
|
|
23
|
|
796
|
4
|
|
|
|
|
35
|
split /\s*,\s*/, $param->{fields}; |
797
|
|
|
|
|
|
|
}; |
798
|
|
|
|
|
|
|
}; |
799
|
|
|
|
|
|
|
|
800
|
20
|
|
|
|
|
25
|
my $entry; |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
# More than one result |
803
|
20
|
50
|
|
|
|
33
|
if ($total_results) { |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
# Table is joined and there are fields existing |
806
|
20
|
100
|
66
|
|
|
75
|
if (ref $self->{table} && @fields) { |
|
|
100
|
|
|
|
|
|
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
# Is a joined table, filter fields afterwards |
809
|
2
|
|
|
|
|
15
|
my $select = $self->select({ %condition, %pagination }); |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
# Iterate for filtering |
812
|
2
|
|
|
|
|
12
|
foreach my $row (@$select) { |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
# Filter |
815
|
12
|
|
|
|
|
13
|
my %new; |
816
|
12
|
|
|
|
|
16
|
foreach (@fields) { |
817
|
36
|
50
|
|
|
|
73
|
$new{$_} = $row->{$_} if exists $row->{$_}; |
818
|
|
|
|
|
|
|
}; |
819
|
12
|
|
|
|
|
20
|
push(@$entry, \%new); |
820
|
|
|
|
|
|
|
}; |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
# Define fields |
823
|
2
|
|
|
|
|
13
|
$filter{fields} = \@fields; |
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
# Fields in simple table |
827
|
|
|
|
|
|
|
elsif (@fields) { |
828
|
|
|
|
|
|
|
# Just prepend field to select |
829
|
3
|
|
|
|
|
8
|
$filter{fields} = \@fields; |
830
|
3
|
|
|
|
|
18
|
$entry = $self->select(\@fields, { %condition, %pagination }); |
831
|
|
|
|
|
|
|
} |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
# No fields |
834
|
|
|
|
|
|
|
else { |
835
|
15
|
|
|
|
|
94
|
$entry = $self->select({ %condition, %pagination }); |
836
|
|
|
|
|
|
|
}; |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
# Use callback for each entry |
839
|
20
|
100
|
66
|
|
|
75
|
if ($cb && @$entry) { |
840
|
1
|
|
|
|
|
2
|
my @entry_cb; |
841
|
1
|
|
|
|
|
7
|
push( @entry_cb, $cb->($_) ) foreach @$entry; |
842
|
1
|
|
|
|
|
52
|
$entry = \@entry_cb; |
843
|
|
|
|
|
|
|
}; |
844
|
|
|
|
|
|
|
}; |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
# Return response |
847
|
|
|
|
|
|
|
{ |
848
|
|
|
|
|
|
|
totalResults => $total_results, |
849
|
|
|
|
|
|
|
startIndex => $start_index, |
850
|
|
|
|
|
|
|
itemsPerPage => $pagination{-limit}, |
851
|
20
|
|
50
|
|
|
299
|
startPage => $start_page, |
852
|
|
|
|
|
|
|
entry => $entry || [], |
853
|
|
|
|
|
|
|
%filter, |
854
|
|
|
|
|
|
|
%sort |
855
|
|
|
|
|
|
|
}; |
856
|
|
|
|
|
|
|
}; |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
|
859
|
|
|
|
|
|
|
# Load one line |
860
|
|
|
|
|
|
|
sub load { |
861
|
29
|
|
|
29
|
1
|
106
|
my $self = shift; |
862
|
29
|
|
|
|
|
80
|
my @param = @_; |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
# Has a condition |
865
|
29
|
50
|
33
|
|
|
178
|
if ($param[-1] && ref($param[-1])) { |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
# Add limitation to the condition |
868
|
29
|
100
|
|
|
|
86
|
if (ref($param[-1]) eq 'HASH') { |
|
|
50
|
|
|
|
|
|
869
|
24
|
|
|
|
|
56
|
$param[-1]->{-limit} = 1; |
870
|
|
|
|
|
|
|
} |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
# Load is malformed |
873
|
|
|
|
|
|
|
elsif (ref($param[-1]) ne 'ARRAY') { |
874
|
0
|
|
|
|
|
0
|
carp 'Load is malformed'; |
875
|
0
|
|
|
|
|
0
|
return; |
876
|
|
|
|
|
|
|
}; |
877
|
|
|
|
|
|
|
} |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
# Has no condition yet |
880
|
|
|
|
|
|
|
else { |
881
|
0
|
|
|
|
|
0
|
push(@param, { -limit => 1 }); |
882
|
|
|
|
|
|
|
}; |
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
# Select with limit |
885
|
29
|
|
|
|
|
117
|
my $row = $self->select(@param); |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
# Error or not found |
888
|
29
|
100
|
|
|
|
98
|
return unless $row; |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
# Return row |
891
|
28
|
|
|
|
|
192
|
$row->[0]; |
892
|
|
|
|
|
|
|
}; |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
|
895
|
|
|
|
|
|
|
# Delete entry |
896
|
|
|
|
|
|
|
sub delete { |
897
|
11
|
|
|
11
|
1
|
20
|
my $self = shift; |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
# Get table name |
900
|
11
|
50
|
|
|
|
37
|
my $table = _table_name($self, \@_) or return; |
901
|
|
|
|
|
|
|
|
902
|
|
|
|
|
|
|
# Build sql |
903
|
11
|
|
|
|
|
37
|
my $sql = 'DELETE FROM ' . $table; |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
# Condition |
906
|
11
|
|
|
|
|
20
|
my ($pairs, $values, $prep, $secure); |
907
|
11
|
100
|
|
|
|
31
|
if ($_[0]) { |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
# Add condition |
910
|
5
|
|
|
|
|
12
|
($pairs, $values, $prep) = _get_pairs( shift(@_) ); |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
# Add where clause to sql |
913
|
5
|
50
|
33
|
|
|
27
|
$sql .= ' WHERE ' . join(' AND ', @$pairs) if @$pairs || $prep; |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
# Apply restrictions |
916
|
5
|
50
|
|
|
|
12
|
$sql .= _restrictions($prep, $values) if $prep; |
917
|
|
|
|
|
|
|
}; |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
# Prepare and execute deletion |
920
|
11
|
|
|
|
|
30
|
my $rv = $self->prep_and_exec($sql, $values); |
921
|
|
|
|
|
|
|
|
922
|
|
|
|
|
|
|
# Return value |
923
|
11
|
100
|
66
|
|
|
120
|
return (!$rv || $rv eq '0E0') ? 0 : $rv; |
924
|
|
|
|
|
|
|
}; |
925
|
|
|
|
|
|
|
|
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
# Update or insert a value |
928
|
|
|
|
|
|
|
sub merge { |
929
|
10
|
|
|
10
|
1
|
18
|
my $self = shift; |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
# Get table name |
932
|
10
|
50
|
|
|
|
31
|
my $table = _table_name($self, \@_) or return; |
933
|
|
|
|
|
|
|
|
934
|
10
|
|
|
|
|
19
|
my %param = %{ shift( @_ ) }; |
|
10
|
|
|
|
|
36
|
|
935
|
10
|
50
|
|
|
|
27
|
my %cond = $_[0] ? %{ shift( @_ ) } : (); |
|
10
|
|
|
|
|
26
|
|
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
# Prefix with table if necessary |
938
|
10
|
|
|
|
|
20
|
my @param = ( \%param, \%cond ); |
939
|
10
|
100
|
|
|
|
30
|
unshift(@param, $table) unless $self->{table}; |
940
|
|
|
|
|
|
|
|
941
|
10
|
|
|
|
|
15
|
my $rv; |
942
|
10
|
|
|
|
|
26
|
my $job = 'update'; |
943
|
|
|
|
|
|
|
$self->txn( |
944
|
|
|
|
|
|
|
sub { |
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
# Update |
947
|
10
|
|
|
10
|
|
33
|
$rv = $self->update( @param ); |
948
|
|
|
|
|
|
|
|
949
|
10
|
100
|
|
|
|
38
|
return 1 if $rv; |
950
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
# Delete all element conditions |
952
|
5
|
|
|
|
|
15
|
delete $cond{$_} foreach grep { |
953
|
6
|
100
|
|
|
|
39
|
ref($cond{$_}) && !blessed($cond{$_}) |
954
|
|
|
|
|
|
|
} keys %cond; |
955
|
|
|
|
|
|
|
|
956
|
|
|
|
|
|
|
# Insert |
957
|
5
|
|
|
|
|
21
|
@param = ( { %param, %cond } ); |
958
|
5
|
50
|
|
|
|
55
|
unshift(@param, $table) unless $self->{table}; |
959
|
|
|
|
|
|
|
|
960
|
5
|
100
|
|
|
|
19
|
$rv = $self->insert(@param) or return -1; |
961
|
|
|
|
|
|
|
|
962
|
4
|
|
|
|
|
8
|
$job = 'insert'; |
963
|
|
|
|
|
|
|
|
964
|
4
|
|
|
|
|
7
|
return; |
965
|
10
|
100
|
|
|
|
64
|
}) or return; |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
# Return value is bigger than 0 |
968
|
9
|
50
|
33
|
|
|
106
|
if ($rv && $rv > 0) { |
969
|
9
|
50
|
|
|
|
60
|
return wantarray ? ($rv, $job) : $rv; |
970
|
|
|
|
|
|
|
}; |
971
|
|
|
|
|
|
|
|
972
|
0
|
|
|
|
|
0
|
return; |
973
|
|
|
|
|
|
|
}; |
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
# Count results |
977
|
|
|
|
|
|
|
sub count { |
978
|
52
|
|
|
52
|
1
|
989
|
my $self = shift; |
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
# Init arrays |
981
|
52
|
|
|
|
|
171
|
my ($tables, $fields, $join_pairs, $treatment, $field_alias) = |
982
|
|
|
|
|
|
|
_table_obj($self, \@_); |
983
|
|
|
|
|
|
|
|
984
|
52
|
|
|
|
|
131
|
my @pairs = @$join_pairs; |
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
# Build sql |
987
|
52
|
|
|
|
|
198
|
my $sql = |
988
|
|
|
|
|
|
|
'SELECT ' . join(', ', 'count(1)', @$fields) . |
989
|
|
|
|
|
|
|
' FROM ' . join(', ', @$tables); |
990
|
|
|
|
|
|
|
|
991
|
|
|
|
|
|
|
# Ignore fields |
992
|
52
|
100
|
100
|
|
|
212
|
shift if $_[0] && ref $_[0] eq 'ARRAY'; |
993
|
|
|
|
|
|
|
|
994
|
|
|
|
|
|
|
# Get conditions |
995
|
52
|
|
|
|
|
91
|
my ($pairs, $values, $prep); |
996
|
52
|
100
|
66
|
|
|
153
|
if ($_[0] && ref $_[0] eq 'HASH') { |
997
|
30
|
|
|
|
|
81
|
($pairs, $values, $prep) = _get_pairs( shift(@_), $field_alias ); |
998
|
30
|
50
|
|
|
|
99
|
push(@pairs, @$pairs) if $pairs->[0]; |
999
|
|
|
|
|
|
|
}; |
1000
|
|
|
|
|
|
|
|
1001
|
|
|
|
|
|
|
# Add where clause |
1002
|
52
|
100
|
|
|
|
157
|
$sql .= ' WHERE ' . join(' AND ', @pairs) if @pairs; |
1003
|
52
|
|
|
|
|
93
|
$sql .= ' LIMIT 1'; |
1004
|
|
|
|
|
|
|
|
1005
|
52
|
|
|
|
|
71
|
my $result; |
1006
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
# Check cache |
1008
|
52
|
|
|
|
|
70
|
my ($chi, $key, $chi_param); |
1009
|
52
|
0
|
33
|
|
|
107
|
if ($prep && $prep->{cache}) { |
1010
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
# Cache parameters |
1012
|
0
|
|
|
|
|
0
|
($chi, $key, $chi_param) = @{$prep->{cache}}; |
|
0
|
|
|
|
|
0
|
|
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
# Generate key |
1015
|
0
|
0
|
|
|
|
0
|
$key = $sql . '-' . join('-', @$values) unless $key; |
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
# Get cache result |
1018
|
0
|
0
|
|
|
|
0
|
if ($result = $chi->get($key)) { |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
# Last sql command |
1021
|
0
|
|
|
|
|
0
|
$self->{last_sql} = $sql . ' -- ' . $CACHE_COMMENT; |
1022
|
|
|
|
|
|
|
|
1023
|
|
|
|
|
|
|
# Return cache result |
1024
|
0
|
|
|
|
|
0
|
return $result; |
1025
|
|
|
|
|
|
|
}; |
1026
|
|
|
|
|
|
|
}; |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
# Prepare and execute |
1029
|
52
|
|
100
|
|
|
219
|
my ($rv, $sth) = $self->prep_and_exec($sql, $values || []); |
1030
|
|
|
|
|
|
|
|
1031
|
|
|
|
|
|
|
# Return value is empty |
1032
|
52
|
100
|
|
|
|
181
|
return undef if !$rv; |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
# Return count |
1035
|
49
|
|
100
|
|
|
461
|
$result = $sth->fetchrow_arrayref->[0] || 0; |
1036
|
49
|
|
|
|
|
177
|
$sth->finish; |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
# Save to cache |
1039
|
49
|
50
|
33
|
|
|
134
|
$chi->set($key => $result, $chi_param) if $chi && $result; |
1040
|
|
|
|
|
|
|
|
1041
|
|
|
|
|
|
|
# Return result |
1042
|
49
|
|
|
|
|
788
|
$result; |
1043
|
|
|
|
|
|
|
}; |
1044
|
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
# Prepare and execute |
1047
|
|
|
|
|
|
|
sub prep_and_exec { |
1048
|
1189
|
|
|
1189
|
1
|
2118
|
my ($self, $sql, $values, $cached) = @_; |
1049
|
1189
|
|
|
|
|
1991
|
my $dbh = $self->dbh; |
1050
|
|
|
|
|
|
|
|
1051
|
|
|
|
|
|
|
# Last sql command |
1052
|
1189
|
|
|
|
|
2369
|
$self->{last_sql} = $sql; |
1053
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
# Prepare |
1055
|
1189
|
50
|
|
|
|
5210
|
my $sth = |
1056
|
|
|
|
|
|
|
$cached ? $dbh->prepare_cached( $sql ) : |
1057
|
|
|
|
|
|
|
$dbh->prepare( $sql ); |
1058
|
|
|
|
|
|
|
|
1059
|
|
|
|
|
|
|
# Check for errors |
1060
|
1189
|
100
|
|
|
|
83876
|
if ($dbh->err) { |
1061
|
|
|
|
|
|
|
|
1062
|
11
|
50
|
|
|
|
83
|
if (index($dbh->errstr, 'database') <= 0) { |
1063
|
11
|
|
|
|
|
59
|
carp $dbh->errstr . ' in "' . _trim_last_sql($self->last_sql) . '"'; |
1064
|
11
|
|
|
|
|
575
|
return; |
1065
|
|
|
|
|
|
|
}; |
1066
|
|
|
|
|
|
|
|
1067
|
|
|
|
|
|
|
# Retry with reconnect |
1068
|
0
|
|
|
|
|
0
|
$dbh = $self->_connect; |
1069
|
|
|
|
|
|
|
|
1070
|
0
|
0
|
|
|
|
0
|
$sth = |
1071
|
|
|
|
|
|
|
$cached ? $dbh->prepare_cached( $sql ) : |
1072
|
|
|
|
|
|
|
$dbh->prepare( $sql ); |
1073
|
|
|
|
|
|
|
|
1074
|
0
|
0
|
|
|
|
0
|
if ($dbh->err) { |
1075
|
0
|
|
|
|
|
0
|
carp $dbh->errstr . ' in "' . _trim_last_sql($self->last_sql) . '"'; |
1076
|
0
|
|
|
|
|
0
|
return; |
1077
|
|
|
|
|
|
|
}; |
1078
|
|
|
|
|
|
|
}; |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
# No statement handle established |
1081
|
1178
|
50
|
|
|
|
2425
|
return unless $sth; |
1082
|
|
|
|
|
|
|
|
1083
|
|
|
|
|
|
|
# Execute |
1084
|
1178
|
|
|
|
|
86517
|
my $rv = $sth->execute( @$values ); |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
# Check for errors |
1087
|
1178
|
100
|
|
|
|
8077
|
if ($dbh->err) { |
1088
|
4
|
|
|
|
|
70
|
carp $dbh->errstr . ' in "' . _trim_last_sql($self->last_sql) . '"'; |
1089
|
4
|
|
|
|
|
209
|
return; |
1090
|
|
|
|
|
|
|
}; |
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
# Return value and statement |
1093
|
1174
|
100
|
|
|
|
2746
|
return ($rv, $sth) if wantarray; |
1094
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
# Finish statement |
1096
|
971
|
|
|
|
|
2220
|
$sth->finish; |
1097
|
|
|
|
|
|
|
|
1098
|
|
|
|
|
|
|
# Return value |
1099
|
971
|
|
|
|
|
10182
|
$rv; |
1100
|
|
|
|
|
|
|
}; |
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
|
1103
|
|
|
|
|
|
|
# Wrapper for DBI do |
1104
|
|
|
|
|
|
|
sub do { |
1105
|
126
|
|
|
126
|
1
|
19646
|
$_[0]->{last_sql} = $_[1]; |
1106
|
|
|
|
|
|
|
|
1107
|
|
|
|
|
|
|
# Database connection |
1108
|
126
|
|
|
|
|
280
|
my $dbh = shift->dbh; |
1109
|
|
|
|
|
|
|
|
1110
|
126
|
|
|
|
|
731
|
my $rv = $dbh->do( @_ ); |
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
# Error |
1113
|
126
|
50
|
33
|
|
|
21015
|
carp $dbh->errstr . ' in "' . $_[0] . '"' if !$rv && $dbh->err; |
1114
|
126
|
|
|
|
|
413
|
return $rv; |
1115
|
|
|
|
|
|
|
}; |
1116
|
|
|
|
|
|
|
|
1117
|
|
|
|
|
|
|
|
1118
|
|
|
|
|
|
|
# Explain query plan |
1119
|
|
|
|
|
|
|
sub explain { |
1120
|
0
|
|
|
0
|
1
|
0
|
'Not implemented for ' . $_[0]->driver; |
1121
|
|
|
|
|
|
|
}; |
1122
|
|
|
|
|
|
|
|
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
# Wrap a transaction |
1125
|
|
|
|
|
|
|
sub txn { |
1126
|
69
|
|
|
69
|
1
|
16203
|
my $self = shift; |
1127
|
|
|
|
|
|
|
|
1128
|
|
|
|
|
|
|
# No callback defined |
1129
|
69
|
50
|
33
|
|
|
440
|
return unless $_[0] && ref($_[0]) eq 'CODE'; |
1130
|
|
|
|
|
|
|
|
1131
|
69
|
|
|
|
|
252
|
my $dbh = $self->dbh; |
1132
|
|
|
|
|
|
|
|
1133
|
|
|
|
|
|
|
# Outside transaction |
1134
|
69
|
100
|
|
|
|
469
|
if ($dbh->{AutoCommit}) { |
1135
|
|
|
|
|
|
|
|
1136
|
|
|
|
|
|
|
# Start new transaction |
1137
|
67
|
|
|
|
|
505
|
$dbh->begin_work; |
1138
|
|
|
|
|
|
|
|
1139
|
67
|
|
|
|
|
1000
|
${$self->{in_txn}} = 1; |
|
67
|
|
|
|
|
151
|
|
1140
|
|
|
|
|
|
|
|
1141
|
|
|
|
|
|
|
# start |
1142
|
67
|
|
|
|
|
113
|
local $_ = $self; |
1143
|
67
|
|
|
|
|
187
|
my $rv = $_[0]->($self); |
1144
|
67
|
100
|
100
|
|
|
1725
|
if (!$rv || $rv ne '-1') { |
1145
|
65
|
|
|
|
|
159
|
${$self->{in_txn}} = 0; |
|
65
|
|
|
|
|
149
|
|
1146
|
65
|
|
|
|
|
33647
|
$dbh->commit; |
1147
|
65
|
|
|
|
|
991
|
return 1; |
1148
|
|
|
|
|
|
|
}; |
1149
|
|
|
|
|
|
|
|
1150
|
|
|
|
|
|
|
# Rollback |
1151
|
2
|
|
|
|
|
6
|
${$self->{in_txn}} = 0; |
|
2
|
|
|
|
|
8
|
|
1152
|
2
|
|
|
|
|
28
|
$dbh->rollback; |
1153
|
2
|
|
|
|
|
19
|
return; |
1154
|
|
|
|
|
|
|
} |
1155
|
|
|
|
|
|
|
|
1156
|
|
|
|
|
|
|
# Inside transaction |
1157
|
|
|
|
|
|
|
else { |
1158
|
2
|
|
|
|
|
5
|
${$self->{in_txn}} = 1; |
|
2
|
|
|
|
|
6
|
|
1159
|
|
|
|
|
|
|
|
1160
|
|
|
|
|
|
|
# Push savepoint on stack |
1161
|
2
|
|
|
|
|
5
|
my $sp_array = $self->{savepoint}; |
1162
|
|
|
|
|
|
|
|
1163
|
|
|
|
|
|
|
# Use PID for concurrent accesses |
1164
|
2
|
|
|
|
|
10
|
my $sp = "orosp_${$}_"; |
1165
|
|
|
|
|
|
|
|
1166
|
|
|
|
|
|
|
# Use TID for concurrent accesses |
1167
|
2
|
50
|
|
|
|
8
|
$sp .= threads->tid . '_' if $self->{tid}; |
1168
|
|
|
|
|
|
|
|
1169
|
2
|
|
|
|
|
6
|
$sp .= $sp_array->[0]++; |
1170
|
|
|
|
|
|
|
|
1171
|
|
|
|
|
|
|
# Push new savepoint to array |
1172
|
2
|
|
|
|
|
5
|
push(@$sp_array, $sp); |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
# Start transaction |
1175
|
2
|
|
|
|
|
8
|
$self->do("SAVEPOINT $sp"); |
1176
|
|
|
|
|
|
|
|
1177
|
|
|
|
|
|
|
# Run wrap actions |
1178
|
2
|
|
|
|
|
5
|
my $rv = $_[0]->($self); |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
# Pop savepoint from stack |
1181
|
2
|
|
|
|
|
27
|
my $last_sp = pop(@$sp_array); |
1182
|
2
|
50
|
|
|
|
11
|
if ($last_sp eq $sp) { |
1183
|
2
|
|
|
|
|
6
|
$sp_array->[0]--; |
1184
|
|
|
|
|
|
|
} |
1185
|
|
|
|
|
|
|
|
1186
|
|
|
|
|
|
|
# Last savepoint does not match |
1187
|
|
|
|
|
|
|
else { |
1188
|
0
|
|
|
|
|
0
|
carp "Savepoint $sp is not the last savepoint on stack"; |
1189
|
|
|
|
|
|
|
}; |
1190
|
|
|
|
|
|
|
|
1191
|
|
|
|
|
|
|
# Commit savepoint |
1192
|
2
|
100
|
66
|
|
|
27
|
if (!$rv || $rv ne '-1') { |
1193
|
1
|
|
|
|
|
9
|
$self->do("RELEASE SAVEPOINT $sp"); |
1194
|
1
|
|
|
|
|
7
|
return 1; |
1195
|
|
|
|
|
|
|
}; |
1196
|
|
|
|
|
|
|
|
1197
|
|
|
|
|
|
|
# Rollback |
1198
|
1
|
|
|
|
|
10
|
$self->do("ROLLBACK TO SAVEPOINT $sp"); |
1199
|
1
|
|
|
|
|
10
|
return; |
1200
|
|
|
|
|
|
|
}; |
1201
|
|
|
|
|
|
|
}; |
1202
|
|
|
|
|
|
|
|
1203
|
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
|
# Add connect event |
1205
|
|
|
|
|
|
|
sub on_connect { |
1206
|
3
|
|
|
3
|
1
|
9
|
my $self = shift; |
1207
|
3
|
|
|
|
|
4
|
my $cb = pop; |
1208
|
|
|
|
|
|
|
|
1209
|
|
|
|
|
|
|
# Parameter is no subroutine |
1210
|
3
|
50
|
33
|
|
|
19
|
return unless ref $cb && ref $cb eq 'CODE'; |
1211
|
|
|
|
|
|
|
|
1212
|
3
|
|
66
|
|
|
13
|
my $name = shift || '_cb_' . $self->{_connect_cb}++; |
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
# Push subroutines on_connect |
1215
|
3
|
100
|
|
|
|
8
|
unless (exists $self->{on_connect}->{$name}) { |
1216
|
2
|
|
|
|
|
6
|
$self->{on_connect}->{$name} = $cb; |
1217
|
2
|
|
|
|
|
11
|
return 1; |
1218
|
|
|
|
|
|
|
}; |
1219
|
|
|
|
|
|
|
|
1220
|
|
|
|
|
|
|
# Event was not newly established |
1221
|
1
|
|
|
|
|
5
|
return; |
1222
|
|
|
|
|
|
|
}; |
1223
|
|
|
|
|
|
|
|
1224
|
|
|
|
|
|
|
|
1225
|
|
|
|
|
|
|
# Wrapper for DBI last_insert_id |
1226
|
|
|
|
|
|
|
sub last_insert_id { |
1227
|
0
|
|
|
0
|
1
|
0
|
my $dbh = shift->dbh; |
1228
|
0
|
0
|
|
|
|
0
|
@_ = (undef) x 4 unless @_; |
1229
|
0
|
|
|
|
|
0
|
$dbh->last_insert_id(@_); |
1230
|
|
|
|
|
|
|
}; |
1231
|
|
|
|
|
|
|
|
1232
|
|
|
|
|
|
|
|
1233
|
|
|
|
|
|
|
# Import files |
1234
|
|
|
|
|
|
|
sub import_sql { |
1235
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1236
|
|
|
|
|
|
|
|
1237
|
0
|
|
|
|
|
0
|
carp 'import_sql is deprecated and will be deleted in further versions'; |
1238
|
|
|
|
|
|
|
|
1239
|
|
|
|
|
|
|
# Get callback |
1240
|
0
|
0
|
0
|
|
|
0
|
my $cb = pop @_ if ref $_[-1] && ref $_[-1] eq 'CODE'; |
1241
|
|
|
|
|
|
|
|
1242
|
0
|
0
|
|
|
|
0
|
my $files = @_ > 1 ? \@_ : shift; |
1243
|
|
|
|
|
|
|
|
1244
|
0
|
0
|
|
|
|
0
|
return unless $files; |
1245
|
|
|
|
|
|
|
|
1246
|
|
|
|
|
|
|
# Import subroutine |
1247
|
|
|
|
|
|
|
my $import = sub { |
1248
|
0
|
|
|
0
|
|
0
|
my $file = shift; |
1249
|
|
|
|
|
|
|
|
1250
|
|
|
|
|
|
|
# No file given |
1251
|
0
|
0
|
|
|
|
0
|
return unless $file; |
1252
|
|
|
|
|
|
|
|
1253
|
0
|
0
|
|
|
|
0
|
if (open(SQL, '<:utf8', $file)) { |
1254
|
0
|
|
|
|
|
0
|
my @sql = split(/^--\s-.*?$/m, join('', )); |
1255
|
0
|
|
|
|
|
0
|
close(SQL); |
1256
|
|
|
|
|
|
|
|
1257
|
|
|
|
|
|
|
# Start transaction |
1258
|
|
|
|
|
|
|
return $self->txn( |
1259
|
|
|
|
|
|
|
sub { |
1260
|
0
|
|
|
|
|
0
|
my ($sql, @sql_seq);; |
1261
|
0
|
|
|
|
|
0
|
foreach $sql (@sql) { |
1262
|
0
|
|
|
|
|
0
|
$sql =~ s/^(?:--.*?|\s*)?$//mg; |
1263
|
0
|
|
|
|
|
0
|
$sql =~ s/\n\n+/\n/sg; |
1264
|
|
|
|
|
|
|
|
1265
|
|
|
|
|
|
|
# Use callback |
1266
|
0
|
0
|
0
|
|
|
0
|
@sql_seq = $cb->($sql) if $cb && $sql; |
1267
|
|
|
|
|
|
|
|
1268
|
0
|
0
|
|
|
|
0
|
next unless $sql; |
1269
|
|
|
|
|
|
|
|
1270
|
|
|
|
|
|
|
# Start import |
1271
|
0
|
|
|
|
|
0
|
foreach (@sql_seq) { |
1272
|
0
|
0
|
|
|
|
0
|
$self->do($_) or return -1; |
1273
|
|
|
|
|
|
|
}; |
1274
|
|
|
|
|
|
|
}; |
1275
|
|
|
|
|
|
|
} |
1276
|
0
|
|
|
|
|
0
|
); |
1277
|
|
|
|
|
|
|
} |
1278
|
|
|
|
|
|
|
|
1279
|
|
|
|
|
|
|
# Unable to read SQL file |
1280
|
|
|
|
|
|
|
else { |
1281
|
0
|
|
|
|
|
0
|
carp "Unable to import file '$file'"; |
1282
|
0
|
|
|
|
|
0
|
return; |
1283
|
|
|
|
|
|
|
}; |
1284
|
0
|
|
|
|
|
0
|
}; |
1285
|
|
|
|
|
|
|
|
1286
|
|
|
|
|
|
|
# Multiple file import |
1287
|
0
|
0
|
|
|
|
0
|
if (ref $files) { |
1288
|
|
|
|
|
|
|
return $self->txn( |
1289
|
|
|
|
|
|
|
sub { |
1290
|
0
|
|
|
0
|
|
0
|
foreach (@$files) { |
1291
|
0
|
0
|
|
|
|
0
|
$import->($_) or return -1; |
1292
|
|
|
|
|
|
|
}; |
1293
|
0
|
|
|
|
|
0
|
}); |
1294
|
|
|
|
|
|
|
}; |
1295
|
|
|
|
|
|
|
|
1296
|
|
|
|
|
|
|
# Single file import |
1297
|
0
|
|
|
|
|
0
|
return $import->($files); |
1298
|
|
|
|
|
|
|
}; |
1299
|
|
|
|
|
|
|
|
1300
|
|
|
|
|
|
|
|
1301
|
|
|
|
|
|
|
# Disconnect on destroy |
1302
|
|
|
|
|
|
|
sub DESTROY { |
1303
|
36
|
|
|
36
|
|
9817
|
my $self = shift; |
1304
|
|
|
|
|
|
|
|
1305
|
|
|
|
|
|
|
# Check if table is parent |
1306
|
36
|
100
|
|
|
|
116
|
unless (exists $self->{table}) { |
1307
|
|
|
|
|
|
|
|
1308
|
|
|
|
|
|
|
# No database connection |
1309
|
10
|
50
|
|
|
|
37
|
return $self unless $self->{dbh}; |
1310
|
|
|
|
|
|
|
|
1311
|
|
|
|
|
|
|
# Delete password |
1312
|
10
|
|
|
|
|
41
|
$self->_password(0); |
1313
|
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
|
# Delete cached kids |
1315
|
10
|
50
|
|
|
|
56
|
if (blessed $self->{dbh}) { |
1316
|
10
|
|
|
|
|
61
|
local $SIG{__WARN__} = \&_no_warn; |
1317
|
10
|
|
|
|
|
147
|
my $kids = $self->{dbh}->{CachedKids}; |
1318
|
10
|
50
|
|
|
|
56
|
%$kids = () if $kids; |
1319
|
|
|
|
|
|
|
}; |
1320
|
|
|
|
|
|
|
|
1321
|
|
|
|
|
|
|
# Disconnect |
1322
|
|
|
|
|
|
|
# $self->{dbh}->disconnect unless $self->{dbh}->{Kids}; |
1323
|
10
|
|
|
|
|
512
|
$self->{dbh}->disconnect; |
1324
|
|
|
|
|
|
|
|
1325
|
|
|
|
|
|
|
# Delete parameters |
1326
|
10
|
|
|
|
|
410
|
delete $self->{$_} foreach qw/dbh on_connect _connect_cb/; |
1327
|
|
|
|
|
|
|
}; |
1328
|
|
|
|
|
|
|
|
1329
|
|
|
|
|
|
|
# Return object |
1330
|
36
|
|
|
|
|
1470
|
$self; |
1331
|
|
|
|
|
|
|
}; |
1332
|
|
|
|
|
|
|
|
1333
|
|
|
|
|
|
|
|
1334
|
|
|
|
|
|
|
# Initialize database |
1335
|
0
|
|
|
0
|
|
0
|
sub _init { 1 }; |
1336
|
|
|
|
|
|
|
|
1337
|
|
|
|
|
|
|
|
1338
|
|
|
|
|
|
|
# Connect with database |
1339
|
|
|
|
|
|
|
sub _connect { |
1340
|
30
|
|
|
30
|
|
58
|
my $self = shift; |
1341
|
|
|
|
|
|
|
|
1342
|
30
|
50
|
|
|
|
82
|
croak 'No database given' unless $self->{dsn}; |
1343
|
|
|
|
|
|
|
|
1344
|
|
|
|
|
|
|
# DBI Connect |
1345
|
|
|
|
|
|
|
my $dbh = DBI->connect( |
1346
|
|
|
|
|
|
|
$self->{dsn}, |
1347
|
|
|
|
|
|
|
$self->{user} // undef, |
1348
|
30
|
|
50
|
|
|
233
|
$self->_password, |
1349
|
|
|
|
|
|
|
{ |
1350
|
|
|
|
|
|
|
PrintError => 0, |
1351
|
|
|
|
|
|
|
RaiseError => 0, |
1352
|
|
|
|
|
|
|
AutoCommit => 1, |
1353
|
|
|
|
|
|
|
@_ |
1354
|
|
|
|
|
|
|
}); |
1355
|
|
|
|
|
|
|
|
1356
|
|
|
|
|
|
|
# Unable to connect to database |
1357
|
30
|
50
|
0
|
|
|
280085
|
carp $DBI::errstr and return unless $dbh; |
1358
|
|
|
|
|
|
|
|
1359
|
|
|
|
|
|
|
# Store database handle |
1360
|
30
|
|
|
|
|
198
|
$self->{dbh} = $dbh; |
1361
|
|
|
|
|
|
|
|
1362
|
|
|
|
|
|
|
# Save process id |
1363
|
30
|
|
|
|
|
107
|
$self->{pid} = $$; |
1364
|
|
|
|
|
|
|
|
1365
|
|
|
|
|
|
|
# Save thread id |
1366
|
30
|
50
|
|
|
|
152
|
$self->{tid} = threads->tid if $INC{'threads.pm'}; |
1367
|
|
|
|
|
|
|
|
1368
|
|
|
|
|
|
|
# Emit all on_connect events |
1369
|
30
|
|
|
|
|
69
|
foreach (values %{ $self->{on_connect} }) { |
|
30
|
|
|
|
|
130
|
|
1370
|
2
|
|
|
|
|
348
|
$_->( $self, $dbh ); |
1371
|
|
|
|
|
|
|
}; |
1372
|
|
|
|
|
|
|
|
1373
|
|
|
|
|
|
|
# Return handle |
1374
|
30
|
|
|
|
|
401
|
$dbh; |
1375
|
|
|
|
|
|
|
}; |
1376
|
|
|
|
|
|
|
|
1377
|
|
|
|
|
|
|
|
1378
|
|
|
|
|
|
|
# Password closure should prevent accidentally overt passwords |
1379
|
|
|
|
|
|
|
{ |
1380
|
|
|
|
|
|
|
# Password hash |
1381
|
|
|
|
|
|
|
my %pwd; |
1382
|
|
|
|
|
|
|
|
1383
|
|
|
|
|
|
|
# Password method |
1384
|
|
|
|
|
|
|
sub _password { |
1385
|
40
|
|
|
40
|
|
86
|
my $id = shift->{_id}; |
1386
|
40
|
|
|
|
|
55
|
my $pwd_set = shift; |
1387
|
|
|
|
|
|
|
|
1388
|
40
|
|
|
|
|
277
|
my ($this) = caller(0); |
1389
|
|
|
|
|
|
|
|
1390
|
|
|
|
|
|
|
# Request only allowed in this namespace |
1391
|
40
|
50
|
|
|
|
198
|
return if index(__PACKAGE__, $this) != 0; |
1392
|
|
|
|
|
|
|
|
1393
|
|
|
|
|
|
|
# Return password |
1394
|
40
|
100
|
|
|
|
101
|
unless (defined $pwd_set) { |
1395
|
30
|
|
|
|
|
292
|
return $pwd{$id}; |
1396
|
|
|
|
|
|
|
} |
1397
|
|
|
|
|
|
|
|
1398
|
|
|
|
|
|
|
# Delete password |
1399
|
10
|
50
|
|
|
|
30
|
unless ($pwd_set) { |
1400
|
10
|
|
|
|
|
24
|
delete $pwd{$id}; |
1401
|
|
|
|
|
|
|
} |
1402
|
|
|
|
|
|
|
|
1403
|
|
|
|
|
|
|
# Set password |
1404
|
|
|
|
|
|
|
else { |
1405
|
|
|
|
|
|
|
|
1406
|
|
|
|
|
|
|
# Password can only be set on construction |
1407
|
0
|
|
|
|
|
0
|
for ((caller(1))[3]) { |
1408
|
0
|
0
|
|
|
|
0
|
m/::new$/o or return; |
1409
|
0
|
0
|
|
|
|
0
|
index($_, __PACKAGE__) == 0 or return; |
1410
|
0
|
0
|
|
|
|
0
|
!$pwd{$id} or return; |
1411
|
0
|
|
|
|
|
0
|
$pwd{$id} = $pwd_set; |
1412
|
|
|
|
|
|
|
}; |
1413
|
|
|
|
|
|
|
}; |
1414
|
|
|
|
|
|
|
}; |
1415
|
|
|
|
|
|
|
}; |
1416
|
|
|
|
|
|
|
|
1417
|
|
|
|
|
|
|
|
1418
|
|
|
|
|
|
|
# Get table name |
1419
|
|
|
|
|
|
|
sub _table_name { |
1420
|
984
|
|
|
984
|
|
1201
|
my $self = shift; |
1421
|
|
|
|
|
|
|
|
1422
|
|
|
|
|
|
|
# Table name |
1423
|
984
|
|
|
|
|
1057
|
my $table; |
1424
|
984
|
100
|
|
|
|
1849
|
unless (exists $self->{table}) { |
1425
|
966
|
50
|
|
|
|
1913
|
return shift(@{ $_[0] }) unless ref $_[0]->[0]; |
|
966
|
|
|
|
|
2932
|
|
1426
|
|
|
|
|
|
|
} |
1427
|
|
|
|
|
|
|
|
1428
|
|
|
|
|
|
|
# Table object |
1429
|
|
|
|
|
|
|
else { |
1430
|
|
|
|
|
|
|
|
1431
|
|
|
|
|
|
|
# Join table object not allowed |
1432
|
18
|
50
|
|
|
|
83
|
return $self->{table} unless ref $self->{table}; |
1433
|
|
|
|
|
|
|
}; |
1434
|
|
|
|
|
|
|
|
1435
|
0
|
|
|
|
|
0
|
return; |
1436
|
|
|
|
|
|
|
}; |
1437
|
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
|
|
1439
|
|
|
|
|
|
|
# Get table object |
1440
|
|
|
|
|
|
|
sub _table_obj { |
1441
|
177
|
|
|
177
|
|
241
|
my $self = shift; |
1442
|
|
|
|
|
|
|
|
1443
|
177
|
|
|
|
|
252
|
my $tables; |
1444
|
177
|
|
|
|
|
358
|
my ($fields, $pairs) = ([], []); |
1445
|
|
|
|
|
|
|
|
1446
|
|
|
|
|
|
|
# Not a table object |
1447
|
177
|
100
|
|
|
|
431
|
unless (exists $self->{table}) { |
1448
|
|
|
|
|
|
|
|
1449
|
124
|
|
|
|
|
173
|
my $table = shift( @{ shift @_ } ); |
|
124
|
|
|
|
|
235
|
|
1450
|
|
|
|
|
|
|
|
1451
|
|
|
|
|
|
|
# Table name as a string |
1452
|
124
|
100
|
|
|
|
257
|
unless (ref $table) { |
1453
|
114
|
|
|
|
|
222
|
$tables = [ $table ]; |
1454
|
|
|
|
|
|
|
} |
1455
|
|
|
|
|
|
|
|
1456
|
|
|
|
|
|
|
# Joined tables |
1457
|
|
|
|
|
|
|
else { |
1458
|
10
|
|
|
|
|
31
|
return _join_tables( $table ); |
1459
|
|
|
|
|
|
|
}; |
1460
|
|
|
|
|
|
|
} |
1461
|
|
|
|
|
|
|
|
1462
|
|
|
|
|
|
|
# A table object |
1463
|
|
|
|
|
|
|
else { |
1464
|
|
|
|
|
|
|
|
1465
|
|
|
|
|
|
|
# joined table |
1466
|
53
|
100
|
|
|
|
84
|
if (ref $self->{table}) { |
1467
|
8
|
|
|
|
|
15
|
return @{ $self->{table} }; |
|
8
|
|
|
|
|
31
|
|
1468
|
|
|
|
|
|
|
} |
1469
|
|
|
|
|
|
|
|
1470
|
|
|
|
|
|
|
# Table name |
1471
|
|
|
|
|
|
|
else { |
1472
|
45
|
|
|
|
|
81
|
$tables = [ $self->{table} ]; |
1473
|
|
|
|
|
|
|
}; |
1474
|
|
|
|
|
|
|
}; |
1475
|
|
|
|
|
|
|
|
1476
|
159
|
|
|
|
|
398
|
return ($tables, $fields, $pairs); |
1477
|
|
|
|
|
|
|
}; |
1478
|
|
|
|
|
|
|
|
1479
|
|
|
|
|
|
|
|
1480
|
|
|
|
|
|
|
# Join tables |
1481
|
|
|
|
|
|
|
sub _join_tables { |
1482
|
13
|
|
|
13
|
|
29
|
my @join = @{ shift @_ }; |
|
13
|
|
|
|
|
39
|
|
1483
|
|
|
|
|
|
|
|
1484
|
13
|
|
|
|
|
50
|
my (@tables, @fields, @pairs, $treatment); |
1485
|
13
|
|
|
|
|
0
|
my %field_alias; |
1486
|
13
|
|
|
|
|
0
|
my %marker; |
1487
|
|
|
|
|
|
|
|
1488
|
|
|
|
|
|
|
# Parse table array |
1489
|
13
|
|
|
|
|
38
|
while (@join) { |
1490
|
|
|
|
|
|
|
|
1491
|
|
|
|
|
|
|
# Table name |
1492
|
26
|
|
|
|
|
52
|
my $table = shift @join; |
1493
|
|
|
|
|
|
|
|
1494
|
|
|
|
|
|
|
# Check table name |
1495
|
26
|
100
|
|
|
|
94
|
my $t_alias = $2 if $table =~ s/^([^:]+?):([^:]+?)$/$1 $2/o; |
1496
|
|
|
|
|
|
|
|
1497
|
|
|
|
|
|
|
# Push table |
1498
|
26
|
|
|
|
|
48
|
push(@tables, $table); |
1499
|
|
|
|
|
|
|
|
1500
|
|
|
|
|
|
|
# Set prefix |
1501
|
26
|
100
|
|
|
|
73
|
my $prefix = $t_alias ? $t_alias : $table; |
1502
|
|
|
|
|
|
|
|
1503
|
26
|
50
|
|
|
|
64
|
if (my $ref = ref $join[0]) { |
1504
|
|
|
|
|
|
|
|
1505
|
|
|
|
|
|
|
# Remember aliases |
1506
|
26
|
|
|
|
|
33
|
my %alias; |
1507
|
|
|
|
|
|
|
|
1508
|
|
|
|
|
|
|
# Field array |
1509
|
26
|
100
|
|
|
|
88
|
if ($ref eq 'ARRAY') { |
1510
|
|
|
|
|
|
|
|
1511
|
22
|
|
|
|
|
34
|
my $field_array = shift @join; |
1512
|
|
|
|
|
|
|
|
1513
|
22
|
|
|
|
|
29
|
my $f_prefix = ''; |
1514
|
|
|
|
|
|
|
|
1515
|
|
|
|
|
|
|
# Has a hash next to it |
1516
|
22
|
50
|
33
|
|
|
120
|
if (ref $join[0] && ref $join[0] eq 'HASH') { |
1517
|
|
|
|
|
|
|
|
1518
|
|
|
|
|
|
|
# Set Prefix if given |
1519
|
|
|
|
|
|
|
# Todo: Is this documented? |
1520
|
22
|
100
|
|
|
|
58
|
if (exists $join[0]->{-prefix}) { |
1521
|
1
|
|
|
|
|
24
|
$f_prefix = delete $join[0]->{-prefix}; |
1522
|
1
|
50
|
|
|
|
7
|
$f_prefix = _clean_alias($prefix) . '_' if $f_prefix eq '*'; |
1523
|
|
|
|
|
|
|
}; |
1524
|
|
|
|
|
|
|
}; |
1525
|
|
|
|
|
|
|
|
1526
|
|
|
|
|
|
|
# Reformat field values |
1527
|
|
|
|
|
|
|
my $reformat = [ |
1528
|
|
|
|
|
|
|
map { |
1529
|
|
|
|
|
|
|
|
1530
|
|
|
|
|
|
|
# Is a reference |
1531
|
22
|
50
|
|
|
|
38
|
unless (ref $_) { |
|
33
|
|
|
|
|
66
|
|
1532
|
|
|
|
|
|
|
|
1533
|
|
|
|
|
|
|
# Set alias semi explicitely |
1534
|
33
|
100
|
|
|
|
72
|
if (index($_, ':') == -1) { |
1535
|
24
|
|
|
|
|
64
|
$_ .= ':~' . $f_prefix . _clean_alias($_); |
1536
|
|
|
|
|
|
|
}; |
1537
|
|
|
|
|
|
|
|
1538
|
|
|
|
|
|
|
# Field is not a function |
1539
|
33
|
100
|
|
|
|
65
|
if (index($_, '(') == -1) { |
1540
|
32
|
100
|
|
|
|
90
|
$_ = "$prefix.$_" if index($_, '.') == -1; |
1541
|
|
|
|
|
|
|
} |
1542
|
|
|
|
|
|
|
|
1543
|
|
|
|
|
|
|
# Field is a function |
1544
|
|
|
|
|
|
|
else { |
1545
|
1
|
|
|
|
|
82
|
s/((?:\(|$FIELD_OP_REGEX)\s*)($KEY_REGEX_NOPREF) |
1546
|
|
|
|
|
|
|
(\s*(?:$FIELD_OP_REGEX|\)))/$1$prefix\.$2$3/ogx; |
1547
|
|
|
|
|
|
|
}; |
1548
|
|
|
|
|
|
|
|
1549
|
|
|
|
|
|
|
}; |
1550
|
|
|
|
|
|
|
|
1551
|
33
|
|
|
|
|
83
|
$_; |
1552
|
|
|
|
|
|
|
} @$field_array |
1553
|
|
|
|
|
|
|
]; |
1554
|
|
|
|
|
|
|
|
1555
|
|
|
|
|
|
|
# Automatically prepend table and, if not given, alias |
1556
|
22
|
|
|
|
|
51
|
(my $fields, $treatment, my $alias) = _fields($t_alias, $reformat); |
1557
|
|
|
|
|
|
|
|
1558
|
|
|
|
|
|
|
# Set alias for markers |
1559
|
|
|
|
|
|
|
# $alias{$_} = 1 foreach keys %$alias; |
1560
|
22
|
|
|
|
|
92
|
while (my ($key, $val) = each %$alias) { |
1561
|
33
|
|
|
|
|
115
|
$field_alias{$key} = $alias{$key} = $val ; |
1562
|
|
|
|
|
|
|
}; |
1563
|
|
|
|
|
|
|
|
1564
|
|
|
|
|
|
|
# TODO: only use alias if necessary, as they can't be used in WHERE! |
1565
|
|
|
|
|
|
|
|
1566
|
22
|
100
|
|
|
|
79
|
push(@fields, $fields) if $fields; |
1567
|
|
|
|
|
|
|
} |
1568
|
|
|
|
|
|
|
|
1569
|
|
|
|
|
|
|
# Add prepended * |
1570
|
|
|
|
|
|
|
else { |
1571
|
4
|
|
|
|
|
16
|
push(@fields, "$prefix.*"); |
1572
|
|
|
|
|
|
|
}; |
1573
|
|
|
|
|
|
|
|
1574
|
|
|
|
|
|
|
# Marker hash reference |
1575
|
26
|
50
|
33
|
|
|
115
|
if (ref $join[0] && ref $join[0] eq 'HASH') { |
1576
|
26
|
|
|
|
|
39
|
my $hash = shift @join; |
1577
|
|
|
|
|
|
|
|
1578
|
|
|
|
|
|
|
# Add database fields to marker hash |
1579
|
26
|
|
|
|
|
80
|
while (my ($key, $value) = each %$hash) { |
1580
|
|
|
|
|
|
|
|
1581
|
|
|
|
|
|
|
# TODO: Does this work? |
1582
|
26
|
50
|
|
|
|
68
|
unless ($alias{$key}) { |
1583
|
26
|
50
|
|
|
|
164
|
$key = "$prefix.$key" if $key =~ $KEY_REGEX_NOPREF; |
1584
|
|
|
|
|
|
|
} |
1585
|
|
|
|
|
|
|
else { |
1586
|
0
|
|
|
|
|
0
|
$key = $alias{$key}; |
1587
|
|
|
|
|
|
|
}; |
1588
|
|
|
|
|
|
|
|
1589
|
|
|
|
|
|
|
# Prefix, if not an explicite alias |
1590
|
26
|
100
|
|
|
|
69
|
foreach (ref $value ? @$value : $value) { |
1591
|
|
|
|
|
|
|
|
1592
|
28
|
|
100
|
|
|
113
|
my $array = ($marker{$_} //= []); |
1593
|
28
|
|
|
|
|
135
|
push(@$array, $key); |
1594
|
|
|
|
|
|
|
}; |
1595
|
|
|
|
|
|
|
}; |
1596
|
|
|
|
|
|
|
}; |
1597
|
|
|
|
|
|
|
}; |
1598
|
|
|
|
|
|
|
}; |
1599
|
|
|
|
|
|
|
|
1600
|
|
|
|
|
|
|
# Create condition pairs based on markers |
1601
|
13
|
|
|
|
|
29
|
my ($ind, $fields); |
1602
|
13
|
|
|
|
|
47
|
while (($ind, $fields) = each %marker) { |
1603
|
14
|
|
|
|
|
22
|
my $field = shift(@$fields); |
1604
|
14
|
|
|
|
|
29
|
foreach (@$fields) { |
1605
|
14
|
100
|
|
|
|
86
|
push( |
1606
|
|
|
|
|
|
|
@pairs, |
1607
|
|
|
|
|
|
|
"$field " . ($ind < 0 ? '!' : '') . "= $_" |
1608
|
|
|
|
|
|
|
); |
1609
|
|
|
|
|
|
|
}; |
1610
|
|
|
|
|
|
|
}; |
1611
|
|
|
|
|
|
|
|
1612
|
|
|
|
|
|
|
# Return join initialised values |
1613
|
13
|
|
|
|
|
99
|
return (\@tables, \@fields, \@pairs, $treatment, \%field_alias); |
1614
|
|
|
|
|
|
|
}; |
1615
|
|
|
|
|
|
|
|
1616
|
|
|
|
|
|
|
|
1617
|
|
|
|
|
|
|
# Get pairs and values |
1618
|
|
|
|
|
|
|
sub _get_pairs { |
1619
|
197
|
|
|
197
|
|
281
|
my (@pairs, @values, %prep); |
1620
|
|
|
|
|
|
|
|
1621
|
|
|
|
|
|
|
# Get alias for fields |
1622
|
197
|
100
|
|
|
|
440
|
my $alias = @_ == 2 ? pop @_ : {}; |
1623
|
|
|
|
|
|
|
|
1624
|
197
|
|
|
|
|
255
|
while (my ($key, $value) = each %{ $_[0] }) { |
|
504
|
|
|
|
|
1572
|
|
1625
|
|
|
|
|
|
|
|
1626
|
|
|
|
|
|
|
# Not a valid key |
1627
|
307
|
50
|
|
|
|
2052
|
unless ($key =~ m/^-?$KEY_REGEX$/o) { |
1628
|
0
|
0
|
|
|
|
0
|
carp "$key is not a valid Oro key" and next; |
1629
|
|
|
|
|
|
|
}; |
1630
|
|
|
|
|
|
|
|
1631
|
|
|
|
|
|
|
# Normal key |
1632
|
307
|
100
|
|
|
|
730
|
if (substr($key, 0, 1) ne '-') { |
1633
|
|
|
|
|
|
|
|
1634
|
|
|
|
|
|
|
# Get alias |
1635
|
195
|
100
|
|
|
|
825
|
$key = exists $alias->{$key} ? $alias->{$key} : (index($key, '.') >= 0 ? $key : '`' . $key . '`'); |
|
|
100
|
|
|
|
|
|
1636
|
|
|
|
|
|
|
|
1637
|
|
|
|
|
|
|
# Equality |
1638
|
195
|
50
|
|
|
|
577
|
unless (ref $value) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1639
|
|
|
|
|
|
|
|
1640
|
|
|
|
|
|
|
# NULL value |
1641
|
100
|
100
|
|
|
|
179
|
unless (defined $value) { |
1642
|
3
|
|
|
|
|
11
|
push(@pairs, "$key IS NULL"); |
1643
|
|
|
|
|
|
|
} |
1644
|
|
|
|
|
|
|
|
1645
|
|
|
|
|
|
|
# Simple value |
1646
|
|
|
|
|
|
|
else { |
1647
|
97
|
|
|
|
|
311
|
push(@pairs, "$key = ?"), |
1648
|
|
|
|
|
|
|
push(@values, $value); |
1649
|
|
|
|
|
|
|
} |
1650
|
|
|
|
|
|
|
} |
1651
|
|
|
|
|
|
|
|
1652
|
|
|
|
|
|
|
# Element of or SQL |
1653
|
0
|
|
|
|
|
0
|
elsif (ref $value eq 'ARRAY') { |
1654
|
|
|
|
|
|
|
|
1655
|
|
|
|
|
|
|
# Escaped SQL |
1656
|
7
|
100
|
66
|
|
|
30
|
if (ref $value->[0] && ref $value->[0] eq 'SCALAR') { |
1657
|
1
|
|
|
|
|
5
|
push(@pairs, "$key = (" . ${$value->[0]} . ')'), |
1658
|
1
|
|
|
|
|
3
|
push(@values, map { _stringify($_) } @{$value}[ 1 .. $#$value ]); |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
4
|
|
1659
|
1
|
|
|
|
|
3
|
next; |
1660
|
|
|
|
|
|
|
}; |
1661
|
|
|
|
|
|
|
|
1662
|
|
|
|
|
|
|
# Undefined values in the array are not specified |
1663
|
|
|
|
|
|
|
# as ' IN (NULL, ...)' does not work |
1664
|
|
|
|
|
|
|
push (@pairs, "$key IN (" . _q($value) . ')' ), |
1665
|
6
|
|
|
|
|
23
|
push(@values, map { _stringify($_) } @$value); |
|
13
|
|
|
|
|
39
|
|
1666
|
|
|
|
|
|
|
} |
1667
|
|
|
|
|
|
|
|
1668
|
|
|
|
|
|
|
# Operators |
1669
|
0
|
|
|
|
|
0
|
elsif (ref $value eq 'HASH') { |
1670
|
84
|
|
|
|
|
303
|
while (my ($op, $val) = each %$value) { |
1671
|
86
|
50
|
|
|
|
670
|
if ($op =~ $OP_REGEX) { |
1672
|
86
|
|
|
|
|
171
|
for ($op) { |
1673
|
|
|
|
|
|
|
|
1674
|
|
|
|
|
|
|
# Uppercase |
1675
|
86
|
|
|
|
|
162
|
$_ = uc; |
1676
|
|
|
|
|
|
|
|
1677
|
|
|
|
|
|
|
# Translate negation |
1678
|
86
|
|
|
|
|
188
|
s{^(?:NOT_|!(?=[MLGRB]))}{NOT }; |
1679
|
|
|
|
|
|
|
|
1680
|
|
|
|
|
|
|
# Translate literal compare operators |
1681
|
86
|
100
|
|
|
|
268
|
tr/GLENTQ/><=!/d if $_ =~ m/^(?:[GL][TE]|NE|EQ)$/o; |
1682
|
86
|
|
|
|
|
183
|
s/==/=/o; |
1683
|
|
|
|
|
|
|
}; |
1684
|
|
|
|
|
|
|
|
1685
|
|
|
|
|
|
|
# Array operators |
1686
|
86
|
100
|
66
|
|
|
214
|
if (ref $val && ref $val eq 'ARRAY') { |
1687
|
|
|
|
|
|
|
|
1688
|
|
|
|
|
|
|
# Between operator |
1689
|
3
|
100
|
|
|
|
14
|
if (index($op, 'BETWEEN') >= 0) { |
|
|
50
|
|
|
|
|
|
1690
|
|
|
|
|
|
|
push(@pairs, "$key $op ? AND ?"), |
1691
|
2
|
|
|
|
|
7
|
push(@values, map { _stringify($_) } @{$val}[0, 1]); |
|
4
|
|
|
|
|
9
|
|
|
2
|
|
|
|
|
8
|
|
1692
|
|
|
|
|
|
|
} |
1693
|
|
|
|
|
|
|
|
1694
|
|
|
|
|
|
|
# Not element of |
1695
|
|
|
|
|
|
|
elsif ($op =~ /^NOT( IN)?$/) { |
1696
|
|
|
|
|
|
|
# Undefined values in the array are not specified |
1697
|
|
|
|
|
|
|
# as ' NOT IN (NULL, ...)' does not work |
1698
|
|
|
|
|
|
|
|
1699
|
|
|
|
|
|
|
push(@pairs, "$key NOT IN (" . _q($val) . ')' ), |
1700
|
1
|
|
|
|
|
5
|
push(@values, map { _stringify($_) } @$val); |
|
2
|
|
|
|
|
5
|
|
1701
|
|
|
|
|
|
|
}; |
1702
|
|
|
|
|
|
|
} |
1703
|
|
|
|
|
|
|
|
1704
|
|
|
|
|
|
|
# Simple operator |
1705
|
|
|
|
|
|
|
else { |
1706
|
83
|
|
|
|
|
194
|
my $p = "$key $op "; |
1707
|
|
|
|
|
|
|
|
1708
|
|
|
|
|
|
|
# Value is an object |
1709
|
83
|
50
|
|
|
|
258
|
if (blessed $val) { |
1710
|
0
|
0
|
0
|
|
|
0
|
$val = _stringify($val) or |
1711
|
|
|
|
|
|
|
carp "Unknown Oro value $key $op $val" and next; |
1712
|
|
|
|
|
|
|
}; |
1713
|
|
|
|
|
|
|
|
1714
|
|
|
|
|
|
|
# Defined value |
1715
|
83
|
100
|
|
|
|
135
|
if (defined $val) { |
1716
|
75
|
|
|
|
|
129
|
$p .= '?'; |
1717
|
75
|
|
|
|
|
162
|
push(@values, $val); |
1718
|
|
|
|
|
|
|
} |
1719
|
|
|
|
|
|
|
|
1720
|
|
|
|
|
|
|
# Null value |
1721
|
|
|
|
|
|
|
else { |
1722
|
8
|
|
|
|
|
58
|
$p .= 'NULL'; |
1723
|
|
|
|
|
|
|
}; |
1724
|
|
|
|
|
|
|
|
1725
|
|
|
|
|
|
|
# Add LIKE escape sequence |
1726
|
83
|
100
|
|
|
|
163
|
if ($op eq 'LIKE') { |
1727
|
29
|
|
|
|
|
35
|
$p .= q! ESCAPE '\'!; |
1728
|
|
|
|
|
|
|
}; |
1729
|
|
|
|
|
|
|
|
1730
|
83
|
|
|
|
|
344
|
push(@pairs, $p); |
1731
|
|
|
|
|
|
|
}; |
1732
|
|
|
|
|
|
|
} |
1733
|
|
|
|
|
|
|
|
1734
|
|
|
|
|
|
|
# Unknown operator |
1735
|
|
|
|
|
|
|
else { |
1736
|
0
|
|
0
|
|
|
0
|
$val //= '?'; |
1737
|
0
|
0
|
|
|
|
0
|
carp "Unknown Oro operator $key $op $val" and next; |
1738
|
|
|
|
|
|
|
} |
1739
|
|
|
|
|
|
|
} |
1740
|
|
|
|
|
|
|
} |
1741
|
|
|
|
|
|
|
|
1742
|
|
|
|
|
|
|
# Escaped SQL |
1743
|
0
|
|
|
|
|
0
|
elsif (ref $value eq 'SCALAR') { |
1744
|
1
|
|
|
|
|
9
|
push(@pairs, "$key = ($$value)"), |
1745
|
|
|
|
|
|
|
} |
1746
|
|
|
|
|
|
|
|
1747
|
|
|
|
|
|
|
# Stringifiable object |
1748
|
0
|
|
|
|
|
0
|
elsif ($value = _stringify($value)) { |
1749
|
|
|
|
|
|
|
# Simple object |
1750
|
3
|
|
|
|
|
12
|
push(@pairs, "$key = ?"), |
1751
|
|
|
|
|
|
|
push(@values, $value); |
1752
|
|
|
|
|
|
|
} |
1753
|
|
|
|
|
|
|
|
1754
|
|
|
|
|
|
|
# Unknown pair |
1755
|
|
|
|
|
|
|
else { |
1756
|
0
|
0
|
|
|
|
0
|
carp "Unknown Oro pair $key, " . ($value ? $value : '[undef]' ) and next; |
|
|
0
|
|
|
|
|
|
1757
|
|
|
|
|
|
|
}; |
1758
|
|
|
|
|
|
|
} |
1759
|
|
|
|
|
|
|
|
1760
|
|
|
|
|
|
|
# Restriction of the result set |
1761
|
|
|
|
|
|
|
else { |
1762
|
112
|
|
|
|
|
220
|
$key = lc $key; |
1763
|
|
|
|
|
|
|
|
1764
|
|
|
|
|
|
|
# No value existing |
1765
|
112
|
50
|
|
|
|
226
|
next unless defined $value; |
1766
|
|
|
|
|
|
|
|
1767
|
|
|
|
|
|
|
# Limit and Offset restriction |
1768
|
112
|
100
|
|
|
|
553
|
if ($key =~ m/^-(?:limit|offset|distinct)$/) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1769
|
70
|
50
|
|
|
|
384
|
$prep{substr($key, 1)} = $value if $value =~ m/^\d+$/o; |
1770
|
|
|
|
|
|
|
} |
1771
|
|
|
|
|
|
|
|
1772
|
|
|
|
|
|
|
# Order restriction |
1773
|
|
|
|
|
|
|
elsif ($key =~ s/^-(order|group)(?:[-_]by)?$/$1/) { |
1774
|
|
|
|
|
|
|
|
1775
|
|
|
|
|
|
|
# Already array and group |
1776
|
38
|
100
|
100
|
|
|
112
|
if ($key eq 'group' && ref $value) { |
1777
|
2
|
100
|
66
|
|
|
12
|
if (ref $value->[-1] && ref $value->[-1] eq 'HASH') { |
1778
|
1
|
|
|
|
|
4
|
$prep{having} = pop @$value; |
1779
|
|
|
|
|
|
|
|
1780
|
1
|
50
|
|
|
|
4
|
unless (@$value) { |
1781
|
0
|
0
|
|
|
|
0
|
carp '"Having" without "Group" is not allowed' and next; |
1782
|
|
|
|
|
|
|
}; |
1783
|
|
|
|
|
|
|
}; |
1784
|
|
|
|
|
|
|
}; |
1785
|
|
|
|
|
|
|
|
1786
|
38
|
|
|
|
|
64
|
my @field_array; |
1787
|
|
|
|
|
|
|
|
1788
|
|
|
|
|
|
|
# Check group values |
1789
|
38
|
100
|
|
|
|
91
|
foreach (ref $value ? @$value : $value) { |
1790
|
|
|
|
|
|
|
|
1791
|
|
|
|
|
|
|
# Valid order/group_by value |
1792
|
39
|
100
|
|
|
|
246
|
if ($_ =~ $VALID_GROUPORDER_REGEX) { |
1793
|
38
|
|
|
|
|
124
|
s/^([\-\+])//o; |
1794
|
38
|
100
|
66
|
|
|
207
|
push(@field_array, $1 && $1 eq '-' ? "$_ DESC" : $_ ); |
1795
|
|
|
|
|
|
|
} |
1796
|
|
|
|
|
|
|
|
1797
|
|
|
|
|
|
|
# Invalid order/group_by value |
1798
|
|
|
|
|
|
|
else { |
1799
|
1
|
|
|
|
|
96
|
carp "$_ is not a valid Oro $key restriction"; |
1800
|
|
|
|
|
|
|
}; |
1801
|
|
|
|
|
|
|
}; |
1802
|
|
|
|
|
|
|
|
1803
|
38
|
100
|
|
|
|
844
|
$prep{$key} = join(', ', @field_array) if scalar @field_array; |
1804
|
|
|
|
|
|
|
} |
1805
|
|
|
|
|
|
|
|
1806
|
|
|
|
|
|
|
# And or or |
1807
|
|
|
|
|
|
|
elsif ($key =~ m/^-(or|and)$/) { |
1808
|
4
|
|
|
|
|
12
|
my $op = uc $1; |
1809
|
4
|
|
|
|
|
9
|
my @array = @$value; |
1810
|
|
|
|
|
|
|
|
1811
|
4
|
|
|
|
|
5
|
my (@or_pairs, @or_values); |
1812
|
4
|
|
|
|
|
8
|
while (@array) { |
1813
|
|
|
|
|
|
|
|
1814
|
|
|
|
|
|
|
# Not a hash |
1815
|
8
|
100
|
|
|
|
16
|
if (!ref $array[0]) { |
1816
|
4
|
|
|
|
|
11
|
unshift(@array, { |
1817
|
|
|
|
|
|
|
shift @array => shift @array |
1818
|
|
|
|
|
|
|
}); |
1819
|
|
|
|
|
|
|
}; |
1820
|
|
|
|
|
|
|
|
1821
|
|
|
|
|
|
|
# Ignore prep |
1822
|
8
|
|
|
|
|
22
|
my ($or_pairs, $or_values) = _get_pairs(shift(@array), $alias); |
1823
|
|
|
|
|
|
|
|
1824
|
|
|
|
|
|
|
# Push values |
1825
|
8
|
|
|
|
|
17
|
push(@values, @$or_values); |
1826
|
|
|
|
|
|
|
|
1827
|
|
|
|
|
|
|
# Push local pairs |
1828
|
8
|
100
|
|
|
|
13
|
if (@$or_pairs > 1) { |
1829
|
2
|
|
|
|
|
10
|
push(@or_pairs, '(' . join (' AND ', @$or_pairs) . ')'); |
1830
|
|
|
|
|
|
|
} |
1831
|
|
|
|
|
|
|
|
1832
|
|
|
|
|
|
|
# Push single local pair |
1833
|
|
|
|
|
|
|
else { |
1834
|
6
|
|
|
|
|
19
|
push(@or_pairs, $or_pairs->[0]); |
1835
|
|
|
|
|
|
|
}; |
1836
|
|
|
|
|
|
|
}; |
1837
|
|
|
|
|
|
|
|
1838
|
|
|
|
|
|
|
# Join with chosen operator |
1839
|
4
|
|
|
|
|
18
|
push(@pairs, '(' . join(" $op ", @or_pairs) . ')'); |
1840
|
|
|
|
|
|
|
} |
1841
|
|
|
|
|
|
|
|
1842
|
|
|
|
|
|
|
# Cache |
1843
|
|
|
|
|
|
|
elsif ($key eq '-cache') { |
1844
|
0
|
|
|
|
|
0
|
my $chi = $value->{chi}; |
1845
|
|
|
|
|
|
|
|
1846
|
|
|
|
|
|
|
# Check chi existence |
1847
|
0
|
0
|
|
|
|
0
|
if ($chi) { |
1848
|
0
|
|
0
|
|
|
0
|
$prep{cache} = [ $chi, $value->{key} // '', $value ]; |
1849
|
|
|
|
|
|
|
} |
1850
|
|
|
|
|
|
|
|
1851
|
|
|
|
|
|
|
# No chi given |
1852
|
|
|
|
|
|
|
else { |
1853
|
0
|
|
|
|
|
0
|
carp 'No CHI driver given for cache'; |
1854
|
|
|
|
|
|
|
}; |
1855
|
|
|
|
|
|
|
} |
1856
|
|
|
|
|
|
|
else { |
1857
|
0
|
|
|
|
|
0
|
carp "$key is an unknown restriction"; |
1858
|
|
|
|
|
|
|
}; |
1859
|
|
|
|
|
|
|
}; |
1860
|
|
|
|
|
|
|
}; |
1861
|
|
|
|
|
|
|
|
1862
|
197
|
100
|
|
|
|
915
|
return (\@pairs, \@values, (keys %prep ? \%prep : undef)); |
1863
|
|
|
|
|
|
|
}; |
1864
|
|
|
|
|
|
|
|
1865
|
|
|
|
|
|
|
|
1866
|
|
|
|
|
|
|
# Get fields |
1867
|
|
|
|
|
|
|
sub _fields { |
1868
|
60
|
|
|
60
|
|
126
|
my $table = shift; |
1869
|
|
|
|
|
|
|
|
1870
|
60
|
|
|
|
|
89
|
my (%treatment, %alias, @fields); |
1871
|
|
|
|
|
|
|
|
1872
|
60
|
|
|
|
|
83
|
foreach ( @{$_[0]} ) { |
|
60
|
|
|
|
|
129
|
|
1873
|
|
|
|
|
|
|
|
1874
|
|
|
|
|
|
|
# Ordinary String |
1875
|
84
|
100
|
33
|
|
|
174
|
unless (ref $_) { |
1876
|
|
|
|
|
|
|
|
1877
|
|
|
|
|
|
|
# Valid field |
1878
|
72
|
100
|
|
|
|
608
|
if ($_ =~ $VALID_FIELD_REGEX) { |
1879
|
71
|
|
|
|
|
164
|
push(@fields, $_); |
1880
|
|
|
|
|
|
|
} |
1881
|
|
|
|
|
|
|
|
1882
|
|
|
|
|
|
|
# Invalid field |
1883
|
|
|
|
|
|
|
else { |
1884
|
1
|
|
|
|
|
160
|
carp "$_ is not a valid Oro field value" |
1885
|
|
|
|
|
|
|
}; |
1886
|
|
|
|
|
|
|
} |
1887
|
|
|
|
|
|
|
|
1888
|
|
|
|
|
|
|
# Treatment |
1889
|
|
|
|
|
|
|
elsif (ref $_ eq 'ARRAY') { |
1890
|
|
|
|
|
|
|
my ($sub, $alias) = @$_; |
1891
|
|
|
|
|
|
|
my ($sql, $inner_sub) = $sub->($table); |
1892
|
|
|
|
|
|
|
($sql, $inner_sub, my @param) = $sql->($table) if ref $sql; |
1893
|
|
|
|
|
|
|
|
1894
|
|
|
|
|
|
|
$treatment{ $alias } = [$inner_sub, @param ] if $inner_sub; |
1895
|
|
|
|
|
|
|
push(@fields, "$sql:$alias"); |
1896
|
|
|
|
|
|
|
}; |
1897
|
|
|
|
|
|
|
}; |
1898
|
|
|
|
|
|
|
|
1899
|
60
|
|
|
|
|
893
|
my $fields = join(', ', @fields); |
1900
|
|
|
|
|
|
|
|
1901
|
|
|
|
|
|
|
# Return if no alias fields exist |
1902
|
60
|
100
|
|
|
|
243
|
return $fields unless $fields =~ m/[\.:=]/o; |
1903
|
|
|
|
|
|
|
|
1904
|
|
|
|
|
|
|
# Join with alias fields |
1905
|
|
|
|
|
|
|
return ( |
1906
|
|
|
|
|
|
|
join( |
1907
|
|
|
|
|
|
|
', ', |
1908
|
|
|
|
|
|
|
map { |
1909
|
|
|
|
|
|
|
# Explicite field alias |
1910
|
41
|
100
|
|
|
|
84
|
if ($_ =~ $FIELD_REST_RE) { |
|
61
|
50
|
|
|
|
402
|
|
|
|
100
|
|
|
|
|
|
1911
|
|
|
|
|
|
|
|
1912
|
|
|
|
|
|
|
# ~ indicates rather not explicite alias |
1913
|
|
|
|
|
|
|
# Will only be set in case of agregate functions |
1914
|
|
|
|
|
|
|
# TODO: if ($2 eq ':' && index($1,'(') >= 0); |
1915
|
53
|
|
|
|
|
187
|
$alias{$3} = $1; |
1916
|
53
|
|
|
|
|
340
|
qq{$1 AS `$3`}; |
1917
|
|
|
|
|
|
|
} |
1918
|
|
|
|
|
|
|
|
1919
|
|
|
|
|
|
|
# Implicite field alias |
1920
|
|
|
|
|
|
|
elsif (m/^(?:.+?)\.(?:[^\.]+?)$/) { |
1921
|
0
|
|
|
|
|
0
|
my $cl = _clean_alias $_; |
1922
|
0
|
|
|
|
|
0
|
$alias{$cl} = qq{$_ AS `$cl`}; |
1923
|
|
|
|
|
|
|
} |
1924
|
|
|
|
|
|
|
|
1925
|
|
|
|
|
|
|
# Field value |
1926
|
|
|
|
|
|
|
else { |
1927
|
8
|
|
|
|
|
25
|
$_ |
1928
|
|
|
|
|
|
|
}; |
1929
|
|
|
|
|
|
|
} @fields |
1930
|
|
|
|
|
|
|
), |
1931
|
|
|
|
|
|
|
(%treatment ? \%treatment : undef), |
1932
|
|
|
|
|
|
|
\%alias |
1933
|
|
|
|
|
|
|
); |
1934
|
|
|
|
|
|
|
}; |
1935
|
|
|
|
|
|
|
|
1936
|
|
|
|
|
|
|
|
1937
|
|
|
|
|
|
|
# Restrictions |
1938
|
|
|
|
|
|
|
sub _restrictions { |
1939
|
63
|
|
|
63
|
|
109
|
my ($prep, $values) = @_; |
1940
|
63
|
|
|
|
|
92
|
my $sql = ''; |
1941
|
|
|
|
|
|
|
|
1942
|
|
|
|
|
|
|
# Group restriction |
1943
|
63
|
100
|
|
|
|
157
|
if ($prep->{group}) { |
1944
|
3
|
|
|
|
|
8
|
$sql .= ' GROUP BY ' . delete $prep->{group}; |
1945
|
|
|
|
|
|
|
|
1946
|
|
|
|
|
|
|
# Having restriction |
1947
|
3
|
100
|
|
|
|
15
|
if ($prep->{having}) { |
1948
|
|
|
|
|
|
|
|
1949
|
|
|
|
|
|
|
# Get conditions |
1950
|
|
|
|
|
|
|
my ($cond_pairs, $cond_values) = _get_pairs( |
1951
|
|
|
|
|
|
|
delete $prep->{having} |
1952
|
1
|
|
|
|
|
4
|
); |
1953
|
|
|
|
|
|
|
|
1954
|
|
|
|
|
|
|
# Conditions given |
1955
|
1
|
50
|
|
|
|
4
|
if (@$cond_pairs) { |
1956
|
|
|
|
|
|
|
|
1957
|
|
|
|
|
|
|
# Append having condition |
1958
|
1
|
|
|
|
|
4
|
$sql .= ' HAVING ' . join(' AND ', @$cond_pairs); |
1959
|
|
|
|
|
|
|
|
1960
|
|
|
|
|
|
|
# Append values |
1961
|
1
|
|
|
|
|
4
|
push(@$values, @$cond_values); |
1962
|
|
|
|
|
|
|
}; |
1963
|
|
|
|
|
|
|
}; |
1964
|
|
|
|
|
|
|
}; |
1965
|
|
|
|
|
|
|
|
1966
|
|
|
|
|
|
|
# Order restriction |
1967
|
63
|
100
|
|
|
|
137
|
if (exists $prep->{order}) { |
1968
|
34
|
|
|
|
|
89
|
$sql .= ' ORDER BY ' . delete $prep->{order}; |
1969
|
|
|
|
|
|
|
}; |
1970
|
|
|
|
|
|
|
|
1971
|
|
|
|
|
|
|
# Limit restriction |
1972
|
63
|
100
|
|
|
|
151
|
if ($prep->{limit}) { |
1973
|
47
|
|
|
|
|
82
|
$sql .= ' LIMIT ?'; |
1974
|
47
|
|
|
|
|
104
|
push(@$values, delete $prep->{limit}); |
1975
|
|
|
|
|
|
|
|
1976
|
|
|
|
|
|
|
# Offset restriction |
1977
|
47
|
100
|
|
|
|
119
|
if (defined $prep->{offset}) { |
1978
|
21
|
|
|
|
|
27
|
$sql .= ' OFFSET ?'; |
1979
|
21
|
|
|
|
|
35
|
push(@$values, delete $prep->{offset}); |
1980
|
|
|
|
|
|
|
}; |
1981
|
|
|
|
|
|
|
}; |
1982
|
|
|
|
|
|
|
|
1983
|
63
|
|
|
|
|
250
|
$sql; |
1984
|
|
|
|
|
|
|
}; |
1985
|
|
|
|
|
|
|
|
1986
|
|
|
|
|
|
|
|
1987
|
|
|
|
|
|
|
# Check for stringification of blessed values |
1988
|
|
|
|
|
|
|
sub _stringify { |
1989
|
23
|
100
|
|
23
|
|
110
|
my $ref = blessed $_[0] or return $_[0]; |
1990
|
3
|
50
|
|
|
|
10
|
if (index(($_ = "$_[0]"), $ref) != 0) { |
1991
|
3
|
|
|
|
|
41
|
return $_; |
1992
|
|
|
|
|
|
|
}; |
1993
|
0
|
|
|
|
|
0
|
undef; |
1994
|
|
|
|
|
|
|
} |
1995
|
|
|
|
|
|
|
|
1996
|
|
|
|
|
|
|
|
1997
|
|
|
|
|
|
|
# Clean alias string |
1998
|
|
|
|
|
|
|
sub _clean_alias { |
1999
|
25
|
|
|
25
|
|
45
|
for (my $x = shift) { |
2000
|
25
|
|
|
|
|
74
|
tr/ ()[]"$@#./_/s; |
2001
|
25
|
|
|
|
|
56
|
s/[_\s]+$//; |
2002
|
25
|
|
|
|
|
65
|
return $x; |
2003
|
|
|
|
|
|
|
}; |
2004
|
|
|
|
|
|
|
}; |
2005
|
|
|
|
|
|
|
|
2006
|
|
|
|
|
|
|
|
2007
|
|
|
|
|
|
|
# Check list param |
2008
|
|
|
|
|
|
|
sub _check_param { |
2009
|
142
|
100
|
66
|
142
|
|
389
|
if ($_[0]->{$_[1]} && !ref $_[0]->{ $_[1] }) { |
2010
|
|
|
|
|
|
|
|
2011
|
|
|
|
|
|
|
# Check for numerical value |
2012
|
98
|
100
|
|
|
|
146
|
if ($_[2]) { |
2013
|
19
|
50
|
|
|
|
173
|
return $_[0]->{$_[1]} =~ $NUM_RE ? $1 : undef; |
2014
|
|
|
|
|
|
|
}; |
2015
|
|
|
|
|
|
|
|
2016
|
|
|
|
|
|
|
# Return value |
2017
|
79
|
|
|
|
|
147
|
return $_[0]->{$_[1]}; |
2018
|
|
|
|
|
|
|
}; |
2019
|
|
|
|
|
|
|
|
2020
|
|
|
|
|
|
|
# Fail |
2021
|
44
|
|
|
|
|
116
|
return; |
2022
|
|
|
|
|
|
|
}; |
2023
|
|
|
|
|
|
|
|
2024
|
|
|
|
|
|
|
|
2025
|
|
|
|
|
|
|
# Questionmark string |
2026
|
|
|
|
|
|
|
sub _q { |
2027
|
944
|
|
|
944
|
|
1363
|
my ($s, $i, $r); |
2028
|
|
|
|
|
|
|
|
2029
|
|
|
|
|
|
|
# Loop over all values |
2030
|
944
|
|
|
|
|
1274
|
for ($i = 0; $i < scalar(@{$_[0]});) { |
|
2397
|
|
|
|
|
3892
|
|
2031
|
1453
|
|
|
|
|
1960
|
$r = $_[0]->[$i]; |
2032
|
|
|
|
|
|
|
|
2033
|
|
|
|
|
|
|
# Append key |
2034
|
1453
|
100
|
|
|
|
2115
|
unless (ref $r) { |
2035
|
1448
|
|
|
|
|
1545
|
$s .= '?,'; |
2036
|
1448
|
|
|
|
|
1376
|
$i++; |
2037
|
1448
|
|
|
|
|
1620
|
next; |
2038
|
|
|
|
|
|
|
}; |
2039
|
|
|
|
|
|
|
|
2040
|
|
|
|
|
|
|
# Scalar for direct SQL input |
2041
|
5
|
100
|
|
|
|
20
|
if (ref $r eq 'SCALAR') { |
|
|
100
|
|
|
|
|
|
2042
|
1
|
|
|
|
|
5
|
$s .= "($$r),"; |
2043
|
1
|
|
|
|
|
2
|
splice(@{$_[0]}, $i, 1, ()); |
|
1
|
|
|
|
|
3
|
|
2044
|
|
|
|
|
|
|
} |
2045
|
|
|
|
|
|
|
|
2046
|
|
|
|
|
|
|
# Array for direct SQL input |
2047
|
|
|
|
|
|
|
elsif (ref $r eq 'ARRAY') { |
2048
|
|
|
|
|
|
|
|
2049
|
|
|
|
|
|
|
# Check for scalar reference |
2050
|
1
|
50
|
|
|
|
3
|
unless (ref $r->[0]) { |
2051
|
0
|
|
|
|
|
0
|
carp 'First element of array insertion needs to be a scalar reference'; |
2052
|
0
|
|
|
|
|
0
|
splice(@{$_[0]}, $i++, 1); |
|
0
|
|
|
|
|
0
|
|
2053
|
0
|
|
|
|
|
0
|
next; |
2054
|
|
|
|
|
|
|
}; |
2055
|
|
|
|
|
|
|
|
2056
|
|
|
|
|
|
|
# Embed SQL statement directly |
2057
|
1
|
|
|
|
|
2
|
$s .= '(' . ${ shift @$r } . '),'; |
|
1
|
|
|
|
|
3
|
|
2058
|
1
|
|
|
|
|
2
|
splice(@{$_[0]}, $i++, scalar @$r, @$r); |
|
1
|
|
|
|
|
5
|
|
2059
|
|
|
|
|
|
|
} |
2060
|
|
|
|
|
|
|
|
2061
|
|
|
|
|
|
|
# Stringifyable objects |
2062
|
|
|
|
|
|
|
else { |
2063
|
3
|
|
|
|
|
6
|
$i++; |
2064
|
3
|
50
|
|
|
|
8
|
$s .= '?,' and next; |
2065
|
|
|
|
|
|
|
}; |
2066
|
|
|
|
|
|
|
}; |
2067
|
|
|
|
|
|
|
|
2068
|
|
|
|
|
|
|
# Delete final ',' |
2069
|
944
|
|
|
|
|
1307
|
chop $s; |
2070
|
|
|
|
|
|
|
|
2071
|
|
|
|
|
|
|
# Return value |
2072
|
944
|
|
|
|
|
1968
|
$s; |
2073
|
|
|
|
|
|
|
}; |
2074
|
|
|
|
|
|
|
|
2075
|
|
|
|
|
|
|
|
2076
|
|
|
|
|
|
|
# Trim last_sql message for reporting |
2077
|
|
|
|
|
|
|
sub _trim_last_sql { |
2078
|
15
|
|
|
15
|
|
28
|
my $last_sql = shift; |
2079
|
|
|
|
|
|
|
|
2080
|
15
|
50
|
|
|
|
2185
|
return $last_sql if length($last_sql) <= 500; |
2081
|
0
|
|
|
|
|
|
return substr($last_sql, 0, 497) . ' ...'; |
2082
|
|
|
|
|
|
|
}; |
2083
|
|
|
|
|
|
|
|
2084
|
|
|
|
|
|
|
|
2085
|
|
|
|
|
|
|
# Empty code ref |
2086
|
|
|
|
0
|
|
|
sub _no_warn {}; |
2087
|
|
|
|
|
|
|
|
2088
|
|
|
|
|
|
|
|
2089
|
|
|
|
|
|
|
1; |
2090
|
|
|
|
|
|
|
|
2091
|
|
|
|
|
|
|
|
2092
|
|
|
|
|
|
|
__END__ |