line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# -*- perl -*- |
2
|
|
|
|
|
|
|
##---------------------------------------------------------------------------- |
3
|
|
|
|
|
|
|
## Database Object Interface - ~/lib/DB/Object/Statement.pm |
4
|
|
|
|
|
|
|
## Version v0.4.2 |
5
|
|
|
|
|
|
|
## Copyright(c) 2022 DEGUEST Pte. Ltd. |
6
|
|
|
|
|
|
|
## Author: Jacques Deguest <jack@deguest.jp> |
7
|
|
|
|
|
|
|
## Created 2017/07/19 |
8
|
|
|
|
|
|
|
## Modified 2023/03/24 |
9
|
|
|
|
|
|
|
## All rights reserved |
10
|
|
|
|
|
|
|
## |
11
|
|
|
|
|
|
|
## This program is free software; you can redistribute it and/or modify it |
12
|
|
|
|
|
|
|
## under the same terms as Perl itself. |
13
|
|
|
|
|
|
|
##---------------------------------------------------------------------------- |
14
|
|
|
|
|
|
|
## This package's purpose is to automatically terminate the statement object and |
15
|
|
|
|
|
|
|
## separate them from the connection object (DB::Object). |
16
|
|
|
|
|
|
|
## Connection object last longer than statement objects |
17
|
|
|
|
|
|
|
##---------------------------------------------------------------------------- |
18
|
|
|
|
|
|
|
package DB::Object::Statement; |
19
|
|
|
|
|
|
|
BEGIN |
20
|
0
|
|
|
|
|
0
|
{ |
21
|
1
|
|
|
1
|
|
1777
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
34
|
|
22
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
28
|
|
23
|
1
|
|
|
1
|
|
5
|
use parent qw( DB::Object ); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
5
|
|
24
|
1
|
|
|
1
|
|
62
|
use vars qw( $VERSION $VERBOSE $DEBUG ); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
53
|
|
25
|
1
|
|
|
1
|
|
6
|
use Class::Struct qw( struct ); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
8
|
|
26
|
1
|
|
|
1
|
|
113
|
use Want; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
60
|
|
27
|
1
|
|
|
1
|
|
57
|
$VERSION = 'v0.4.2'; |
28
|
1
|
|
|
|
|
1
|
$VERBOSE = 0; |
29
|
1
|
|
|
|
|
19
|
$DEBUG = 0; |
30
|
1
|
|
|
1
|
|
6
|
use Devel::Confess; |
|
1
|
|
|
|
|
12
|
|
|
1
|
|
|
|
|
8
|
|
31
|
|
|
|
|
|
|
}; |
32
|
|
|
|
|
|
|
|
33
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
35
|
|
34
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1872
|
|
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
sub as_string |
37
|
|
|
|
|
|
|
{ |
38
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
39
|
|
|
|
|
|
|
# my $q = $self->_query_object_current; |
40
|
|
|
|
|
|
|
# used by select, insert, update, delete to flag that we need to reformat the query |
41
|
0
|
|
|
|
|
|
$self->{as_string}++; |
42
|
0
|
0
|
|
|
|
|
if( my $qo = $self->query_object ) |
43
|
|
|
|
|
|
|
{ |
44
|
0
|
|
|
|
|
|
$qo->final(1); |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
# return( $self->{sth}->{Statement} ); |
47
|
|
|
|
|
|
|
# Same: |
48
|
|
|
|
|
|
|
# return( $q->as_string ); |
49
|
0
|
|
|
|
|
|
return( $self->{query} ); |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub bind_param |
53
|
|
|
|
|
|
|
{ |
54
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
55
|
0
|
|
|
|
|
|
my( $pack, $file, $line ) = caller(); |
56
|
0
|
|
|
|
|
|
my $sub = ( caller(1) )[3]; |
57
|
0
|
|
|
|
|
|
$self->{pack} = $pack; |
58
|
0
|
|
|
|
|
|
$self->{file} = $file; |
59
|
0
|
|
|
|
|
|
$self->{line} = $line; |
60
|
0
|
|
|
|
|
|
$self->{sub} = $sub; |
61
|
|
|
|
|
|
|
my $rc = |
62
|
|
|
|
|
|
|
eval |
63
|
0
|
|
|
|
|
|
{ |
64
|
0
|
|
|
|
|
|
$self->{sth}->bind_param( @_ ); |
65
|
|
|
|
|
|
|
}; |
66
|
0
|
0
|
|
|
|
|
if( $@ ) |
|
|
0
|
|
|
|
|
|
67
|
|
|
|
|
|
|
{ |
68
|
0
|
|
|
|
|
|
my $err = $self->errstr(); |
69
|
0
|
|
|
|
|
|
$err =~ s/ at line \d+.*$//; |
70
|
|
|
|
|
|
|
# printf( STDERR "%s in %s at line %d within sub '%s'.\n", $err, $self->{file}, $self->{line}, $self->{sub} ); |
71
|
|
|
|
|
|
|
# exit(1); |
72
|
0
|
|
|
|
|
|
return( $self->error( $err ) ); |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
elsif( $rc ) |
75
|
|
|
|
|
|
|
{ |
76
|
0
|
|
|
|
|
|
return( $rc ); |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
else |
79
|
|
|
|
|
|
|
{ |
80
|
0
|
|
0
|
|
|
|
my $err = $@ = $self->{sth}->errstr() || "Unknown error while binding parameters to query."; |
81
|
0
|
|
|
|
|
|
return( $self->error( $err ) ); |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
sub commit |
86
|
|
|
|
|
|
|
{ |
87
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
88
|
0
|
0
|
0
|
|
|
|
if( $self->{sth} && $self->param( 'autocommit' ) ) |
89
|
|
|
|
|
|
|
{ |
90
|
0
|
|
0
|
|
|
|
my $sth = $self->prepare( 'COMMIT' ) || return( $self->pass_error ); |
91
|
0
|
0
|
|
|
|
|
$sth->execute() || return( $self->error( "An error occurred while executing query: ", $sth->error ) ); |
92
|
0
|
|
|
|
|
|
$sth->finish(); |
93
|
|
|
|
|
|
|
} |
94
|
0
|
|
|
|
|
|
return( $self ); |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
0
|
|
|
0
|
1
|
|
sub database_object { return( shift->_set_get_object_without_init( 'dbo', 'DB::Object', @_ ) ); } |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
sub distinct |
100
|
|
|
|
|
|
|
{ |
101
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
102
|
|
|
|
|
|
|
my $query = $self->{query} || |
103
|
0
|
|
0
|
|
|
|
return( $self->error( "No query to set as to be ignored." ) ); |
104
|
|
|
|
|
|
|
|
105
|
0
|
|
|
|
|
|
my $type = uc( ( $query =~ /^\s*(\S+)\s+/ )[0] ); |
106
|
|
|
|
|
|
|
# ALTER for table alteration statements (DB::Object::Tables |
107
|
0
|
|
|
|
|
|
my @allowed = qw( SELECT ); |
108
|
0
|
|
|
|
|
|
my $allowed = CORE::join( '|', @allowed ); |
109
|
0
|
0
|
|
|
|
|
if( !scalar( grep{ /^$type$/i } @allowed ) ) |
|
0
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
{ |
111
|
0
|
|
|
|
|
|
return( $self->error( "You may not flag statement of type \U$type\E to be distinct:\n$query" ) ); |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
# Incompatible. Do not bother going further |
114
|
0
|
0
|
|
|
|
|
return( $self ) if( $query =~ /^\s*(?:$allowed)\s+(?:DISTINCT|DISTINCTROW|ALL)\s+/i ); |
115
|
|
|
|
|
|
|
|
116
|
0
|
|
|
|
|
|
$query =~ s/^(\s*)($allowed)(\s+)/$1$2 DISTINCT /; |
117
|
|
|
|
|
|
|
# my $sth = $self->prepare( $query ) || |
118
|
|
|
|
|
|
|
# $self->{ 'query' } = $query; |
119
|
|
|
|
|
|
|
# saving parameters to bind later on must have been done previously |
120
|
0
|
|
0
|
|
|
|
my $sth = $self->_cache_this( $query ) || |
121
|
|
|
|
|
|
|
return( $self->error( "Error while preparing new ignored query:\n$query" ) ); |
122
|
0
|
0
|
|
|
|
|
if( !defined( wantarray() ) ) |
123
|
|
|
|
|
|
|
{ |
124
|
0
|
0
|
|
|
|
|
$sth->execute() || |
125
|
|
|
|
|
|
|
return( $self->error( "Error while executing new ignored query:\n$query" ) ); |
126
|
|
|
|
|
|
|
} |
127
|
0
|
|
|
|
|
|
return( $sth ); |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
sub dump |
131
|
|
|
|
|
|
|
{ |
132
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
133
|
0
|
|
|
|
|
|
my $file = shift( @_ ); |
134
|
0
|
0
|
|
|
|
|
if( $file ) |
|
|
0
|
|
|
|
|
|
135
|
|
|
|
|
|
|
{ |
136
|
|
|
|
|
|
|
# Used to be handled by SQL server |
137
|
|
|
|
|
|
|
# my $query = $self->as_string(); |
138
|
|
|
|
|
|
|
# $query =~ s/(\s+FROM\s+)/ INTO OUTFILE '$file'$1/; |
139
|
|
|
|
|
|
|
# my $sth = $self->prepare( $query ) || |
140
|
|
|
|
|
|
|
# return( $self->error( "Error while preparing query to dump result on select:\n$query" ) ); |
141
|
|
|
|
|
|
|
# $sth->execute() || |
142
|
|
|
|
|
|
|
# return( $self->error( "Error while executing query to dump result on select:\n$query" ) ); |
143
|
0
|
0
|
|
|
|
|
$self->_load_class( 'DateTime' ) || return( $self->pass_error ); |
144
|
0
|
|
|
|
|
|
my $fields = $self->{_fields}; |
145
|
0
|
|
|
|
|
|
my @header = sort{ $fields->{ $a } <=> $fields->{ $b } } keys( %$fields ); |
|
0
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
# new_file is inherited from Module::Generic |
147
|
0
|
|
|
|
|
|
$file = $self->new_file( $file ); |
148
|
0
|
|
0
|
|
|
|
my $io = $file->open( '>', { binmode => 'utf8' }) || |
149
|
|
|
|
|
|
|
return( $self->error( "Unable to open file '$file' in write mode: ", $file->error ) ); |
150
|
0
|
|
|
|
|
|
my $date = DateTime->now; |
151
|
0
|
|
|
|
|
|
my $table = $self->{table}; |
152
|
0
|
|
|
|
|
|
$io->printf( "## Generated on %s for table $table\n", $date->strftime( '%c' ) ); |
153
|
0
|
|
|
|
|
|
$io->print( "## ", CORE::join( "\t", @header ), "\n" ); |
154
|
0
|
|
|
|
|
|
my @data = (); |
155
|
0
|
|
|
|
|
|
while( @data = $self->fetchrow() ) |
156
|
|
|
|
|
|
|
{ |
157
|
0
|
|
|
|
|
|
print( $io CORE::join( "\t", @data ), "\n" ); |
158
|
|
|
|
|
|
|
} |
159
|
0
|
|
|
|
|
|
$io->close; |
160
|
0
|
|
|
|
|
|
$self->finish; |
161
|
0
|
|
|
|
|
|
return( $self ); |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
elsif( exists( $self->{sth} ) ) |
164
|
|
|
|
|
|
|
{ |
165
|
|
|
|
|
|
|
# my $fields = $self->{ '_fields' }; |
166
|
0
|
|
|
|
|
|
my @fields = @{ $self->{sth}->FETCH( 'NAME' ) }; |
|
0
|
|
|
|
|
|
|
167
|
0
|
|
|
|
|
|
my $max = 0; |
168
|
|
|
|
|
|
|
# foreach my $field ( keys( %$fields ) ) |
169
|
0
|
|
|
|
|
|
foreach my $field ( @fields ) |
170
|
|
|
|
|
|
|
{ |
171
|
0
|
0
|
|
|
|
|
$max = length( $field ) if( length( $field ) > $max ); |
172
|
|
|
|
|
|
|
} |
173
|
0
|
|
|
|
|
|
my $template = ''; |
174
|
|
|
|
|
|
|
## foreach my $field ( sort{ $fields->{ $a } <=> $fields->{ $b } } keys( %$fields ) ) |
175
|
0
|
|
|
|
|
|
foreach my $field ( @fields ) |
176
|
|
|
|
|
|
|
{ |
177
|
0
|
|
|
|
|
|
$template .= "$field" . ( '.' x ( $max - length( $field ) ) ) . ": %s\n"; |
178
|
|
|
|
|
|
|
} |
179
|
0
|
|
|
|
|
|
$template .= "\n"; |
180
|
0
|
|
|
|
|
|
my @data = (); |
181
|
0
|
|
|
|
|
|
while( @data = $self->fetchrow() ) |
182
|
|
|
|
|
|
|
{ |
183
|
0
|
|
|
|
|
|
printf( STDERR $template, @data ); |
184
|
|
|
|
|
|
|
} |
185
|
0
|
|
|
|
|
|
$self->finish; |
186
|
0
|
|
|
|
|
|
return( $self ); |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
else |
189
|
|
|
|
|
|
|
{ |
190
|
0
|
|
|
|
|
|
return( $self->error( "No query to dump." ) ); |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
0
|
|
|
0
|
1
|
|
sub exec { return( shift->execute( @_ ) ); } |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub execute |
197
|
|
|
|
|
|
|
{ |
198
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
199
|
0
|
|
|
|
|
|
my( $pack, $file, $line ) = caller(); |
200
|
0
|
|
|
|
|
|
my $sub = ( caller(1) )[3]; |
201
|
|
|
|
|
|
|
# What we want is to get the point from where we were originatly called |
202
|
0
|
0
|
|
|
|
|
if( $pack =~ /^DB::Object/ ) |
203
|
|
|
|
|
|
|
{ |
204
|
0
|
|
|
|
|
|
for( my $i = 1; $i < 5; $i++ ) |
205
|
|
|
|
|
|
|
{ |
206
|
0
|
|
|
|
|
|
( $pack, $file, $line ) = caller( $i ); |
207
|
0
|
|
|
|
|
|
$sub = ( caller( $i + 1 ) )[3]; |
208
|
0
|
0
|
|
|
|
|
last if( $pack !~ /^DB::Object/ ); |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
# my $sub = ( caller( 1 ) )[ 3 ]; |
212
|
0
|
|
|
|
|
|
$self->{pack} = $pack; |
213
|
0
|
|
|
|
|
|
$self->{file} = $file; |
214
|
0
|
|
|
|
|
|
$self->{line} = $line; |
215
|
0
|
|
|
|
|
|
$self->{sub} = $sub; |
216
|
0
|
|
|
|
|
|
$self->{executed}++; |
217
|
0
|
|
|
|
|
|
my $q = $self->query_object; |
218
|
0
|
0
|
|
|
|
|
$q->final(1) if( $q ); |
219
|
0
|
|
|
|
|
|
my @binded = (); |
220
|
0
|
|
|
|
|
|
my @binded_types = (); |
221
|
0
|
0
|
0
|
|
|
|
if( $q && $q->binded_types->length ) |
222
|
|
|
|
|
|
|
{ |
223
|
0
|
|
|
|
|
|
my $types = $q->binded_types_as_param; |
224
|
0
|
|
|
|
|
|
@binded_types = @$types; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
# if( $q && ( $self->{bind} || |
228
|
|
|
|
|
|
|
# ( |
229
|
|
|
|
|
|
|
# ( $q->_query_type eq 'insert' || $q->_query_type eq 'update' ) && |
230
|
|
|
|
|
|
|
# $q->binded_types->length ) |
231
|
|
|
|
|
|
|
# ) ) |
232
|
0
|
0
|
0
|
|
|
|
if( $q && $self->{bind} ) |
233
|
|
|
|
|
|
|
{ |
234
|
|
|
|
|
|
|
# if( @_ && ( $self->_is_hash( $_[0] ) ) ) |
235
|
0
|
0
|
0
|
|
|
|
if( @_ && |
|
|
0
|
0
|
|
|
|
|
236
|
|
|
|
|
|
|
( |
237
|
|
|
|
|
|
|
# hash reference |
238
|
|
|
|
|
|
|
( @_ == 1 && $self->_is_hash( $_[0] ) ) || |
239
|
|
|
|
|
|
|
# key => value pairs |
240
|
|
|
|
|
|
|
( !( @_ % 2 ) && ref( $_[0] ) ne 'HASH' ) |
241
|
|
|
|
|
|
|
) |
242
|
|
|
|
|
|
|
) |
243
|
|
|
|
|
|
|
{ |
244
|
0
|
|
|
|
|
|
my $vals = {}; |
245
|
0
|
0
|
|
|
|
|
if( $self->_is_hash( $_[0] ) ) |
246
|
|
|
|
|
|
|
{ |
247
|
0
|
|
|
|
|
|
$vals = shift( @_ ); |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
else |
250
|
|
|
|
|
|
|
{ |
251
|
0
|
|
|
|
|
|
$vals = { @_ }; |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
# This is the list of fields as they appear in the order in insert or update query |
254
|
|
|
|
|
|
|
# Knowing their order of appearance is key so we can bind follow-on values to them |
255
|
0
|
|
|
|
|
|
my $sorted = $q->sorted; |
256
|
0
|
|
|
|
|
|
foreach my $f ( @$sorted ) |
257
|
|
|
|
|
|
|
{ |
258
|
0
|
0
|
|
|
|
|
if( !CORE::exists( $vals->{ $f } ) ) |
259
|
|
|
|
|
|
|
{ |
260
|
0
|
|
|
|
|
|
push( @binded, undef() ); |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
# The value may be defined or not, or may be zero length long |
263
|
|
|
|
|
|
|
else |
264
|
|
|
|
|
|
|
{ |
265
|
0
|
|
|
|
|
|
push( @binded, $vals->{ $f } ); |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
elsif( @_ ) |
270
|
|
|
|
|
|
|
{ |
271
|
0
|
|
|
|
|
|
push( @binded, @_ ); |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
else |
274
|
|
|
|
|
|
|
{ |
275
|
0
|
|
|
|
|
|
my $binded_values = $q->binded; |
276
|
0
|
0
|
|
|
|
|
push( @binded, @$binded_values ) if( scalar( @$binded_values ) ); |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
|
280
|
0
|
0
|
0
|
|
|
|
@binded = @_ if( ( !@binded && @_ ) || @_ ); |
|
|
|
0
|
|
|
|
|
281
|
0
|
0
|
|
|
|
|
@binded = () if( !@binded ); |
282
|
0
|
0
|
0
|
|
|
|
if( $q && $q->is_upsert ) |
283
|
|
|
|
|
|
|
{ |
284
|
0
|
0
|
|
|
|
|
if( scalar( @binded_types ) > scalar( @binded ) ) |
285
|
|
|
|
|
|
|
{ |
286
|
0
|
|
|
|
|
|
CORE::push( @binded, @binded ); |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
|
290
|
0
|
0
|
|
|
|
|
if( scalar( @_ ) ) |
291
|
|
|
|
|
|
|
{ |
292
|
0
|
|
|
|
|
|
my $temp = {}; |
293
|
0
|
|
|
|
|
|
for( my $i = 0; $i < scalar( @_ ); $i++ ) |
294
|
|
|
|
|
|
|
{ |
295
|
|
|
|
|
|
|
# { $some_value => 'varchar' } |
296
|
0
|
0
|
0
|
|
|
|
if( ref( $_[$i] ) eq 'HASH' && |
|
|
|
0
|
|
|
|
|
297
|
0
|
|
|
|
|
|
scalar( keys( %{$_[$i]} ) ) == 1 && |
298
|
|
|
|
|
|
|
# e.g. DBI::SQL_VARCHAR or DBI::SQL_INTEGER |
299
|
0
|
|
|
|
|
|
DBI->can( "SQL_" . uc( [values( %{$_[$i]} )]->[0] ) ) ) |
300
|
|
|
|
|
|
|
{ |
301
|
0
|
|
|
|
|
|
my $constant = DBI->can( "SQL_" . uc( [values( %{$_[$i]} )]->[0] ) ); |
|
0
|
|
|
|
|
|
|
302
|
0
|
|
|
|
|
|
$temp->{$i} = { type => $constant->(), value => [keys( %{$_[$i]} )]->[0] }; |
|
0
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
# The user has chosen to override any datatype computed and be explicit. |
307
|
0
|
0
|
|
|
|
|
if( scalar( keys( %$temp ) ) == scalar( @_ ) ) |
|
|
0
|
|
|
|
|
|
308
|
|
|
|
|
|
|
{ |
309
|
0
|
|
|
|
|
|
@binded = @_; |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
elsif( scalar( keys( %$temp ) ) ) |
312
|
|
|
|
|
|
|
{ |
313
|
0
|
|
|
|
|
|
foreach my $i ( sort( keys( %$temp ) ) ) |
314
|
|
|
|
|
|
|
{ |
315
|
0
|
|
|
|
|
|
CORE::splice( @binded_types, $i, 0, $temp->{ $i }->{type} ); |
316
|
0
|
|
|
|
|
|
$binded[$i] = $temp->{ $i }->{value}; |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
# $sth->exec({ $my_value => DBI::SQL_VARCHAR }); |
322
|
|
|
|
|
|
|
# for( my $i = 0; $i < scalar( @binded ); $i++ ) |
323
|
|
|
|
|
|
|
# { |
324
|
|
|
|
|
|
|
# # { $some_value => 'varchar' } |
325
|
|
|
|
|
|
|
# if( ref( $binded[$i] ) eq 'HASH' && |
326
|
|
|
|
|
|
|
# scalar( keys( %{$binded[$i]} ) ) == 1 && |
327
|
|
|
|
|
|
|
# # e.g. DBI::SQL_VARCHAR or DBI::SQL_INTEGER |
328
|
|
|
|
|
|
|
# DBI->can( "SQL_" . uc( [values( %{$binded[$i]} )]->[0] ) ) ) |
329
|
|
|
|
|
|
|
# { |
330
|
|
|
|
|
|
|
# my $constant = DBI->can( "SQL_" . uc( [values( %{$binded[$i]} )]->[0] ) ); |
331
|
|
|
|
|
|
|
# # Get the DBI SQL contant value and add it as a type |
332
|
|
|
|
|
|
|
# CORE::splice( @binded_types, $i, 0, $constant->() ); |
333
|
|
|
|
|
|
|
# # Replace our current value with the actual value |
334
|
|
|
|
|
|
|
# $binded[$i] = [keys( %{$binded[$i]} )]->[0]; |
335
|
|
|
|
|
|
|
# } |
336
|
|
|
|
|
|
|
# } |
337
|
|
|
|
|
|
|
|
338
|
0
|
0
|
0
|
|
|
|
if( $q && scalar( @binded ) != scalar( @binded_types ) ) |
339
|
|
|
|
|
|
|
{ |
340
|
0
|
|
|
|
|
|
warn( sprintf( "Warning: total %d bound values does not match the total %d bound types ('%s')! Check the code for query $self->{sth}->{Statement}...\n", scalar( @binded ), scalar( @binded_types ), CORE::join( "','", @binded_types ) ) ); |
341
|
|
|
|
|
|
|
# Cancel it, because it will create problems |
342
|
0
|
|
|
|
|
|
@binded_types = (); |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
# If there are any array object of some sort provided, make sure they are transformed into a regular array so DBD::Ph can then transform it into a Postgres array. |
346
|
0
|
|
|
|
|
|
for( my $i = 0; $i < scalar( @binded ); $i++ ) |
347
|
|
|
|
|
|
|
{ |
348
|
0
|
0
|
|
|
|
|
next if( !defined( $binded[$i] ) ); |
349
|
0
|
0
|
0
|
|
|
|
if( $self->_is_array( $binded[$i] ) && |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
350
|
|
|
|
|
|
|
ref( $binded[$i] ) ne 'ARRAY' ) |
351
|
|
|
|
|
|
|
{ |
352
|
0
|
|
|
|
|
|
$binded[$i] = [@{$binded[$i]}]; |
|
0
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
elsif( $self->_is_object( $binded[$i] ) && |
355
|
|
|
|
|
|
|
overload::Overloaded( $binded[$i] ) && |
356
|
|
|
|
|
|
|
overload::Method( $binded[$i], '""' ) ) |
357
|
|
|
|
|
|
|
{ |
358
|
1
|
|
|
1
|
|
9
|
no warnings 'uninitialized'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
5399
|
|
359
|
0
|
|
|
|
|
|
my $v = "$binded[$i]"; |
360
|
0
|
0
|
|
|
|
|
$binded[$i] = defined( $v ) ? $v : undef; |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
# Will work well with Module::Generic::Hash |
363
|
|
|
|
|
|
|
elsif( $self->_is_hash( $binded[$i] ) && |
364
|
|
|
|
|
|
|
$self->_can( $binded[$i], 'as_json' ) ) |
365
|
|
|
|
|
|
|
{ |
366
|
0
|
|
|
|
|
|
$binded[$i] = $binded[$i]->as_json; |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
|
370
|
0
|
|
|
|
|
|
local $_; |
371
|
|
|
|
|
|
|
my $rv = |
372
|
|
|
|
|
|
|
eval |
373
|
0
|
|
|
|
|
|
{ |
374
|
|
|
|
|
|
|
#local( $SIG{__DIE__} ) = sub{ }; |
375
|
|
|
|
|
|
|
#local( $SIG{__WARN__} ) = sub{ }; |
376
|
0
|
|
|
0
|
|
|
local( $SIG{ALRM} ) = sub{ die( "Timeout while processing query $self->{sth}->{Statement}\n" ) }; |
|
0
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
# print( STDERR ref( $self ) . "::execute(): binding parameters '", join( ', ', @$binded ), "' to query:\n$self->{ 'query' }\n" ); |
378
|
|
|
|
|
|
|
# $self->{ 'sth' }->execute( @binded ); |
379
|
0
|
|
|
|
|
|
for( my $i = 0; $i < scalar( @binded ); $i++ ) |
380
|
|
|
|
|
|
|
{ |
381
|
|
|
|
|
|
|
# Stringify the binded value if it is a stringifyable object. |
382
|
0
|
0
|
0
|
|
|
|
if( ref( $binded[$i] ) && |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
383
|
|
|
|
|
|
|
$self->_is_object( $binded[$i] ) && |
384
|
|
|
|
|
|
|
overload::Overloaded( $binded[$i] ) && |
385
|
|
|
|
|
|
|
overload::Method( $binded[$i], '""' ) ) |
386
|
|
|
|
|
|
|
{ |
387
|
0
|
|
|
|
|
|
$binded[$i] .= ''; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
0
|
|
|
|
|
|
my $data_type = $binded_types[ $i ]; |
391
|
0
|
0
|
0
|
|
|
|
if( CORE::length( $data_type ) && $self->_is_hash( $data_type ) ) |
392
|
|
|
|
|
|
|
{ |
393
|
0
|
|
|
|
|
|
$self->{sth}->bind_param( $i + 1, $binded[ $i ], $data_type ); |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
else |
396
|
|
|
|
|
|
|
{ |
397
|
0
|
|
|
|
|
|
$self->{sth}->bind_param( $i + 1, $binded[ $i ] ); |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
} |
400
|
0
|
|
|
|
|
|
$self->{sth}->execute(); |
401
|
|
|
|
|
|
|
}; |
402
|
0
|
|
|
|
|
|
my $error = $@; |
403
|
0
|
0
|
0
|
|
|
|
$error ||= $self->{sth}->errstr if( !$rv ); |
404
|
0
|
0
|
|
|
|
|
if( $q ) |
405
|
|
|
|
|
|
|
{ |
406
|
0
|
0
|
|
|
|
|
if( $q->join_tables->length > 0 ) |
407
|
|
|
|
|
|
|
{ |
408
|
|
|
|
|
|
|
$q->join_tables->foreach(sub{ |
409
|
0
|
|
|
0
|
|
|
my $tbl = shift( @_ ); |
410
|
0
|
0
|
0
|
|
|
|
return if( !$tbl || !ref( $tbl ) ); |
411
|
0
|
|
|
|
|
|
$tbl->reset; |
412
|
0
|
|
|
|
|
|
}); |
413
|
|
|
|
|
|
|
} |
414
|
0
|
|
|
|
|
|
$q->table_object->reset; |
415
|
|
|
|
|
|
|
} |
416
|
0
|
|
0
|
|
|
|
my $tie = $self->{tie} || {}; |
417
|
|
|
|
|
|
|
# Maybe it is time to bind SQL result to possible provided perl variables? |
418
|
0
|
0
|
0
|
|
|
|
if( !$error && %$tie ) |
419
|
|
|
|
|
|
|
{ |
420
|
0
|
|
|
|
|
|
my $order = $self->{tie_order}; |
421
|
0
|
|
|
|
|
|
my $sth = $self->{sth}; |
422
|
0
|
|
|
|
|
|
for( my $i = 0; $i < @$order; $i++ ) |
423
|
|
|
|
|
|
|
{ |
424
|
0
|
|
|
|
|
|
my $pos = $i + 1; |
425
|
0
|
|
|
|
|
|
my $val = $order->[ $i ]; |
426
|
0
|
0
|
0
|
|
|
|
if( exists( $tie->{ $val } ) && ref( $tie->{ $val } ) eq 'SCALAR' ) |
427
|
|
|
|
|
|
|
{ |
428
|
0
|
|
|
|
|
|
$sth->bind_col( $pos, $tie->{ $val } ); |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
} |
432
|
0
|
0
|
|
|
|
|
if( $error ) |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
433
|
|
|
|
|
|
|
{ |
434
|
0
|
|
|
|
|
|
$error =~ s/ at (\S+\s)?line \d+.*$//s; |
435
|
|
|
|
|
|
|
# $err .= ":\n\"$self->{ 'query' }\""; |
436
|
0
|
|
|
|
|
|
$error .= ":\n\"$self->{sth}->{Statement}\""; |
437
|
0
|
|
|
|
|
|
$error = "Error while trying to execute query $self->{sth}->{Statement}: $error"; |
438
|
0
|
0
|
|
|
|
|
if( $self->fatal() ) |
439
|
|
|
|
|
|
|
{ |
440
|
0
|
|
|
|
|
|
die( "$error in $self->{file} at line $self->{line} within sub $self->{sub}\n" ); |
441
|
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
|
else |
443
|
|
|
|
|
|
|
{ |
444
|
|
|
|
|
|
|
# return( $self->error( "$err in $self->{ 'file' } at line $self->{ 'line' } within sub $self->{ 'sub' }" ) ); |
445
|
0
|
|
|
|
|
|
return( $self->error( $error ) ); |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
} |
448
|
|
|
|
|
|
|
elsif( $self->{sth}->errstr() ) |
449
|
|
|
|
|
|
|
{ |
450
|
0
|
|
|
|
|
|
return( $self->error( "Error while trying to execute query $self->{sth}->{Statement}: ", $self->{sth}->errstr ) ); |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
# User wants an object for chaining like: |
453
|
|
|
|
|
|
|
# $sth->exec( 'some value' )->fetchrow; |
454
|
|
|
|
|
|
|
elsif( want( 'OBJECT' ) ) |
455
|
|
|
|
|
|
|
{ |
456
|
0
|
|
|
|
|
|
return( $self ); |
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
elsif( $rv ) |
459
|
|
|
|
|
|
|
{ |
460
|
0
|
|
|
|
|
|
return( $rv ); |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
# For void context too |
463
|
|
|
|
|
|
|
else |
464
|
|
|
|
|
|
|
{ |
465
|
0
|
|
|
|
|
|
return(1); |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
sub executed |
470
|
|
|
|
|
|
|
{ |
471
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
472
|
|
|
|
|
|
|
# For hand made query to avoid clash when executing generic routine such as fetchall_arrayref... |
473
|
0
|
0
|
|
|
|
|
return( 1 ) if( !exists( $self->{query} ) ); |
474
|
0
|
|
0
|
|
|
|
return( exists( $self->{executed} ) && $self->{executed} ); |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
sub fetchall_arrayref($@) |
478
|
|
|
|
|
|
|
{ |
479
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
480
|
0
|
|
0
|
|
|
|
my $slice = shift( @_ ) || []; |
481
|
0
|
|
|
|
|
|
my $dbo = $self->database_object; |
482
|
0
|
|
|
|
|
|
my $sth = $self->{sth}; |
483
|
0
|
0
|
|
|
|
|
if( !$self->executed() ) |
484
|
|
|
|
|
|
|
{ |
485
|
0
|
0
|
|
|
|
|
$self->execute() || return; |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
# $self->_cleanup(); |
488
|
0
|
|
|
|
|
|
my $mode = ref( $slice ); |
489
|
0
|
|
|
|
|
|
my @rows; |
490
|
|
|
|
|
|
|
my $row; |
491
|
0
|
0
|
|
|
|
|
if( $mode eq 'ARRAY' ) |
|
|
0
|
|
|
|
|
|
492
|
|
|
|
|
|
|
{ |
493
|
0
|
0
|
|
|
|
|
if( @$slice ) |
494
|
|
|
|
|
|
|
{ |
495
|
0
|
|
|
|
|
|
push( @rows, [ @{ $row }[ @{ $slice } ] ] ) while( $row = $self->{sth}->fetch() ); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
} |
497
|
|
|
|
|
|
|
else |
498
|
|
|
|
|
|
|
{ |
499
|
0
|
|
|
|
|
|
push( @rows, [ @{ $row } ] ) while( $row = $self->{sth}->fetch ); |
|
0
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
} |
502
|
|
|
|
|
|
|
elsif( $mode eq 'HASH' ) |
503
|
|
|
|
|
|
|
{ |
504
|
0
|
|
|
|
|
|
my @o_keys = keys( %$slice ); |
505
|
0
|
0
|
|
|
|
|
if( @o_keys ) |
506
|
|
|
|
|
|
|
{ |
507
|
0
|
|
|
|
|
|
my %i_names = map{ ( lc( $_ ) => $_ ) } @{ $self->{sth}->FETCH( 'NAME' ) }; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
508
|
0
|
|
|
|
|
|
my @i_keys = map{ $i_names{ lc( $_ ) } } @o_keys; |
|
0
|
|
|
|
|
|
|
509
|
0
|
|
|
|
|
|
while( $row = $self->{sth}->fetchrow_hashref() ) |
510
|
|
|
|
|
|
|
{ |
511
|
0
|
|
|
|
|
|
my %hash; |
512
|
0
|
|
|
|
|
|
@hash{ @o_keys } = @{ $row }{ @i_keys }; |
|
0
|
|
|
|
|
|
|
513
|
0
|
|
|
|
|
|
push( @rows, \%hash ); |
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
else |
517
|
|
|
|
|
|
|
{ |
518
|
0
|
|
|
|
|
|
push( @rows, $row ) while( $row = $self->{sth}->fetchrow_hashref() ); |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
else |
522
|
|
|
|
|
|
|
{ |
523
|
0
|
|
|
|
|
|
warn( "fetchall_arrayref($mode) invalid" ); |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
# return( \@rows ); |
526
|
0
|
0
|
0
|
|
|
|
return( \@rows ) if( !$dbo->auto_decode_json && !$dbo->auto_convert_datetime_to_object ); |
527
|
0
|
|
|
|
|
|
my $data = \@rows; |
528
|
0
|
0
|
|
|
|
|
$data = $self->_convert_json2hash({ statement => $sth, data => $data }) if( $dbo->auto_decode_json ); |
529
|
0
|
0
|
|
|
|
|
$data = $self->_convert_datetime2object({ statement => $sth, data => $data }) if( $dbo->auto_convert_datetime_to_object ); |
530
|
0
|
|
|
|
|
|
return( $data ); |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
sub fetchcol($;$) |
534
|
|
|
|
|
|
|
{ |
535
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
536
|
|
|
|
|
|
|
# @arr = $sth->fetchcol( $col_number ); |
537
|
0
|
|
|
|
|
|
my $col_num = shift( @_ ); |
538
|
0
|
0
|
|
|
|
|
if( !$self->executed() ) |
539
|
|
|
|
|
|
|
{ |
540
|
0
|
0
|
|
|
|
|
$self->execute() || return( $self->pass_error ); |
541
|
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
# $self->_cleanup(); |
543
|
|
|
|
|
|
|
# return( $h->fetchcol( $COL_NUM ) ); |
544
|
0
|
|
|
|
|
|
my @col; |
545
|
|
|
|
|
|
|
# $self->dataseek( 0 ); |
546
|
|
|
|
|
|
|
my $ref; |
547
|
0
|
|
|
|
|
|
while( $ref = $self->{sth}->fetchrow_arrayref() ) |
548
|
|
|
|
|
|
|
{ |
549
|
0
|
|
|
|
|
|
push( @col, $ref->[ $col_num ] ); |
550
|
|
|
|
|
|
|
} |
551
|
0
|
|
|
|
|
|
return( @col ); |
552
|
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
sub fetchhash(@) |
555
|
|
|
|
|
|
|
{ |
556
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
557
|
0
|
0
|
|
|
|
|
if( !$self->executed() ) |
558
|
|
|
|
|
|
|
{ |
559
|
0
|
0
|
|
|
|
|
$self->execute() || return( $self->pass_error ); |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
# $self->_cleanup(); |
562
|
|
|
|
|
|
|
# %hash = $sth->fetchhash; |
563
|
|
|
|
|
|
|
# return( $h->fetchhash ); |
564
|
0
|
|
|
|
|
|
my $ref = $self->{sth}->fetchrow_hashref(); |
565
|
0
|
0
|
|
|
|
|
if( $ref ) |
566
|
|
|
|
|
|
|
{ |
567
|
0
|
|
|
|
|
|
return( %$ref ); |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
else |
570
|
|
|
|
|
|
|
{ |
571
|
0
|
|
|
|
|
|
return( () ); |
572
|
|
|
|
|
|
|
} |
573
|
|
|
|
|
|
|
} |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
sub fetchrow(@) |
576
|
|
|
|
|
|
|
{ |
577
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
578
|
0
|
0
|
|
|
|
|
if( !$self->executed() ) |
579
|
|
|
|
|
|
|
{ |
580
|
0
|
0
|
|
|
|
|
$self->execute() || return( $self->pass_error ); |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
# $self->_cleanup(); |
583
|
|
|
|
|
|
|
# @arr = $sth->fetchrow; # Array context |
584
|
|
|
|
|
|
|
# $firstcol = $sth->fetchrow; # Scalar context |
585
|
|
|
|
|
|
|
# return( $h->fetchrow ); |
586
|
|
|
|
|
|
|
# my $ref = $self->fetchrow_arrayref(); |
587
|
0
|
|
|
|
|
|
my $ref = $self->{sth}->fetchrow_arrayref(); |
588
|
|
|
|
|
|
|
# my $ref = $self->{sth}->fetch(); |
589
|
0
|
0
|
|
|
|
|
if( $ref ) |
590
|
|
|
|
|
|
|
{ |
591
|
0
|
0
|
|
|
|
|
return( wantarray ? @$ref : $ref->[0] ); |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
else |
594
|
|
|
|
|
|
|
{ |
595
|
0
|
|
|
|
|
|
return( () ); |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
# sub fetchrow_hashref(@) is inherited from DBI |
600
|
|
|
|
|
|
|
sub fetchrow_hashref |
601
|
|
|
|
|
|
|
{ |
602
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
603
|
0
|
|
|
|
|
|
my $dbo = $self->database_object; |
604
|
0
|
|
|
|
|
|
my $deb = {}; |
605
|
0
|
|
|
|
|
|
%$deb = %$self; |
606
|
0
|
|
|
|
|
|
my $sth = $self->{sth}; |
607
|
0
|
0
|
|
|
|
|
if( !$self->executed() ) |
608
|
|
|
|
|
|
|
{ |
609
|
0
|
0
|
|
|
|
|
$self->execute() || return( $self->pass_error ); |
610
|
|
|
|
|
|
|
} |
611
|
0
|
0
|
0
|
|
|
|
return( $sth->fetchrow_hashref ) if( !$dbo->auto_decode_json && !$dbo->auto_convert_datetime_to_object ); |
612
|
0
|
|
|
|
|
|
my $ref = $sth->fetchrow_hashref; |
613
|
|
|
|
|
|
|
# Convert json to hash for the relevant fields |
614
|
|
|
|
|
|
|
# return( $self->_convert_json2hash( $ref ) ); |
615
|
0
|
0
|
|
|
|
|
$ref = $self->_convert_json2hash({ statement => $sth, data => $ref }) if( $dbo->auto_decode_json ); |
616
|
0
|
0
|
|
|
|
|
$ref = $self->_convert_datetime2object({ statement => $sth, data => $ref }) if( $dbo->auto_convert_datetime_to_object ); |
617
|
0
|
|
|
|
|
|
return( $ref ); |
618
|
|
|
|
|
|
|
} |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
sub fetchrow_object |
621
|
|
|
|
|
|
|
{ |
622
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
623
|
|
|
|
|
|
|
# This should give us something like Postgres or Mysql or SQLite |
624
|
0
|
|
|
|
|
|
my $basePack = ( ref( $self ) =~ /^DB::Object::([^\:]+)/ )[0]; |
625
|
0
|
0
|
|
|
|
|
if( !$self->executed() ) |
626
|
|
|
|
|
|
|
{ |
627
|
0
|
0
|
|
|
|
|
$self->execute() || return( $self->pass_error ); |
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
# $self->_cleanup(); |
630
|
0
|
|
|
|
|
|
my $rows = $self->{sth}->rows; |
631
|
0
|
|
|
|
|
|
my $ref = $self->{sth}->fetchrow_hashref(); |
632
|
0
|
0
|
0
|
|
|
|
if( $ref && scalar( keys( %$ref ) ) ) |
633
|
|
|
|
|
|
|
{ |
634
|
0
|
|
|
|
|
|
my $struct = { map{ $_ => '$' } keys( %$ref ) }; |
|
0
|
|
|
|
|
|
|
635
|
0
|
|
|
|
|
|
my $table = $self->table; |
636
|
0
|
|
|
|
|
|
my $class = "DB::Object::${basePack}::Result::${table}"; |
637
|
0
|
0
|
|
|
|
|
if( !defined( &{ $class . '::new' } ) ) |
|
0
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
{ |
639
|
0
|
|
|
|
|
|
struct $class => $struct; |
640
|
|
|
|
|
|
|
} |
641
|
0
|
|
|
|
|
|
my $obj = $class->new( %$ref ); |
642
|
0
|
|
|
|
|
|
return( $obj ); |
643
|
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
|
else |
645
|
|
|
|
|
|
|
{ |
646
|
0
|
|
|
|
|
|
return( () ); |
647
|
|
|
|
|
|
|
} |
648
|
|
|
|
|
|
|
} |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
sub finish |
651
|
|
|
|
|
|
|
{ |
652
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
653
|
0
|
|
|
|
|
|
my $rc = $self->{sth}->finish(); |
654
|
0
|
0
|
|
|
|
|
if( !$rc ) |
655
|
|
|
|
|
|
|
{ |
656
|
0
|
|
|
|
|
|
return( $self->error( $self->{sth}->errstr() ) ); |
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
else |
659
|
|
|
|
|
|
|
{ |
660
|
0
|
|
|
|
|
|
return( $rc ); |
661
|
|
|
|
|
|
|
} |
662
|
|
|
|
|
|
|
} |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
sub ignore |
665
|
|
|
|
|
|
|
{ |
666
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
667
|
|
|
|
|
|
|
my $query = $self->{query} || |
668
|
0
|
|
0
|
|
|
|
return( $self->error( "No query to set as to be ignored." ) ); |
669
|
|
|
|
|
|
|
|
670
|
0
|
|
|
|
|
|
my $type = uc( ( $query =~ /^\s*(\S+)\s+/ )[0] ); |
671
|
|
|
|
|
|
|
# ALTER for table alteration statements (DB::Object::Tables |
672
|
0
|
|
|
|
|
|
my @allowed = qw( INSERT UPDATE ALTER ); |
673
|
0
|
|
|
|
|
|
my $allowed = CORE::join( '|', @allowed ); |
674
|
0
|
0
|
|
|
|
|
if( !scalar( grep{ /^$type$/i } @allowed ) ) |
|
0
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
{ |
676
|
0
|
|
|
|
|
|
return( $self->error( "You may not flag statement of type \U$type\E to be ignored:\n$query" ) ); |
677
|
|
|
|
|
|
|
} |
678
|
|
|
|
|
|
|
# Incompatible. Do not bother going further |
679
|
0
|
0
|
|
|
|
|
return( $self ) if( $query =~ /^\s*(?:$allowed)\s+(?:DELAYED|LOW_PRIORITY|HIGH_PRIORITY)\s+/i ); |
680
|
0
|
0
|
0
|
|
|
|
return( $self ) if( $type eq 'ALTER' && $query !~ /^\s*$type\s+TABLE\s+/i ); |
681
|
|
|
|
|
|
|
|
682
|
0
|
|
|
|
|
|
$query =~ s/^(\s*)($allowed)(\s+)/$1$2 IGNORE /; |
683
|
|
|
|
|
|
|
# my $sth = $self->prepare( $query ) || |
684
|
|
|
|
|
|
|
# $self->{ 'query' } = $query; |
685
|
|
|
|
|
|
|
# saving parameters to bind later on must have been done previously |
686
|
0
|
|
0
|
|
|
|
my $sth = $self->_cache_this( $query ) || |
687
|
|
|
|
|
|
|
return( $self->error( "Error while preparing new ignored query:\n$query" ) ); |
688
|
0
|
0
|
|
|
|
|
if( !defined( wantarray() ) ) |
689
|
|
|
|
|
|
|
{ |
690
|
0
|
0
|
|
|
|
|
$sth->execute() || |
691
|
|
|
|
|
|
|
return( $self->error( "Error while executing new ignored query:\n$query" ) ); |
692
|
|
|
|
|
|
|
} |
693
|
0
|
|
|
|
|
|
return( $sth ); |
694
|
|
|
|
|
|
|
} |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
sub join |
697
|
|
|
|
|
|
|
{ |
698
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
699
|
0
|
|
|
|
|
|
my $data = shift( @_ ); |
700
|
0
|
|
|
|
|
|
my $on; |
701
|
0
|
0
|
|
|
|
|
if( @_ ) |
702
|
|
|
|
|
|
|
{ |
703
|
0
|
0
|
0
|
|
|
|
$on = ( scalar( @_ ) == 1 && ref( $_[0] ) ) ? shift( @_ ) : [ @_ ]; |
704
|
|
|
|
|
|
|
} |
705
|
0
|
|
0
|
|
|
|
my $q = $self->query_object || return( $self->error( "No query formatter object was set" ) ); |
706
|
0
|
|
0
|
|
|
|
my $tbl_o = $q->table_object || return( $self->error( "No table object is set in query object." ) ); |
707
|
0
|
|
0
|
|
|
|
my $query = $q->query || |
708
|
|
|
|
|
|
|
return( $self->error( "No query prepared for join with another table." ) ); |
709
|
0
|
0
|
|
|
|
|
if( $query !~ /^[[:blank:]]*SELECT[[:blank:]]+/i ) |
710
|
|
|
|
|
|
|
{ |
711
|
0
|
|
|
|
|
|
return( $self->error( "You may not perform a join on a query other than select." ) ); |
712
|
|
|
|
|
|
|
} |
713
|
0
|
|
|
|
|
|
my $constant = $q->constant; |
714
|
|
|
|
|
|
|
# Constant is set and query object marked as final, which means this statement has already been processed as a join and so we skip all further processing. |
715
|
0
|
0
|
0
|
|
|
|
if( scalar( keys( %$constant ) ) && $q->final ) |
716
|
|
|
|
|
|
|
{ |
717
|
0
|
|
|
|
|
|
return( $self ); |
718
|
|
|
|
|
|
|
} |
719
|
0
|
|
|
|
|
|
my $table = $tbl_o->table; |
720
|
0
|
|
|
|
|
|
my $db = $tbl_o->database(); |
721
|
0
|
|
|
|
|
|
my $multi_db = $tbl_o->prefix_database; |
722
|
0
|
|
|
|
|
|
my $alias = $tbl_o->as; |
723
|
0
|
|
|
|
|
|
my $new_fields = ''; |
724
|
0
|
|
|
|
|
|
my $new_table = ''; |
725
|
0
|
|
|
|
|
|
my $new_db = ''; |
726
|
0
|
|
|
|
|
|
my $class = ref( $self ); |
727
|
0
|
|
|
|
|
|
my $q2 = $q->clone; |
728
|
0
|
|
|
|
|
|
my $q1; |
729
|
0
|
0
|
|
|
|
|
$q2->join_tables( $tbl_o ) if( !$q2->join_tables->length ); |
730
|
|
|
|
|
|
|
# $data is a DB::Object::Postgres::Statement object - we get all its parameter and merge them with ours |
731
|
|
|
|
|
|
|
# if( ref( $data ) && ref( $data ) eq $class ) |
732
|
0
|
0
|
0
|
|
|
|
if( ref( $data ) && $self->_is_a( $data, $class ) ) |
733
|
|
|
|
|
|
|
{ |
734
|
0
|
|
|
|
|
|
$q1 = $data->query_object; |
735
|
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
|
# $data is the table name |
737
|
|
|
|
|
|
|
else |
738
|
|
|
|
|
|
|
{ |
739
|
0
|
|
|
|
|
|
my $join_tbl; |
740
|
0
|
0
|
0
|
|
|
|
if( $self->_is_object( $data ) && $data->isa( 'DB::Object::Tables' ) ) |
|
|
0
|
|
|
|
|
|
741
|
|
|
|
|
|
|
{ |
742
|
0
|
|
|
|
|
|
$join_tbl = $data; |
743
|
|
|
|
|
|
|
} |
744
|
|
|
|
|
|
|
elsif( $self->_is_object( $data ) ) |
745
|
|
|
|
|
|
|
{ |
746
|
0
|
|
|
|
|
|
return( $self->error( "I was expecting either a table name as a scalar or a table object, but instead got \"$data\" (", ref( $data ), ")." ) ); |
747
|
|
|
|
|
|
|
} |
748
|
|
|
|
|
|
|
else |
749
|
|
|
|
|
|
|
{ |
750
|
0
|
0
|
|
|
|
|
return( $self->error( "No such table \"$data\" exists in database \"$db\"." ) ) if( !$self->database_object->table_exists( $data ) ); |
751
|
0
|
|
|
|
|
|
$join_tbl = $self->database_object->table( $data ); |
752
|
0
|
0
|
|
|
|
|
return( $self->error( "Could not get a table object from \"$data\"." ) ) if( !$join_tbl ); |
753
|
|
|
|
|
|
|
} |
754
|
0
|
0
|
|
|
|
|
$join_tbl->prefixed( $db ne $join_tbl->database_object->database ? 3 : 1 ); |
755
|
0
|
|
0
|
|
|
|
my $sth_tmp = $join_tbl->select || return( $self->pass_error( $join_tbl->error ) ); |
756
|
0
|
|
0
|
|
|
|
$q1 = $sth_tmp->query_object || return( $self->error( "Could not get a query object out of the dummy select query I made from table \"$data\"." ) ); |
757
|
0
|
|
|
|
|
|
$new_fields = $q1->selected_fields; |
758
|
|
|
|
|
|
|
# NOTE: 2021-08-22: If we reset it here, we lose the table aliasing |
759
|
|
|
|
|
|
|
# $join_tbl->reset; |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
# $join_tbl->prefixed( $db ne $join_tbl->database_object->database ? 3 : 1 ) unless( $join_tbl->prefixed ); |
762
|
0
|
|
|
|
|
|
$new_table = $join_tbl->prefix; |
763
|
0
|
|
|
|
|
|
$join_tbl->reset; |
764
|
|
|
|
|
|
|
# We assume this table is part of our same database |
765
|
0
|
|
|
|
|
|
$new_db = $db; |
766
|
|
|
|
|
|
|
# my $db_data = $self->getdefault( $new_table ); |
767
|
|
|
|
|
|
|
# $new_fields = $db_data->format_statement(); |
768
|
0
|
|
|
|
|
|
$new_fields = ''; |
769
|
|
|
|
|
|
|
} |
770
|
|
|
|
|
|
|
# TODO: check this or remove it |
771
|
|
|
|
|
|
|
# $q1->table_object->prefixed( $db ne $q1->database_object->database ? 3 : 1 ); |
772
|
0
|
|
|
|
|
|
$new_fields = $q1->selected_fields; |
773
|
0
|
|
|
|
|
|
$new_table = $q1->table_object->name; |
774
|
|
|
|
|
|
|
# $new_table = $q1->table_object->prefix; |
775
|
0
|
|
|
|
|
|
$new_db = $q1->database_object->database; |
776
|
0
|
|
|
|
|
|
$q2->join_tables->push( $q1->table_object ); |
777
|
0
|
0
|
|
|
|
|
if( CORE::length( $q->where ) ) |
|
|
0
|
|
|
|
|
|
778
|
|
|
|
|
|
|
{ |
779
|
0
|
0
|
|
|
|
|
$q2->where( $self->AND( ( $q->where ), $q1->new_clause({ value => '( ' . ( $q1->where ) . ' )' }) ) ) if( CORE::length( $q1->where ) ); |
780
|
|
|
|
|
|
|
} |
781
|
|
|
|
|
|
|
elsif( CORE::length( $q1->where ) ) |
782
|
|
|
|
|
|
|
{ |
783
|
0
|
|
|
|
|
|
$q2->where( $q1->where ); |
784
|
|
|
|
|
|
|
} |
785
|
0
|
0
|
|
|
|
|
$q2->group( $q->group, $q1->group ) if( $q1->group->value->length ); |
786
|
0
|
0
|
|
|
|
|
$q2->order( $q->order, $q1->order ) if( $q1->order->value->length ); |
787
|
0
|
|
|
|
|
|
$q2->binded_where->push( @{$q1->binded_where} ); |
|
0
|
|
|
|
|
|
|
788
|
0
|
|
|
|
|
|
$q2->binded_group->push( @{$q1->binded_group} ); |
|
0
|
|
|
|
|
|
|
789
|
0
|
|
|
|
|
|
$q2->binded_order->push( @{$q1->binded_order} ); |
|
0
|
|
|
|
|
|
|
790
|
0
|
|
|
|
|
|
$q2->binded( @{$q1->binded} ); |
|
0
|
|
|
|
|
|
|
791
|
0
|
0
|
0
|
|
|
|
if( ( !$q->limit || !$q->_limit->length ) && $q2->_limit->length ) |
|
|
|
0
|
|
|
|
|
792
|
|
|
|
|
|
|
{ |
793
|
0
|
|
|
|
|
|
$q2->_limit( $q1->_limit ); |
794
|
0
|
|
|
|
|
|
$q2->binded_limit( $q1->binded_limit ); |
795
|
|
|
|
|
|
|
} |
796
|
0
|
0
|
|
|
|
|
my $prev_fields = length( $q->join_fields ) ? $q->join_fields : $q->selected_fields; |
797
|
|
|
|
|
|
|
# Regular express to prepend previous fields by their table name if that's not the case already |
798
|
|
|
|
|
|
|
# my $prev_prefix = $new_db ? "$db.$table" : $table; |
799
|
|
|
|
|
|
|
# my $prev_prefix = $tbl_o->query_object->table_alias ? $tbl_o->query_object->table_alias : $tbl_o->prefixed( $db ne $new_db ? 3 : 1 )->prefix; |
800
|
|
|
|
|
|
|
# unless( $tbl_o->query_object->table_alias ) |
801
|
|
|
|
|
|
|
# { |
802
|
|
|
|
|
|
|
# $tbl_o->prefixed( $db ne $new_db ? 3 : 1 ) |
803
|
|
|
|
|
|
|
# } |
804
|
0
|
0
|
|
|
|
|
$tbl_o->prefixed( $db ne $new_db ? 3 : 1 ); |
805
|
|
|
|
|
|
|
# Prefix for previous fields list |
806
|
0
|
|
|
|
|
|
my $prev_prefix = $tbl_o->prefix; |
807
|
0
|
|
|
|
|
|
my $prev_fields_hash = $q->table_object->fields; |
808
|
0
|
|
|
|
|
|
my $prev_fields_list = CORE::join( '|', sort( keys( %$prev_fields_hash ) ) ); |
809
|
0
|
|
|
|
|
|
my $re = qr/(?<![\.\"])\b($prev_fields_list)\b/; |
810
|
0
|
|
|
|
|
|
$prev_fields =~ s/(?<![\.\"])\b($prev_fields_list)\b/${prev_prefix}.$1/gs; |
811
|
0
|
0
|
|
|
|
|
my $fields = $new_fields ? CORE::join( ', ', $prev_fields, $new_fields ) : $prev_fields; |
812
|
0
|
|
|
|
|
|
$q2->join_fields( $fields ); |
813
|
|
|
|
|
|
|
#my $from_table = $q2->from_table; |
814
|
|
|
|
|
|
|
#$from_table = $multi_db ? [ "$db.$table" ] : [ $table ] if( !scalar( @$from_table ) ); |
815
|
|
|
|
|
|
|
# $q2->from_table( $multi_db ? "$db.$table" : $table ) if( !$q2->from_table->length ); |
816
|
0
|
0
|
|
|
|
|
$q2->from_table->push( |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
817
|
|
|
|
|
|
|
$q2->table_alias |
818
|
|
|
|
|
|
|
? sprintf( '%s AS %s', $q2->table_object->name, $q2->table_alias ) |
819
|
|
|
|
|
|
|
: ( $q2->table_object->prefixed ? $q2->table_object->prefix : $q2->table_object->name ) |
820
|
|
|
|
|
|
|
) if( !$q2->from_table->length ); |
821
|
|
|
|
|
|
|
# $q2->left_join( {} ) if( !$q2->left_join ); |
822
|
0
|
|
|
|
|
|
my $left_join = ''; |
823
|
0
|
|
|
|
|
|
my $condition = ''; |
824
|
0
|
|
|
|
|
|
my $format_condition; |
825
|
|
|
|
|
|
|
$format_condition = sub |
826
|
|
|
|
|
|
|
{ |
827
|
0
|
|
|
0
|
|
|
my @vals = (); |
828
|
0
|
|
|
|
|
|
my $vals = shift( @_ ); |
829
|
0
|
|
|
|
|
|
my $op = shift( @_ ); |
830
|
0
|
|
|
|
|
|
my @res = (); |
831
|
0
|
|
|
|
|
|
my $fields_tables = {}; |
832
|
0
|
|
|
|
|
|
while( scalar( @$vals ) ) |
833
|
|
|
|
|
|
|
{ |
834
|
0
|
0
|
0
|
|
|
|
if( $self->_is_object( $vals->[0] ) && $vals->[0]->isa( 'DB::Object::Operator' ) ) |
835
|
|
|
|
|
|
|
{ |
836
|
0
|
|
|
|
|
|
my $sub_obj = shift( @$vals ); |
837
|
0
|
|
|
|
|
|
my $sub_op = $sub_obj->operator; |
838
|
0
|
|
|
|
|
|
my( @sub_vals ) = $sub_obj->value; |
839
|
0
|
|
|
|
|
|
my $this_ref = $format_condition->( \@sub_vals, $sub_op ); |
840
|
0
|
0
|
|
|
|
|
CORE::push( @res, $this_ref->{clause} ) if( length( $this_ref->{clause} ) ); |
841
|
0
|
|
|
|
|
|
my $tmp = $this_ref->{fields_tables}; |
842
|
0
|
|
|
|
|
|
my @those_table_names = keys( %$tmp ); |
843
|
0
|
|
|
|
|
|
@$fields_tables{ @those_table_names } = @$tmp{ @those_table_names }; |
844
|
|
|
|
|
|
|
} |
845
|
|
|
|
|
|
|
else |
846
|
|
|
|
|
|
|
{ |
847
|
0
|
0
|
0
|
|
|
|
if( $self->_is_object( $vals->[0] ) && $vals->[0]->isa( 'DB::Object::Fields::Field::Overloaded' ) ) |
848
|
|
|
|
|
|
|
{ |
849
|
0
|
|
|
|
|
|
my $f1 = shift( @$vals ); |
850
|
0
|
0
|
|
|
|
|
$f1->field->prefixed( $multi_db ? 3 : 1 ); |
851
|
0
|
|
|
|
|
|
CORE::push( @res, "$f1" ); |
852
|
0
|
0
|
|
|
|
|
$fields_tables->{ $f1->field->table }++ if( !$fields_tables->{ $f1->field->table } ); |
853
|
0
|
|
|
|
|
|
next; |
854
|
|
|
|
|
|
|
} |
855
|
|
|
|
|
|
|
|
856
|
0
|
|
|
|
|
|
my( $f1, $f2 ) = ( shift( @$vals ), shift( @$vals ) ); |
857
|
0
|
|
|
|
|
|
my $i_am_negative = 0; |
858
|
0
|
0
|
0
|
|
|
|
if( $self->_is_object( $f2 ) && $f2->isa( 'DB::Object::NOT' ) ) |
859
|
|
|
|
|
|
|
{ |
860
|
0
|
|
|
|
|
|
( $f2 ) = $f2->value; |
861
|
0
|
|
|
|
|
|
$i_am_negative++; |
862
|
|
|
|
|
|
|
} |
863
|
|
|
|
|
|
|
|
864
|
0
|
|
|
|
|
|
my( $field1, $field2 ); |
865
|
0
|
0
|
0
|
|
|
|
if( $self->_is_object( $f1 ) && $f1->isa( 'DB::Object::Fields::Field' ) ) |
866
|
|
|
|
|
|
|
{ |
867
|
0
|
0
|
|
|
|
|
$f1->prefixed( $multi_db ? 3 : 1 ); |
868
|
0
|
|
|
|
|
|
$field1 = $f1->name; |
869
|
0
|
0
|
|
|
|
|
$fields_tables->{ $f1->table }++ if( !$fields_tables->{ $f1->table } ); |
870
|
|
|
|
|
|
|
} |
871
|
|
|
|
|
|
|
else |
872
|
|
|
|
|
|
|
{ |
873
|
0
|
0
|
|
|
|
|
$field1 = $multi_db ? "$new_db.$new_table.$f1" : "$new_table.$f1"; |
874
|
|
|
|
|
|
|
} |
875
|
0
|
0
|
0
|
|
|
|
if( $self->_is_object( $f2 ) && $f2->isa( 'DB::Object::Fields::Field' ) ) |
876
|
|
|
|
|
|
|
{ |
877
|
0
|
0
|
|
|
|
|
$f2->prefixed( $multi_db ? 3 : 1 ); |
878
|
0
|
|
|
|
|
|
$field2 = $f2->name; |
879
|
0
|
0
|
|
|
|
|
$fields_tables->{ $f2->table }++ if( !$fields_tables->{ $f2->table } ); |
880
|
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
|
else |
882
|
|
|
|
|
|
|
{ |
883
|
0
|
0
|
|
|
|
|
$field2 = $multi_db ? "$new_db.$new_table.$f2" : "$new_table.$f2"; |
884
|
|
|
|
|
|
|
} |
885
|
0
|
0
|
|
|
|
|
CORE::push( @res, $i_am_negative ? "$field1 != $field2" : "$field1 = $field2" ); |
886
|
|
|
|
|
|
|
} |
887
|
|
|
|
|
|
|
} |
888
|
|
|
|
|
|
|
return({ |
889
|
0
|
|
|
|
|
|
clause => CORE::join( $op, @res ), |
890
|
|
|
|
|
|
|
fields_tables => $fields_tables, |
891
|
|
|
|
|
|
|
}); |
892
|
0
|
|
|
|
|
|
}; |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
# $on is either a $dbh->AND, or $dbh->OR |
895
|
0
|
0
|
|
|
|
|
if( defined( $on ) ) |
896
|
|
|
|
|
|
|
{ |
897
|
0
|
0
|
0
|
|
|
|
if( $self->_is_object( $on ) && $on->isa( 'DB::Object::Operator' ) ) |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
898
|
|
|
|
|
|
|
{ |
899
|
0
|
|
|
|
|
|
my $op = $on->operator; |
900
|
0
|
|
|
|
|
|
my( @vals ) = $on->value; |
901
|
0
|
|
|
|
|
|
my $ret = $format_condition->( \@vals, $op ); |
902
|
0
|
0
|
|
|
|
|
my $as = $q1->table_alias ? sprintf( ' AS %s', $q1->table_alias ) : ''; |
903
|
0
|
|
|
|
|
|
$left_join = "LEFT JOIN ${new_table}${as} ON $ret->{clause}"; |
904
|
|
|
|
|
|
|
} |
905
|
|
|
|
|
|
|
elsif( $self->_is_object( $on ) && $on->isa( 'DB::Object::Fields::Field::Overloaded' ) ) |
906
|
|
|
|
|
|
|
{ |
907
|
0
|
0
|
|
|
|
|
my $as = $q1->table_alias ? sprintf( ' AS %s', $q1->table_alias ) : ''; |
908
|
0
|
|
|
|
|
|
$left_join = "LEFT JOIN ${new_table}${as} ON ${on}"; |
909
|
|
|
|
|
|
|
} |
910
|
|
|
|
|
|
|
elsif( $self->_is_array( $on ) ) |
911
|
|
|
|
|
|
|
{ |
912
|
0
|
|
|
|
|
|
my $ret = $format_condition->( $on, 'AND' ); |
913
|
0
|
0
|
|
|
|
|
my $as = $q1->table_alias ? sprintf( ' AS %s', $q1->table_alias ) : ''; |
914
|
0
|
|
|
|
|
|
$left_join = "LEFT JOIN ${new_table}${as} ON $ret->{clause}"; |
915
|
|
|
|
|
|
|
} |
916
|
|
|
|
|
|
|
# There is a second parameter - if so this is the condition of the 'LEFT JOIN' |
917
|
|
|
|
|
|
|
elsif( $self->_is_hash( $on ) ) |
918
|
|
|
|
|
|
|
{ |
919
|
|
|
|
|
|
|
# Previous join |
920
|
0
|
|
|
|
|
|
my $join_ref = $q2->left_join; |
921
|
0
|
|
|
|
|
|
my $def = { on => $on, table_object => $q1->table_object, query_object => $q1 }; |
922
|
|
|
|
|
|
|
## Add the current one |
923
|
0
|
0
|
|
|
|
|
if( $multi_db ) |
924
|
|
|
|
|
|
|
{ |
925
|
0
|
|
|
|
|
|
$join_ref->{ "$new_db.$new_table" } = $def; |
926
|
|
|
|
|
|
|
} |
927
|
|
|
|
|
|
|
else |
928
|
|
|
|
|
|
|
{ |
929
|
0
|
|
|
|
|
|
$join_ref->{ $new_table } = $def; |
930
|
|
|
|
|
|
|
} |
931
|
|
|
|
|
|
|
# (Re)build the LEFT JOIN ... ON ... definition |
932
|
0
|
|
|
|
|
|
my @join_data = (); |
933
|
0
|
|
|
|
|
|
foreach my $joined ( keys( %$join_ref ) ) |
934
|
|
|
|
|
|
|
{ |
935
|
0
|
|
|
|
|
|
my $condition = $join_ref->{ $joined }->{on}; |
936
|
0
|
|
|
|
|
|
my $to = $join_ref->{ $joined }->{table_object}; |
937
|
0
|
|
|
|
|
|
my $qo = $join_ref->{ $joined }->{query_object}; |
938
|
0
|
|
|
|
|
|
my $join_table_name = $to->prefix; |
939
|
0
|
|
|
|
|
|
my $join_table_alias = ''; |
940
|
0
|
0
|
|
|
|
|
if( length( $join_table_alias = $qo->table_alias ) ) |
941
|
|
|
|
|
|
|
{ |
942
|
0
|
|
|
|
|
|
$join_table_alias = " AS $join_table_alias"; |
943
|
|
|
|
|
|
|
} |
944
|
0
|
|
|
|
|
|
push( @join_data, "LEFT JOIN ${join_table_name}${join_table_alias} ON " . CORE::join( ' AND ', map{ "$_=$condition->{ $_ }" } keys( %$condition ) ) ); |
|
0
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
} |
946
|
0
|
|
|
|
|
|
$left_join = CORE::join( ' ', @join_data ); |
947
|
|
|
|
|
|
|
} |
948
|
|
|
|
|
|
|
else |
949
|
|
|
|
|
|
|
{ |
950
|
0
|
|
|
|
|
|
warn( "Warning: I have no clue what to do with '$on' (", overload::StrVal( $on ), ") in this join for table \"", $q->table_object->name, "\"\n" ); |
951
|
|
|
|
|
|
|
} |
952
|
|
|
|
|
|
|
} |
953
|
|
|
|
|
|
|
# Otherwise, this is a straight JOIN |
954
|
|
|
|
|
|
|
else |
955
|
|
|
|
|
|
|
{ |
956
|
|
|
|
|
|
|
# $q2->from_table->push( $multi_db ? "$new_db.$new_table" : $new_table ); |
957
|
0
|
0
|
|
|
|
|
$q2->from_table->push( |
|
|
0
|
|
|
|
|
|
958
|
|
|
|
|
|
|
$q1->table_alias |
959
|
|
|
|
|
|
|
? sprintf( '%s AS %s', $q1->table_object->name, $q1->table_alias ) |
960
|
|
|
|
|
|
|
: ( $q1->table_object->prefixed ? $q1->table_object->prefix : $q1->table_object->name ) |
961
|
|
|
|
|
|
|
); |
962
|
|
|
|
|
|
|
} |
963
|
0
|
|
|
|
|
|
my $from = $q2->from_table->join( ', ' ); |
964
|
|
|
|
|
|
|
# $q2->from_table( $from_table ); |
965
|
0
|
|
|
|
|
|
my $clause = $q2->_query_components( 'select', { no_bind_copy => 1 } ); |
966
|
|
|
|
|
|
|
# You may not sort if there is no order clause |
967
|
|
|
|
|
|
|
# my $table_alias = ''; |
968
|
|
|
|
|
|
|
# if( length( $table_alias = $q2->table_alias ) ) |
969
|
|
|
|
|
|
|
# { |
970
|
|
|
|
|
|
|
# $table_alias = " AS ${table_alias}"; |
971
|
|
|
|
|
|
|
# } |
972
|
|
|
|
|
|
|
# my @query = ( "SELECT ${fields} FROM ${from}${table_alias} ${left_join}" ); |
973
|
0
|
|
|
|
|
|
my @query = ( "SELECT ${fields} FROM ${from} ${left_join}" ); |
974
|
0
|
0
|
|
|
|
|
push( @query, @$clause ) if( @$clause ); |
975
|
0
|
|
|
|
|
|
my $statement = CORE::join( ' ', @query ); |
976
|
0
|
|
|
|
|
|
$q2->query( $statement ); |
977
|
|
|
|
|
|
|
# my $sth = $self->prepare( $self->{ 'query' } ) || |
978
|
0
|
|
0
|
|
|
|
my $sth = $tbl_o->_cache_this( $q2 ) || |
979
|
|
|
|
|
|
|
return( $self->error( "Error while preparing query to select:\n", $q2->as_string(), $tbl_o->error ) ); |
980
|
|
|
|
|
|
|
# Routines such as as_string() expect an array on pupose so we do not have to commit the action |
981
|
|
|
|
|
|
|
# but rather get the statement string. At the end, we write: |
982
|
|
|
|
|
|
|
# $obj->select() to really select |
983
|
|
|
|
|
|
|
# $obj->select->as_string() to ONLY get the formatted statement |
984
|
|
|
|
|
|
|
# wantarray() returns the undefined value in void context, which is typical use of a real select command |
985
|
|
|
|
|
|
|
# i.e. $obj->select(); |
986
|
0
|
0
|
|
|
|
|
if( !defined( wantarray() ) ) |
987
|
|
|
|
|
|
|
{ |
988
|
0
|
0
|
|
|
|
|
$sth->execute() || |
989
|
|
|
|
|
|
|
return( $self->error( "Error while executing query to select:\n", $q2->as_string(), "\nError: ", $sth->error() ) ); |
990
|
|
|
|
|
|
|
} |
991
|
0
|
|
|
|
|
|
return( $sth ); |
992
|
|
|
|
|
|
|
} |
993
|
|
|
|
|
|
|
|
994
|
|
|
|
|
|
|
sub object |
995
|
|
|
|
|
|
|
{ |
996
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
997
|
|
|
|
|
|
|
# This is intended for statement to fetched their object: |
998
|
|
|
|
|
|
|
# my $obj = $table->select( '*' )->object(); |
999
|
|
|
|
|
|
|
# my $obj = $table->select( '*' ) |
1000
|
|
|
|
|
|
|
# would merly execute the statement before returning its object, but there are conditions |
1001
|
|
|
|
|
|
|
# such like using a SELECT to create a table where we do not want the statement to be executed already |
1002
|
0
|
0
|
|
|
|
|
return( $self->{sth} ) if( $self->{sth} ); |
1003
|
|
|
|
|
|
|
# More sensible approach will return a special Module::Generic::Null object to avoid perl complaining of 'called on undef value' if this is used in chaining |
1004
|
0
|
0
|
|
|
|
|
return( Module::Generic::Null->new ) if( want( 'OBJECT' ) ); |
1005
|
0
|
|
|
|
|
|
return; |
1006
|
|
|
|
|
|
|
} |
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
sub priority |
1009
|
|
|
|
|
|
|
{ |
1010
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
1011
|
0
|
|
|
|
|
|
my $prio = shift( @_ ); |
1012
|
0
|
|
|
|
|
|
my $map = |
1013
|
|
|
|
|
|
|
{ |
1014
|
|
|
|
|
|
|
0 => 'LOW_PRIORITY', |
1015
|
|
|
|
|
|
|
1 => 'HIGH_PRIORITY', |
1016
|
|
|
|
|
|
|
}; |
1017
|
|
|
|
|
|
|
## Bad argument. Do not bother |
1018
|
0
|
0
|
|
|
|
|
return( $self ) if( !exists( $map->{ $prio } ) ); |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
my $query = $self->{query} || |
1021
|
0
|
|
0
|
|
|
|
return( $self->error( "No query to set priority for was provided." ) ); |
1022
|
0
|
|
|
|
|
|
my $type = uc( ( $query =~ /^\s*(\S+)\s+/ )[ 0 ] ); |
1023
|
0
|
|
|
|
|
|
my @allowed = qw( DELETE INSERT REPLACE SELECT UPDATE ); |
1024
|
0
|
|
|
|
|
|
my $allowed = CORE::join( '|', @allowed ); |
1025
|
|
|
|
|
|
|
# Ignore if not allowed |
1026
|
0
|
0
|
|
|
|
|
if( !scalar( grep{ /^$type$/i } @allowed ) ) |
|
0
|
|
|
|
|
|
|
1027
|
|
|
|
|
|
|
{ |
1028
|
0
|
|
|
|
|
|
$self->error( "You may not set priority on statement of type \U$type\E:\n$query" ); |
1029
|
0
|
|
|
|
|
|
return( $self ); |
1030
|
|
|
|
|
|
|
} |
1031
|
|
|
|
|
|
|
# Incompatible. Do not bother going further |
1032
|
0
|
0
|
|
|
|
|
return( $self ) if( $query =~ /^\s*(?:$allowed)\s+(?:DELAYED|LOW_PRIORITY|HIGH_PRIORITY)\s+/i ); |
1033
|
|
|
|
|
|
|
# SELECT with something else than HIGH_PRIORITY is incompatible, so do not bother to go further |
1034
|
0
|
0
|
0
|
|
|
|
return( $self ) if( $prio != 1 && $type =~ /^(?:SELECT)$/i ); |
1035
|
0
|
0
|
0
|
|
|
|
return( $self ) if( $prio != 0 && $type =~ /^(?:DELETE|INSERT|REPLACE|UPDATE)$/i ); |
1036
|
|
|
|
|
|
|
|
1037
|
0
|
|
|
|
|
|
$query =~ s/^(\s*)($allowed)(\s+)/$1$2 $map->{ $prio } /i; |
1038
|
|
|
|
|
|
|
# $self->{ 'query' } = $query; |
1039
|
|
|
|
|
|
|
# my $sth = $self->prepare( $query ) || |
1040
|
0
|
|
0
|
|
|
|
my $sth = $self->_cache_this( $query ) || |
1041
|
|
|
|
|
|
|
return( $self->error( "Error while preparing new low priority query:\n$query" ) ); |
1042
|
0
|
0
|
|
|
|
|
if( !defined( wantarray() ) ) |
1043
|
|
|
|
|
|
|
{ |
1044
|
0
|
0
|
|
|
|
|
$sth->execute() || |
1045
|
|
|
|
|
|
|
return( $self->error( "Error while executing new low priority query:\n$query" ) ); |
1046
|
|
|
|
|
|
|
} |
1047
|
0
|
|
|
|
|
|
return( $sth ); |
1048
|
|
|
|
|
|
|
} |
1049
|
|
|
|
|
|
|
|
1050
|
|
|
|
|
|
|
sub promise |
1051
|
|
|
|
|
|
|
{ |
1052
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
1053
|
0
|
0
|
|
|
|
|
$self->_load_class( 'Promise::Me' ) || return( $self->pass_error ); |
1054
|
|
|
|
|
|
|
return( Promise::Me->new(sub |
1055
|
|
|
|
|
|
|
{ |
1056
|
0
|
|
|
0
|
|
|
return( $self->execute( @_ ) ); |
1057
|
0
|
|
|
|
|
|
}) ); |
1058
|
|
|
|
|
|
|
} |
1059
|
|
|
|
|
|
|
|
1060
|
0
|
|
|
0
|
1
|
|
sub query { return( shift->_set_get_scalar( 'query', @_ ) ); } |
1061
|
|
|
|
|
|
|
|
1062
|
0
|
|
|
0
|
1
|
|
sub query_object { return( shift->_set_get_object_without_init( 'query_object', 'DB::Object::Query', @_ ) ); } |
1063
|
|
|
|
|
|
|
|
1064
|
0
|
|
|
0
|
1
|
|
sub query_time { return( shift->_set_get_datetime( 'query_time', @_ ) ); } |
1065
|
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
|
sub rollback |
1067
|
|
|
|
|
|
|
{ |
1068
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
1069
|
0
|
0
|
0
|
|
|
|
if( $self->{sth} && $self->param( 'autocommit' ) ) |
1070
|
|
|
|
|
|
|
{ |
1071
|
0
|
|
0
|
|
|
|
my $sth = $self->prepare( "ROLLBACK" ) || return( $self->error( "An error occurred while preparing query to rollback: ", $self->error ) ); |
1072
|
0
|
0
|
|
|
|
|
$sth->execute() || return( $self->error( "Error occurred while executing query to rollback: ", $sth->error ) ); |
1073
|
0
|
|
|
|
|
|
$sth->finish(); |
1074
|
|
|
|
|
|
|
} |
1075
|
0
|
|
|
|
|
|
return( $self ); |
1076
|
|
|
|
|
|
|
} |
1077
|
|
|
|
|
|
|
|
1078
|
|
|
|
|
|
|
sub rows(@) |
1079
|
|
|
|
|
|
|
{ |
1080
|
0
|
|
|
0
|
1
|
|
my $self = shift( @_ ); |
1081
|
0
|
0
|
|
|
|
|
if( !$self->executed() ) |
1082
|
|
|
|
|
|
|
{ |
1083
|
0
|
0
|
|
|
|
|
$self->execute() || return( $self->pass_error ); |
1084
|
|
|
|
|
|
|
} |
1085
|
|
|
|
|
|
|
# $self->_cleanup(); |
1086
|
|
|
|
|
|
|
# $rv = $sth->rows; |
1087
|
0
|
0
|
|
|
|
|
if( !ref( $self ) ) |
1088
|
|
|
|
|
|
|
{ |
1089
|
0
|
|
|
|
|
|
return( $DBI::rows ); |
1090
|
|
|
|
|
|
|
} |
1091
|
|
|
|
|
|
|
else |
1092
|
|
|
|
|
|
|
{ |
1093
|
0
|
|
|
|
|
|
return( $self->{sth}->rows() ); |
1094
|
|
|
|
|
|
|
} |
1095
|
|
|
|
|
|
|
} |
1096
|
|
|
|
|
|
|
|
1097
|
|
|
|
|
|
|
# A DBI::sth object. This should rather be a _set_get_object helper method, but I am not 100% sure if this is really a DBI::sth |
1098
|
0
|
|
|
0
|
1
|
|
sub sth { return( shift->_set_get_scalar( 'sth', @_ ) ); } |
1099
|
|
|
|
|
|
|
|
1100
|
0
|
|
|
0
|
1
|
|
sub table { return( shift->{table} ); } |
1101
|
|
|
|
|
|
|
|
1102
|
0
|
|
|
0
|
1
|
|
sub table_object { return( shift->_set_get_object_without_init( 'table_object', 'DB::Object::Tables', @_ ) ); } |
1103
|
|
|
|
|
|
|
|
1104
|
|
|
|
|
|
|
sub undo |
1105
|
|
|
|
|
|
|
{ |
1106
|
0
|
|
|
0
|
1
|
|
goto( &rollback ); |
1107
|
|
|
|
|
|
|
} |
1108
|
|
|
|
|
|
|
|
1109
|
0
|
|
|
0
|
1
|
|
sub wait { return( shift->error( "Method wait() is not implemented by this driver." ) ); } |
1110
|
|
|
|
|
|
|
|
1111
|
0
|
|
|
0
|
|
|
sub _convert_datetime2object { return( shift->database_object->_convert_datetime2object( @_ ) ); } |
1112
|
|
|
|
|
|
|
|
1113
|
0
|
|
|
0
|
|
|
sub _convert_json2hash { return( shift->database_object->_convert_json2hash( @_ ) ); } |
1114
|
|
|
|
|
|
|
|
1115
|
|
|
|
|
|
|
DESTROY |
1116
|
|
|
|
0
|
|
|
{ |
1117
|
|
|
|
|
|
|
# Do nothing but existing so it is handled by this package |
1118
|
|
|
|
|
|
|
# print( STDERR "DESTROY'ing statement $self ($self->{ 'query' })\n" ); |
1119
|
|
|
|
|
|
|
}; |
1120
|
|
|
|
|
|
|
|
1121
|
|
|
|
|
|
|
1; |
1122
|
|
|
|
|
|
|
# NOTE: POD |
1123
|
|
|
|
|
|
|
__END__ |
1124
|
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
|
=encoding utf-8 |
1126
|
|
|
|
|
|
|
|
1127
|
|
|
|
|
|
|
=head1 NAME |
1128
|
|
|
|
|
|
|
|
1129
|
|
|
|
|
|
|
DB::Object::Statement - Statement Object |
1130
|
|
|
|
|
|
|
|
1131
|
|
|
|
|
|
|
=head1 SYNOPSIS |
1132
|
|
|
|
|
|
|
|
1133
|
|
|
|
|
|
|
say $sth->as_string; |
1134
|
|
|
|
|
|
|
$sth->bind_param( 2, $binded_value ); |
1135
|
|
|
|
|
|
|
$sth->bind_param( 2, $binded_value, $binded_type ); |
1136
|
|
|
|
|
|
|
$sth->commit; |
1137
|
|
|
|
|
|
|
my $dbh = $sth->database_object; |
1138
|
|
|
|
|
|
|
$sth->distinct; |
1139
|
|
|
|
|
|
|
say $sth->dump; |
1140
|
|
|
|
|
|
|
say $sth->execute; |
1141
|
|
|
|
|
|
|
$sth->execute( $val1, $val2 ) || die( $sth->error ); |
1142
|
|
|
|
|
|
|
# explicitly specify types |
1143
|
|
|
|
|
|
|
# Here in this mixed example, $val1 and $val3 have known types |
1144
|
|
|
|
|
|
|
$tbl->where( $dbh->AND( |
1145
|
|
|
|
|
|
|
$tbl->fo->name == '?', |
1146
|
|
|
|
|
|
|
$tbl->fo>city == '?', |
1147
|
|
|
|
|
|
|
'?' == ANY( $tbl->fo->alias ) |
1148
|
|
|
|
|
|
|
) ); |
1149
|
|
|
|
|
|
|
my $sth = $tbl->select || die( $tbl->error ); |
1150
|
|
|
|
|
|
|
$sth->execute( $val1, $val2, { $val3 => 'varchar' } ) || die( $sth->error ); |
1151
|
|
|
|
|
|
|
my $ref = $sth->fetchall_arrayref; |
1152
|
|
|
|
|
|
|
my $val = $sth->fetchcol; |
1153
|
|
|
|
|
|
|
my %hash = $sth->fetchhash; |
1154
|
|
|
|
|
|
|
my @values = $sth->fetchrow; |
1155
|
|
|
|
|
|
|
my $ref = $sth->fetchrow_hashref; |
1156
|
|
|
|
|
|
|
my $obj = $sth->fetchrow_object; |
1157
|
|
|
|
|
|
|
$sth->finish; |
1158
|
|
|
|
|
|
|
$sth->ignore; |
1159
|
|
|
|
|
|
|
$sth->join( $join_condition ); |
1160
|
|
|
|
|
|
|
my $qo = $sth->query_object; |
1161
|
|
|
|
|
|
|
$sth->rollback; |
1162
|
|
|
|
|
|
|
my $rows = $sth->rows; |
1163
|
|
|
|
|
|
|
my $dbi_sth = $sth->sth; |
1164
|
|
|
|
|
|
|
my $tbl = $sth->table_object; |
1165
|
|
|
|
|
|
|
|
1166
|
|
|
|
|
|
|
=head1 VERSION |
1167
|
|
|
|
|
|
|
|
1168
|
|
|
|
|
|
|
v0.4.2 |
1169
|
|
|
|
|
|
|
|
1170
|
|
|
|
|
|
|
=head1 DESCRIPTION |
1171
|
|
|
|
|
|
|
|
1172
|
|
|
|
|
|
|
This is the statement object package from which other driver specific packages inherit from. |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
=head1 METHODS |
1175
|
|
|
|
|
|
|
|
1176
|
|
|
|
|
|
|
=head2 as_string |
1177
|
|
|
|
|
|
|
|
1178
|
|
|
|
|
|
|
Returns the current statement object as a string. |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
=head2 bind_param |
1181
|
|
|
|
|
|
|
|
1182
|
|
|
|
|
|
|
Provided with a list of arguments and they will be passed to L<DBI/bind_param> |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
If an error occurred, an error is returned, otherwise the return value of calling C<bind_param> is returned. |
1185
|
|
|
|
|
|
|
|
1186
|
|
|
|
|
|
|
=head2 commit |
1187
|
|
|
|
|
|
|
|
1188
|
|
|
|
|
|
|
If the statement parameter I<autocommit> is true, a C<COMMIT> statement will be prepared and executed. |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
The current object is returned. |
1191
|
|
|
|
|
|
|
|
1192
|
|
|
|
|
|
|
=head2 database_object |
1193
|
|
|
|
|
|
|
|
1194
|
|
|
|
|
|
|
Sets or gets the current database object. |
1195
|
|
|
|
|
|
|
|
1196
|
|
|
|
|
|
|
=head2 distinct |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
Assuming a I<query> object property has already been set previously, this will add the C<DISTINCT> keyword to it if not already set. |
1199
|
|
|
|
|
|
|
|
1200
|
|
|
|
|
|
|
If L</distinct> is called in void context, the query is executed immediately. |
1201
|
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
|
The query statement is returned. |
1203
|
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
|
=head2 dump |
1205
|
|
|
|
|
|
|
|
1206
|
|
|
|
|
|
|
Provided with a file and this will print on STDOUT the columns used, separated by a tab and then will process each rows fetched with L<DBI::fetchrow> and will join the column valus with a tab before printing it out to STDOUT. |
1207
|
|
|
|
|
|
|
|
1208
|
|
|
|
|
|
|
It returns the current object for chaining. |
1209
|
|
|
|
|
|
|
|
1210
|
|
|
|
|
|
|
=head2 exec |
1211
|
|
|
|
|
|
|
|
1212
|
|
|
|
|
|
|
This is an alias for L</execute> |
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
=head2 execute |
1215
|
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
|
$sth->execute || die( $sth->error ); |
1217
|
|
|
|
|
|
|
$sth->execute( $val1, $val2 ) || die( $sth->error ); |
1218
|
|
|
|
|
|
|
# explicitly specify types |
1219
|
|
|
|
|
|
|
# Here in this mixed example, $val1 and $val3 have known types |
1220
|
|
|
|
|
|
|
$tbl->where( $dbh->AND( |
1221
|
|
|
|
|
|
|
$tbl->fo->name == '?', |
1222
|
|
|
|
|
|
|
$tbl->fo>city == '?', |
1223
|
|
|
|
|
|
|
'?' == ANY( $tbl->fo->alias ) |
1224
|
|
|
|
|
|
|
) ); |
1225
|
|
|
|
|
|
|
my $sth = $tbl->select || die( $tbl->error ); |
1226
|
|
|
|
|
|
|
$sth->execute( $val1, $val2, { $val3 => 'varchar' } ) || die( $sth->error ); |
1227
|
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
|
If binded values have been prepared, they are applied here before executing the query. |
1229
|
|
|
|
|
|
|
|
1230
|
|
|
|
|
|
|
Sometime, you need to clearly specify what the datatype are for the value provided with C<execute>, because L<DB::Object::Query> could not figure it out. |
1231
|
|
|
|
|
|
|
|
1232
|
|
|
|
|
|
|
Thus, if you do: |
1233
|
|
|
|
|
|
|
|
1234
|
|
|
|
|
|
|
$tbl->where( |
1235
|
|
|
|
|
|
|
$tbl->fo->name == '?' |
1236
|
|
|
|
|
|
|
); |
1237
|
|
|
|
|
|
|
|
1238
|
|
|
|
|
|
|
L<DB::Object::Query> knows the datatype, because you are using a field object (C<fo>), but if you were doing: |
1239
|
|
|
|
|
|
|
|
1240
|
|
|
|
|
|
|
$tbl->where( |
1241
|
|
|
|
|
|
|
'?' == ANY( $tbl->fo->alias ) |
1242
|
|
|
|
|
|
|
); |
1243
|
|
|
|
|
|
|
|
1244
|
|
|
|
|
|
|
In this scenario, L<DB::Object::Query> does not know what the bind value would be, although we could venture a guess by looking at the right-hand side, but this is a bit hazardous. So you are left with a placeholder, but no datatype. So you would execute like: |
1245
|
|
|
|
|
|
|
|
1246
|
|
|
|
|
|
|
$sth->execute({ $val => 'varchar' }); |
1247
|
|
|
|
|
|
|
|
1248
|
|
|
|
|
|
|
If the total number of binded values does not match the total number of binded type, this will trigger a warning. |
1249
|
|
|
|
|
|
|
|
1250
|
|
|
|
|
|
|
L<DBI/execute> will be called with the binded values and if this method was called in an object context, the current object is returned, otherwise the returned value from L<DBI/execute> is returned. |
1251
|
|
|
|
|
|
|
|
1252
|
|
|
|
|
|
|
=head2 executed |
1253
|
|
|
|
|
|
|
|
1254
|
|
|
|
|
|
|
Returns true if this statement has already been executed, and false otherwise. |
1255
|
|
|
|
|
|
|
|
1256
|
|
|
|
|
|
|
=head2 fetchall_arrayref |
1257
|
|
|
|
|
|
|
|
1258
|
|
|
|
|
|
|
Similar to L<DBI/fetchall_arrayref>, this will execute the query and return an array reference of data. |
1259
|
|
|
|
|
|
|
|
1260
|
|
|
|
|
|
|
=head2 fetchcol |
1261
|
|
|
|
|
|
|
|
1262
|
|
|
|
|
|
|
Provided with an integer that represents a column number, starting from 0, and this will get each row of results and add the value for the column at the given offset. |
1263
|
|
|
|
|
|
|
|
1264
|
|
|
|
|
|
|
it returns a list of those column value fetched. |
1265
|
|
|
|
|
|
|
|
1266
|
|
|
|
|
|
|
=head2 fetchhash |
1267
|
|
|
|
|
|
|
|
1268
|
|
|
|
|
|
|
This will retrieve an hash reference for the given row and return it as a regular hash. |
1269
|
|
|
|
|
|
|
|
1270
|
|
|
|
|
|
|
=head2 fetchrow |
1271
|
|
|
|
|
|
|
|
1272
|
|
|
|
|
|
|
This will retrieve the data from database using L</fetchrow_arrayref> and return the list of data as array in list context, or the first entry of the array in scalar context. |
1273
|
|
|
|
|
|
|
|
1274
|
|
|
|
|
|
|
=head2 fetchrow_hashref |
1275
|
|
|
|
|
|
|
|
1276
|
|
|
|
|
|
|
This will retrieve the data from the database as an hash reference. |
1277
|
|
|
|
|
|
|
|
1278
|
|
|
|
|
|
|
It will convert any data from json to hash reference if L<DB::Object/auto_decode_json> is set to true. |
1279
|
|
|
|
|
|
|
|
1280
|
|
|
|
|
|
|
it will also convert any datetime data into a L<DateTime> object if L<DB::Object/auto_convert_datetime_to_object> is true. |
1281
|
|
|
|
|
|
|
|
1282
|
|
|
|
|
|
|
It returns the hash reference retrieved. |
1283
|
|
|
|
|
|
|
|
1284
|
|
|
|
|
|
|
=head2 fetchrow_object |
1285
|
|
|
|
|
|
|
|
1286
|
|
|
|
|
|
|
This will create dynamically a package named C<DB::Object::Postgres::Result::SomeTable> for example and load the hash reference retrieved from the database into this dynamically created packackage. |
1287
|
|
|
|
|
|
|
|
1288
|
|
|
|
|
|
|
It returns the object thus created. |
1289
|
|
|
|
|
|
|
|
1290
|
|
|
|
|
|
|
=head2 finish |
1291
|
|
|
|
|
|
|
|
1292
|
|
|
|
|
|
|
Calls L<DBI/finish> and return the returned value, or an error if an error occurred. |
1293
|
|
|
|
|
|
|
|
1294
|
|
|
|
|
|
|
=head2 ignore |
1295
|
|
|
|
|
|
|
|
1296
|
|
|
|
|
|
|
This will change the query prepared and add the keyword C<IGNORE>. |
1297
|
|
|
|
|
|
|
|
1298
|
|
|
|
|
|
|
If called in void context, this will execute the resulting statement handler immediately. |
1299
|
|
|
|
|
|
|
|
1300
|
|
|
|
|
|
|
=head2 join |
1301
|
|
|
|
|
|
|
|
1302
|
|
|
|
|
|
|
Provided with a target and an hash reference, or list or array reference of condition for the join and this will prepare the join statement. |
1303
|
|
|
|
|
|
|
|
1304
|
|
|
|
|
|
|
If the original query is not of type C<select>, this will trigger an error. |
1305
|
|
|
|
|
|
|
|
1306
|
|
|
|
|
|
|
The target mentioned above can be either a L<DB::Object::Statement> object, or a table object (L<DB::Object::Tables>), or even just a string representing the name of a table. |
1307
|
|
|
|
|
|
|
|
1308
|
|
|
|
|
|
|
$tbl->select->join( $sth ); |
1309
|
|
|
|
|
|
|
$tbl->select->join( $other_tbl ); |
1310
|
|
|
|
|
|
|
$tbl->select->join( 'table_name' ); |
1311
|
|
|
|
|
|
|
|
1312
|
|
|
|
|
|
|
The condition mentioned above can be a L<DB::Object::Operator> (C<AND>, C<OR> or C<NOT>), in which case the actual condition will be taken from that operator embedded value. |
1313
|
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
|
The condition can also be a L<DB::Object::Fields::Field::Overloaded> object, which implies a table field with some operator and some value. |
1315
|
|
|
|
|
|
|
|
1316
|
|
|
|
|
|
|
$tbl->select->join( $other_tbl, $other_tbl->fo->id == 2 ); |
1317
|
|
|
|
|
|
|
|
1318
|
|
|
|
|
|
|
Here C<$other_tbl->fo->id == 2> will become a L<DB::Object::Fields::Field::Overloaded> object. |
1319
|
|
|
|
|
|
|
|
1320
|
|
|
|
|
|
|
The condition can also be an array reference or array object of conditions and implicitly the array entry will be joined with C<AND>: |
1321
|
|
|
|
|
|
|
|
1322
|
|
|
|
|
|
|
$tbl->select->join( $other_tbl, ["user = 'joe'", $other_tbl->fo->id == 2] ); |
1323
|
|
|
|
|
|
|
|
1324
|
|
|
|
|
|
|
The condition can also be an hash reference with each key being a table name to join and each value an hash reference of condition for that particular join with each key being a column name and each value the value of the join for that column. |
1325
|
|
|
|
|
|
|
|
1326
|
|
|
|
|
|
|
my $tbl = $dbh->first_table; |
1327
|
|
|
|
|
|
|
$tbl->select->join({ |
1328
|
|
|
|
|
|
|
other_table => |
1329
|
|
|
|
|
|
|
{ |
1330
|
|
|
|
|
|
|
id => 'first_table.id', |
1331
|
|
|
|
|
|
|
user => 'first_table.user', |
1332
|
|
|
|
|
|
|
}, |
1333
|
|
|
|
|
|
|
yet_another_table => |
1334
|
|
|
|
|
|
|
{ |
1335
|
|
|
|
|
|
|
id => 'other_table.id', |
1336
|
|
|
|
|
|
|
}, |
1337
|
|
|
|
|
|
|
}); |
1338
|
|
|
|
|
|
|
|
1339
|
|
|
|
|
|
|
would become something like: |
1340
|
|
|
|
|
|
|
|
1341
|
|
|
|
|
|
|
SELECT * |
1342
|
|
|
|
|
|
|
FROM first_table |
1343
|
|
|
|
|
|
|
LEFT JOIN other_table ON |
1344
|
|
|
|
|
|
|
first_table.id = id AND |
1345
|
|
|
|
|
|
|
first_table.user = user |
1346
|
|
|
|
|
|
|
LEFT JOIN yet_another_table ON |
1347
|
|
|
|
|
|
|
other_table.id = id |
1348
|
|
|
|
|
|
|
|
1349
|
|
|
|
|
|
|
Each condition will be formatted assuming an C<AND> expression, so this is less flexible than using operator objects and table field objects. |
1350
|
|
|
|
|
|
|
|
1351
|
|
|
|
|
|
|
If no condition is provided, this is taken to be a straight join. |
1352
|
|
|
|
|
|
|
|
1353
|
|
|
|
|
|
|
$tbl->where( $tbl->fo->id == 2 ); |
1354
|
|
|
|
|
|
|
$other_tbl->where( $other_tbl->fo->user 'john' ); |
1355
|
|
|
|
|
|
|
$tbl->select->join( $other_tbl ); |
1356
|
|
|
|
|
|
|
|
1357
|
|
|
|
|
|
|
Would become something like: |
1358
|
|
|
|
|
|
|
|
1359
|
|
|
|
|
|
|
SELECT * |
1360
|
|
|
|
|
|
|
FROM first_table, other_table |
1361
|
|
|
|
|
|
|
WHERE id = 2 AND user = 'john' |
1362
|
|
|
|
|
|
|
|
1363
|
|
|
|
|
|
|
If called in void context, this will execute the resulting statement handler immediately. |
1364
|
|
|
|
|
|
|
|
1365
|
|
|
|
|
|
|
It returns the resulting statement handler. |
1366
|
|
|
|
|
|
|
|
1367
|
|
|
|
|
|
|
It returns the statement handler. |
1368
|
|
|
|
|
|
|
|
1369
|
|
|
|
|
|
|
=head2 object |
1370
|
|
|
|
|
|
|
|
1371
|
|
|
|
|
|
|
Returns the statement object explicitly. |
1372
|
|
|
|
|
|
|
|
1373
|
|
|
|
|
|
|
my $sth = $tbl->select->object; |
1374
|
|
|
|
|
|
|
|
1375
|
|
|
|
|
|
|
which is really equivalent to: |
1376
|
|
|
|
|
|
|
|
1377
|
|
|
|
|
|
|
my $sth = $tbl->select; |
1378
|
|
|
|
|
|
|
|
1379
|
|
|
|
|
|
|
=head2 priority |
1380
|
|
|
|
|
|
|
|
1381
|
|
|
|
|
|
|
Provided with a priority integer that can be 0 or 1 with 0 being C<LOW_PRIORITY> and 1 being C<HIGH_PRIORITY> and this will adjust the query formatted to add the priority. This works only on Mysql drive though. |
1382
|
|
|
|
|
|
|
|
1383
|
|
|
|
|
|
|
If used on queries other than C<DELETE>, C<INSERT>, C<REPLACE>, C<SELECT>, C<UPDATE> an error will be returned. |
1384
|
|
|
|
|
|
|
|
1385
|
|
|
|
|
|
|
If called in void context, this will execute the newly create statement handler immediately. |
1386
|
|
|
|
|
|
|
|
1387
|
|
|
|
|
|
|
It returns the newly create statement handler. |
1388
|
|
|
|
|
|
|
|
1389
|
|
|
|
|
|
|
=head2 promise |
1390
|
|
|
|
|
|
|
|
1391
|
|
|
|
|
|
|
This the same as calling L</execute>, except that the query will be executed asynchronously and a L<Promise::Me> object will be returned, so you can do asynchronous queries like this: |
1392
|
|
|
|
|
|
|
|
1393
|
|
|
|
|
|
|
my $sth = $dbh->prepare( "SELECT some_slow_function(?)" ) || die( $dbh->error ); |
1394
|
|
|
|
|
|
|
my $p = $sth->promise(10)->then(sub |
1395
|
|
|
|
|
|
|
{ |
1396
|
|
|
|
|
|
|
my $st = shift( @_ ); |
1397
|
|
|
|
|
|
|
my $ref = $st->fetchrow_hashref; |
1398
|
|
|
|
|
|
|
my $obj = My::Module->new( %$ref ); |
1399
|
|
|
|
|
|
|
})->catch(sub |
1400
|
|
|
|
|
|
|
{ |
1401
|
|
|
|
|
|
|
$log->warn( "Failed to execute query: ", @_ ); |
1402
|
|
|
|
|
|
|
}); |
1403
|
|
|
|
|
|
|
my( $obj ) = await( $p ); |
1404
|
|
|
|
|
|
|
|
1405
|
|
|
|
|
|
|
=head2 query |
1406
|
|
|
|
|
|
|
|
1407
|
|
|
|
|
|
|
Sets or gets the previously formatted query as a regular string. |
1408
|
|
|
|
|
|
|
|
1409
|
|
|
|
|
|
|
=head2 query_object |
1410
|
|
|
|
|
|
|
|
1411
|
|
|
|
|
|
|
Sets or gets the query object used in this query. |
1412
|
|
|
|
|
|
|
|
1413
|
|
|
|
|
|
|
=head2 query_time |
1414
|
|
|
|
|
|
|
|
1415
|
|
|
|
|
|
|
Sets or gets the query time as a L<DateTime> object. |
1416
|
|
|
|
|
|
|
|
1417
|
|
|
|
|
|
|
=head2 rollback |
1418
|
|
|
|
|
|
|
|
1419
|
|
|
|
|
|
|
If there is a statement handler and the database parameter C<autocommit> is set to true, this will prepare a C<ROLLBACK> query and execute it. |
1420
|
|
|
|
|
|
|
|
1421
|
|
|
|
|
|
|
=head2 rows |
1422
|
|
|
|
|
|
|
|
1423
|
|
|
|
|
|
|
Returns the number of rows affected by the last query. |
1424
|
|
|
|
|
|
|
|
1425
|
|
|
|
|
|
|
=head2 sth |
1426
|
|
|
|
|
|
|
|
1427
|
|
|
|
|
|
|
Sets or gets the L<DBI> statement handler. |
1428
|
|
|
|
|
|
|
|
1429
|
|
|
|
|
|
|
=head2 table |
1430
|
|
|
|
|
|
|
|
1431
|
|
|
|
|
|
|
Sets or gets the table object (L<DB::Object::Tables>) for this query. |
1432
|
|
|
|
|
|
|
|
1433
|
|
|
|
|
|
|
=head2 table_object |
1434
|
|
|
|
|
|
|
|
1435
|
|
|
|
|
|
|
Sets or get the table object (L<DB::Object::Tables>) |
1436
|
|
|
|
|
|
|
|
1437
|
|
|
|
|
|
|
=head2 undo |
1438
|
|
|
|
|
|
|
|
1439
|
|
|
|
|
|
|
This is an alias for L</rollback> |
1440
|
|
|
|
|
|
|
|
1441
|
|
|
|
|
|
|
=head2 wait |
1442
|
|
|
|
|
|
|
|
1443
|
|
|
|
|
|
|
The implementation is driver dependent, and in this case, this is implemented only in L<DB::Object::Mysql> |
1444
|
|
|
|
|
|
|
|
1445
|
|
|
|
|
|
|
=head2 _convert_datetime2object |
1446
|
|
|
|
|
|
|
|
1447
|
|
|
|
|
|
|
A convenient short to enable or disable L<DB::Object/_convert_datetime2object> |
1448
|
|
|
|
|
|
|
|
1449
|
|
|
|
|
|
|
=head2 _convert_json2hash |
1450
|
|
|
|
|
|
|
|
1451
|
|
|
|
|
|
|
A convenient short to enable or disable L<DB::Object/_convert_json2hash> |
1452
|
|
|
|
|
|
|
|
1453
|
|
|
|
|
|
|
=head1 SEE ALSO |
1454
|
|
|
|
|
|
|
|
1455
|
|
|
|
|
|
|
L<DB::Object::Query>, L<DB::Object::Mysql::Query>, L<DB::Object::Postgres::Query>, L<DB::Object::SQLite::Query> |
1456
|
|
|
|
|
|
|
|
1457
|
|
|
|
|
|
|
=head1 AUTHOR |
1458
|
|
|
|
|
|
|
|
1459
|
|
|
|
|
|
|
Jacques Deguest E<lt>F<jack@deguest.jp>E<gt> |
1460
|
|
|
|
|
|
|
|
1461
|
|
|
|
|
|
|
=head1 COPYRIGHT & LICENSE |
1462
|
|
|
|
|
|
|
|
1463
|
|
|
|
|
|
|
Copyright (c) 2019-2021 DEGUEST Pte. Ltd. |
1464
|
|
|
|
|
|
|
|
1465
|
|
|
|
|
|
|
You can use, copy, modify and redistribute this package and associated |
1466
|
|
|
|
|
|
|
files under the same terms as Perl itself. |
1467
|
|
|
|
|
|
|
|
1468
|
|
|
|
|
|
|
=cut |