line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package DBD::TSM; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
50936
|
use 5.008; |
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
41
|
|
4
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
101
|
|
5
|
|
|
|
|
|
|
#use warnings; |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
require Exporter; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our @ISA = qw(Exporter); |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
# Items to export into callers namespace by default. Note: do not export |
12
|
|
|
|
|
|
|
# names by default without a very good reason. Use EXPORT_OK instead. |
13
|
|
|
|
|
|
|
# Do not simply export all your public functions/methods/constants. |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# This allows declaration use DBD::TSM ':all'; |
16
|
|
|
|
|
|
|
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK |
17
|
|
|
|
|
|
|
# will save memory. |
18
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( 'all' => [ qw( |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
) ] ); |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
our @EXPORT = qw( |
25
|
|
|
|
|
|
|
); |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# Preloaded methods go here. |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
#-------------------------------------------------------------- |
30
|
|
|
|
|
|
|
# Module principal pour le driver: constructeur |
31
|
|
|
|
|
|
|
#-------------------------------------------------------------- |
32
|
1
|
|
|
1
|
|
5
|
use Carp; |
|
1
|
|
|
|
|
12
|
|
|
1
|
|
|
|
|
226
|
|
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
our ($VERSION,$err,$errstr,$sqlstate,$drh); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
$VERSION = '0.14'; |
37
|
|
|
|
|
|
|
## Error in Makefile.PL, see change file |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# Gestion des erreurs DBI |
40
|
|
|
|
|
|
|
$err = 0; # DBI::err |
41
|
|
|
|
|
|
|
$errstr = ""; # DBI::errstr |
42
|
|
|
|
|
|
|
$sqlstate = ""; # DBI::state |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
$drh = undef; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# Construction / initialisation du driver |
47
|
|
|
|
|
|
|
sub driver { |
48
|
|
|
|
|
|
|
#Ne charge qu'un driver |
49
|
0
|
0
|
|
0
|
0
|
|
return $drh if $drh; |
50
|
|
|
|
|
|
|
|
51
|
0
|
|
|
|
|
|
my ($class,$attr)=@_; |
52
|
|
|
|
|
|
|
|
53
|
0
|
|
|
|
|
|
$drh = DBI::_new_drh($class.'::dr', { |
54
|
|
|
|
|
|
|
'Name' => 'TSM', |
55
|
|
|
|
|
|
|
'Version' => $VERSION, |
56
|
|
|
|
|
|
|
'Err' => \$DBD::TSM::err, |
57
|
|
|
|
|
|
|
'Errstr' => \$DBD::TSM::errstr, |
58
|
|
|
|
|
|
|
'State' => \$DBD::TSM::state, |
59
|
|
|
|
|
|
|
'Attribution' => 'DBD::TSM by Laurent Bendavid', |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
); |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
# Gestion de l'erreur à la création |
64
|
0
|
0
|
|
|
|
|
croak 'DBD::TSM: Error - Could not load driver: ',$DBI::errstr,"\n" unless $drh; |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
# Gestion des variables d'environnement et autres présence de l'environnement minimum |
67
|
|
|
|
|
|
|
# Fin |
68
|
0
|
|
|
|
|
|
return $drh; |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
#-------------------------------------------------------------- |
72
|
|
|
|
|
|
|
# Connexion à la base / déconnexion création du database handler |
73
|
|
|
|
|
|
|
# à partir du driver |
74
|
|
|
|
|
|
|
#-------------------------------------------------------------- |
75
|
|
|
|
|
|
|
package DBD::TSM::dr; |
76
|
|
|
|
|
|
|
|
77
|
1
|
|
|
1
|
|
6
|
use constant DEBUG => 0;; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
83
|
|
78
|
|
|
|
|
|
|
BEGIN { |
79
|
1
|
|
|
1
|
|
2
|
DEBUG && require Data::Dumper; |
80
|
1
|
|
|
|
|
19
|
DEBUG && import Data::Dumper; |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
1
|
|
|
1
|
|
4
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
21
|
|
84
|
|
|
|
|
|
|
#use warnings; |
85
|
1
|
|
|
1
|
|
457
|
use DBD::TSM::Functions; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
252
|
|
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
our $imp_data_size = 0; |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub disconnect_all { |
90
|
0
|
|
|
0
|
|
|
my ($drh)=(@_); |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# Déconnexion: fin de l'utilisation de la connexion et donc de l'objet |
93
|
|
|
|
|
|
|
# Fin |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
sub data_sources { |
97
|
0
|
|
|
0
|
|
|
my ($drh)=@_; |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
# Recuperer les infos d'un fichier |
100
|
0
|
|
|
|
|
|
return tsm_data_sources($drh); |
101
|
|
|
|
|
|
|
# Fin |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub connect { |
105
|
0
|
|
|
0
|
|
|
my ($drh, $dbname, $user, $auth, $attr) = @_; |
106
|
|
|
|
|
|
|
|
107
|
0
|
|
|
|
|
|
DEBUG && warn "DEBUG - ",__PACKAGE__,"->connect: @_\n"; |
108
|
|
|
|
|
|
|
|
109
|
0
|
|
|
|
|
|
my $dbh = DBI::_new_dbh($drh, { |
110
|
|
|
|
|
|
|
Name => $dbname, |
111
|
|
|
|
|
|
|
USER => $user, |
112
|
|
|
|
|
|
|
CURRENT_USER => $user, |
113
|
|
|
|
|
|
|
}); |
114
|
|
|
|
|
|
|
|
115
|
0
|
|
|
|
|
|
foreach my $attr_name (qw(PrintError AutoCommit RaiseError)) { |
116
|
|
|
|
|
|
|
# foreach my $attr_name (qw(Active PrintError AutoCommit RaiseError)) { |
117
|
0
|
0
|
|
|
|
|
my $attr_value = (exists $attr->{$attr_name}) ? $attr->{$attr_name} : 1; |
118
|
0
|
|
|
|
|
|
$dbh->STORE($attr_name => $attr_value); |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
0
|
0
|
|
|
|
|
$dbh->STORE(tsm_pipe => ($^O =~ m/win/i)?(0):(1)); |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
# Gestion de la connexion, c'est a dire verification que les user/password permet de se connecter |
124
|
0
|
0
|
|
|
|
|
tsm_connect($dbh,$dbname,$user,$auth) and return $dbh; |
125
|
|
|
|
|
|
|
|
126
|
0
|
|
|
|
|
|
return; |
127
|
|
|
|
|
|
|
# Fin |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
#-------------------------------------------------------------- |
131
|
|
|
|
|
|
|
# Préparation des requêtes à la base |
132
|
|
|
|
|
|
|
#-------------------------------------------------------------- |
133
|
|
|
|
|
|
|
package DBD::TSM::db; |
134
|
|
|
|
|
|
|
|
135
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
32
|
|
136
|
|
|
|
|
|
|
#use warnings; |
137
|
|
|
|
|
|
|
|
138
|
1
|
|
|
1
|
|
4
|
use constant DEBUG => 0;; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
45
|
|
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
BEGIN { |
141
|
1
|
|
|
1
|
|
463
|
DEBUG && require Data::Dumper; |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
our $imp_data_size = 0; |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
sub ping { |
147
|
0
|
|
|
0
|
|
|
my ($dbh) = @_; |
148
|
|
|
|
|
|
|
|
149
|
0
|
|
|
|
|
|
return 1; |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
sub prepare { |
153
|
0
|
|
|
0
|
|
|
my ($dbh, $statement, @attribs) = @_; |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# Initialisation |
156
|
0
|
|
|
|
|
|
my ($sth) = DBI::_new_sth($dbh, { |
157
|
|
|
|
|
|
|
'Statement' => $statement, |
158
|
|
|
|
|
|
|
}); |
159
|
0
|
|
|
|
|
|
$sth->STORE('NUM_OF_PARAMS' => ($statement =~ tr/\?//)); |
160
|
0
|
|
|
|
|
|
$sth->STORE('tsm_params' => []); |
161
|
0
|
|
|
|
|
|
$sth->STORE('tsm_pipe' => $dbh->{tsm_pipe}); |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# Compilation de requete |
164
|
|
|
|
|
|
|
# Fin |
165
|
|
|
|
|
|
|
|
166
|
0
|
|
|
|
|
|
return ($sth); |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
#NEW: spec non fini |
170
|
|
|
|
|
|
|
#$dbh->table_info($catalog, $schema, $table, $type); |
171
|
|
|
|
|
|
|
#$dbh->tables($catalog, $schema, $table, $type); |
172
|
|
|
|
|
|
|
#$dbh->get_info($info_type); |
173
|
|
|
|
|
|
|
#$dbh->type_info_all($info_type); |
174
|
|
|
|
|
|
|
#$dbh->type_info($info_type); |
175
|
|
|
|
|
|
|
#$dbh->column_info($catalog, $schema, $table, $type); |
176
|
|
|
|
|
|
|
#$dbh->primary_key_info($catalog, $schema, $table); |
177
|
|
|
|
|
|
|
#$dbh->primary_key($catalog, $schema, $table); |
178
|
|
|
|
|
|
|
#$dbh->foreign_key_info($catalog, $schema, $table); |
179
|
|
|
|
|
|
|
#$dbh->foreign_key($catalog, $schema, $table); |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
# Pas de commit ni rollback implemente |
182
|
|
|
|
|
|
|
sub commit { |
183
|
0
|
|
|
0
|
|
|
my ($dbh) = @_; |
184
|
0
|
0
|
|
|
|
|
if ($dbh->FETCH('Warn')) { |
185
|
0
|
|
|
|
|
|
warn("Commit ineffective while AutoCommit is on"); |
186
|
|
|
|
|
|
|
} |
187
|
0
|
|
|
|
|
|
return 1; |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
sub rollback { |
190
|
0
|
|
|
0
|
|
|
my ($dbh) = @_; |
191
|
0
|
0
|
|
|
|
|
if ($dbh->FETCH('Warn')) { |
192
|
0
|
|
|
|
|
|
warn("Rollback ineffective while AutoCommit is on"); |
193
|
|
|
|
|
|
|
} |
194
|
0
|
|
|
|
|
|
return 0; |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
sub STORE { |
198
|
0
|
|
|
0
|
|
|
my ($dbh, $attr, $val) = @_; |
199
|
|
|
|
|
|
|
|
200
|
0
|
0
|
|
|
|
|
if ($attr eq 'AutoCommit') { |
201
|
0
|
0
|
|
|
|
|
die "Can't disable AutoCommit" unless $val; |
202
|
0
|
|
|
|
|
|
return 1; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
0
|
0
|
|
|
|
|
if ($attr =~ m/^tsm_/ ) { |
206
|
|
|
|
|
|
|
# Attributs prives |
207
|
0
|
|
|
|
|
|
$dbh->{$attr} = $val; |
208
|
0
|
|
|
|
|
|
return 1; |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
# Else pass up to DBI to handle for us |
212
|
0
|
|
|
|
|
|
$dbh->SUPER::STORE($attr, $val); |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
sub FETCH { |
216
|
0
|
|
|
0
|
|
|
my ($dbh, $attr) = @_; |
217
|
0
|
0
|
|
|
|
|
return 1 if ($attr eq 'AutoCommit'); |
218
|
0
|
0
|
|
|
|
|
return $dbh->{$attr} if ($attr =~ m/^tsm_/); |
219
|
0
|
|
|
|
|
|
return $dbh->SUPER::FETCH($attr); |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
sub DESTROY { |
223
|
0
|
|
|
0
|
|
|
my ($dbh) = @_; |
224
|
|
|
|
|
|
|
|
225
|
0
|
|
|
|
|
|
DEBUG && warn "DEBUG - ",__PACKAGE__,"->DESTROY: call @_\n"; |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
#--------------------------------------------------------------------- |
229
|
|
|
|
|
|
|
# Execution |
230
|
|
|
|
|
|
|
#--------------------------------------------------------------------- |
231
|
|
|
|
|
|
|
package DBD::TSM::st; |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
#use warnings; |
234
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
28
|
|
235
|
|
|
|
|
|
|
|
236
|
1
|
|
|
1
|
|
4
|
use DBD::TSM::Functions; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
42
|
|
237
|
1
|
|
|
1
|
|
4
|
use Data::Dumper; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
35
|
|
238
|
|
|
|
|
|
|
|
239
|
1
|
|
|
1
|
|
5
|
use constant DEBUG => 0;; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
1000
|
|
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
our $imp_data_size = 0; |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
sub bind_param { |
244
|
0
|
|
|
0
|
|
|
my ($sth, $pNum, $val, $attr) = @_; |
245
|
|
|
|
|
|
|
|
246
|
0
|
0
|
|
|
|
|
my $type = (ref $attr) ? $attr->{TYPE} : $attr; |
247
|
|
|
|
|
|
|
|
248
|
0
|
0
|
|
|
|
|
if ($type) { |
249
|
0
|
|
|
|
|
|
my $dbh = $sth->{Database}; |
250
|
0
|
|
|
|
|
|
$val = $dbh->quote($sth, $type); |
251
|
|
|
|
|
|
|
} |
252
|
0
|
|
|
|
|
|
my $params = $sth->FETCH('tsm_params'); |
253
|
0
|
|
|
|
|
|
$params->[$pNum-1] = $val; |
254
|
0
|
|
|
|
|
|
return 1; |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
sub execute { |
258
|
0
|
|
|
0
|
|
|
my ($sth, @bind_values) = @_; |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
#Référence sur les paramètres d'exécute |
261
|
0
|
0
|
|
|
|
|
$sth->finish() if ($sth->{Active}); |
262
|
|
|
|
|
|
|
|
263
|
0
|
0
|
|
|
|
|
my $params_ref = (@bind_values) ? \@bind_values : $sth->FETCH('tsm_params'); |
264
|
0
|
|
|
|
|
|
my $num_of_param = $sth->FETCH('NUM_OF_PARAMS'); |
265
|
0
|
|
|
|
|
|
my $num_param = scalar @{$params_ref}; |
|
0
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
# Nombre de paramètre au moment du prepare |
268
|
0
|
0
|
|
|
|
|
if ($num_of_param > $num_param) { |
269
|
0
|
|
|
|
|
|
$sth->set_err(1,"Wrong number of parameters: $num_param <> expected: $num_of_param."); |
270
|
0
|
|
|
|
|
|
return; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
# Substitute character ? with parameters |
274
|
0
|
|
|
|
|
|
my $statement = $sth->{Statement}; |
275
|
0
|
|
|
|
|
|
foreach my $param_value (@{$params_ref}) { |
|
0
|
|
|
|
|
|
|
276
|
0
|
|
|
|
|
|
$statement =~ s/ [?] /$param_value/xms; # Substitute ? from beginning |
277
|
|
|
|
|
|
|
# Check is realized by dsmadmc |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
|
280
|
0
|
|
|
|
|
|
DEBUG && warn "DEBUG - ",__PACKAGE__,"->execute: AutoCommit=",$sth->FETCH('AutoCommit'),"\n"; |
281
|
0
|
0
|
|
|
|
|
my ($data_ref, $fields_ref, $rawdata_ref) = tsm_execute($sth, $statement) |
282
|
|
|
|
|
|
|
or return; |
283
|
|
|
|
|
|
|
|
284
|
0
|
|
|
|
|
|
my ($fields_lc_ref, $fields_uc_ref); |
285
|
0
|
|
|
|
|
|
@{$fields_uc_ref} = map { uc($_) } @{$fields_ref}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
286
|
0
|
|
|
|
|
|
@{$fields_lc_ref} = map { lc($_) } @{$fields_ref}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
# Store parameters |
289
|
0
|
|
|
|
|
|
$sth->STORE(tsm_data => $data_ref); |
290
|
0
|
|
|
|
|
|
$sth->STORE(tsm_raw => $rawdata_ref); |
291
|
0
|
|
|
|
|
|
$sth->STORE(tsm_rows => scalar @{$data_ref}); # number of rows |
|
0
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
#Number of fields, already set by other routine ? |
294
|
0
|
|
|
|
|
|
my $nb_fields = @{$fields_ref}; |
|
0
|
|
|
|
|
|
|
295
|
0
|
|
|
|
|
|
DEBUG && warn "DEBUG - ", __PACKAGE__ |
296
|
|
|
|
|
|
|
, "->execute: nb fields = $nb_fields, " |
297
|
|
|
|
|
|
|
, $sth->FETCH('NUM_OF_FIELDS') |
298
|
|
|
|
|
|
|
, "\n"; |
299
|
0
|
0
|
0
|
|
|
|
$sth->STORE(NUM_OF_FIELDS => $nb_fields) unless ( |
300
|
|
|
|
|
|
|
$sth->FETCH('NUM_OF_FIELDS') |
301
|
|
|
|
|
|
|
and $nb_fields == $sth->FETCH('NUM_OF_FIELDS') |
302
|
|
|
|
|
|
|
); #pourquoi faut il faire ce test? |
303
|
0
|
|
|
|
|
|
$sth->STORE(NAME => $fields_ref); |
304
|
0
|
|
|
|
|
|
$sth->STORE(NAME_lc => $fields_lc_ref); |
305
|
0
|
|
|
|
|
|
$sth->STORE(NAME_uc => $fields_uc_ref); |
306
|
0
|
|
|
|
|
|
$sth->STORE(NULLABLE => [ (0) x @{$fields_ref} ]); |
|
0
|
|
|
|
|
|
|
307
|
0
|
|
|
|
|
|
$sth->STORE(TYPE => [ (DBI::SQL_VARCHAR()) x @{$fields_ref} ]); |
|
0
|
|
|
|
|
|
|
308
|
0
|
|
|
|
|
|
$sth->STORE(SCALE => undef); |
309
|
0
|
|
|
|
|
|
$sth->STORE(PRECISION => undef); |
310
|
|
|
|
|
|
|
|
311
|
0
|
|
|
|
|
|
DEBUG && warn "DEBUG:Execute: ", Dumper($data_ref); |
312
|
|
|
|
|
|
|
|
313
|
0
|
|
0
|
|
|
|
return (@{$data_ref} || '0E0'); |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
sub fetchrow_arrayref { |
317
|
0
|
|
|
0
|
|
|
my ($sth) = @_; |
318
|
|
|
|
|
|
|
|
319
|
0
|
|
|
|
|
|
my $data_ref = $sth->FETCH('tsm_data'); |
320
|
0
|
|
|
|
|
|
my $row_ref = shift @{$data_ref}; |
|
0
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
|
322
|
0
|
|
|
|
|
|
DEBUG && warn "DEBUG:Line: ", Dumper($row_ref); |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
# Fin du tableau |
325
|
0
|
0
|
|
|
|
|
unless ($row_ref) { |
326
|
0
|
|
|
|
|
|
DEBUG && "DEBUG:Line: Fini.\n"; |
327
|
0
|
|
|
|
|
|
$sth->{Active} = 0; |
328
|
0
|
|
|
|
|
|
return undef; |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
0
|
0
|
|
|
|
|
if ($sth->FETCH('ChopBlanks')) { |
332
|
0
|
|
|
|
|
|
foreach (@{$row_ref}) { |
|
0
|
|
|
|
|
|
|
333
|
0
|
|
|
|
|
|
s/\s+$//; |
334
|
0
|
|
|
|
|
|
s/^\s+//; |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
|
338
|
0
|
|
|
|
|
|
return $sth->_set_fbav($row_ref); |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
*fetch = \&fetchrow_arrayref; |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
sub rows { |
344
|
0
|
|
|
0
|
|
|
my ($sth) = @_; |
345
|
|
|
|
|
|
|
|
346
|
0
|
|
|
|
|
|
return $sth->FETCH('tsm_rows'); |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
sub STORE { |
350
|
0
|
|
|
0
|
|
|
my ($sth, $attr, $val) = @_; |
351
|
|
|
|
|
|
|
|
352
|
0
|
0
|
|
|
|
|
return 1 if ($attr eq 'AutoCommit'); |
353
|
|
|
|
|
|
|
|
354
|
0
|
0
|
0
|
|
|
|
if ($attr =~ m/^tsm_/ or |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
355
|
|
|
|
|
|
|
$attr =~ m/^NAME/ or |
356
|
|
|
|
|
|
|
$attr eq 'NULLABLE' or |
357
|
|
|
|
|
|
|
$attr eq 'SCALE' or |
358
|
|
|
|
|
|
|
$attr eq 'TYPE' or |
359
|
|
|
|
|
|
|
$attr eq 'PRECISION' ) { |
360
|
0
|
|
|
|
|
|
$sth->{$attr} = $val; |
361
|
0
|
|
|
|
|
|
return 1; |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
# Else pass up to DBI to handle for us |
365
|
0
|
|
|
|
|
|
$sth->SUPER::STORE($attr, $val); |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
sub FETCH { |
369
|
0
|
|
|
0
|
|
|
my ($sth, $attr) = @_; |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
# Parametres optionnels de Database, mélange Min et Maj |
372
|
0
|
0
|
|
|
|
|
return 1 if ($attr eq 'AutoCommit'); |
373
|
0
|
0
|
|
|
|
|
return $sth->{$attr} if ($attr =~ m/^tsm_/); |
374
|
0
|
|
|
|
|
|
return $sth->SUPER::FETCH($attr); |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
1; |
379
|
|
|
|
|
|
|
__END__ |