File Coverage

blib/lib/CTK/DBI.pm
Criterion Covered Total %
statement 21 137 15.3
branch 0 58 0.0
condition 0 67 0.0
subroutine 7 24 29.1
pod 11 12 91.6
total 39 298 13.0


line stmt bran cond sub pod time code
1             package CTK::DBI;
2 1     1   64249 use strict;
  1         11  
  1         32  
3 1     1   540 use utf8;
  1         15  
  1         6  
4              
5             =encoding utf-8
6              
7             =head1 NAME
8              
9             CTK::DBI - Database independent interface for CTKlib
10              
11             =head1 VERSION
12              
13             Version 2.31
14              
15             =head1 SYNOPSIS
16              
17             use CTK::DBI;
18              
19             # Enable debugging
20             # $CTK::DBI::CTK_DBI_DEBUG = 1;
21              
22             # MySQL connect
23             my $mso = CTK::DBI->new(
24             -dsn => 'DBI:mysql:database=TEST;host=192.168.1.1',
25             -user => 'login',
26             -pass => 'password',
27             -connect_to => 5,
28             -request_to => 60
29             #-attr => {},
30             #-prepare_attr => {},
31             #-debug => 1,
32             );
33              
34             my $dbh = $mso->connect or die($mso->error);
35              
36             die($mso->error) if $mso->error;
37              
38             # Table select (as array)
39             my @result = $mso->table($sql, @inargs);
40              
41             # Table select (as hash)
42             my %result = $mso->tableh($key, $sql, @inargs); # $key - primary index field name
43              
44             # Record (as array)
45             my @result = $mso->record($sql, @inargs);
46              
47             # Record (as hash)
48             my %result = $mso->recordh($sql, @inargs);
49              
50             # Field (as scalar)
51             my $result = $mso->field($sql, @inargs);
52              
53             # SQL
54             my $sth = $mso->execute($sql, @inargs);
55             ...
56             $sth->finish;
57              
58             =head1 DESCRIPTION
59              
60             For example: print($mso->field("select sysdate() from dual"));
61              
62             =head2 new
63              
64             # MySQL connect
65             my $mso = CTK::DBI->new(
66             -dsn => 'DBI:mysql:database=TEST;host=192.168.1.1',
67             -user => 'login',
68             -pass => 'password',
69             -connect_to => 5,
70             -request_to => 60
71             #-attr => {},
72             #-prepare_attr => {},
73             #-debug => 1,
74             );
75              
76             Create the DBI object
77              
78             =head2 connect
79              
80             my $dbh = $mso->connect;
81              
82             See L
83              
84             =head2 dbh
85              
86             my $dbh = $mso->dbh;
87              
88             Returns DBH object (DB handler of DBI)
89              
90             =head2 disconnect
91              
92             my $rc = $mso->disconnect;
93              
94             Forced disconnecting. Please not use this method
95              
96             =head2 error
97              
98             die $mso->error if $mso->error;
99              
100             Returns error string
101              
102             =head2 execute
103              
104             # SQL
105             my $sth = $mso->execute($sql, @inargs);
106             ...
107             $sth->finish;
108              
109             Executing the SQL
110              
111             =head2 field
112              
113             # Fields (as scalar)
114             my $result = $mso->field($sql, @inargs);
115              
116             Get (select) field from database as scalar value
117              
118             =head2 record, recordh
119              
120             # Record (as array)
121             my @result = $mso->record($sql, @inargs);
122              
123             # Record (as hash)
124             my %result = $mso->recordh($sql, @inargs);
125              
126             Get (select) record from database as array or hash
127              
128             =head2 table, tableh
129              
130             # Table select (as array)
131             my @result = $mso->table($sql, @inargs);
132              
133             # Table select (as hash)
134             my %result = $mso->tableh($key, $sql, @inargs); # $key - primary index field name
135              
136             Get (select) table from database as array or hash
137              
138             =head1 HISTORY
139              
140             See C file
141              
142             =head1 VARIABLES
143              
144             =over 4
145              
146             =item B<$CTK::DBI::CTK_DBI_DEBUG>
147              
148             Debug mode flag. Default: 0
149              
150             =item B<$CTK::DBI::CTK_DBI_ERROR>
151              
152             General error string
153              
154             =back
155              
156             =head1 DEPENDENCIES
157              
158             L
159              
160             =head1 TO DO
161              
162             See C file
163              
164             =head1 BUGS
165              
166             * none noted
167              
168             =head1 SEE ALSO
169              
170             L
171              
172             =head1 AUTHOR
173              
174             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
175              
176             =head1 COPYRIGHT
177              
178             Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
179              
180             =head1 LICENSE
181              
182             This program is free software; you can redistribute it and/or
183             modify it under the same terms as Perl itself.
184              
185             See C file and L
186              
187             =cut
188              
189 1     1   54 use vars qw/$VERSION/;
  1         2  
  1         84  
190             $VERSION = '2.31';
191              
192             our $CTK_DBI_DEBUG = 0;
193             our $CTK_DBI_ERROR = "";
194              
195 1     1   7 use Carp;
  1         1  
  1         128  
196 1     1   528 use CTK::Util qw( :API );
  1         2  
  1         173  
197 1     1   1345 use CTK::Timeout;
  1         2  
  1         27  
198 1     1   1329 use DBI qw();
  1         14850  
  1         1240  
199              
200             # Create global Timeout object
201             my $to = CTK::Timeout->new();
202              
203             sub new {
204 0     0 1   my $class = shift;
205 0           my @in = read_attributes([
206             ['DSN','STRING','STR'],
207             ['USER','USERNAME','LOGIN'],
208             ['PASSWORD','PASS'],
209             ['TIMEOUT_CONNECT','CONNECT_TIMEOUT','CNT_TIMEOUT','TIMEOUT_CNT','TO_CONNECT','CONNECT_TO'],
210             ['TIMEOUT_REQUEST','REQUEST_TIMEOUT','REQ_TIMEOUT','TIMEOUT_REQ','TO_REQUEST','REQUEST_TO'],
211             ['ATTRIBUTES','ATTR','ATTRS','ATTRHASH','PARAMS'],
212             ['PREPARE_ATTRIBUTES','PREPARE_ATTR','PREPARE_ATTRS'],
213             ['DEBUG'],
214             ], @_);
215 0 0         if ($in[7]) {
216 0           $CTK_DBI_DEBUG = 1;
217             }
218              
219             # General arguments
220 0   0       my %args = (
      0        
      0        
      0        
      0        
      0        
      0        
      0        
221             dsn => $in[0] || '',
222             user => $in[1] // '',
223             password => $in[2] // '',
224             connect_to => $in[3] // 0,
225             request_to => $in[4] // 0,
226             attr => $in[5] || undef,
227             prepare_attr=> $in[6] || undef,
228             debug => $in[7] // 0,
229             dbh => undef,
230             error => "", # Ok
231             );
232              
233             # Connect
234 0           my $_err = "";
235 0           $args{dbh} = DBI_CONNECT($args{dsn}, $args{user}, $args{password}, $args{attr}, $args{connect_to}, \$_err);
236              
237             # Create CTK::DBI object
238 0           my $self = bless {%args}, $class;
239 0 0         if ($args{dbh}) { # Ok
240 0           _debug(sprintf("--- CTK::DBI CONNECT {%s} ---", $args{dsn}));
241             } else {
242 0           $self->_set_error($_err);
243             }
244              
245 0           return $self;
246             }
247              
248             sub _set_error {
249 0     0     my $self = shift;
250 0           my $merr = shift;
251 0           my $dbh = $self->{dbh};
252              
253             # Set error string
254 0           $self->{error} = "";
255 0 0         if (defined($merr)) {
256 0           $self->{error} = $merr;
257             } else {
258 0 0 0       if ($dbh && $dbh->can('errstr')) {
259 0   0       $self->{error} = $dbh->errstr // '';
260             }
261 0 0         unless (length($self->{error})) {
262 0           $self->{error} = $DBI::errstr;
263             }
264             }
265              
266             # Print error if PrintError
267 0 0 0       if ($dbh && $dbh->{PrintError}) {
268 0 0         carp(sprintf("%s: %s", __PACKAGE__, $self->{error})) if length($self->{error});
269             }
270              
271 0           return;
272             }
273              
274             sub error {
275 0     0 1   my $self = shift;
276 0   0       return $self->{error} // "";
277             }
278             sub dbh {
279             # Returns dbh object
280 0     0 1   my $self = shift;
281 0           return $self->{dbh};
282             }
283 0     0 1   sub connect { goto &dbh }
284             sub disconnect {
285 0     0 1   my $self = shift;
286 0 0         return unless $self->{dbh};
287 0           my $rc = $self->{dbh}->disconnect;
288 0   0       _debug(sprintf("--- CTK::DBI DISCONNECT {%s} ---", $self->{dsn} || ''));
289 0           return $rc;
290             }
291             sub field {
292 0     0 1   my $self = shift;
293 0           my @result = $self->record(@_);
294 0           return shift @result;
295             }
296             sub record {
297 0     0 1   my $self = shift;
298 0           my $sth = $self->execute(@_);
299 0 0         return () unless $sth;
300 0           my @result = $sth->fetchrow_array;
301 0           $sth->finish;
302 0           return @result;
303             }
304             sub recordh {
305 0     0 1   my $self = shift;
306 0           my $sth = $self->execute(@_);
307 0 0         return () unless $sth;
308 0           my $rslt = $sth->fetchrow_hashref;
309 0 0 0       $rslt = {} unless $rslt && ref($rslt) eq 'HASH';
310 0           my %result = %$rslt;
311 0           $sth->finish;
312 0           return %result;
313             }
314             sub table {
315 0     0 1   my $self = shift;
316 0           my $sth = $self->execute(@_);
317 0 0         return () unless $sth;
318 0           my $rslt = $sth->fetchall_arrayref;
319 0 0 0       $rslt = [] unless $rslt && ref($rslt) eq 'ARRAY';
320 0           my @result = @$rslt;
321 0           $sth->finish;
322 0           return @result;
323             }
324             sub tableh {
325 0     0 1   my $self = shift;
326 0           my $key_field = shift; # See keys (http://search.cpan.org/~timb/DBI-1.607/DBI.pm#fetchall_hashref)
327 0           my $sth = $self->execute(@_);
328 0 0         return () unless $sth;
329 0           my $rslt = $sth->fetchall_hashref($key_field);
330 0 0 0       $rslt = {} unless $rslt && ref($rslt) eq 'HASH';
331 0           my %result = %$rslt;
332 0           $sth->finish;
333 0           return %result;
334             }
335             sub execute {
336 0     0 1   my $self = shift;
337 0   0       my $sql = shift // '';
338 0           my @inargs = @_;
339 0   0       my $dbh = $self->{dbh} || return;
340 0           $self->_set_error(""); # Flush errors first
341 0 0         return $self->_set_error("No statement specified") unless length($sql);
342              
343             # Prepare
344 0           my $prepare_attr = $self->{prepare_attr};
345 0 0 0       my %attr = ($prepare_attr && ref($prepare_attr) eq 'HASH') ? %$prepare_attr : ();
346 0 0         my $sth_ex = keys(%attr)
347             ? $dbh->prepare($sql, {%attr})
348             : $dbh->prepare($sql);
349 0 0         unless ($sth_ex) {
350 0   0       return $self->_set_error(sprintf("Can't prepare statement \"%s\": %s", $sql, $dbh->errstr // 'unknown error'));
351             }
352              
353             # Execute
354 0           my $err = "";
355             my $retval = $to->timeout_call(sub {
356 0 0   0     unless ($sth_ex->execute(@inargs)) {
357 0   0       $err = $dbh->errstr || "the DBI::execute method has returned false status";
358             }
359 0           1;
360 0           }, $self->{request_to});
361 0 0         unless ($retval) {
362 0   0       $err = $to->error || "unknown error";
363             }
364              
365             # Errors
366 0 0         if ($err) {
367 0           my @repsrgs = @inargs;
368 0           my $argb = "";
369 0 0         $argb = sprintf(" with bind variables: %s", join(", ", map {defined($_) ? sprintf("\"%s\"", $_) : 'undef'} @repsrgs))
  0 0          
370             if exists($inargs[0]);
371 0           return $self->_set_error(sprintf("Can't execute statement \"%s\"%s: %s", $sql, $argb, $err));
372             }
373              
374 0           return $sth_ex;
375             }
376              
377             sub DESTROY {
378 0     0     my $self = shift;
379 0           $self->disconnect();
380             }
381             sub DBI_CONNECT {
382             # $dbh = DBI_CONNECT($dsn, $user, $password, $attr, $timeout, \$error)
383 0   0 0 0   my $db_dsn = shift || ''; # DSN
384 0   0       my $db_user = shift // ''; # DB Username
385 0   0       my $db_password = shift // ''; # DB Password
386 0   0       my $db_attr = shift || {}; # Attributes DBD::* (hash-ref) E.g., {ORACLE_enable_utf8 => 1}
387 0   0       my $db_tocnt = shift // 0; # Timeout value
388 0           my $rerr = shift; # Reference to error scalar
389 0 0 0       $rerr = \$CTK_DBI_ERROR unless $rerr && ref($rerr) eq 'SCALAR';
390 0           my $dbh;
391              
392             # Connect
393 0           my $err = "";
394             my $retval = $to->timeout_call(sub {
395 0     0     $dbh = DBI->connect($db_dsn, "$db_user", "$db_password", $db_attr);
396 0 0         unless ($dbh) {
397 0   0       $err = $DBI::errstr || "the DBI::connect method has returned false status";
398             }
399 0           1;
400 0           }, $db_tocnt);
401 0 0         unless ($retval) {
402 0   0       $err = $to->error || "unknown error";
403             }
404              
405             # Errors
406 0 0         if ($err) {
407 0           $$rerr = sprintf("Can't connect to \"%s\", %s", $db_dsn, $err);
408             }
409              
410             # DBI handler or undef
411 0           return $dbh;
412             }
413              
414 0 0   0     sub _debug { $CTK_DBI_DEBUG ? carp(@_) : 1 }
415              
416             1;
417              
418             __END__