line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package SQL::SqlObject; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
#use 5.006; |
4
|
3
|
|
|
3
|
|
6789
|
use strict; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
105
|
|
5
|
3
|
|
|
3
|
|
18
|
use warnings; |
|
3
|
|
|
|
|
16
|
|
|
3
|
|
|
|
|
83
|
|
6
|
3
|
|
|
3
|
|
16
|
use Carp; |
|
3
|
|
|
|
|
12
|
|
|
3
|
|
|
|
|
230
|
|
7
|
3
|
|
|
3
|
|
7666
|
use DBI; |
|
3
|
|
|
|
|
106389
|
|
|
3
|
|
|
|
|
1030
|
|
8
|
3
|
|
|
3
|
|
3330
|
use SQL::SqlObject::Config; |
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
227
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
# 110803 - VERSION incremented to 0.02 for first CPAN release |
11
|
|
|
|
|
|
|
# 101903 - fixed argument verification for insert_select |
12
|
|
|
|
|
|
|
# - added connection arg cacheing |
13
|
|
|
|
|
|
|
# - we now cache db_name, db_dsn and db_pre if they |
14
|
|
|
|
|
|
|
# are provided as arguments to connect_string() -cz |
15
|
|
|
|
|
|
|
# 011003 - arguments for constructor now come from |
16
|
|
|
|
|
|
|
# SQL::SqlObject::Config -cz |
17
|
|
|
|
|
|
|
# 010803 - added constuctor_args/process_contructror args -cz |
18
|
|
|
|
|
|
|
# 010603 - added AUTOLOAD to pass through method calls -cz |
19
|
|
|
|
|
|
|
# 052699 - Minor fix to Hashes Sub -cz |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
our $VERSION = '0.02'; |
22
|
|
|
|
|
|
|
our %SqlConfig; # read from SQL::SqlObject::Config |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
sub new |
25
|
|
|
|
|
|
|
{ |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# install confguration, if necessary |
28
|
5
|
100
|
|
5
|
0
|
967
|
unless (%SqlConfig) |
29
|
|
|
|
|
|
|
{ |
30
|
3
|
|
|
3
|
|
18
|
no strict 'refs'; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
23864
|
|
31
|
3
|
|
|
|
|
12
|
*SQL::SqlObject::SqlConfig = \%SQL::SqlObject::Config::SqlConfig; |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
|
34
|
5
|
|
|
|
|
14
|
my ($class) = @_; |
35
|
5
|
|
|
|
|
10
|
my $self; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
# we don't really support clones... |
39
|
5
|
100
|
|
|
|
18
|
if (ref $class) |
40
|
|
|
|
|
|
|
{ |
41
|
|
|
|
|
|
|
# clones must have us somwhere in their ancestory |
42
|
1
|
50
|
|
|
|
5
|
unless (UNIVERSAL::isa($class, __PACKAGE__)) |
43
|
|
|
|
|
|
|
{ |
44
|
0
|
|
|
|
|
0
|
Carp::confess ( |
45
|
|
|
|
|
|
|
"process_constructor_args: attemp to clone", |
46
|
|
|
|
|
|
|
" from unrelated class: ", ref $class |
47
|
|
|
|
|
|
|
); |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
|
50
|
1
|
|
|
|
|
7
|
($class) = $class =~ /(.*?)=/; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
5
|
|
|
|
|
14
|
$self = bless {}, $class; |
54
|
5
|
|
|
|
|
38
|
$self->process_constructor_args(@_); |
55
|
|
|
|
|
|
|
# post construction initialization |
56
|
5
|
100
|
|
|
|
46
|
$self->_init if $self->can('_init'); |
57
|
|
|
|
|
|
|
|
58
|
5
|
|
|
|
|
14
|
return $self; |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
0
|
|
|
0
|
0
|
0
|
sub clone { shift->new(@_) } |
62
|
|
|
|
|
|
|
|
63
|
5
|
|
|
5
|
|
298
|
sub DESTROY { $_[0]->disconnect } |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
sub process_constructor_args |
66
|
|
|
|
|
|
|
{ |
67
|
|
|
|
|
|
|
|
68
|
5
|
50
|
|
5
|
0
|
17
|
unless (@_>1) { |
69
|
0
|
|
|
|
|
0
|
Carp::confess "process_constructor_args: wrong number of parameters" |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
5
|
|
|
|
|
31
|
my $self = shift; |
73
|
5
|
|
|
|
|
6
|
my $class = shift; |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# coerse input to hash reference |
76
|
5
|
|
|
|
|
9
|
my $args = {}; |
77
|
5
|
50
|
|
|
|
34
|
if ($_ = ref $_[0]) |
|
|
100
|
|
|
|
|
|
78
|
|
|
|
|
|
|
{ |
79
|
0
|
0
|
|
|
|
0
|
if (/HASH/) |
|
|
0
|
|
|
|
|
|
80
|
|
|
|
|
|
|
{ |
81
|
0
|
|
|
|
|
0
|
while (my ($k, $v) = each %{ $_[0] }) |
|
0
|
|
|
|
|
0
|
|
82
|
|
|
|
|
|
|
{ |
83
|
0
|
|
|
|
|
0
|
my $arg_ix = SQL::SqlObject::Config::arg_index($k); |
84
|
0
|
|
|
|
|
0
|
$k =~ y/A-Z-/a-z/d; |
85
|
0
|
|
|
|
|
0
|
$args->{$SqlConfig{ARGS}[ $arg_ix ][0]} = $v; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
elsif (/ARRAY/) |
90
|
|
|
|
|
|
|
{ |
91
|
0
|
|
|
|
|
0
|
$args = { |
92
|
0
|
|
|
|
|
0
|
map { $SqlConfig{ARGS}[$_][0] => $_[0][$_] } 0..$#{$_[0]} |
|
0
|
|
|
|
|
0
|
|
93
|
|
|
|
|
|
|
}; |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
else |
97
|
|
|
|
|
|
|
{ |
98
|
0
|
|
|
|
|
0
|
Carp::Confess (q(process_constructor_args encountered ), |
99
|
|
|
|
|
|
|
q(unexpected reference type ), $_); |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
elsif (@_) |
104
|
|
|
|
|
|
|
{ |
105
|
1
|
50
|
|
|
|
4
|
if ($_[0] =~ /^-/) |
106
|
|
|
|
|
|
|
{ |
107
|
|
|
|
|
|
|
# input aleardy in key-value format |
108
|
0
|
0
|
|
|
|
0
|
if (@_ % 2) |
109
|
|
|
|
|
|
|
{ |
110
|
0
|
|
|
|
|
0
|
Carp::confess ('process_constructor_args uneven number ', |
111
|
|
|
|
|
|
|
'of input parameters') |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
0
|
|
|
|
|
0
|
for (my $input_ix = 0; $input_ix < @_; $input_ix += 2 ) |
115
|
|
|
|
|
|
|
{ |
116
|
0
|
|
|
|
|
0
|
my $arg_ix = SQL::SqlObject::Config::arg_index($_[$input_ix] ); |
117
|
0
|
|
|
|
|
0
|
$args->{ $SqlConfig{ARGS}[ $arg_ix ][0] } = $_[ $input_ix + 1 ]; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
else |
122
|
|
|
|
|
|
|
{ |
123
|
|
|
|
|
|
|
# input in ordered list format |
124
|
1
|
|
|
|
|
3
|
for (0..$#_) |
125
|
|
|
|
|
|
|
{ |
126
|
3
|
|
|
|
|
8
|
$args->{ $SqlConfig{ARGS}[$_][0] } = $_[$_]; |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
# now try to supply values for all args |
132
|
5
|
|
|
|
|
9
|
ARG: for my $arg_id ( 0..$#{ $SqlConfig{ARGS} }) |
|
5
|
|
|
|
|
22
|
|
133
|
|
|
|
|
|
|
{ |
134
|
29
|
|
|
|
|
61
|
my $name = $SqlConfig{ARGS}[$arg_id][0]; |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# see value if value was supplied as an argument |
137
|
29
|
100
|
|
|
|
87
|
if (exists $args->{$name}) |
138
|
|
|
|
|
|
|
{ |
139
|
3
|
|
|
|
|
7
|
$self->$name( $args->{$name} ); |
140
|
3
|
|
|
|
|
5
|
next ARG; |
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# if we're cloning look at the parent object first |
144
|
26
|
100
|
100
|
|
|
64
|
if (ref $class and defined $class->$name) |
145
|
|
|
|
|
|
|
{ |
146
|
4
|
|
|
|
|
9
|
$self->$name($class->$name); |
147
|
4
|
|
|
|
|
8
|
next ARG; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# search env variables if any we're supplied |
151
|
22
|
100
|
|
|
|
56
|
if ($SqlConfig{ARGS}[$arg_id][2]) |
152
|
|
|
|
|
|
|
{ |
153
|
7
|
|
|
|
|
14
|
my $env = $SqlConfig{ARGS}[$arg_id][2]; |
154
|
|
|
|
|
|
|
|
155
|
7
|
100
|
|
|
|
16
|
if (ref $env) |
156
|
|
|
|
|
|
|
{ |
157
|
3
|
|
|
|
|
6
|
ENV: for (@$env) |
158
|
|
|
|
|
|
|
{ |
159
|
3
|
50
|
|
|
|
18
|
next ENV unless exists $ENV{$_}; |
160
|
0
|
|
|
|
|
0
|
$self->$name( $ENV{$_} ); |
161
|
0
|
|
|
|
|
0
|
next ARG; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
else |
166
|
|
|
|
|
|
|
{ |
167
|
4
|
50
|
|
|
|
12
|
if (exists $ENV{$env}) |
168
|
|
|
|
|
|
|
{ |
169
|
0
|
|
|
|
|
0
|
$self->$name( $ENV{$env} ); |
170
|
0
|
|
|
|
|
0
|
next ARG; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
# use default if one was provided |
176
|
22
|
100
|
66
|
|
|
155
|
if ($SqlConfig{ARGS}[$arg_id][3] and |
177
|
|
|
|
|
|
|
$_ = $SqlConfig{ $SqlConfig{ARGS}[$arg_id][3] }) |
178
|
|
|
|
|
|
|
{ |
179
|
14
|
|
|
|
|
74
|
$self->$name( $_ ); |
180
|
14
|
|
|
|
|
31
|
next ARG; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
|
184
|
5
|
|
|
|
|
12
|
return $self; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
# is_connected: toggled on by dbh |
188
|
|
|
|
|
|
|
# off by disconnect |
189
|
2
|
|
|
2
|
1
|
7
|
sub is_connected : lvalue { $_[0]->{connected_P} } |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
# primary flock of accessors |
192
|
11
|
|
|
11
|
1
|
58
|
sub db_name : lvalue { delete $_[0]->{__connection_args}; |
193
|
11
|
100
|
|
|
|
29
|
$#_ and $_[0]->{name} = $_[1]; $_[0]->{name}} |
|
11
|
|
|
|
|
48
|
|
194
|
8
|
|
|
8
|
0
|
15
|
sub db_name_prefix : lvalue { delete $_[0]->{__connection_args}; |
195
|
8
|
100
|
|
|
|
48
|
$#_ and $_[0]->{pre} = $_[1]; $_[0]->{pre}} |
|
8
|
|
|
|
|
19
|
|
196
|
11
|
|
|
11
|
1
|
328
|
sub db_dsn : lvalue { delete $_[0]->{__connection_args}; |
197
|
11
|
100
|
|
|
|
30
|
$#_ and $_[0]->{dsn} = $_[1]; $_[0]->{dsn}} |
|
11
|
|
|
|
|
29
|
|
198
|
11
|
|
|
11
|
1
|
48
|
sub db_user : lvalue { delete $_[0]->{__connection_args}; |
199
|
11
|
100
|
|
|
|
32
|
$#_ and $_[0]->{user} = $_[1]; $_[0]->{user}} |
|
11
|
|
|
|
|
25
|
|
200
|
6
|
|
|
6
|
1
|
50
|
sub db_password : lvalue { delete $_[0]->{__connection_args}; |
201
|
6
|
100
|
|
|
|
14
|
$#_ and $_[0]->{passwd} = $_[1]; $_[0]->{passwd}} |
|
6
|
|
|
|
|
41
|
|
202
|
0
|
0
|
|
0
|
0
|
0
|
sub Error : lvalue { $#_ and $DBI::errstr = $_[1]; $DBI::errstr} |
|
0
|
|
|
|
|
0
|
|
203
|
|
|
|
|
|
|
sub dbh : lvalue |
204
|
|
|
|
|
|
|
{ |
205
|
0
|
0
|
|
0
|
1
|
0
|
unless ($_[0]->is_connected) { |
206
|
0
|
|
|
|
|
0
|
$_[0]->{dbh} = $_[0]->connect; |
207
|
0
|
|
|
|
|
0
|
$_[0]->is_connected = 1; |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
0
|
|
|
|
|
0
|
$_[0]->{dbh} |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
sub connect |
214
|
|
|
|
|
|
|
{ |
215
|
|
|
|
|
|
|
|
216
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
217
|
|
|
|
|
|
|
|
218
|
0
|
0
|
|
|
|
0
|
if (@_) |
|
|
0
|
|
|
|
|
|
219
|
|
|
|
|
|
|
# cache the arguments, in case we have to reconnect |
220
|
|
|
|
|
|
|
# as seems to be needed for insert_select |
221
|
|
|
|
|
|
|
{ |
222
|
0
|
|
|
|
|
0
|
$self->{__connection_args} = [ @_ ]; |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
elsif ($self->{__connection_args}) |
226
|
|
|
|
|
|
|
# load the connection args from the cache |
227
|
|
|
|
|
|
|
{ |
228
|
0
|
|
|
|
|
0
|
@_ = @{ $self->{__connection_args} } |
|
0
|
|
|
|
|
0
|
|
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
0
|
|
|
|
|
0
|
my $connect_string = $self->connect_string(@_); |
232
|
|
|
|
|
|
|
|
233
|
0
|
0
|
|
|
|
0
|
$self->is_connected and $self->disconnect; |
234
|
|
|
|
|
|
|
|
235
|
0
|
|
|
|
|
0
|
my $dbh = DBI->connect($connect_string,$self->db_user,$self->db_password); |
236
|
|
|
|
|
|
|
|
237
|
0
|
|
|
|
|
0
|
my $err = $self->Error; |
238
|
0
|
0
|
0
|
|
|
0
|
$err and Carp::confess ( |
239
|
|
|
|
|
|
|
q(Whoops - couldn\'t connect to ), |
240
|
|
|
|
|
|
|
$_[0] || $self->db_name, "\n", |
241
|
|
|
|
|
|
|
'Error:', $err |
242
|
|
|
|
|
|
|
); |
243
|
|
|
|
|
|
|
|
244
|
0
|
|
|
|
|
0
|
return $dbh; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
# build the connect string |
248
|
|
|
|
|
|
|
sub connect_string |
249
|
|
|
|
|
|
|
{ |
250
|
0
|
|
|
0
|
0
|
0
|
my ($self, $name, $dsn, $pre) = @_; |
251
|
|
|
|
|
|
|
|
252
|
0
|
0
|
0
|
|
|
0
|
$self->db_name ||= $name if $name; |
253
|
0
|
0
|
0
|
|
|
0
|
$self->db_dsn ||= $dsn if $dsn; |
254
|
0
|
0
|
0
|
|
|
0
|
$self->db_name_prefix ||= $pre if $pre; |
255
|
|
|
|
|
|
|
|
256
|
0
|
0
|
|
|
|
0
|
defined $name or $name = $self->db_name; |
257
|
0
|
0
|
0
|
|
|
0
|
defined $dsn or $dsn = $self->db_dsn |
258
|
|
|
|
|
|
|
or Carp::confess "No data source named for SqlObject connect string"; |
259
|
0
|
0
|
|
|
|
0
|
defined $pre or $pre = $self->db_name_prefix; |
260
|
|
|
|
|
|
|
|
261
|
0
|
|
|
|
|
0
|
my $other = ''; |
262
|
0
|
0
|
|
|
|
0
|
if ($SqlConfig{OTHER_ARGS}) |
263
|
|
|
|
|
|
|
{ |
264
|
0
|
0
|
|
|
|
0
|
if (ref $SqlConfig{OTHER_ARGS}) |
265
|
|
|
|
|
|
|
{ |
266
|
0
|
|
|
|
|
0
|
for (@{$SqlConfig{OTHER_ARGS}}) |
|
0
|
|
|
|
|
0
|
|
267
|
|
|
|
|
|
|
{ |
268
|
0
|
0
|
|
|
|
0
|
my $val = $self->$_ or next; |
269
|
0
|
|
|
|
|
0
|
my ($key) = (/^(?:.*?_)?(.*)$/); |
270
|
0
|
|
|
|
|
0
|
$other .= "$SqlConfig{OTHER_ARG_SEP}$key=$val"; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
else |
275
|
|
|
|
|
|
|
{ |
276
|
0
|
|
|
|
|
0
|
my $meth = $SqlConfig{OTHER_ARGS}; |
277
|
0
|
|
|
|
|
0
|
my $val = $self->$meth; |
278
|
0
|
0
|
|
|
|
0
|
$other = "$SqlConfig{OTHER_ARG_SEP}$SqlConfig{OTHER_ARGS}=$val" |
279
|
|
|
|
|
|
|
if defined $val; |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
0
|
|
|
|
|
0
|
return "$dsn:$pre$name$other"; |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
sub disconnect |
287
|
|
|
|
|
|
|
{ |
288
|
5
|
|
|
5
|
0
|
9
|
my $self = shift; |
289
|
|
|
|
|
|
|
|
290
|
5
|
50
|
|
|
|
330
|
if(exists $self->{'dbh'}) |
291
|
|
|
|
|
|
|
{ |
292
|
0
|
|
|
|
|
|
$self->dbh->disconnect; |
293
|
0
|
|
|
|
|
|
$self->is_connected = ''; |
294
|
0
|
|
|
|
|
|
delete $self->{'dbh'}; |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
sub hash |
299
|
|
|
|
|
|
|
{ |
300
|
0
|
0
|
|
0
|
1
|
|
unless (@_==2) { |
301
|
0
|
|
|
|
|
|
Carp::confess qq(SqlObject: wrong number of arguments for hash); |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
0
|
|
|
|
|
|
my ($self,$query) = @_; |
305
|
|
|
|
|
|
|
|
306
|
0
|
|
|
|
|
|
my $sth = $self->prepare($query); |
307
|
0
|
|
|
|
|
|
$sth->execute(); |
308
|
|
|
|
|
|
|
|
309
|
0
|
|
|
|
|
|
my $href = $sth->fetchrow_hashref; |
310
|
0
|
|
|
|
|
|
$sth->finish; |
311
|
|
|
|
|
|
|
|
312
|
0
|
0
|
|
|
|
|
return unless defined $href; |
313
|
0
|
0
|
|
|
|
|
return wantarray ? %$href : $href; |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
sub hashes |
317
|
|
|
|
|
|
|
{ |
318
|
0
|
0
|
0
|
0
|
1
|
|
if (@_<2 or @_>3) { |
319
|
0
|
|
|
|
|
|
Carp::confess "SqlObject: wrong number of arguments for hashes" |
320
|
|
|
|
|
|
|
} |
321
|
0
|
|
|
|
|
|
my ($self,$query,$cref) = @_; |
322
|
|
|
|
|
|
|
|
323
|
0
|
|
|
|
|
|
my $sth = $self->prepare($query); $sth->execute(); |
|
0
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
|
325
|
0
|
0
|
|
|
|
|
if($cref) |
326
|
|
|
|
|
|
|
{ |
327
|
0
|
|
|
|
|
|
my $href; |
328
|
0
|
|
|
|
|
|
$cref->($href) while $href = $sth->fetchrow_hashref; |
329
|
|
|
|
|
|
|
|
330
|
0
|
|
|
|
|
|
$sth->finish(); |
331
|
0
|
|
|
|
|
|
return; |
332
|
|
|
|
|
|
|
} else |
333
|
|
|
|
|
|
|
{ |
334
|
0
|
|
|
|
|
|
my @AoH = @{ $sth->fetchall_arrayref( {} ) }; |
|
0
|
|
|
|
|
|
|
335
|
0
|
|
|
|
|
|
$sth->finish(); |
336
|
|
|
|
|
|
|
|
337
|
0
|
0
|
|
|
|
|
return wantarray ? @AoH : \@AoH; |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
sub array |
342
|
|
|
|
|
|
|
{ |
343
|
0
|
0
|
|
0
|
1
|
|
unless (@_==2) { |
344
|
0
|
|
|
|
|
|
Carp::confess "SqlObject: wrong number of arguments for array" |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
0
|
|
|
|
|
|
my $self = shift; |
348
|
0
|
|
|
|
|
|
my $query = shift; |
349
|
|
|
|
|
|
|
|
350
|
0
|
|
|
|
|
|
my $sth = $self->prepare($query); |
351
|
|
|
|
|
|
|
|
352
|
0
|
0
|
|
|
|
|
if (my $err = $self->Error) |
353
|
|
|
|
|
|
|
{ |
354
|
0
|
|
|
|
|
|
Carp::confess ("SqlObject: bad SQL for array \n", |
355
|
|
|
|
|
|
|
"Query: '$query'\nError: '$err'") |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
0
|
|
|
|
|
|
$sth->execute(); |
359
|
|
|
|
|
|
|
|
360
|
0
|
|
|
|
|
|
my @arr = $sth->fetchrow_array(); |
361
|
0
|
|
|
|
|
|
$sth->finish; |
362
|
|
|
|
|
|
|
|
363
|
0
|
0
|
|
|
|
|
return wantarray ? @arr : \@arr; |
364
|
|
|
|
|
|
|
} |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
# |
367
|
|
|
|
|
|
|
# Execute the query and return a single element |
368
|
|
|
|
|
|
|
# |
369
|
|
|
|
|
|
|
sub value |
370
|
|
|
|
|
|
|
{ |
371
|
0
|
0
|
|
0
|
1
|
|
unless (@_==2) { |
372
|
0
|
|
|
|
|
|
Carp::confess "SqlObject: wrong number of arguments for value" |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
|
375
|
0
|
|
|
|
|
|
my $self = shift; |
376
|
0
|
|
|
|
|
|
my $query = shift; |
377
|
|
|
|
|
|
|
|
378
|
0
|
|
|
|
|
|
my $sth = $self->prepare($query); |
379
|
|
|
|
|
|
|
|
380
|
0
|
0
|
|
|
|
|
if (my $err = $self->Error) |
381
|
|
|
|
|
|
|
{ |
382
|
0
|
|
|
|
|
|
Carp::confess ("SqlObject: bad SQL for value \n", |
383
|
|
|
|
|
|
|
"Query: '$query'\nError: '$err'") |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
0
|
|
|
|
|
|
$sth->execute(); |
387
|
|
|
|
|
|
|
|
388
|
0
|
|
|
|
|
|
my ($val) = $sth->fetchrow_array; |
389
|
0
|
|
|
|
|
|
$sth->finish; |
390
|
|
|
|
|
|
|
|
391
|
0
|
|
|
|
|
|
return $val; |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
# |
395
|
|
|
|
|
|
|
# Execute the query and return the first element of each result row |
396
|
|
|
|
|
|
|
# |
397
|
|
|
|
|
|
|
sub list { |
398
|
0
|
0
|
|
0
|
1
|
|
unless (@_==2) { |
399
|
0
|
|
|
|
|
|
Carp::confess "SqlObject: wrong number of arguments for list" |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
|
402
|
0
|
|
|
|
|
|
my $self = shift; |
403
|
0
|
|
|
|
|
|
my $query = shift; |
404
|
|
|
|
|
|
|
|
405
|
0
|
|
|
|
|
|
my $sth = $self->prepare($query); |
406
|
|
|
|
|
|
|
|
407
|
0
|
0
|
|
|
|
|
if (my $err = $self->Error) |
408
|
|
|
|
|
|
|
{ |
409
|
0
|
|
|
|
|
|
Carp::confess ("SqlObject: bad SQL for list \n", |
410
|
|
|
|
|
|
|
"Query: '$query'\nError: '$err'") |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
0
|
|
|
|
|
|
$sth->execute(); |
414
|
|
|
|
|
|
|
|
415
|
0
|
|
|
|
|
|
my @vals; |
416
|
0
|
|
|
|
|
|
push @vals, $_ while ($_) = $sth->fetchrow_array; |
417
|
0
|
|
|
|
|
|
$sth->finish; |
418
|
|
|
|
|
|
|
|
419
|
0
|
0
|
|
|
|
|
return wantarray ? @vals : \@vals; |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
sub delete { |
424
|
|
|
|
|
|
|
|
425
|
0
|
0
|
0
|
0
|
1
|
|
unless (@_>1 and @_<4) |
426
|
|
|
|
|
|
|
{ |
427
|
0
|
|
|
|
|
|
Carp::confess "SqlObject: wrong number of arguments for delete" |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
|
430
|
0
|
|
|
|
|
|
my ($self,$table,$href) = @_; |
431
|
0
|
|
|
|
|
|
my ($err, $query); |
432
|
|
|
|
|
|
|
|
433
|
0
|
0
|
0
|
|
|
|
$self->_sql_quote_hash($href) if defined $href and ref $href; |
434
|
|
|
|
|
|
|
|
435
|
0
|
|
|
|
|
|
$query = $self->_sql_delete_query($table,$href); |
436
|
0
|
|
|
|
|
|
$self->do($query); |
437
|
0
|
|
|
|
|
|
$err = $self->Error(); |
438
|
|
|
|
|
|
|
|
439
|
0
|
0
|
|
|
|
|
if ($err = $self->Error) |
440
|
|
|
|
|
|
|
{ |
441
|
0
|
|
|
|
|
|
Carp::confess ("SqlObject: delete error\n", |
442
|
|
|
|
|
|
|
"Query: '$query' Error: '$err'") |
443
|
|
|
|
|
|
|
} |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
sub insert |
447
|
|
|
|
|
|
|
{ |
448
|
0
|
0
|
|
0
|
1
|
|
unless (@_==3) |
449
|
|
|
|
|
|
|
{ |
450
|
0
|
|
|
|
|
|
Carp::confess "SqlObject: wrong number of arguments for insert" |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
0
|
|
|
|
|
|
my ($self, $table, $href) = @_; |
454
|
0
|
|
|
|
|
|
my ($err, $query); |
455
|
|
|
|
|
|
|
|
456
|
0
|
|
|
|
|
|
$self->_sql_quote_hash($href); |
457
|
|
|
|
|
|
|
|
458
|
0
|
|
|
|
|
|
$query = $self->_sql_insert_query($table,$href); |
459
|
0
|
|
|
|
|
|
$self->do($query); $err = $self->Error(); |
|
0
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
|
461
|
0
|
0
|
|
|
|
|
if ($err = $self->Error) |
462
|
|
|
|
|
|
|
{ |
463
|
0
|
|
|
|
|
|
Carp::confess ("SqlObject: insert error\n", |
464
|
|
|
|
|
|
|
"Query: '$query'\nError: '$err'") |
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
sub cond_insert { |
469
|
0
|
0
|
0
|
0
|
1
|
|
unless (@_>2 and @_<4) |
470
|
|
|
|
|
|
|
{ |
471
|
0
|
|
|
|
|
|
Carp::confess "SqlObject: wrong number of arguments for insert" |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
|
474
|
0
|
|
|
|
|
|
my ($self, $table, $href, $whref) = @_; |
475
|
0
|
|
|
|
|
|
my ($found,$err, $exists_query); |
476
|
|
|
|
|
|
|
|
477
|
0
|
|
|
|
|
|
$self->_sql_quote_hash($href); |
478
|
|
|
|
|
|
|
|
479
|
0
|
0
|
|
|
|
|
if ($whref) |
480
|
|
|
|
|
|
|
{ |
481
|
0
|
|
|
|
|
|
$self->_sql_quote_hash($href); |
482
|
0
|
|
|
|
|
|
$exists_query = |
483
|
|
|
|
|
|
|
$self->_sql_select_query($table,[keys %$whref], $whref); |
484
|
|
|
|
|
|
|
} else |
485
|
|
|
|
|
|
|
{ |
486
|
0
|
|
|
|
|
|
$exists_query = |
487
|
|
|
|
|
|
|
$self->_sql_select_query($table, [keys %$href], $href); |
488
|
|
|
|
|
|
|
} |
489
|
|
|
|
|
|
|
|
490
|
0
|
|
|
|
|
|
$found = $self->value($exists_query); |
491
|
0
|
|
|
|
|
|
$err = $self->Error(); |
492
|
|
|
|
|
|
|
|
493
|
0
|
0
|
|
|
|
|
if ($err) |
494
|
|
|
|
|
|
|
{ |
495
|
0
|
|
|
|
|
|
Carp::confess ("SqlObject cond_insert exists error\n", |
496
|
|
|
|
|
|
|
"Query: $exists_query\nError: $err") |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
|
499
|
0
|
0
|
|
|
|
|
return if $found; |
500
|
|
|
|
|
|
|
|
501
|
0
|
|
|
|
|
|
my $insert_query = $self->_sql_insert_query($table,$href); |
502
|
0
|
|
|
|
|
|
$self->do($insert_query); |
503
|
0
|
|
|
|
|
|
$err = $self->Error(); |
504
|
0
|
0
|
|
|
|
|
if ($err) |
505
|
|
|
|
|
|
|
{ |
506
|
0
|
|
|
|
|
|
Carp::confess ("SqlObject insert error\n", |
507
|
|
|
|
|
|
|
"Query: $insert_query\nError: $err") |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
|
510
|
0
|
|
|
|
|
|
return 1; |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
sub insert_select { |
515
|
|
|
|
|
|
|
|
516
|
0
|
0
|
0
|
0
|
1
|
|
unless (@_>2 and @_ < 5) |
517
|
|
|
|
|
|
|
{ |
518
|
0
|
|
|
|
|
|
Carp::confess "SqlObject: wrong number of arguments for insert_select" |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
|
521
|
0
|
|
|
|
|
|
my ($self, $table, $href, $column) = @_; |
522
|
0
|
|
|
|
|
|
my ($err, $insert_query); |
523
|
|
|
|
|
|
|
|
524
|
0
|
|
0
|
|
|
|
$column ||= join '_', $table, 'id'; |
525
|
0
|
|
|
|
|
|
$column =~ s/^.*?(\w+)_id$/$1_id/; |
526
|
|
|
|
|
|
|
|
527
|
0
|
|
|
|
|
|
$self->_sql_quote_hash($href); |
528
|
|
|
|
|
|
|
|
529
|
0
|
|
|
|
|
|
$insert_query = $self->_sql_insert_query($table,$href); |
530
|
0
|
|
|
|
|
|
$self->do($insert_query); |
531
|
0
|
|
|
|
|
|
$err = $self->Error(); |
532
|
|
|
|
|
|
|
|
533
|
0
|
0
|
|
|
|
|
if ($err) |
534
|
|
|
|
|
|
|
{ |
535
|
0
|
|
|
|
|
|
Carp::confess ("SqlObject insert_select insert error\n", |
536
|
|
|
|
|
|
|
"Query: $insert_query\nError: $err") |
537
|
|
|
|
|
|
|
} |
538
|
|
|
|
|
|
|
|
539
|
0
|
|
|
|
|
|
my $select_query = $self->_sql_select_query($table,[$column],$href); |
540
|
0
|
|
|
|
|
|
return $self->value($select_query); |
541
|
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
sub cond_insert_select { |
544
|
|
|
|
|
|
|
|
545
|
0
|
0
|
0
|
0
|
1
|
|
unless (@_>2 and @_<6) |
546
|
|
|
|
|
|
|
{ |
547
|
0
|
|
|
|
|
|
Carp::confess "SqlObject: wrong number of arguments for cond_insert_select" |
548
|
|
|
|
|
|
|
} |
549
|
|
|
|
|
|
|
|
550
|
0
|
|
|
|
|
|
my ($self, $table, $href, $arg4, $arg5) = splice @_, 0, 3; |
551
|
0
|
|
|
|
|
|
my ($whref,$column, $found, $err, $exists_query); |
552
|
|
|
|
|
|
|
|
553
|
0
|
|
|
|
|
|
$self->_sql_quote_hash($href); |
554
|
|
|
|
|
|
|
|
555
|
0
|
0
|
|
|
|
|
if (@_ == 1) |
|
|
0
|
|
|
|
|
|
556
|
|
|
|
|
|
|
{ |
557
|
|
|
|
|
|
|
# we have whref or column but not both |
558
|
0
|
0
|
|
|
|
|
if (ref $_[0]) |
559
|
|
|
|
|
|
|
{ |
560
|
0
|
|
|
|
|
|
$whref = shift; |
561
|
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
else |
564
|
|
|
|
|
|
|
{ |
565
|
0
|
|
|
|
|
|
$column = shift; |
566
|
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
elsif (@_ ==2) |
569
|
|
|
|
|
|
|
{ |
570
|
|
|
|
|
|
|
# we have both $whref = shift; |
571
|
0
|
|
|
|
|
|
$column = shift; |
572
|
0
|
|
|
|
|
|
last; |
573
|
|
|
|
|
|
|
} |
574
|
|
|
|
|
|
|
else |
575
|
|
|
|
|
|
|
{ |
576
|
|
|
|
|
|
|
# we have neither |
577
|
0
|
|
|
|
|
|
$column = join '_',$table,'id'; |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
|
580
|
0
|
0
|
|
|
|
|
if ($whref) |
581
|
|
|
|
|
|
|
{ |
582
|
0
|
|
|
|
|
|
$self->_sql_quote_hash($href); |
583
|
0
|
|
|
|
|
|
$exists_query = $self->_sql_select_query($table, [$column], $whref); |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
else |
586
|
|
|
|
|
|
|
{ |
587
|
0
|
|
|
|
|
|
$exists_query = $self->_sql_select_query($table, [$column], $href); |
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
|
590
|
0
|
|
|
|
|
|
$found = $self->value($exists_query); |
591
|
0
|
|
|
|
|
|
$err = $self->Error(); |
592
|
|
|
|
|
|
|
|
593
|
0
|
0
|
|
|
|
|
if ($err) |
594
|
|
|
|
|
|
|
{ |
595
|
0
|
|
|
|
|
|
Carp::confess ("SqlObject cond_insert_select exists error\n", |
596
|
|
|
|
|
|
|
"Query: $exists_query\nError: $err") |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
|
599
|
0
|
0
|
|
|
|
|
return $found if $found; |
600
|
|
|
|
|
|
|
|
601
|
0
|
|
|
|
|
|
my $insert_query = $self->_sql_insert_query($table,$href); |
602
|
0
|
|
|
|
|
|
my $select_query = $self->_sql_select_query($table,[$column],$href); |
603
|
|
|
|
|
|
|
|
604
|
0
|
|
|
|
|
|
$self->do($insert_query); |
605
|
0
|
|
|
|
|
|
$err = $self->Error(); |
606
|
|
|
|
|
|
|
|
607
|
0
|
0
|
|
|
|
|
if ($err) |
608
|
|
|
|
|
|
|
{ |
609
|
0
|
|
|
|
|
|
Carp::confess ("SqlObject insert_select insert error\n", |
610
|
|
|
|
|
|
|
"Query: $insert_query\nError: $err") |
611
|
|
|
|
|
|
|
} |
612
|
|
|
|
|
|
|
|
613
|
0
|
|
|
|
|
|
return $self->value($select_query); |
614
|
|
|
|
|
|
|
} |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
sub update |
617
|
|
|
|
|
|
|
{ |
618
|
|
|
|
|
|
|
|
619
|
0
|
0
|
0
|
0
|
1
|
|
unless (@_>2 and @_<5) |
620
|
|
|
|
|
|
|
{ |
621
|
0
|
|
|
|
|
|
Carp::confess "SqlObject: wrong number of arguments for update" |
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
|
624
|
0
|
|
|
|
|
|
my ($self, $table, $shref, $whref) = @_; |
625
|
0
|
|
|
|
|
|
my($err, $query); |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
|
628
|
0
|
|
|
|
|
|
$self->_sql_quote_hash($shref); |
629
|
0
|
0
|
0
|
|
|
|
$self->_sql_quote_hash($whref) if defined $whref && ref $whref; |
630
|
|
|
|
|
|
|
|
631
|
0
|
|
|
|
|
|
$query = $self->_sql_update_query($table,$shref,$whref); |
632
|
0
|
|
|
|
|
|
$self->do($query); |
633
|
0
|
|
|
|
|
|
$err = $self->Error(); |
634
|
|
|
|
|
|
|
|
635
|
0
|
0
|
|
|
|
|
if ($err) |
636
|
|
|
|
|
|
|
{ |
637
|
0
|
|
|
|
|
|
Carp::confess ("SqlObject update error\n", |
638
|
|
|
|
|
|
|
"Query: $query\nError: $err") |
639
|
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
} |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
## Here be the private methods |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
sub _sql_quote_hash |
646
|
|
|
|
|
|
|
{ |
647
|
0
|
|
|
0
|
|
|
my $href = pop; |
648
|
|
|
|
|
|
|
|
649
|
0
|
|
|
|
|
|
while ( my ($k,$v) = each %$href) |
650
|
|
|
|
|
|
|
{ |
651
|
0
|
|
|
|
|
|
$v =~ s|^'||; |
652
|
0
|
|
|
|
|
|
$v =~ s|'$||; |
653
|
0
|
|
|
|
|
|
$v =~ s|'|''|g; |
654
|
0
|
0
|
|
|
|
|
$v = qq('') if $v=~/^\s*$/; |
655
|
0
|
0
|
0
|
|
|
|
$v = qq('$v') if $v=~/[^0-9]/ and $v!~/^null$/i; |
656
|
0
|
|
|
|
|
|
$href->{$k}=$v; |
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
sub _sql_insert_query |
661
|
|
|
|
|
|
|
{ |
662
|
0
|
0
|
|
0
|
|
|
return unless @_ > 2; |
663
|
|
|
|
|
|
|
|
664
|
0
|
|
|
|
|
|
my ($self, $table, $href) = @_; |
665
|
|
|
|
|
|
|
|
666
|
0
|
|
|
|
|
|
my ($columns,$values); |
667
|
0
|
|
|
|
|
|
while (my ($k,$v)=each %$href) |
668
|
|
|
|
|
|
|
{ |
669
|
0
|
|
|
|
|
|
$columns .= "$k,"; |
670
|
0
|
|
|
|
|
|
$values .= "$v,"; |
671
|
|
|
|
|
|
|
} |
672
|
0
|
|
|
|
|
|
$columns =~ s|,$||; |
673
|
0
|
|
|
|
|
|
$values =~ s|,$||; |
674
|
|
|
|
|
|
|
|
675
|
0
|
|
|
|
|
|
return qq(insert into $table ($columns) values($values)); |
676
|
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
sub _sql_select_query { |
679
|
0
|
0
|
|
0
|
|
|
return unless @_ > 2; |
680
|
|
|
|
|
|
|
|
681
|
0
|
|
|
|
|
|
my ($self,$table,$aref,$href) = @_; |
682
|
0
|
|
|
|
|
|
my $columns = join ',',@$aref; |
683
|
0
|
|
|
|
|
|
my $where; |
684
|
|
|
|
|
|
|
|
685
|
0
|
|
|
|
|
|
while (my ($k,$v)=each %$href) |
686
|
|
|
|
|
|
|
{ |
687
|
0
|
|
|
|
|
|
$where .= qq($k = $v and ); |
688
|
|
|
|
|
|
|
} |
689
|
0
|
|
|
|
|
|
$where =~ s|\s*and\s*$||; |
690
|
|
|
|
|
|
|
|
691
|
0
|
|
|
|
|
|
return qq(select $columns from $table where $where); |
692
|
|
|
|
|
|
|
} |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
sub _sql_delete_query |
695
|
|
|
|
|
|
|
{ |
696
|
0
|
0
|
|
0
|
|
|
return unless @_ > 1; |
697
|
|
|
|
|
|
|
|
698
|
0
|
|
|
|
|
|
my ($self, $table, $href) = @_; |
699
|
0
|
0
|
|
|
|
|
return "delete from $table" if $href == undef; |
700
|
|
|
|
|
|
|
|
701
|
0
|
|
|
|
|
|
my $where; |
702
|
0
|
|
|
|
|
|
while (my ($k,$v)=each %$href) { |
703
|
0
|
|
|
|
|
|
$where .= qq($k = $v and ); |
704
|
|
|
|
|
|
|
} |
705
|
0
|
|
|
|
|
|
$where =~ s|\s*and\s*$||; |
706
|
|
|
|
|
|
|
|
707
|
0
|
|
|
|
|
|
return qq(delete from $table where $where); |
708
|
|
|
|
|
|
|
} |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
sub _sql_update_query { |
711
|
0
|
0
|
|
0
|
|
|
return unless @_ > 2; |
712
|
|
|
|
|
|
|
|
713
|
0
|
|
|
|
|
|
my ($self, $table, $shref, $whref) = @_; |
714
|
|
|
|
|
|
|
|
715
|
0
|
|
|
|
|
|
my ($set,$where); |
716
|
0
|
|
|
|
|
|
while (my ($k,$v)=each %$shref) |
717
|
|
|
|
|
|
|
{ |
718
|
0
|
|
|
|
|
|
$set .= qq($k = $v, ); |
719
|
|
|
|
|
|
|
} |
720
|
0
|
|
|
|
|
|
$set =~ s|\s*,\s*$||; |
721
|
|
|
|
|
|
|
|
722
|
0
|
0
|
|
|
|
|
if (ref $whref) |
723
|
|
|
|
|
|
|
{ |
724
|
0
|
|
|
|
|
|
while (my ($k,$v)=each %$whref) |
725
|
|
|
|
|
|
|
{ |
726
|
0
|
|
|
|
|
|
$where .= qq($k = $v and ); |
727
|
|
|
|
|
|
|
} |
728
|
0
|
|
|
|
|
|
$where=~ s|\s*and\s*$||; |
729
|
0
|
|
|
|
|
|
$where = "where $where"; |
730
|
|
|
|
|
|
|
} |
731
|
|
|
|
|
|
|
|
732
|
0
|
|
|
|
|
|
return qq(update $table set $set $where); |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
our $AUTOLOAD; |
736
|
|
|
|
|
|
|
sub AUTOLOAD |
737
|
|
|
|
|
|
|
{ |
738
|
0
|
|
|
0
|
|
|
$AUTOLOAD =~ /::([a-zA-Z_][a-zA-Z_0-9]+)$/; |
739
|
|
|
|
|
|
|
my $func = $1 or do |
740
|
0
|
0
|
|
|
|
|
{ |
741
|
0
|
|
|
|
|
|
my @caller = caller; |
742
|
0
|
|
|
|
|
|
die (qq[Database Handle unable to dispatch.\n], |
743
|
|
|
|
|
|
|
qq[Method $AUTOLOAD called by $caller[1] line $caller[2].\n]); |
744
|
|
|
|
|
|
|
}; |
745
|
|
|
|
|
|
|
|
746
|
0
|
|
|
|
|
|
my $self = shift; |
747
|
0
|
|
|
|
|
|
my $result; |
748
|
|
|
|
|
|
|
|
749
|
0
|
0
|
|
|
|
|
if (my $dbh = eval { $self->dbh }) |
|
0
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
{ |
751
|
0
|
|
|
|
|
|
$result = eval { $dbh->$func(@_) }; |
|
0
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
} |
753
|
|
|
|
|
|
|
|
754
|
0
|
0
|
|
|
|
|
if ($@) |
755
|
|
|
|
|
|
|
{ |
756
|
|
|
|
|
|
|
# error while calling DBI function |
757
|
0
|
|
|
|
|
|
my @caller = caller; |
758
|
0
|
0
|
0
|
|
|
|
my $err = ref $_[0] && UNIVERSAL::isa($_[0],__PACKAGE__) |
759
|
|
|
|
|
|
|
? $_[0]->Error |
760
|
|
|
|
|
|
|
: 'no object'; |
761
|
0
|
|
|
|
|
|
die (qq[Database Handle encountered an error executing $func.\n], |
762
|
|
|
|
|
|
|
qq[$AUTOLOAD called by $caller[1] line $caller[2].\n], |
763
|
|
|
|
|
|
|
qq[Error: $@.\n], |
764
|
|
|
|
|
|
|
qq[DBI Error: $err.\n]); |
765
|
|
|
|
|
|
|
} |
766
|
|
|
|
|
|
|
|
767
|
0
|
|
|
|
|
|
return $result; |
768
|
|
|
|
|
|
|
} |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
1; |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
__END__ |